diff --git a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs index 924b9c0..87e5077 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/Resolver/Cli/Command.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs index 7abb400..452d280 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs @@ -113,7 +113,7 @@ 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 } -> + 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/Plain.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs index 62206c4..7ee503e 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs @@ -92,7 +92,7 @@ specToConfigValueCli -> (Text, Spec.ConfigValue ()) -> m (Opt.Parser ConfigValue) specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of - Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } -> + 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 80aca80..1dbe17a 100644 --- a/etc/src/System/Etc/Internal/Resolver/Default.hs +++ b/etc/src/System/Etc/Internal/Resolver/Default.hs @@ -20,7 +20,7 @@ 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 dca762a..ec9e091 100644 --- a/etc/src/System/Etc/Internal/Resolver/Env.hs +++ b/etc/src/System/Etc/Internal/Resolver/Env.hs @@ -36,7 +36,7 @@ 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 } -> + Spec.ConfigValue (Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType, Spec.configSources }) -> let updateConfig = do envSource' <- resolveEnvVarSource lookupEnv configValueType diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs index bc840b5..a270148 100644 --- a/etc/src/System/Etc/Internal/Resolver/File.hs +++ b/etc/src/System/Etc/Internal/Resolver/File.hs @@ -67,7 +67,7 @@ parseConfigValue keys spec fileIndex fileSource' json = (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json - (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do + (Spec.ConfigValue (Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType }), _) -> do either throwM return $ Spec.assertMatchingConfigValueType json configValueType return $ ConfigValue (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive diff --git a/etc/src/System/Etc/Internal/Spec/Parser.hs b/etc/src/System/Etc/Internal/Spec/Parser.hs index bc7b5ce..21a0ad7 100644 --- a/etc/src/System/Etc/Internal/Spec/Parser.hs +++ b/etc/src/System/Etc/Internal/Spec/Parser.hs @@ -222,13 +222,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") - <*> pure json + 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" @@ -239,14 +240,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 - , rawConfigValue = json - } + $ 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 diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs index 914e639..c94ea86 100644 --- a/etc/src/System/Etc/Internal/Spec/Types.hs +++ b/etc/src/System/Etc/Internal/Spec/Types.hs @@ -13,7 +13,7 @@ module System.Etc.Internal.Spec.Types where -import RIO +import RIO hiding (lift) import qualified RIO.HashMap as HashMap import qualified RIO.Text as Text import qualified RIO.Vector as Vector @@ -142,23 +142,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, rawConfigValue } = - [| ConfigValue defaultValue configValueType isSensitive configSources rawConfigValue |] - 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 diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs index 8f68486..ebea824 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 - (show keys ++ " should map to a config value, got sub config map instead") - Just (value :: ConfigValue ()) -> assertEqual "should contain default value" + 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") , 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,45 @@ 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 (value :: ConfigValue ()) -> assertEqual + Just (ConfigValue value) -> 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 - (show keys ++ " should map to a config value, got sub config map instead") - Just (value :: ConfigValue ()) -> assertEqual "should contain default value" + 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") , testCase "spec map cannot be empty object" $ do let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}" @@ -233,11 +234,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - PlainEntry 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 metadata <- cliEntry (configSources value) + short <- optShort metadata + return (short, valueType) + _ -> + Nothing case result of Nothing -> @@ -255,11 +260,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - PlainEntry 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 metadata <- cliEntry (configSources value) + long <- optLong metadata + return (long, valueType) + _ -> + Nothing case result of Nothing -> @@ -277,11 +286,15 @@ cli_tests = let result = do - value <- getConfigValue keys (specConfigValues config) - let valueType = configValueType value - CmdEntry cmd 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 metadata <- cliEntry (configSources value) + long <- optLong metadata + return (cmd, long, valueType) + _ -> + Nothing case result of Nothing -> @@ -317,11 +330,11 @@ envvar_tests = testGroup (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 -> assertEqual "should contain EnvVar 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") ] #ifdef WITH_YAML @@ -341,13 +354,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