diff --git a/etc/src/System/Etc.hs b/etc/src/System/Etc.hs index dbd94a8..a37fe5b 100644 --- a/etc/src/System/Etc.hs +++ b/etc/src/System/Etc.hs @@ -13,7 +13,7 @@ module System.Etc ( -- * ConfigSpec -- $config_spec - , ConfigSource (..) + , SomeConfigSource (..) , ConfigValue , ConfigSpec , parseConfigSpec @@ -71,7 +71,7 @@ module System.Etc ( import System.Etc.Internal.Resolver.Default (resolveDefault) import System.Etc.Internal.Types - (Config, ConfigSource (..), ConfigValue, IConfig (..), Value (..)) + (Config, ConfigValue, IConfig (..), SomeConfigSource (..), Value (..)) import System.Etc.Spec ( ConfigInvalidSyntaxFound (..) , ConfigSpec diff --git a/etc/src/System/Etc/Internal/Config.hs b/etc/src/System/Etc/Internal/Config.hs index ed54c6b..9836266 100644 --- a/etc/src/System/Etc/Internal/Config.hs +++ b/etc/src/System/Etc/Internal/Config.hs @@ -9,6 +9,8 @@ import qualified RIO.HashMap as HashMap import qualified RIO.Set as Set import qualified RIO.Text as Text +import Data.Typeable (cast) + import qualified Data.Aeson as JSON import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse) import qualified Data.Aeson.Types as JSON (Parser) @@ -23,7 +25,7 @@ configValueToJsonObject configValue = case configValue of ConfigValue sources -> case Set.maxView sources of Nothing -> JSON.Null - Just (source, _) -> fromValue $ value source + Just (source, _) -> fromValue $ sourceValue source SubConfig configm -> configm @@ -35,16 +37,14 @@ configValueToJsonObject configValue = case configValue of & JSON.Object _getConfigValueWith - :: MonadThrow m => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result + :: (MonadThrow m) => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result _getConfigValueWith parser keys0 (Config configValue0) = let loop keys configValue = case (keys, configValue) of ([], ConfigValue sources) -> case Set.maxView sources of Nothing -> throwM $ InvalidConfigKeyPath keys0 - Just (None , _) -> throwM $ InvalidConfigKeyPath keys0 - - Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of + Just (source, _) -> case JSON.iparse parser (fromValue $ sourceValue source) of JSON.IError path err -> JSON.formatError path err & Text.pack & ConfigValueParserFailed keys0 & throwM @@ -65,13 +65,16 @@ _getConfigValueWith parser keys0 (Config configValue0) = _ -> throwM $ InvalidConfigKeyPath keys0 in loop keys0 configValue0 -_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m ConfigSource +_getSelectedConfigSource + :: (MonadThrow m, IConfigSource result) => [Text] -> Config -> m result _getSelectedConfigSource keys0 (Config configValue0) = let loop keys configValue = case (keys, configValue) of ([], ConfigValue sources) -> case Set.maxView sources of - Nothing -> throwM $ InvalidConfigKeyPath keys0 + Nothing -> throwM $ InvalidConfigKeyPath keys0 - Just (source, _) -> return source + Just (SomeConfigSource _ source, _) -> + -- TODO: Change exception from InvalidConfigKeyPath + maybe (throwM $ InvalidConfigKeyPath keys0) return (cast source) (k : keys1, SubConfig configm) -> case HashMap.lookup k configm of Nothing -> throwM $ InvalidConfigKeyPath keys0 @@ -81,7 +84,7 @@ _getSelectedConfigSource keys0 (Config configValue0) = in loop keys0 configValue0 -_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set ConfigSource) +_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set SomeConfigSource) _getAllConfigSources keys0 (Config configValue0) = let loop keys configValue = case (keys, configValue) of ([] , ConfigValue sources) -> return sources @@ -96,7 +99,6 @@ _getAllConfigSources keys0 (Config configValue0) = _getConfigValue :: (MonadThrow m, JSON.FromJSON result) => [Text] -> Config -> m result _getConfigValue = _getConfigValueWith JSON.parseJSON - instance IConfig Config where getConfigValue = _getConfigValue getConfigValueWith = _getConfigValueWith diff --git a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs index 924b9c0..4a0ea79 100644 --- a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs +++ b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs @@ -34,7 +34,7 @@ data EnvMisspell lookupSpecEnvKeys :: ConfigSpec a -> Vector Text lookupSpecEnvKeys spec = let foldEnvSettings val acc = case val of - ConfigValue { configSources } -> + ConfigValue ConfigValueData { configSources } -> maybe acc (`Vector.cons` acc) (envVar configSources) SubConfig hsh -> HashMap.foldr foldEnvSettings acc hsh in foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs index 852aa52..a5dc7d2 100644 --- a/etc/src/System/Etc/Internal/Extra/Printer.hs +++ b/etc/src/System/Etc/Internal/Extra/Printer.hs @@ -89,7 +89,6 @@ renderConfigValueJSON value = case value of ) (HashMap.toList obj) - renderConfigValue :: (JSON.Value -> Doc) -> Value JSON.Value -> [Doc] renderConfigValue f value = case value of Plain (JSON.Array jsonArray) -> @@ -97,37 +96,14 @@ renderConfigValue f value = case value of Plain jsonValue -> return $ f jsonValue Sensitive{} -> return $ text "<>" -renderConfigSource :: (JSON.Value -> Doc) -> ConfigSource -> ([Doc], Doc) -renderConfigSource f configSource = case configSource of - Default value -> - let sourceDoc = text "Default" - valueDoc = renderConfigValue f value - in (valueDoc, sourceDoc) - - File _index fileSource value -> - let sourceDoc = case fileSource of - FilePathSource filepath -> text "File:" <+> text (Text.unpack filepath) - EnvVarFileSource envVar filepath -> - text "File:" <+> text (Text.unpack envVar) <> "=" <> text (Text.unpack filepath) - valueDoc = renderConfigValue f value - in (valueDoc, sourceDoc) - - Env varname value -> - let sourceDoc = text "Env:" <+> text (Text.unpack varname) - valueDoc = renderConfigValue f value - in (valueDoc, sourceDoc) - - Cli value -> - let sourceDoc = text "Cli" - valueDoc = renderConfigValue f value - in (valueDoc, sourceDoc) - - None -> (mempty, mempty) +renderConfigSource :: (JSON.Value -> Doc) -> SomeConfigSource -> ([Doc], Doc) +renderConfigSource f source = + (renderConfigValue f (sourceValue source), sourcePrettyDoc source) renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc renderConfig_ ColorFn { blueColor } (Config configMap) = let - renderSources :: MonadThrow m => [ConfigSource] -> m Doc + renderSources :: MonadThrow m => [SomeConfigSource] -> m Doc renderSources sources = let sourceDocs = map (renderConfigSource renderConfigValueJSON) sources diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs index 7abb400..81a75f9 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs @@ -113,8 +113,8 @@ specToConfigValueCli -> (Text, Spec.ConfigValue cmd) -> m (HashMap cmd (Opt.Parser ConfigValue)) specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of - Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } -> - configValueSpecToCli acc specEntryKey configValueType isSensitive configSources + Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources } + -> configValueSpecToCli acc specEntryKey configValueType isSensitive configSources Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs index d13d407..f84d51a 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs @@ -139,7 +139,7 @@ parseCommandJsonValue commandValue = case JSON.iparse JSON.parseJSON commandValu jsonToConfigValue :: Maybe (Value JSON.Value) -> ConfigValue jsonToConfigValue specEntryDefVal = - ConfigValue $ Set.fromList $ maybe [] ((: []) . Cli) specEntryDefVal + ConfigValue $ Set.fromList $ maybe [] ((: []) . cliSource 3) specEntryDefVal handleCliResult :: Either SomeException a -> IO a handleCliResult result = case result of diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs index 62206c4..3debc1e 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs @@ -92,8 +92,8 @@ specToConfigValueCli -> (Text, Spec.ConfigValue ()) -> m (Opt.Parser ConfigValue) specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of - Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } -> - configValueSpecToCli specEntryKey configValueType isSensitive configSources acc + Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources } + -> configValueSpecToCli specEntryKey configValueType isSensitive configSources acc Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc diff --git a/etc/src/System/Etc/Internal/Resolver/Default.hs b/etc/src/System/Etc/Internal/Resolver/Default.hs index 1742045..c3bae2f 100644 --- a/etc/src/System/Etc/Internal/Resolver/Default.hs +++ b/etc/src/System/Etc/Internal/Resolver/Default.hs @@ -13,14 +13,14 @@ import System.Etc.Internal.Types toDefaultConfigValue :: Bool -> JSON.Value -> ConfigValue toDefaultConfigValue sensitive = - ConfigValue . Set.singleton . Default . markAsSensitive sensitive + ConfigValue . Set.singleton . defaultSource . markAsSensitive sensitive buildDefaultResolver :: Spec.ConfigSpec cmd -> Maybe ConfigValue buildDefaultResolver spec = let resolverReducer :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue resolverReducer specKey specValue mConfig = case specValue of - Spec.ConfigValue { Spec.defaultValue, Spec.isSensitive } -> + Spec.ConfigValue Spec.ConfigValueData { Spec.defaultValue, Spec.isSensitive } -> let mConfigSource = toDefaultConfigValue isSensitive <$> defaultValue updateConfig = writeInSubConfig specKey <$> mConfigSource <*> mConfig diff --git a/etc/src/System/Etc/Internal/Resolver/Env.hs b/etc/src/System/Etc/Internal/Resolver/Env.hs index c099449..ac3b688 100644 --- a/etc/src/System/Etc/Internal/Resolver/Env.hs +++ b/etc/src/System/Etc/Internal/Resolver/Env.hs @@ -19,12 +19,12 @@ resolveEnvVarSource -> Spec.ConfigValueType -> Bool -> Spec.ConfigSources cmd - -> Maybe ConfigSource + -> Maybe SomeConfigSource resolveEnvVarSource lookupEnv configValueType isSensitive specSources = let envTextToJSON = Spec.parseBytesToConfigValueJSON configValueType toEnvSource varname envValue = - Env varname . markAsSensitive isSensitive <$> envTextToJSON envValue + envSource 2 varname . markAsSensitive isSensitive <$> envTextToJSON envValue in do varname <- Spec.envVar specSources envText <- lookupEnv varname @@ -36,14 +36,15 @@ buildEnvVarResolver lookupEnv spec = resolverReducer :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue resolverReducer specKey specValue mConfig = case specValue of - Spec.ConfigValue { Spec.isSensitive, Spec.configValueType, Spec.configSources } -> - let updateConfig = do - envSource <- resolveEnvVarSource lookupEnv - configValueType - isSensitive - configSources - writeInSubConfig specKey (ConfigValue $ Set.singleton envSource) <$> mConfig - in updateConfig <|> mConfig + Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType, Spec.configSources } + -> let updateConfig = do + envSource' <- resolveEnvVarSource lookupEnv + configValueType + isSensitive + configSources + writeInSubConfig specKey (ConfigValue $ Set.singleton envSource') + <$> mConfig + in updateConfig <|> mConfig Spec.SubConfig specConfigMap -> let mSubConfig = diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs index 3a32c8b..567d1eb 100644 --- a/etc/src/System/Etc/Internal/Resolver/File.hs +++ b/etc/src/System/Etc/Internal/Resolver/File.hs @@ -25,7 +25,7 @@ import System.Environment (lookupEnv) import System.Etc.Internal.Errors import qualified System.Etc.Internal.Spec.Parser as Spec import qualified System.Etc.Internal.Spec.Types as Spec -import System.Etc.Internal.Types hiding (filepath) +import System.Etc.Internal.Types -------------------------------------------------------------------------------- @@ -41,34 +41,40 @@ parseConfigValue => [Text] -> Spec.ConfigValue cmd -> Int - -> FileSource + -> FileValueOrigin -> JSON.Value -> m ConfigValue -parseConfigValue keys spec fileIndex fileSource json = - let parentKeys = reverse keys - currentKey = Text.intercalate "." parentKeys - in case (spec, json) of - (Spec.SubConfig currentSpec, JSON.Object object) -> SubConfig <$> foldM - (\acc (key, subConfigValue) -> case HashMap.lookup key currentSpec of - Nothing -> - throwM $ UnknownConfigKeyFound parentKeys key (HashMap.keys currentSpec) - Just subConfigSpec -> do - value1 <- parseConfigValue (key : keys) - subConfigSpec - fileIndex - fileSource - subConfigValue - return $ HashMap.insert key value1 acc - ) - HashMap.empty - (HashMap.toList object) - - (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json - - (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do +parseConfigValue keys spec fileIndex fileSource' json = + let + parentKeys = reverse keys + currentKey = Text.intercalate "." parentKeys + in + case (spec, json) of + (Spec.SubConfig currentSpec, JSON.Object object) -> SubConfig <$> foldM + (\acc (key, subConfigValue) -> case HashMap.lookup key currentSpec of + Nothing -> + throwM $ UnknownConfigKeyFound parentKeys key (HashMap.keys currentSpec) + Just subConfigSpec -> do + value1 <- parseConfigValue (key : keys) + subConfigSpec + fileIndex + fileSource' + subConfigValue + return $ HashMap.insert key value1 acc + ) + HashMap.empty + (HashMap.toList object) + + (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json + + (Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType }, _) + -> do either throwM return $ Spec.assertMatchingConfigValueType json configValueType return $ ConfigValue - (Set.singleton $ File fileIndex fileSource $ markAsSensitive isSensitive json) + (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive + isSensitive + json + ) @@ -88,9 +94,15 @@ eitherDecode contents0 = case contents0 of parseConfig - :: MonadThrow m => Spec.ConfigValue cmd -> Int -> FileSource -> ConfigFile -> m Config -parseConfig spec fileIndex fileSource contents = case eitherDecode contents of - Left err -> throwM $ ConfigInvalidSyntaxFound (fileSourcePath fileSource) (Text.pack err) + :: MonadThrow m + => Spec.ConfigValue cmd + -> Int + -> FileValueOrigin + -> ConfigFile + -> m Config +parseConfig spec fileIndex fileSource' contents = case eitherDecode contents of + Left err -> + throwM $ ConfigInvalidSyntaxFound (fileSourcePath fileSource') (Text.pack err) -- Right json -> -- case JSON.iparse (parseConfigValue [] spec fileIndex fileSource) json of -- JSON.IError _ err -> @@ -100,7 +112,7 @@ parseConfig spec fileIndex fileSource contents = case eitherDecode contents of -- _ -> -- throwM $ InvalidConfiguration Nothing (Text.pack err) -- JSON.ISuccess result -> return (Config result) - Right json -> Config <$> parseConfigValue [] spec fileIndex fileSource json + Right json -> Config <$> parseConfigValue [] spec fileIndex fileSource' json readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile) readConfigFile filepath = @@ -121,18 +133,18 @@ readConfigFile filepath = else return $ throwM $ ConfigurationFileNotFound filepath readConfigFromFileSources - :: Spec.ConfigSpec cmd -> [FileSource] -> IO (Config, [SomeException]) + :: Spec.ConfigSpec cmd -> [FileValueOrigin] -> IO (Config, [SomeException]) readConfigFromFileSources spec fileSources = fileSources & zip [1 ..] & mapM - (\(fileIndex, fileSource) -> do - mContents <- readConfigFile (fileSourcePath fileSource) + (\(fileIndex, fileSource') -> do + mContents <- readConfigFile (fileSourcePath fileSource') return ( mContents >>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec) fileIndex - fileSource + fileSource' ) ) & (foldl' @@ -147,15 +159,14 @@ processFilesSpec :: Spec.ConfigSpec cmd -> IO (Config, [SomeException]) processFilesSpec spec = case Spec.specConfigFilepaths spec of Nothing -> readConfigFromFileSources spec [] Just (Spec.FilePathsSpec paths) -> - readConfigFromFileSources spec (map FilePathSource paths) + readConfigFromFileSources spec (map ConfigFileOrigin paths) Just (Spec.FilesSpec fileEnvVar paths0) -> do let getPaths = case fileEnvVar of - Nothing -> return $ map FilePathSource paths0 + Nothing -> return $ map ConfigFileOrigin paths0 Just filePath -> do envFilePath <- lookupEnv (Text.unpack filePath) - let envPath = - maybeToList (EnvVarFileSource filePath . Text.pack <$> envFilePath) - return $ map FilePathSource paths0 ++ envPath + let envPath = maybeToList (EnvFileOrigin filePath . Text.pack <$> envFilePath) + return $ map ConfigFileOrigin paths0 ++ envPath paths <- getPaths readConfigFromFileSources spec paths diff --git a/etc/src/System/Etc/Internal/Spec/Parser.hs b/etc/src/System/Etc/Internal/Spec/Parser.hs index 2d33f5f..ab47ea3 100644 --- a/etc/src/System/Etc/Internal/Spec/Parser.hs +++ b/etc/src/System/Etc/Internal/Spec/Parser.hs @@ -241,12 +241,14 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where mSensitive <- fieldSpec .:? "sensitive" mCvType <- fieldSpec .:? "type" let sensitive = fromMaybe False mSensitive - ConfigValue - <$> pure mDefaultValue - <*> getConfigValueType mDefaultValue mCvType - <*> pure sensitive - <*> (ConfigSources <$> fieldSpec .:? "env" - <*> fieldSpec .:? "cli") + ConfigValue <$> + (ConfigValueData + <$> pure mDefaultValue + <*> getConfigValueType mDefaultValue mCvType + <*> pure sensitive + <*> (ConfigSources <$> fieldSpec .:? "env" + <*> fieldSpec .:? "cli") + <*> pure json) else fail "etc/spec object can only contain one key" @@ -257,13 +259,15 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where _ -> do cvType <- either fail pure $ jsonToConfigValueType json return - ConfigValue - { - defaultValue = Just json - , configValueType = cvType - , isSensitive = False - , configSources = ConfigSources Nothing Nothing - } + $ ConfigValue + ConfigValueData + { + defaultValue = Just json + , configValueType = cvType + , isSensitive = False + , configSources = ConfigSources Nothing Nothing + , rawConfigValue = json + } parseFiles :: JSON.Value -> JSON.Parser FilesSpec parseFiles = JSON.withObject "FilesSpec" $ \object -> do @@ -297,5 +301,6 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where <$> parseFileSpec json <*> (object .:? "etc/cli") <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries")) + <*> pure json _ -> JSON.typeMismatch "ConfigSpec" json diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs index bd28b6b..05f1339 100644 --- a/etc/src/System/Etc/Internal/Spec/Types.hs +++ b/etc/src/System/Etc/Internal/Spec/Types.hs @@ -185,22 +185,29 @@ instance Display ConfigValueType where CVTSingle singleVal -> display singleVal CVTArray singleVal -> display $ "[" <> display singleVal <> "]" -data ConfigValue cmd - = ConfigValue { +data ConfigValueData cmd = + ConfigValueData { defaultValue :: !(Maybe JSON.Value) , configValueType :: !ConfigValueType , isSensitive :: !Bool , configSources :: !(ConfigSources cmd) + , rawConfigValue :: !JSON.Value } - | SubConfig { - subConfig :: !(HashMap Text (ConfigValue cmd)) - } + deriving (Generic, Show, Eq) + +instance Lift cmd => Lift (ConfigValueData cmd) where + lift ConfigValueData {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } = + [| ConfigValueData defaultValue configValueType isSensitive configSources rawConfigValue |] + +data ConfigValue cmd + = ConfigValue !(ConfigValueData cmd) + | SubConfig !(HashMap Text (ConfigValue cmd)) deriving (Generic, Show, Eq) instance Lift cmd => Lift (ConfigValue cmd) where - lift ConfigValue {defaultValue, configValueType, isSensitive, configSources} = - [| ConfigValue defaultValue configValueType isSensitive configSources |] - lift SubConfig {subConfig} = + lift (ConfigValue configValueData) = + [| ConfigValue configValueData |] + lift (SubConfig subConfig) = [| SubConfig (HashMap.fromList $ map (first Text.pack) subConfigList) |] where subConfigList = map (first Text.unpack) $ HashMap.toList subConfig @@ -245,13 +252,15 @@ data ConfigSpec cmd specConfigFilepaths :: !(Maybe FilesSpec) , specCliProgramSpec :: !(Maybe CliProgramSpec) , specConfigValues :: !(HashMap Text (ConfigValue cmd)) + , rawSpec :: !JSON.Value } deriving (Generic, Show, Eq) instance Lift cmd => Lift (ConfigSpec cmd) where - lift ConfigSpec {specConfigFilepaths, specCliProgramSpec, specConfigValues} = + lift ConfigSpec {specConfigFilepaths, specCliProgramSpec, specConfigValues, rawSpec } = [| ConfigSpec specConfigFilepaths specCliProgramSpec - (HashMap.fromList $ map (first Text.pack) configValuesList) |] + (HashMap.fromList $ map (first Text.pack) configValuesList) + rawSpec |] where configValuesList = map (first Text.unpack) $ HashMap.toList specConfigValues diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs index 32d3495..9831661 100644 --- a/etc/src/System/Etc/Internal/Types.hs +++ b/etc/src/System/Etc/Internal/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module System.Etc.Internal.Types @@ -8,12 +10,22 @@ module System.Etc.Internal.Types , module System.Etc.Internal.Spec.Types ) where -import RIO +import RIO hiding ((<>)) import qualified RIO.HashMap as HashMap import qualified RIO.Set as Set +import qualified RIO.Text as Text + +import Text.PrettyPrint.ANSI.Leijen (Doc, (<+>)) +import qualified Text.PrettyPrint.ANSI.Leijen as Doc + + + +import Control.Exception (throw) import Data.Bool (bool) +import Data.Monoid ((<>)) import qualified Data.Semigroup as Semigroup +import Data.Typeable (cast, typeOf) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON (Parser) @@ -28,6 +40,8 @@ data Value a | Sensitive { fromValue :: !a } deriving (Generic, Eq, Ord) +instance NFData a => NFData (Value a) + instance Show a => Show (Value a) where show (Plain a) = show a show (Sensitive _) = "<>" @@ -53,70 +67,130 @@ instance IsString a => IsString (Value a) where markAsSensitive :: Bool -> (a -> Value a) markAsSensitive = bool Plain Sensitive -data FileSource - = FilePathSource { fileSourcePath :: !Text } - | EnvVarFileSource { fileSourceEnvVar :: !Text, fileSourcePath :: !Text } - deriving (Show, Eq) - -data ConfigSource - = File { - configIndex :: !Int - , filepath :: !FileSource - , value :: !(Value JSON.Value) - } - | Env { - envVar :: !Text - , value :: !(Value JSON.Value) - } - | Cli { - value :: !(Value JSON.Value) - } - | Default { - value :: !(Value JSON.Value) - } - | None - deriving (Show, Eq) - -instance Ord ConfigSource where - compare a b = - if a == b then - EQ - else - case (a, b) of - (None, _) -> - LT - - (_, None) -> - GT - - (_, _) - | fromValue (value a) == JSON.Null -> LT - | fromValue (value b) == JSON.Null -> GT - - (Default {}, _) -> - LT - - (Cli {}, _) -> - GT - - (_, Cli {}) -> - LT - - (Env {}, _) -> - GT - - (_, Env {}) -> - LT - - (File {}, File {}) -> - comparing configIndex a b - - (File {}, _) -> - GT +data FileValueOrigin + = ConfigFileOrigin { fileSourcePath :: !Text } + | EnvFileOrigin { fileSourceEnvVar :: !Text, fileSourcePath :: !Text } + deriving (Generic, Show, Eq) + +instance NFData FileValueOrigin + +class (Show source, Typeable source) => + IConfigSource source + where + sourceValue :: source -> Value JSON.Value + sourcePrettyDoc :: source -> Doc + compareSources :: source -> source -> Ordering + compareSources _ _ = EQ + +data SomeConfigSource = + forall source. (IConfigSource source) => + SomeConfigSource !Int + !source + +instance Show SomeConfigSource where + show (SomeConfigSource i a) = "SomeConfigSource " <> show i <> " (" <> show a <> ")" + +-- | Thrown when comparing config sources of different types on a same +-- precedence level, this should never happen because config source values of +-- the same type are created and compared on a single execution; if this does +-- happen, it maybe either be an urgent bug or you used the private API +-- incorrectly. +data InvalidConfigSourceComparison + = InvalidConfigSourceComparison !SomeConfigSource !SomeConfigSource + deriving (Show) + +instance Exception InvalidConfigSourceComparison + +instance IConfigSource SomeConfigSource where + sourcePrettyDoc (SomeConfigSource _ inner) = sourcePrettyDoc inner + sourceValue (SomeConfigSource _ inner) = sourceValue inner + compareSources x@(SomeConfigSource ia a) y@(SomeConfigSource ib b) + | ia == ib = + if fromValue (sourceValue a) == JSON.Null && fromValue (sourceValue b) == JSON.Null then + EQ + else if typeOf a == typeOf b then + let b' = fromMaybe (throw (InvalidConfigSourceComparison x y)) (cast a) + in compareSources a b' + else + throw (InvalidConfigSourceComparison x y) + | fromValue (sourceValue a) == JSON.Null = LT + | fromValue (sourceValue b) == JSON.Null = GT + | otherwise = + compare ia ib + +instance Eq SomeConfigSource where + (==) a b = compareSources a b == EQ + +instance Ord SomeConfigSource where + compare = compareSources + +data FileSource = FileSource + { fsConfigIndex :: !Int + , fsValueOrigin :: !FileValueOrigin + , fsValue :: !(Value JSON.Value) } + deriving (Generic, Typeable, Show, Eq) + +instance NFData FileSource +instance IConfigSource FileSource where + compareSources = comparing fsConfigIndex + sourceValue = fsValue + sourcePrettyDoc (FileSource _index origin _value) = + case origin of + ConfigFileOrigin filepath -> Doc.text "File:" <+> Doc.text (Text.unpack filepath) + EnvFileOrigin envVar filepath -> + Doc.text "File:" <+> Doc.text (Text.unpack envVar) <> "=" <> Doc.text (Text.unpack filepath) + +fileSource :: Int -> Int -> FileValueOrigin -> Value JSON.Value -> SomeConfigSource +fileSource precedenceOrder index origin val = + SomeConfigSource precedenceOrder $ FileSource index origin val + +data EnvSource = EnvSource + { + esVarName :: !Text + , esValue :: !(Value JSON.Value) + } + deriving (Generic, Typeable, Show, Eq) + +instance NFData EnvSource +instance IConfigSource EnvSource where + sourceValue = esValue + sourcePrettyDoc (EnvSource varname _value) = + Doc.text "Env:" <+> Doc.text (Text.unpack varname) + +envSource :: Int -> Text -> Value JSON.Value -> SomeConfigSource +envSource precedenceOrder varName val = + SomeConfigSource precedenceOrder $ EnvSource varName val + +newtype DefaultSource = + DefaultSource (Value JSON.Value) + deriving (Generic, Typeable, Show, Eq, NFData) + +instance IConfigSource DefaultSource where + sourceValue (DefaultSource value) = value + sourcePrettyDoc (DefaultSource _value) = Doc.text "Default" + +defaultSource :: Value JSON.Value -> SomeConfigSource +defaultSource = SomeConfigSource 0 . DefaultSource + +-------------------------------------------------------------------------------- +-- TODO: Split out + +newtype CliSource + = CliSource (Value JSON.Value) + deriving (Generic, Typeable, Show, Eq, NFData) + +instance IConfigSource CliSource where + sourceValue (CliSource value) = value + sourcePrettyDoc (CliSource _value) = Doc.text "Cli" + +cliSource :: Int -> Value JSON.Value -> SomeConfigSource +cliSource precedenceOrder val = SomeConfigSource precedenceOrder $ CliSource val + +-------------------------------------------------------------------------------- data ConfigValue = ConfigValue { - configSource :: !(Set ConfigSource) + configSource :: !(Set SomeConfigSource) } | SubConfig { configMap :: !(HashMap Text ConfigValue) @@ -208,9 +282,9 @@ class IConfig config where :: (MonadThrow m) => [Text] -> config - -> m (Set ConfigSource) + -> m (Set SomeConfigSource) getSelectedConfigSource - :: (MonadThrow m) + :: (MonadThrow m, IConfigSource source) => [Text] -> config - -> m ConfigSource + -> m source diff --git a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs index 045f3aa..eb2799f 100644 --- a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs +++ b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs @@ -11,6 +11,7 @@ import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) import System.Etc +import System.Etc.Internal.Types (CliSource (..)) with_command_option_tests :: TestTree with_command_option_tests = testGroup @@ -40,8 +41,9 @@ with_command_option_tests = testGroup case getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (Cli "hello cli") aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SomeConfigSource 3 $ CliSource "hello cli") aSet) , testCase "entry accepts long" $ do let input = mconcat [ "{ \"etc/cli\": {" @@ -70,8 +72,9 @@ with_command_option_tests = testGroup case getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (Cli "hello cli") aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SomeConfigSource 3 $ CliSource "hello cli") aSet) , testCase "entry gets validated with a type" $ do let input = mconcat [ "{ \"etc/cli\": {" diff --git a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs index 8897e77..62f8eec 100644 --- a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs +++ b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs @@ -13,7 +13,8 @@ import qualified Data.Aeson as JSON import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) -import qualified System.Etc as SUT +import qualified System.Etc as SUT +import System.Etc.Internal.Types (CliSource (..)) resolver_tests :: TestTree resolver_tests = testGroup @@ -96,8 +97,9 @@ option_tests = testGroup case SUT.getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (SUT.Cli "hello cli") aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SUT.SomeConfigSource 3 $ CliSource "hello cli") aSet) , testCase "entry accepts long" $ do let input = mconcat [ "{ \"etc/entries\": {" @@ -115,8 +117,9 @@ option_tests = testGroup case SUT.getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (SUT.Cli "hello cli") aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SUT.SomeConfigSource 3 $ CliSource "hello cli") aSet) , testCase "entry gets validated with a type" $ do let input = mconcat [ "{ \"etc/entries\": {" diff --git a/etc/test/System/Etc/Resolver/DefaultTest.hs b/etc/test/System/Etc/Resolver/DefaultTest.hs index a9b0016..3a52e8c 100644 --- a/etc/test/System/Etc/Resolver/DefaultTest.hs +++ b/etc/test/System/Etc/Resolver/DefaultTest.hs @@ -11,12 +11,13 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase) import System.Etc +import System.Etc.Internal.Types (DefaultSource (..)) assertDefaultValue :: Config -> [Text] -> Value JSON.Value -> IO () assertDefaultValue config keys val = case getAllConfigSources keys config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (Default val) aSet) + (Set.member (SomeConfigSource 0 $ DefaultSource val) aSet) tests :: TestTree tests = testGroup @@ -47,6 +48,7 @@ tests = testGroup case getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (Default $ Plain JSON.Null) aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SomeConfigSource 0 $ DefaultSource $ Plain JSON.Null) aSet) ] diff --git a/etc/test/System/Etc/Resolver/EnvTest.hs b/etc/test/System/Etc/Resolver/EnvTest.hs index c3bd5da..8d67402 100644 --- a/etc/test/System/Etc/Resolver/EnvTest.hs +++ b/etc/test/System/Etc/Resolver/EnvTest.hs @@ -14,6 +14,7 @@ import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) import Paths_etc (getDataFileName) import System.Etc +import System.Etc.Internal.Types (EnvSource (..)) tests :: TestTree @@ -31,8 +32,9 @@ tests = testGroup case getAllConfigSources ["greeting"] config of Nothing -> assertFailure ("expecting to get entries for greeting (check fixtures)\n" <> show config) - Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet) - (Set.member (Env "GREETING" "hello env") aSet) + Just aSet -> assertBool + ("expecting to see entry from env; got " <> show aSet) + (Set.member (SomeConfigSource 2 $ EnvSource "GREETING" "hello env") aSet) , testCase "has precedence over default and file values" $ do jsonFilepath <- getDataFileName "test/fixtures/config.json" let input = mconcat diff --git a/etc/test/System/Etc/Resolver/FileTest.hs b/etc/test/System/Etc/Resolver/FileTest.hs index 9ce8de1..0cbc2f2 100644 --- a/etc/test/System/Etc/Resolver/FileTest.hs +++ b/etc/test/System/Etc/Resolver/FileTest.hs @@ -12,6 +12,8 @@ import qualified RIO.Text as Text import qualified RIO.Vector as Vector import qualified RIO.Vector.Partial as Vector (head) +import Data.Typeable (cast) + import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) @@ -21,7 +23,7 @@ import Paths_etc (getDataFileName) import System.Environment (setEnv) import System.Etc -import System.Etc.Internal.Types (FileSource (..)) +import System.Etc.Internal.Types (FileSource (..), FileValueOrigin (..)) tests :: TestTree tests = testGroup @@ -102,14 +104,19 @@ filePathsTests = testGroup ("expecting to get entries for greeting (check fixtures)\n" <> show config) Just aSet -> assertBool ("expecting to see entry from json config file " <> show aSet) - (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet) + (Set.member + ( SomeConfigSource 1 + $ FileSource 1 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json" + ) + aSet + ) #ifdef WITH_YAML >> assertBool ("expecting to see entry from yaml config file " <> show aSet) - (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello yaml") aSet) + (Set.member (SomeConfigSource 1 $ FileSource 2 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello yaml") aSet) >> assertBool ("expecting to see entry from yml config file " <> show aSet) - (Set.member (File 3 (FilePathSource $ Text.pack jsonFilepath) "hello yml") aSet) + (Set.member (SomeConfigSource 1 $ FileSource 3 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello yml") aSet) #endif , testCase "does not support any other file extension" $ do fooFilepath <- getDataFileName "test/fixtures/config.foo" @@ -151,7 +158,12 @@ filePathsTests = testGroup ("expecting to get entries for greeting (check fixtures)\n" <> show config) Just aSet -> assertBool ("expecting to see entry from json config file " <> show aSet) - (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet) + (Set.member + ( SomeConfigSource 1 + $ FileSource 1 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json" + ) + aSet + ) if Vector.null errs then assertFailure "expecting one error, got none" @@ -186,9 +198,9 @@ filePathsTests = testGroup Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config) Just aSet -> let result = any - (\entry -> case entry of - File _ _ (Plain JSON.Null) -> True - _ -> False + (\(SomeConfigSource _ source) -> case cast source of + Just (FileSource _ _ (Plain JSON.Null)) -> True + _ -> False ) aSet in assertBool ("expecting to see entry from env; got " <> show aSet) result @@ -235,13 +247,19 @@ filesTest = testGroup assertBool ("expecting to see entry from env config file " <> show aSet) (Set.member - (File 1 - (EnvVarFileSource envFileTest $ Text.pack envFilePath) - "hello environment" + (SomeConfigSource 1 $ FileSource + 1 + (EnvFileOrigin envFileTest $ Text.pack envFilePath) + "hello environment" ) aSet ) assertBool ("expecting to see entry from json config file " <> show aSet) - (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet) + (Set.member + ( SomeConfigSource 1 + $ FileSource 2 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json" + ) + aSet + ) ] diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs index 924d01b..2eae9e9 100644 --- a/etc/test/System/Etc/SpecTest.hs +++ b/etc/test/System/Etc/SpecTest.hs @@ -79,26 +79,26 @@ general_tests = testGroup let input = "{\"etc/entries\":{\"greeting\":123}}" keys = ["greeting"] - config <- SUT.parseConfigSpec input + (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure + Just (ConfigValue value) -> assertEqual "should contain default value" + (Just (JSON.Number 123)) + (defaultValue value) + _ -> assertFailure (show keys ++ " should map to a config value, got sub config map instead") - Just (value :: ConfigValue ()) -> assertEqual "should contain default value" - (Just (JSON.Number 123)) - (defaultValue value) , testCase "entries that finish with arrays sets them as default value" $ do let input = "{\"etc/entries\":{\"greeting\":[123]}}" keys = ["greeting"] - config <- SUT.parseConfigSpec input + (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure - (show keys ++ " should map to a config value, got sub config map instead") - Just (value :: ConfigValue ()) -> assertEqual + Just (ConfigValue value) -> assertEqual "should contain default value" (Just (JSON.Array (Vector.fromList [JSON.Number 123]))) (defaultValue value) + _ -> assertFailure + (show keys ++ " should map to a config value, got sub config map instead") , testCase "entries with empty arrays as values fail because type cannot be infered" $ do let input = "{\"etc/entries\":{\"greeting\": []}}" case SUT.parseConfigSpec input of @@ -115,44 +115,43 @@ general_tests = testGroup = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[],\"type\":\"[string]\"}}}}" keys = ["greeting"] - config <- SUT.parseConfigSpec input + (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure - (show keys ++ " should map to an array config value, got sub config map instead") + Just (ConfigValue value) -> assertEqual "should contain default array value" + (Just (JSON.Array (Vector.fromList []))) + (defaultValue value) - Just (value :: ConfigValue ()) -> assertEqual - "should contain default array value" - (Just (JSON.Array (Vector.fromList []))) - (defaultValue value) + _ -> assertFailure + (show keys ++ " should map to an array config value, got sub config map instead") , testCase "entries with array of objects do not fail" $ do let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[{\"hello\":\"world\"}],\"type\":\"[object]\"}}}}" keys = ["greeting"] - config <- SUT.parseConfigSpec input + (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure - (show keys ++ " should map to an array config value, got sub config map instead") - - Just (value :: ConfigValue ()) -> assertEqual + Just (ConfigValue value) -> assertEqual "should contain default array value" (Just (JSON.Array (Vector.fromList [JSON.object ["hello" JSON..= ("world" :: Text)]])) ) (defaultValue value) + + _ -> assertFailure + (show keys ++ " should map to an array config value, got sub config map instead") , testCase "entries can have many levels of nesting" $ do let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}" keys = ["english", "greeting"] - config <- SUT.parseConfigSpec input + (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure + Just (ConfigValue value) -> assertEqual "should contain default value" + (Just (JSON.String "hello")) + (defaultValue value) + _ -> assertFailure (show keys ++ " should map to a config value, got sub config map instead") - Just (value :: ConfigValue ()) -> assertEqual "should contain default value" - (Just (JSON.String "hello")) - (defaultValue value) , testCase "spec map cannot be empty object" $ do let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}" @@ -233,11 +232,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - PlainEntry (Opt metadata) <- cliEntry (configSources value) - short <- optShort metadata - return (short, valueType) + configValue <- getConfigValue keys (specConfigValues config) + case configValue of + ConfigValue value -> do + let valueType = configValueType value + PlainEntry (Opt metadata) <- cliEntry (configSources value) + short <- optShort metadata + return (short, valueType) + _ -> + Nothing case result of Nothing -> @@ -255,11 +258,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - PlainEntry (Opt metadata) <- cliEntry (configSources value) - long <- optLong metadata - return (long, valueType) + configValue <- getConfigValue keys (specConfigValues config) + case configValue of + ConfigValue value -> do + let valueType = configValueType value + PlainEntry (Opt metadata) <- cliEntry (configSources value) + long <- optLong metadata + return (long, valueType) + _ -> + Nothing case result of Nothing -> @@ -277,11 +284,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - CmdEntry cmd (Opt metadata) <- cliEntry (configSources value) - long <- optLong metadata - return (cmd, long, valueType) + configValue <- getConfigValue keys (specConfigValues config) + case configValue of + (ConfigValue value) -> do + let valueType = configValueType value + CmdEntry cmd (Opt metadata) <- cliEntry (configSources value) + long <- optLong metadata + return (cmd, long, valueType) + _ -> + Nothing case result of Nothing -> @@ -317,11 +328,11 @@ envvar_tests = testGroup (config :: ConfigSpec ()) <- SUT.parseConfigSpec input case getConfigValue keys (specConfigValues config) of - Nothing -> assertFailure + Just (ConfigValue value) -> assertEqual "should contain EnvVar value" + (ConfigSources (Just "GREETING") Nothing) + (configSources value) + _ -> assertFailure (show keys ++ " should map to a config value, got sub config map instead") - Just value -> assertEqual "should contain EnvVar value" - (ConfigSources (Just "GREETING") Nothing) - (configSources value) ] #ifdef WITH_YAML @@ -341,13 +352,13 @@ yaml_tests = Right (config :: ConfigSpec ()) -> case getConfigValue keys (specConfigValues config) of - Nothing -> - assertFailure (show keys ++ " should map to a config value, got sub config map instead") - - Just value -> + Just (ConfigValue value) -> assertEqual "should contain EnvVar value" (ConfigSources (Just "GREETING") Nothing) (configSources value) + _ -> + assertFailure (show keys ++ " should map to a config value, got sub config map instead") + ] #endif diff --git a/examples/etc-command-example/src/Main.hs b/examples/etc-command-example/src/Main.hs index 87b629a..57488ab 100644 --- a/examples/etc-command-example/src/Main.hs +++ b/examples/etc-command-example/src/Main.hs @@ -58,6 +58,10 @@ main = do Etc.reportEnvMisspellingWarnings configSpec + -- in case source fetching fails with an IO error, you may want to fail fast (e.g. vault) + -- config <- Etc.resolve [defaultCli, defaultVault, defaultEnv] configSpec + -- cmd <- Etc.resolveCommandCli configSpec + -- fileWarnings <- Etc.resolveFiles configSpec (configFiles, _fileWarnings) <- Etc.resolveFiles configSpec (cmd , configCli ) <- Etc.resolveCommandCli configSpec configEnv <- Etc.resolveEnv configSpec