diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for panfiguration + +## 0.0 + +* First version. Released on an unsuspecting world. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` + +You can also override individual names directly by `withNames`. diff --git a/panfiguration.cabal b/panfiguration.cabal new file mode 100644 --- /dev/null +++ b/panfiguration.cabal @@ -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 diff --git a/src/Panfiguration.hs b/src/Panfiguration.hs new file mode 100644 --- /dev/null +++ b/src/Panfiguration.hs @@ -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 diff --git a/src/Panfiguration/Case.hs b/src/Panfiguration/Case.hs new file mode 100644 --- /dev/null +++ b/src/Panfiguration/Case.hs @@ -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 diff --git a/src/Panfiguration/Core.hs b/src/Panfiguration/Core.hs new file mode 100644 --- /dev/null +++ b/src/Panfiguration/Core.hs @@ -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 diff --git a/src/Panfiguration/FromParam.hs b/src/Panfiguration/FromParam.hs new file mode 100644 --- /dev/null +++ b/src/Panfiguration/FromParam.hs @@ -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) diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -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` ()