packages feed

panfiguration (empty) → 0.0

raw patch · 8 files changed

+568/−0 lines, 8 filesdep +barbiesdep +barbies-thdep +base

Dependencies added: barbies, barbies-th, base, bytestring, network, optparse-applicative, panfiguration, split, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for panfiguration++## 0.0++* First version. Released on an unsuspecting world.
+ README.md view
@@ -0,0 +1,66 @@+Usage+----++[![Hackage](https://img.shields.io/hackage/v/panfiguration.svg)](https://hackage.haskell.org/package/panfiguration)+![Haskell CI](https://github.com/herp-inc/panfiguration/workflows/Haskell%20CI/badge.svg)++Panfiguration is a library that provides a composable, automatically-derived interface for configuration parameters.++Currently three backends are supported; `envs` for environment variables, `opts` for command-line options and `defaults` for default values.+The `Monoid` instance makes these backends composable. See the example below for the basic usage.++Example+----++```haskell+import Barbies.TH+import Panfiguration++passthroughBareB [d|+    data ServerArgs = ServerArgs+        { http_host :: String+        , http_port :: Int+        , enable_service_log :: Bool+        , environment :: String+        }+    |]++getServerArgs :: IO ServerArgs+getServerArgs = run $ mconcat+    [ logger putStrLn+    , declCase snake+    , envs `withNames` \names -> names+        { http_host = "HTTP_HOST"+        , http_port = "HTTP_PORT"+        }+    , opts `asCase` kebab+    , defaults ServerArgs+        { http_host = Just "0.0.0.0"+        , http_port = Just 8080+        , enable_service_log = Just True+        , environment = Nothing -- required parameter+        }+    ]+```++Naming conventions+----++`declCase` specifies the naming convention of the Haskell data declaration (the default is `camel`).+The naming conventions are configurable by the `asCase` modifier.+By default, `envs` and `opts` uses SNAKE_CASE and kebab-case respectively.++The following styles are supported:++```haskell+AsIs+Camel+camel+snake+SNAKE+kebab+KEBAB+Prefixed <str>+```++You can also override individual names directly by `withNames`.
+ panfiguration.cabal view
@@ -0,0 +1,56 @@+cabal-version:      2.4+name:               panfiguration+version:            0.0++-- A short (one-line) description of the package.+synopsis:           Merge environment variables and command line options generically++-- A longer description of the package.+description:        See README.md++-- A URL where users can report bugs.+bug-reports:        https://github.com/herp-inc/panfiguration++-- The license under which the package is released.+license:            Apache-2.0+author:             Fumiaki Kinoshita+maintainer:         fumiaki.kinoshita@herp.co.jp++-- A copyright notice.+copyright:          Copyright (c) 2022 Fumiaki Kinoshita+-- category:+extra-source-files: CHANGELOG.md, README.md++source-repository head+  type: git+  location: https://github.com/herp-inc/panfiguration.git++library+    exposed-modules:+        Panfiguration+        Panfiguration.FromParam+        Panfiguration.Case+        Panfiguration.Core+    build-depends:    base >=4.10 && <5+        , barbies+        , barbies-th ^>= 0.1.10+        , bytestring+        , network+        , optparse-applicative+        , split+        , text+    hs-source-dirs:   src+    default-language: Haskell2010+    ghc-options: -Wall -Wcompat++test-suite test+  type: exitcode-stdio-1.0+  main-is: test.hs+  hs-source-dirs:+      tests+  build-depends:+      base >=4.7 && <5+    , barbies-th+    , panfiguration+  default-language: Haskell2010+  ghc-options: -Wall -Wcompat
+ src/Panfiguration.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE PatternSynonyms #-}+module Panfiguration (+    Panfiguration,+    declCase,+    asCase,+    withNames,+    envs,+    opts,+    defaults,+    fullDefaults,+    logger,+    run,+    -- * Naming convention+    Case(..),+    camel,+    snake,+    pattern SNAKE,+    pattern KEBAB,+    kebab,+    -- * Parameter+    FromParam,+    Secret(..),+    Collect(..),+    ) where++import Panfiguration.Core+import Panfiguration.Case+import Panfiguration.FromParam
+ src/Panfiguration/Case.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE PatternSynonyms #-}+module Panfiguration.Case+    ( Case(..)+    , camel+    , snake+    , pattern SNAKE+    , pattern KEBAB+    , kebab+    -- * Operation+    , split+    , join+    , convert+    )+    where++import Data.Char+import qualified Data.List.Split as S+import Data.List (intercalate)++data Case = Delimiter String+    | AsIs+    | Camel+    | LowerCamel+    | Upper Case+    | Lower Case+    | Prefixed String Case++camel :: Case+camel = LowerCamel++snake :: Case+snake = Lower $ Delimiter "_"++pattern SNAKE :: Case+pattern SNAKE = Upper (Delimiter "_")++kebab :: Case+kebab = Lower $ Delimiter "-"++pattern KEBAB :: Case+pattern KEBAB = Upper (Delimiter "-")++split :: Case -> String -> [String]+split AsIs = pure+split (Delimiter d) = S.splitOn d+split Camel = splitCamel+split LowerCamel = splitCamel+split (Lower c) = split c+split (Upper c) = split c+split (Prefixed p c) = \str -> case split c str of+    x : xs | x == p -> xs+    xs -> xs++splitCamel :: String -> [String]+splitCamel = concatMap (bravo "") . alpha "" where+    alpha "" "" = []+    alpha buf "" = [reverse buf]+    alpha buf (x:u:l:xs) | isUpper u && isLower l = reverse (x : buf) : alpha [l, u] xs+    alpha buf (x:xs) = alpha (x : buf) xs+    +    bravo "" "" = []+    bravo buf "" = [reverse buf]+    bravo buf (l:u:xs) | isLower l && isUpper u = reverse (l : buf) : bravo [u] xs+    bravo buf (x:xs) = bravo (x : buf) xs++join :: Case -> [String] -> String+join AsIs xs = concat xs+join (Delimiter d) xs = intercalate d xs+join Camel xs = concatMap capitalise xs+join LowerCamel (x : xs) = x <> concatMap capitalise xs+join LowerCamel [] = ""+join (Upper c) xs = map toUpper $ join c xs+join (Lower c) xs = map toLower $ join c xs+join (Prefixed str c) xs = join c $ str : xs+ +capitalise :: String -> String+capitalise (x : xs) = toUpper x : xs+capitalise xs = xs++convert :: Case -> Case -> String -> String+convert c d = join d . split c
+ src/Panfiguration/Core.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TupleSections #-}+module Panfiguration.Core (+     Panfiguration(..)+    , Result(..)+    , Source(..)+    , declCase+    , asCase+    , withNames+    , envs+    , opts+    , defaults+    , fullDefaults+    , logger+    , Panfigurable+    , exec+    , run+    , runMaybe+    ) where++import Barbies+import Barbies.Bare+import Barbies.Constraints (Dict(..))+import Barbies.TH+import Control.Applicative+import Control.Monad (forM)+import Data.Bifunctor+import Data.Functor.Compose+import Data.Functor.Identity+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe)+import Data.Monoid (First(..))+import qualified Options.Applicative as O+import System.Environment (getEnvironment)++import Panfiguration.FromParam+import Panfiguration.Case++data Result a = Result+    { resultSources :: [String]+    , resultUsed :: [String]+    , resultContent :: Maybe a+    }+    deriving (Show, Eq, Ord)++mkResult :: String -> Maybe a -> Result a+mkResult key = Result [key] [key]++instance FromParam a => Semigroup (Result a) where+    Result s0 _ Nothing <> Result s1 _ Nothing = Result (s0 <> s1) mempty Nothing+    Result s0 _ Nothing <> Result s1 u (Just a) = Result (s0 <> s1) u (Just a)+    Result s0 u (Just a) <> Result s1 _ Nothing = Result (s0 <> s1) u (Just a)+    Result s0 u0 (Just a) <> Result s1 u1 (Just b)+        =   let (side, c) = mergeParams a b+                used = case side of+                    LT -> u0+                    EQ -> u0 <> u1+                    GT -> u1+            in Result (s0 <> s1) used $ Just c++instance FromParam a => Monoid (Result a) where+    mempty = Result [] [] Nothing++data Source h = Source+    { sourceCase :: Case+    , sourceRun :: h (Const String) -> IO (h Result)+    }++mapConsts :: FunctorB h => (a -> b) -> h (Const a) -> h (Const b)+mapConsts f = bmap (first f)++data Panfiguration h = Panfiguration+    { fieldNameCase :: First Case+    , loggerFunction :: First (String -> IO ())+    , sources :: [Source h]+    }++instance Semigroup (Panfiguration h) where+    Panfiguration a b c <> Panfiguration x y z = Panfiguration (a <> x) (b <> y) (c <> z)++instance Monoid (Panfiguration h) where+    mempty = Panfiguration mempty mempty mempty++mkSource :: Case -> (h (Const String) -> IO (h Result)) -> Panfiguration h+mkSource c f = mempty { sources = [Source c f] }++-- | Set the letter case of the data declaration+declCase :: Case -> Panfiguration h+declCase c = mempty { fieldNameCase = pure c }++-- | Set the letter case of the sources+asCase :: Panfiguration h -> Case -> Panfiguration h+asCase pfg c = pfg { sources = [ s { sourceCase = c } | s <- sources pfg] }++-- | Update names being used for the backends+withNames :: Panfiguration h -> (h (Const String) -> h (Const String)) -> Panfiguration h+withNames pfg f = pfg { sources = [ s { sourceRun = sourceRun s . f } | s <- sources pfg] }++envs :: (TraversableB h, ConstraintsB h, AllB FromParam h) => Panfiguration h+envs = mkSource SNAKE $ \envNames -> do+    vars <- getEnvironment+    either fail pure $ btraverseC @FromParam+        (\(Const k) -> tag k <$> traverse fromParam (lookup k vars))+        envNames+  where+    tag k = mkResult $ "env:" <> k++opts :: (TraversableB h, ConstraintsB h, AllB FromParam h) => Panfiguration h+opts = mkSource kebab $ \optNames -> do+    let parsers = btraverseC @FromParam+            (\(Const k) -> fmap (tag k) $ optional $ mkOption k)+            optNames+    O.execParser $ O.info (parsers <**> O.helper) mempty+  where+    tag k = mkResult $ "--" <> k+    mkOption k = O.option (O.eitherReader fromParam) $ O.long k++defaults :: FunctorB h => h Maybe -> Panfiguration h+defaults def = mkSource AsIs $ const $ pure $ bmap (mkResult "the default") def++-- | Provide all the default values by a plain record+fullDefaults :: (BareB b, FunctorB (b Covered)) => b Bare Identity  -> Panfiguration (b Covered)+fullDefaults = defaults . bmap (Just . runIdentity) . bcover++logger :: (String -> IO ()) -> Panfiguration h+logger f = mempty { loggerFunction = pure f }++resolve :: (String -> IO ()) -> Dict Show a -> Const (NE.NonEmpty String) a -> Result a -> Compose IO Maybe a+resolve logFunc Dict (Const key) (Result srcs used r) = Compose $ r <$ case r of+    Nothing -> logFunc $ unwords [displayKey key <> ":", "None of", commas srcs, "provides a value"]+    Just v -> logFunc $ unwords [displayKey key <> ":", "using", show v, "from", commas used]+    where+        displayKey = intercalate "." . NE.toList+        commas [] = ""+        commas [a] = a+        commas [a, b] = unwords [a, "and", b]+        commas (x : xs) = x <> ", " <> commas xs+++type Panfigurable h = (FieldNamesB h+    , TraversableB h+    , ApplicativeB h+    , ConstraintsB h+    , AllB Show h+    , AllB FromParam h)++-- | Parse all the relevant environment variables and command line options, then merges them.+exec :: (Panfigurable h)+    => Panfiguration h+    -> IO (h Result)+exec Panfiguration{..} = do+    let names = mapConsts+            (fmap $ split $ fromMaybe camel $ getFirst fieldNameCase)+            bnestedFieldNames++    results <- forM sources $ \Source{..} -> sourceRun+        $ mapConsts (join sourceCase . concat) names+ +    pure $ foldr (bzipWithC @FromParam (<>)) (bpureC @FromParam mempty) results++runMaybe :: (Panfigurable h)+    => Panfiguration h+    -> IO (h Maybe)+runMaybe panfig = do+    result <- exec panfig+    let logFunc = fromMaybe mempty $ getFirst $ loggerFunction panfig+    bsequence $ bzipWith3 (resolve logFunc) bdicts bnestedFieldNames result++run :: (BareB b, Panfigurable (b Covered))+    => Panfiguration (b Covered)+    -> IO (b Bare Identity)+run panfig = do+    maybes <- runMaybe panfig+    fmap bstrip <$> maybe (error "Failed to run panfiguration") pure $ bsequence' maybes
+ src/Panfiguration/FromParam.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+module Panfiguration.FromParam (+    FromParam(..)+    , readFromParam+    -- * Wrappers+    , Secret(..)+    , Collect(..)+    ) where++import Control.Applicative+import Data.ByteString.Char8 as BC (ByteString, pack)+import Data.Char+import Data.Functor.Identity+import Data.Monoid+import Data.Typeable+import Network.Socket (PortNumber)+import Numeric.Natural+import Text.Read (readMaybe)+import qualified Data.Text as Text++-- | A newtype wrapper to distinguish confidential values.+-- 'show' and error messages from 'fromParam' mask its contents.+newtype Secret a = Secret { unSecret :: a } deriving (Eq, Ord)++instance Show a => Show (Secret a) where+    show = ('*' <$) . show . unSecret++class FromParam a where+    -- | Parse a parameter+    fromParam :: String -> Either String a+    default fromParam :: (Typeable a, Read a) => String -> Either String a+    fromParam = readFromParam++    fromParamList :: String -> Either String [a]+    fromParamList _ = Left "No implementation for fromParamList"++    -- | Merge two parameters. The 'Ordering' indicates which side of the arguments is used.+    mergeParams :: a -> a -> (Ordering, a)+    mergeParams a _ = (LT, a)++-- | A reasonable default implementation for 'fromParam' via 'Read'+readFromParam :: forall a. (Typeable a, Read a) => String -> Either String a+readFromParam str = maybe (Left err) Right $ readMaybe str+    where+        err = unwords ["failed to parse", str, "as", show (typeRep (Proxy :: Proxy a))]++instance (Typeable a, FromParam a) => FromParam (Secret a) where+    fromParam str = either (const err) (pure . Secret) $ fromParam str where+        err = Left $ unwords ["failed to parse", '*' <$ str, "as", show (typeRep (Proxy :: Proxy a))]++instance FromParam Bool where+    fromParam str = case map toLower str of+        "false" -> Right False+        "true" -> Right True+        _ -> Left "Expected true or false"++instance FromParam Char where+    fromParam [c] = Right c+    fromParam _ = Left "Got more than one character"+    fromParamList = Right++instance FromParam a => FromParam [a] where+    fromParam = fromParamList++instance FromParam () where+    fromParam _ = Right ()+deriving instance FromParam a => FromParam (Identity a)+deriving instance FromParam a => FromParam (Const a b)+instance FromParam Int+instance FromParam Float+instance FromParam Double+instance FromParam Integer+instance FromParam Natural+instance FromParam PortNumber+instance FromParam Text.Text where+    fromParam = pure . Text.pack++instance FromParam ByteString where+    fromParam str+        | all ((<128) . fromEnum) str = Right $ BC.pack str+        | otherwise = Left "expected ByteString, but found a non-ASCII character"++instance FromParam a => FromParam (Maybe a) where+    fromParam str = Just <$> fromParam str++instance FromParam Any where+    fromParam = fmap Any . fromParam+    mergeParams (Any False) a = (GT, a)+    mergeParams (Any True) _ = (LT, Any True)++instance FromParam All where+    fromParam = fmap All . fromParam+    mergeParams (All False) _ = (LT, All False)+    mergeParams (All True) a = (GT, a)++-- | Collect all the specified parameters instead of overriding+newtype Collect a = Collect { unCollect :: [a] } deriving (Eq, Ord, Show, Semigroup, Monoid)++instance FromParam a => FromParam (Collect a) where+    fromParam = fmap (Collect . pure) . fromParam+    mergeParams a (Collect []) = (LT, a)+    mergeParams (Collect []) b = (GT, b)+    mergeParams (Collect a) (Collect b) = (EQ, Collect $ a <> b)
+ tests/test.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Barbies.TH+import Data.Proxy+import Panfiguration++passthroughBareB [d|+    data Bind = Bind { host :: String, port :: Int }+    data ServerArgs = ServerArgs+        { http :: Bind+        , enable_service_log :: Bool+        , environment :: String+        , extensions :: Collect String+        }+    |]++deriving instance Show Bind+deriving instance Show ServerArgs++getServerArgs :: IO ServerArgs+getServerArgs = run $ mconcat+    [ logger putStrLn+    , declCase snake+    , opts `asCase` kebab+    , envs+    , defaults ServerArgs+        { http = Bind (Just "0.0.0.0") (Just 8080)+        , enable_service_log = Just True+        , environment = Nothing+        , extensions = Just $ Collect []+        }+    ]++main :: IO ()+main = getServerArgs >>= print++_unused :: ()+_unused = Proxy @BindH `seq` Proxy @ServerArgsH `seq` ()