diff --git a/configifier.cabal b/configifier.cabal --- a/configifier.cabal +++ b/configifier.cabal @@ -1,15 +1,7 @@ name: configifier -version: 0.0.3 -synopsis: - parser for config files, shell variables, command line args. -description: - - WARNING NOT READY FOR USE YET. JUST PUTTING IT OUT THERE TO HAVE A DISCUSSION. - . - Read runtime configuration from files, command line, and shell - environment in a uniform, canonical, and flexible way. Inspired - by, among others, Configurator, cmdargs, optparse-applicative. - +version: 0.0.4 +synopsis: parser for config files, shell variables, command line args. +description: See license: AGPL-3 license-file: LICENSE author: Matthias Fischmann , Andres Löh @@ -26,6 +18,9 @@ flag profiling default: False +flag with-example + default: False + library hs-source-dirs: src @@ -36,9 +31,9 @@ exposed-modules: Data.Configifier build-depends: - base >=4.7 && <4.8 + base >=4.7 && <5 - , aeson >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 , case-insensitive >=1.2 && <1.3 , containers >=0.5 && <0.6 , either >=4.3 && <4.4 @@ -51,6 +46,11 @@ , yaml >=0.8 && <0.9 executable configifier-example + if flag(with-example) + Buildable: True + else + Buildable: False + default-language: Haskell2010 hs-source-dirs: diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -17,7 +17,7 @@ where import Control.Applicative ((<$>)) -import Data.String.Conversions (ST, cs) +import Data.String.Conversions (ST, cs, (<>)) import Data.Typeable (Proxy(Proxy)) import System.Environment (getEnvironment, getArgs) import Text.Show.Pretty (ppShow) @@ -30,20 +30,20 @@ -- * an interesting example -type Cfg = NoDesc CfgDesc -type CfgDesc = ToConfigCode Cfg' - +type Cfg = ToConfigCode Cfg' type Cfg' = - "frontend" :> ServerCfg :>: "descr" - :*> Maybe ("backend" :> ServerCfg) - :*> "default_users" :> [UserCfg] :>: "list of users that are created on start if database is empty" + "frontend" :> ServerCfg' :>: "descr" + :*> Maybe ("backend" :> ServerCfg') + :*> "default_users" :> [UserCfg'] :>: "list of users that are created on start if database is empty" -type ServerCfg = +type ServerCfg = ToConfigCode ServerCfg' +type ServerCfg' = "bind_port" :> Int :*> "bind_host" :> ST :*> Maybe ("expose_host" :> ST) -type UserCfg = +type UserCfg = ToConfigCode UserCfg' +type UserCfg' = "name" :> ST :>: "user name (must be unique)" :*> "email" :> ST :>: "email address (must also be unique)" :*> "password" :> ST :>: "password (not encrypted)" @@ -62,12 +62,12 @@ main :: IO () main = do sources <- sequence - [ ConfigFileYaml <$> SBS.readFile "examples/config.yaml" - , ShellEnv <$> getEnvironment - , CommandLine <$> getArgs + [ YamlString <$> SBS.readFile "examples/config.yaml" + , ShellEnv <$> getEnvironment + , CommandLine <$> getArgs ] - ST.putStrLn $ docs (Proxy :: Proxy CfgDesc) + ST.putStrLn $ docs (Proxy :: Proxy Cfg) <> "\n\n" let dump cfg = do putStrLn $ ppShow cfg @@ -75,11 +75,56 @@ dump defaultCfg - case configify sources :: Result Cfg of - Left e -> print e - Right cfg -> do - dump cfg + cfg :: Tagged Cfg <- configify sources + dump cfg - putStrLn "accessing config values:" - print $ cfg >>. (Proxy :: Proxy '["frontend"]) - print $ cfg >>. (Proxy :: Proxy '["frontend", "expose_host"]) + putStrLn "accessing config values:" + print $ (Tagged (cfg >>. (Proxy :: Proxy '["frontend"])) :: Tagged ServerCfg) + print $ cfg >>. (Proxy :: Proxy '["frontend", "expose_host"]) + print $ cfg >>. (Proxy :: Proxy '["frontend", "bind_port"]) + + +{- + +Example session: + +$ configifier-example +[...] +accessing config values: +(Tagged Id 8001 :*> (Id "localhost" :*> JustO (Id "fost"))) +Just "fost" +8001 + +$ FRONTEND_BIND_PORT=31 configifier-example +[...] +accessing config values: +(Tagged Id 31 :*> (Id "localhost" :*> JustO (Id "fost"))) +Just "fost" +31 + +$ FRONTEND_BIND_PORT=31 configifier-example --frontend-bind-port 15 +[...] +accessing config values: +(Tagged Id 15 :*> (Id "localhost" :*> JustO (Id "fost"))) +Just "fost" +15 + +$ configifier-example --frontend-expose-host "false" +[...] +configifier-example: CommandLinePrimitiveOtherError (ShellEnvNoParse {shellEnvNoParseType = "Text", shellEnvNoParseValue = "false", shellEnvNoParseMsg = "when expecting a Text, encountered Boolean instead"}) + +$ configifier-example --frontend-expose-host "\"false\"" +[...] +accessing config values: +(Tagged Id 8001 :*> (Id "localhost" :*> JustO (Id "false"))) +Just "false" +8001 + +$ configifier-example --config examples/config2.yaml +[...] +backend: + bind_host: arrr + bind_port: 281 +[...] + +-} diff --git a/src/Data/Configifier.hs b/src/Data/Configifier.hs --- a/src/Data/Configifier.hs +++ b/src/Data/Configifier.hs @@ -20,22 +20,23 @@ module Data.Configifier where -import Control.Applicative ((<$>), (<*>), (<|>)) -import Control.Exception (Exception) -import Data.Aeson (ToJSON, FromJSON, Value(Object, Null), object, toJSON, (.=)) +import Control.Applicative ((<$>), (<|>)) +import Control.Exception (Exception, throwIO) import Data.CaseInsensitive (mk) import Data.Char (toUpper) import Data.Either.Combinators (mapLeft) import Data.Function (on) -import Data.List (nubBy, intercalate) +import Data.List (nubBy, intercalate, isPrefixOf) import Data.Maybe (catMaybes) import Data.Monoid (Monoid, (<>), mempty, mappend, mconcat) import Data.String.Conversions (ST, SBS, cs) import Data.Typeable (Typeable, Proxy(Proxy), typeOf) +import Data.Yaml.Include (decodeFileEither) +import Data.Yaml (ToJSON, FromJSON, Value(Object, Array, Null), object, toJSON, parseJSON, (.=)) import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import System.Environment (getEnvironment, getArgs, getProgName) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as SBS import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml @@ -80,19 +81,15 @@ ToConfigCode (Maybe a) = Option (ToConfigCode a) ToConfigCode a = Type a --- | Filter 'Descr' constructors from 'ConfigCode'. +{-# DEPRECATED NoDesc "use of NoDesc is redundant and can be dropped without replacement." #-} type family NoDesc (a :: ConfigCode *) :: ConfigCode * where - NoDesc (Record a b) = Record (NoDesc a) (NoDesc b) - NoDesc (Label s a) = Label s (NoDesc a) - NoDesc (Descr a s) = NoDesc a - NoDesc (List a) = List (NoDesc a) - NoDesc (Option a) = Option (NoDesc a) - NoDesc (Type a) = Type a + NoDesc a = a -- | Map 'ConfgCode' types to the types of config values. type family ToConfig (a :: ConfigCode *) (f :: * -> *) :: * where ToConfig (Record a b) f = ToConfig a f :*> ToConfig b f ToConfig (Label s a) f = f (ToConfig a f) + ToConfig (Descr a s) f = ToConfig a f ToConfig (List a) f = [ToConfig a f] ToConfig (Option a) f = MaybeO (ToConfig a f) ToConfig (Type a) f = a @@ -111,7 +108,8 @@ -- * sources data Source = - ConfigFileYaml SBS + YamlString SBS + | YamlFile FilePath | ShellEnv [(String, String)] | CommandLine [String] deriving (Eq, Ord, Show, Typeable) @@ -146,13 +144,15 @@ -- * results and errors -type Result cfg = Either Error (Tagged cfg) - data Error = - InvalidYaml + InvalidYamlString { invalidYamlInput :: SBS - , invalidYamlMsg :: String + , invalidYamlMsg :: Yaml.ParseException } + | InvalidYamlFile + { invalidYamlFile :: FilePath + , invalidYamlMsg :: Yaml.ParseException + } | ShellEnvNil | ShellEnvNoParse { shellEnvNoParseType :: String @@ -164,7 +164,7 @@ | FreezeIncomplete { freezeIncompleteAtPath :: [String] } - deriving (Eq, Ord, Show, Typeable) + deriving (Show, Typeable) instance Exception Error @@ -180,10 +180,10 @@ , HasParseShellEnv cfg , HasParseCommandLine cfg , CanonicalizePartial cfg - ) => [Source] -> Result cfg -configify = configify' (mempty :: tm) + ) => [Source] -> IO (Tagged cfg) +configify = configifyWithDefault (mempty :: tm) -configify' :: forall cfg tm . +configifyWithDefault :: forall cfg tm . ( tm ~ TaggedM cfg , Show tm , Monoid tm @@ -192,20 +192,90 @@ , HasParseShellEnv cfg , HasParseCommandLine cfg , CanonicalizePartial cfg - ) => tm -> [Source] -> Result cfg -configify' def sources = sequence (get <$> sources) >>= merge . (def:) + ) => tm -> [Source] -> IO (Tagged cfg) +configifyWithDefault def sources = sequence (get <$> readUserConfigFiles sources) >>= run . merge . (def:) where - get :: Source -> Either Error tm - get (ConfigFileYaml sbs) = parseConfigFile sbs - get (ShellEnv env) = parseShellEnv env - get (CommandLine args) = parseCommandLine args + run :: Either Error a -> IO a + run = either throwIO return + get :: Source -> IO tm + get (YamlString sbs) = run $ parseConfigFile sbs + get (YamlFile fpath) = parseConfigFileWithIncludes fpath >>= run + get (ShellEnv env) = run $ parseShellEnv env + get (CommandLine args) = run $ parseCommandLine args + +-- * IO + +-- | From a list of config file paths, construct a source list that +-- (1) reads those files allowing for recursive includes; then (2) +-- processes shell environment variables (with `getProgName` as +-- prefix), and finally (3) processes command line args, turning +-- @--config@ arguments into further recursive config file loads. +defaultSources :: [FilePath] -> IO [Source] +defaultSources filePaths = do + let files = YamlFile <$> filePaths + env <- ShellEnv <$> (getEnvironment >>= withShellEnvPrefix) + args <- CommandLine <$> getArgs + return $ files ++ [env] ++ readUserConfigFiles [args] + +-- | Require that all shell env variables start with executable name. +-- (This is just a call to 'requireShellEnvPrefix'' with the result of +-- 'progName'.) +withShellEnvPrefix :: Env -> IO Env +withShellEnvPrefix env = (`withShellEnvPrefix'` env) <$> getProgName + + +-- * corner cases + +-- FUTURE WORK: the functions in this section operate on sources, not +-- parsers. This has the unintended effect of leaving the +-- documentation functionality oblivious of what happens here, so the +-- user of the apliation that uses configifier has no way of knowing +-- about '--config' or the program name prefix of shell env variables. +-- there should be a better way. + +-- | Handle `--config=`, `--config `: split up +-- 'CommandLine' source on each of these, and inject a +-- 'YamlFile' source with the resp. file name. +readUserConfigFiles :: [Source] -> [Source] +readUserConfigFiles = mconcat . map f + where + f :: Source -> [Source] + f s@(YamlString _) = [s] + f s@(YamlFile _) = [s] + f s@(ShellEnv _) = [s] + f (CommandLine args) = filter (not . (== CommandLine [])) $ g [] args + + g :: [String] -> [String] -> [Source] + g acc [] = [CommandLine (reverse acc)] + g acc fresh@(freshHead:freshTail) = case popArg fresh of + Right (("config", v), fresh') -> CommandLine (reverse acc) : YamlFile v : g [] fresh' + _ -> g (freshHead : acc) freshTail + +-- | Require prefix for shell env variables. This function will chop +-- off the given prefix of all env entries, and filter all entries +-- that do not have this prefix. +withShellEnvPrefix' :: String -> Env -> Env +withShellEnvPrefix' prefix = catMaybes . map f + where + f (k, v) = if prefix `isPrefixOf` k + then Just (take (length prefix) k, v) + else Nothing + + -- * yaml / json parseConfigFile :: (FromJSON (TaggedM cfg)) => SBS -> Either Error (TaggedM cfg) -parseConfigFile sbs = mapLeft (InvalidYaml sbs) $ Yaml.decodeEither sbs +parseConfigFile sbs = mapLeft (InvalidYamlString (trunc sbs)) $ Yaml.decodeEither' sbs + where + l = 21 + trunc s = if SBS.length s > l then SBS.take l s <> "..." else s +-- | See "Data.Yaml.Include". +parseConfigFileWithIncludes :: (FromJSON (TaggedM cfg)) => FilePath -> IO (Either Error (TaggedM cfg)) +parseConfigFileWithIncludes fpath = mapLeft (InvalidYamlFile fpath) <$> decodeFileEither fpath + renderConfigFile :: (Freeze cfg, t ~ Tagged cfg, ToJSON (TaggedM cfg)) => t -> SBS renderConfigFile = Yaml.encode . thaw @@ -229,11 +299,16 @@ , KnownSymbol s ) => ToJSON (TaggedM (Label s cfg)) where - toJSON (TaggedM Nothing) = Aeson.Null + toJSON (TaggedM Nothing) = Null toJSON (TaggedM (Just v)) = case toJSON (TaggedM v :: TaggedM cfg) of - Aeson.Null -> Aeson.Null + Null -> Null val -> object [key .= val] where key = cs $ symbolVal (Proxy :: Proxy s) +instance ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe + , ToJSON (TaggedM cfg) + ) => ToJSON (TaggedM (Descr cfg s)) where + toJSON (TaggedM v) = toJSON (TaggedM v :: TaggedM cfg) + -- | @instance ToJSON List@ instance ( t ~ ToConfig cfg Maybe , ToJSON (TaggedM cfg) @@ -247,7 +322,7 @@ , ToJSON (TaggedM cfg) ) => ToJSON (TaggedM (Option cfg)) where toJSON (TaggedM (JustO v)) = toJSON $ (TaggedM v :: TaggedM cfg) - toJSON (TaggedM NothingO) = Aeson.Null + toJSON (TaggedM NothingO) = Null -- | @instance ToJSON Type@ instance (ToJSON a) => ToJSON (TaggedM (Type a)) where @@ -259,36 +334,46 @@ -- | @instance FromJSON Record@ instance (FromJSON (TaggedM cfg1), FromJSON (TaggedM cfg2)) => FromJSON (TaggedM (Record cfg1 cfg2)) where parseJSON json = do - TaggedM o1 :: TaggedM cfg1 <- Aeson.parseJSON json - TaggedM o2 :: TaggedM cfg2 <- Aeson.parseJSON json + TaggedM o1 :: TaggedM cfg1 <- parseJSON json + TaggedM o2 :: TaggedM cfg2 <- parseJSON json return . TaggedM $ o1 :*> o2 -- | @instance FromJSON Label@ (tolerates unknown fields in json object.) instance (FromJSON (TaggedM cfg), KnownSymbol s) => FromJSON (TaggedM (Label s cfg)) where - parseJSON = Aeson.withObject "configifier object" $ \ m -> - case HashMap.lookup key m of + parseJSON (Object hashmap) = + case HashMap.lookup key hashmap of (Just json) -> TaggedM . Just . fromTaggedM <$> parseJSON' json Nothing -> return $ TaggedM Nothing where key = cs $ symbolVal (Proxy :: Proxy s) - parseJSON' :: Aeson.Value -> Aeson.Parser (TaggedM cfg) = Aeson.parseJSON + parseJSON' :: Value -> Yaml.Parser (TaggedM cfg) = parseJSON + parseJSON bad = fail $ "when expecting 'Label', encountered this instead: " ++ show bad +instance ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe + , FromJSON (TaggedM cfg) + ) => FromJSON (TaggedM (Descr cfg s)) where + parseJSON v = cast <$> parseJSON v + where + cast :: TaggedM cfg -> TaggedM (Descr cfg s) + cast = TaggedM . fromTaggedM + -- | @instance ParseJSON List@ instance (FromJSON (TaggedM cfg)) => FromJSON (TaggedM (List cfg)) where - parseJSON = Aeson.withArray "configifier list" $ \ vector -> do - vector' :: [TaggedM cfg] <- sequence $ Aeson.parseJSON <$> Vector.toList vector + parseJSON (Array vector) = do + vector' :: [TaggedM cfg] <- sequence $ parseJSON <$> Vector.toList vector return . TaggedM . (fromTaggedM <$>) $ vector' + parseJSON bad = fail $ "when expecting 'List', encountered this instead: " ++ show bad -- | @instance ParseJSON Option@ instance (FromJSON (TaggedM cfg)) => FromJSON (TaggedM (Option cfg)) where parseJSON Null = return (TaggedM NothingO :: TaggedM (Option cfg)) parseJSON v = do - TaggedM js :: TaggedM cfg <- Aeson.parseJSON v + TaggedM js :: TaggedM cfg <- parseJSON v return $ (TaggedM (JustO js) :: TaggedM (Option cfg)) -- | @instance FromJSON Type@ instance (FromJSON a) => FromJSON (TaggedM (Type a)) where - parseJSON = (TaggedM <$>) . Aeson.parseJSON + parseJSON = (TaggedM <$>) . parseJSON -- * shell env @@ -326,6 +411,14 @@ (key', '_':s@(_:_)) | mk key == mk key' -> Just (s, v) _ -> Nothing +instance ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe + , HasParseShellEnv cfg + ) => HasParseShellEnv (Descr cfg s) where + parseShellEnv env = cast <$> parseShellEnv env + where + cast :: TaggedM cfg -> TaggedM (Descr cfg s) + cast = TaggedM . fromTaggedM + -- | You can provide a list value via the shell environment by -- providing a single element. This element will be put into a list -- implicitly. @@ -369,7 +462,7 @@ parseCommandLine = primitiveParseCommandLine --- | Very basic fist approach: read @/--(key)(=|\s+)(value)/@; +-- | Very basic first approach: read @/--(key)(=|\s+)(value)/@; -- construct shell env from keys and names, and use 'parseShellEnv' on -- the command line. If it doesn't like the syntax used in the -- command line, it will crash. I hope for this to get much fancier @@ -383,18 +476,22 @@ parseArgs :: Args -> Either String Env parseArgs [] = Right [] -parseArgs (h:[]) = parseArgsWithEqSign h -parseArgs (h:h':t) = ((++) <$> parseArgsWithEqSign h <*> parseArgs (h':t)) - <|> ((++) <$> parseArgsWithSpace h h' <*> parseArgs t) +parseArgs args = popArg args >>= \ ((k, v), args') -> ((parseArgName k, v):) <$> parseArgs args' -parseArgsWithEqSign :: String -> Either String Env +popArg :: Args -> Either String ((String, String), Args) +popArg [] = Left "empty argument list." +popArg (h:[]) = (, []) <$> parseArgsWithEqSign h +popArg (h:h':t) = ((, h':t) <$> parseArgsWithEqSign h) + <|> ((, t) <$> parseArgsWithSpace h h') + +parseArgsWithEqSign :: String -> Either String (String, String) parseArgsWithEqSign s = case cs s Regex.=~- "^--([^=]+)=(.*)$" of - [_, k, v] -> Right [(parseArgName $ cs k, cs v)] + [_, k, v] -> Right (cs k, cs v) bad -> Left $ "could not parse last arg: " ++ show (s, bad) -parseArgsWithSpace :: String -> String -> Either String Env +parseArgsWithSpace :: String -> String -> Either String (String, String) parseArgsWithSpace s v = case cs s Regex.=~- "^--([^=]+)$" of - [_, k] -> Right [(parseArgName $ cs k, cs v)] + [_, k] -> Right (cs k, cs v) bad -> Left $ "could not parse long-arg with value: " ++ show (s, v, bad) parseArgName :: String -> String @@ -422,6 +519,7 @@ ToVal (Record a b) '[] = Just (ToConfig (Record a b) Id) ToVal (Record a b) ps = OrElse (ToVal a ps) (ToVal b ps) ToVal (Label p a) (p ': ps) = ToVal a ps + ToVal (Descr a s) ps = ToVal a ps ToVal (Option a) ps = ToValueMaybe (ToVal a ps) ToVal a '[] = Just (ToConfig a Id) ToVal a (p ': ps) = Nothing @@ -483,20 +581,26 @@ sel (Tagged record) Proxy = CJust record instance ( cfg ~ Record cfg' cfg'' - -- @ToVal cfg ps ~ Just t@ or @ToVal cfg ps ~ Nothing@ , Sel cfg' (p ': ps) , Sel cfg'' (p ': ps) ) => Sel (Record cfg' cfg'') (p ': ps) where sel (Tagged (a :*> b)) path = orElse (sel (Tagged a :: Tagged cfg') path) (sel (Tagged b :: Tagged cfg'') path) instance ( cfg ~ Label p cfg' - -- @ToVal cfg ps ~ Just t@ or @ToVal cfg ps ~ Nothing@ - , t ~ ToConfig cfg Id , Sel cfg' ps , KnownSymbol p ) => Sel (Label p cfg') (p ': ps) where sel (Tagged (Id a)) Proxy = sel (Tagged a :: Tagged cfg') (Proxy :: Proxy ps) +instance ( cfg ~ Descr cfg' s + , Sel cfg' ps + , ToConfig (Descr cfg' s) Id ~ ToConfig cfg' Id + ) => Sel (Descr cfg' s) ps where + sel = sel . cast + where + cast :: Tagged (Descr cfg' s) -> Tagged cfg' + cast = Tagged . fromTagged + instance ( cfg ~ Option cfg' , NothingValue (ToVal cfg' ps) , Sel cfg' ps @@ -586,6 +690,23 @@ tagA :: ToConfig a Maybe -> TaggedM a tagA = TaggedM +instance ( ToConfig (Descr a s) Maybe ~ ToConfig a Maybe + , ToConfig a Maybe ~ Maybe a' + , Monoid (TaggedM a) + ) => Monoid (TaggedM (Descr a s)) where + mempty = cast $ TaggedM Nothing + where + cast :: TaggedM a -> TaggedM (Descr a s) + cast = TaggedM . fromTaggedM + + mappend x x' = cast $ cast' x <> cast' x' + where + cast :: TaggedM a -> TaggedM (Descr a s) + cast' :: TaggedM (Descr a s) -> TaggedM a + + cast = TaggedM . fromTaggedM + cast' = TaggedM . fromTaggedM + -- | There is no @instance Monoid (TaggedM (Type a))@, since there -- is no reasonable 'mempty'. Therefore, we offer a specialized -- instance for labels that map to 'Type'. @@ -636,6 +757,13 @@ thw Proxy (Id x) = Just $ thw (Proxy :: Proxy t) x +instance ( ToConfig (Descr t s) Maybe ~ ToConfig t Maybe + , ToConfig (Descr t s) Id ~ ToConfig t Id + , Freeze t + ) => Freeze (Descr t s) where + frz Proxy path x = frz (Proxy :: Proxy t) path x + thw Proxy = thw (Proxy :: Proxy t) + instance (Freeze c) => Freeze (List c) where frz Proxy path xs = sequence $ frz (Proxy :: Proxy c) path <$> xs thw Proxy xs = thw (Proxy :: Proxy c) <$> xs @@ -669,6 +797,9 @@ thw Proxy x = x +-- | Partials are constructed with every 'Nothing' spelled out, +-- resulting in deep skeletons of 'Nothing's. 'CanonicalizePartial' +-- replaces those with single 'Nothing's at their tops. class CanonicalizePartial a where canonicalizePartial :: TaggedM a -> TaggedM a emptyPartial :: TaggedM a -> Bool @@ -695,6 +826,21 @@ emptyPartial (TaggedM Nothing) = True emptyPartial (TaggedM (Just a)) = emptyPartial (TaggedM a :: TaggedM cfg') + +instance (cfg ~ Descr cfg' s, CanonicalizePartial cfg') + => CanonicalizePartial (Descr cfg' s) where + canonicalizePartial = cast . canonicalizePartial . cast' + where + cast :: TaggedM a -> TaggedM (Descr a s) + cast' :: TaggedM (Descr a s) -> TaggedM a + + cast = TaggedM . fromTaggedM + cast' = TaggedM . fromTaggedM + + emptyPartial = emptyPartial . cast + where + cast :: TaggedM (Descr a s) -> TaggedM a + cast = TaggedM . fromTaggedM instance (cfg ~ List cfg', CanonicalizePartial cfg') => CanonicalizePartial (List cfg') where diff --git a/tests/Data/ConfigifierSpec.hs b/tests/Data/ConfigifierSpec.hs --- a/tests/Data/ConfigifierSpec.hs +++ b/tests/Data/ConfigifierSpec.hs @@ -31,6 +31,7 @@ selectSpec mergeSpec sourcesSpec + readUserConfigFilesSpec miscSpec :: Spec miscSpec = do @@ -47,8 +48,7 @@ it "descriptions" $ let text :: SBS want :: ( c ~ ToConfigCode ("bla" :> Int :>: "describe stuff!") - , c' ~ NoDesc c - ) => Tagged c' + ) => Tagged c text = "bla: 3" want = Tagged $ Id 3 @@ -65,13 +65,13 @@ in run text want it "option, no sources" $ - let have :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Configifier.Result c + let have :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => IO (Tagged c) want :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Tagged c have = configify [] want = Tagged NothingO - in have `shouldBe` Right want + in have >>= (`shouldBe` want) it "yaml cannot parse empty cfg files (even if all config data is optional!)" $ let text1, text2, text3 :: SBS @@ -127,8 +127,7 @@ it "lists" $ let text :: SBS want :: ( c ~ ToConfigCode ("bla" :> [Bool]) - , c' ~ NoDesc c - ) => Tagged c' + ) => Tagged c text = "bla: [yes, no]" want = Tagged $ Id [True, False] @@ -149,11 +148,11 @@ , CanonicalizePartial cfg ) => SBS -> ti -> IO () run text parsedWant = do - let f :: SBS -> Either Error ti - f sbs = configify [ConfigFileYaml sbs] + let f :: SBS -> IO ti + f sbs = configify [YamlString sbs] - f text `shouldBe` Right parsedWant - f (renderConfigFile parsedWant) `shouldBe` Right parsedWant + f text >>= (`shouldBe` parsedWant) + f (renderConfigFile parsedWant) >>= (`shouldBe` parsedWant) selectSpec :: Spec @@ -234,22 +233,22 @@ it "partial select paths and non-leaf sub-configs" $ let t :: forall config config' ponfig ponfig' . - ( config ~ Tagged (NoDesc (ToConfigCode config')) + ( config ~ Tagged (ToConfigCode config') , config' ~ (Maybe ("a" :> ST) :*> ("b" :> ST)) - , ponfig ~ Tagged (NoDesc (ToConfigCode ponfig')) + , ponfig ~ Tagged (ToConfigCode ponfig') , ponfig' ~ ("c" :> config') ) => IO () t = do - let Right (cfg1 :: ponfig) = configify [ConfigFileYaml . cs . unlines $ + cfg1 :: ponfig <- configify [YamlString . cs . unlines $ "c:" : " a: goih" : " b: c38" : "..." : []] - Right (Tagged cfg2 :: config) = configify [ConfigFileYaml . cs . unlines $ + Tagged cfg2 :: config <- configify [YamlString . cs . unlines $ "a: goih" : "b: c38" : "..." : @@ -304,10 +303,10 @@ let f :: ( c ~ ToConfigCode c' , c' ~ ("frontend" :> sc :*> Maybe ("backend" :> sc)) , sc ~ ("bind_port" :> Int :*> Maybe ("expose_host" :> ST)) - ) => [Source] -> Result c + ) => [Source] -> IO (Tagged c) f = configify - configFile1 :: Source = ConfigFileYaml . cs . unlines $ + configFile1 :: Source = YamlString . cs . unlines $ "frontend:" : " bind_port: 3" : " expose_host: host" : @@ -315,7 +314,7 @@ " bind_port: 4" : " expose_host: hist" : [] - configFile2 :: Source = ConfigFileYaml . cs . unlines $ + configFile2 :: Source = YamlString . cs . unlines $ "frontend:" : " bind_port: 3" : [] @@ -331,21 +330,35 @@ parseArgs (["--arg=31", "--flob", "gluh"] :: Args) `shouldBe` Right ([("ARG", "31"), ("FLOB", "gluh")] :: Env) it "1" $ - f [configFile1] `shouldBe` - (Right . Tagged $ Id (Id 3 :*> JustO (Id "host")) - :*> JustO (Id (Id 4 :*> JustO (Id "hist")))) + f [configFile1] >>= (`shouldBe` + (Tagged $ Id (Id 3 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "hist"))))) it "2" $ - f [configFile1, shellEnv1, shellEnv2] `shouldBe` - (Right . Tagged $ Id (Id 18 :*> JustO (Id "host")) - :*> JustO (Id (Id 4 :*> JustO (Id "bom")))) + f [configFile1, shellEnv1, shellEnv2] >>= (`shouldBe` + (Tagged $ Id (Id 18 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "bom"))))) it "3" $ - f [configFile1, shellEnv1, shellEnv2, commandLine1] `shouldBe` - (Right . Tagged $ Id (Id 31 :*> JustO (Id "host")) - :*> JustO (Id (Id 4 :*> JustO (Id "bom")))) + f [configFile1, shellEnv1, shellEnv2, commandLine1] >>= (`shouldBe` + (Tagged $ Id (Id 31 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "bom"))))) it "4" $ - f [configFile2, commandLine2] `shouldBe` - (Right . Tagged $ Id (Id 3 :*> NothingO) - :*> JustO (Id (Id 8710 :*> JustO (Id "mab")))) + f [configFile2, commandLine2] >>= (`shouldBe` + (Tagged $ Id (Id 3 :*> NothingO) + :*> JustO (Id (Id 8710 :*> JustO (Id "mab"))))) + + +readUserConfigFilesSpec :: Spec +readUserConfigFilesSpec = describe "readUserConfigFiles" $ do + it "finds --config args" $ + readUserConfigFiles [CommandLine ["--config=FILE"]] `shouldBe` [YamlFile "FILE"] + + it "keeps surrounding args intact" $ do + readUserConfigFiles [CommandLine ["1", "2", "--config=FILE", "3", "4"]] `shouldBe` + [CommandLine ["1", "2"], YamlFile "FILE", CommandLine ["3", "4"]] + readUserConfigFiles [CommandLine ["--config=FILE", "2"]] `shouldBe` + [YamlFile "FILE", CommandLine ["2"]] + readUserConfigFiles [CommandLine ["1", "--config=FILE"]] `shouldBe` + [CommandLine ["1"], YamlFile "FILE"]