From ffd0376c2a7b5034fd1b14e4788ca89b93b89c3f Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Fri, 27 Apr 2018 17:12:46 -0700 Subject: [PATCH 1/6] Support for multiple types with different resolvers (closes #30) --- etc/CHANGELOG.md | 10 + etc/etc.cabal | 2 +- etc/src/System/Etc.hs | 6 - etc/src/System/Etc/Internal/Config.hs | 4 +- .../System/Etc/Internal/Extra/EnvMisspell.hs | 5 +- .../Etc/Internal/Resolver/Cli/Command.hs | 17 +- .../Etc/Internal/Resolver/Cli/Common.hs | 47 +++-- .../System/Etc/Internal/Resolver/Cli/Plain.hs | 20 +- .../System/Etc/Internal/Resolver/Default.hs | 8 +- etc/src/System/Etc/Internal/Resolver/Env.hs | 66 ++++--- etc/src/System/Etc/Internal/Resolver/File.hs | 2 +- etc/src/System/Etc/Internal/Spec/Types.hs | 178 ++++++++++++------ etc/src/System/Etc/Internal/Types.hs | 4 +- etc/test/System/Etc/Extra/EnvMisspellTest.hs | 2 +- .../System/Etc/Resolver/Cli/CommandTest.hs | 52 +++-- etc/test/System/Etc/Resolver/Cli/PlainTest.hs | 131 ++++++++----- etc/test/System/Etc/Resolver/DefaultTest.hs | 6 +- etc/test/System/Etc/Resolver/EnvTest.hs | 73 ++++++- etc/test/System/Etc/SpecTest.hs | 84 +++++++-- etc/test/fixtures/config.spec.yaml | 1 + 20 files changed, 485 insertions(+), 233 deletions(-) diff --git a/etc/CHANGELOG.md b/etc/CHANGELOG.md index 69874a0..5edecd2 100644 --- a/etc/CHANGELOG.md +++ b/etc/CHANGELOG.md @@ -1,3 +1,13 @@ +0.4.0.0 +---- +**BREAKING CHANGES** + +* Add new `type` field to `etc/spec` with support for `string`, `number`, `bool`, `[string]`, `[number]` and `[bool]` +* Remove `type` field in `cli` spec in favor of `type` on `etc/spec` +* Allow ENV vars to accept supported types (only strings were allowed) +* Allow CLI options to accept supported types (only strings and numbers were allowed) +* Allow spec file to have array as default values + 0.3.2.0 ---- diff --git a/etc/etc.cabal b/etc/etc.cabal index f7e2d08..82dda59 100644 --- a/etc/etc.cabal +++ b/etc/etc.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: etc -version: 0.3.2.0 +version: 0.3.3.0 synopsis: Declarative configuration spec for Haskell projects description: `etc` gathers configuration values from multiple sources (cli options, OS environment variables, files) using a declarative spec file that defines where diff --git a/etc/src/System/Etc.hs b/etc/src/System/Etc.hs index 87fdb25..7cbcdbb 100644 --- a/etc/src/System/Etc.hs +++ b/etc/src/System/Etc.hs @@ -1,11 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} - - -{-| - --} - module System.Etc ( -- * Config -- $config diff --git a/etc/src/System/Etc/Internal/Config.hs b/etc/src/System/Etc/Internal/Config.hs index 2a81662..6239ad9 100644 --- a/etc/src/System/Etc/Internal/Config.hs +++ b/etc/src/System/Etc/Internal/Config.hs @@ -46,7 +46,7 @@ _getConfigValueWith parser keys0 (Config configValue0) = Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of JSON.IError path err -> - let key = keys0 & reverse & Text.intercalate "." + let key = keys0 & Text.intercalate "." in JSON.formatError path err & Text.pack & InvalidConfiguration (Just key) @@ -57,7 +57,7 @@ _getConfigValueWith parser keys0 (Config configValue0) = ([], innerConfigValue) -> case JSON.iparse parser (configValueToJsonObject innerConfigValue) of JSON.IError path err -> - let key = keys0 & reverse & Text.intercalate "." + let key = keys0 & Text.intercalate "." in JSON.formatError path err & Text.pack & InvalidConfiguration (Just key) diff --git a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs index 6b6b6d9..924b9c0 100644 --- a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs +++ b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Extra.EnvMisspell ( @@ -33,8 +34,8 @@ data EnvMisspell lookupSpecEnvKeys :: ConfigSpec a -> Vector Text lookupSpecEnvKeys spec = let foldEnvSettings val acc = case val of - ConfigValue _defVal _sensitive sources -> - maybe acc (`Vector.cons` acc) (envVar sources) + ConfigValue { 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 22e9f6d..b414997 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure) where @@ -22,12 +23,13 @@ import qualified System.Etc.Internal.Spec.Types as Spec entrySpecToJsonCli :: (MonadThrow m) - => Bool + => Spec.ConfigValueType + -> Bool -> Spec.CliEntrySpec cmd -> m (Vector cmd, Opt.Parser (Maybe (Value JSON.Value))) -entrySpecToJsonCli sensitive entrySpec = case entrySpec of +entrySpecToJsonCli cvType isSensitive entrySpec = case entrySpec of Spec.CmdEntry commandJsonValue specSettings -> - return (commandJsonValue, settingsToJsonCli sensitive specSettings) + return (commandJsonValue, settingsToJsonCli cvType isSensitive specSettings) Spec.PlainEntry{} -> throwM CommandKeyMissing @@ -35,10 +37,11 @@ configValueSpecToCli :: (MonadThrow m, Eq cmd, Hashable cmd) => HashMap cmd (Opt.Parser ConfigValue) -> Text + -> Spec.ConfigValueType -> Bool -> Spec.ConfigSources cmd -> m (HashMap cmd (Opt.Parser ConfigValue)) -configValueSpecToCli acc0 specEntryKey sensitive sources = +configValueSpecToCli acc0 specEntryKey cvType isSensitive sources = let updateAccConfigOptParser configValueParser accOptParser = (\configValue accSubConfig -> case accSubConfig of ConfigValue{} -> accSubConfig @@ -52,7 +55,7 @@ configValueSpecToCli acc0 specEntryKey sensitive sources = Nothing -> return acc0 Just entrySpec -> do - (commands, jsonOptParser) <- entrySpecToJsonCli sensitive entrySpec + (commands, jsonOptParser) <- entrySpecToJsonCli cvType isSensitive entrySpec let configValueParser = jsonToConfigValue <$> jsonOptParser @@ -111,8 +114,8 @@ specToConfigValueCli -> (Text, Spec.ConfigValue cmd) -> m (HashMap cmd (Opt.Parser ConfigValue)) specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of - Spec.ConfigValue _ sensitive sources -> - configValueSpecToCli acc specEntryKey sensitive sources + Spec.ConfigValue { 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 0f0fd64..8a6e55d 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs @@ -70,7 +70,6 @@ specToCliSwitchFieldMod specSettings = specToCliVarFieldMod specSettings = specToCliSwitchFieldMod specSettings `mappend` maybe Opt.idm (Opt.metavar . Text.unpack) (Spec.optMetavar specSettings) - commandToKey :: (MonadThrow m, JSON.ToJSON cmd) => cmd -> m [Text] commandToKey cmd = case JSON.toJSON cmd of JSON.String commandStr -> return [commandStr] @@ -84,31 +83,31 @@ commandToKey cmd = case JSON.toJSON cmd of & InvalidCliCommandKey & throwM -settingsToJsonCli :: Bool -> Spec.CliEntryMetadata -> Opt.Parser (Maybe (Value JSON.Value)) -settingsToJsonCli sensitive specSettings = +jsonOptReader :: Spec.ConfigValueType -> Bool -> String -> Either String (Value JSON.Value) +jsonOptReader cvType isSensitive content = + let contentText = Text.pack content + jsonValue = fromMaybe (JSON.String contentText) + (JSON.decodeStrict' $ Text.encodeUtf8 contentText) + in if Spec.matchesConfigValueType jsonValue cvType + then Right $ markAsSensitive isSensitive jsonValue + else Left "input is not valid" + +settingsToJsonCli + :: Spec.ConfigValueType + -> Bool + -> Spec.CliEntryMetadata + -> Opt.Parser (Maybe (Value JSON.Value)) +settingsToJsonCli cvType isSensitive specSettings = let requiredCombinator = if Spec.optRequired specSettings then (Just <$>) else Opt.optional - in - requiredCombinator $ case specSettings of - Spec.Opt{} -> case Spec.optValueType specSettings of - Spec.StringOpt -> boolToValue sensitive . JSON.String . Text.pack <$> Opt.strOption - (specToCliVarFieldMod specSettings) - - Spec.NumberOpt -> boolToValue sensitive . JSON.Number . fromInteger <$> Opt.option - Opt.auto - (specToCliVarFieldMod specSettings) - - Spec.SwitchOpt -> boolToValue sensitive . JSON.Bool <$> Opt.switch - (specToCliSwitchFieldMod specSettings) - - Spec.Arg{} -> case Spec.argValueType specSettings of - Spec.StringArg -> - boolToValue sensitive . JSON.String . Text.pack <$> Opt.strArgument - (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack)) - Spec.NumberArg -> - boolToValue sensitive . JSON.Number . fromInteger <$> Opt.argument - Opt.auto - (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack)) + in requiredCombinator $ case specSettings of + Spec.Opt{} -> Opt.option (Opt.eitherReader $ jsonOptReader cvType isSensitive) + (specToCliVarFieldMod specSettings) + + Spec.Arg{} -> Opt.argument + (Opt.eitherReader $ jsonOptReader cvType isSensitive) + (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack)) + parseCommandJsonValue :: (MonadThrow m, JSON.FromJSON a) => JSON.Value -> m a parseCommandJsonValue commandValue = case JSON.iparse JSON.parseJSON commandValue of diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs index 6252fa6..62206c4 100644 --- a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs +++ b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} module System.Etc.Internal.Resolver.Cli.Plain (PlainConfigSpec, resolvePlainCli, resolvePlainCliPure) where @@ -23,23 +24,26 @@ type PlainConfigSpec = entrySpecToConfigValueCli :: (MonadThrow m) - => Bool + => Spec.ConfigValueType + -> Bool -> Spec.CliEntrySpec () -> m (Opt.Parser (Maybe (Value JSON.Value))) -entrySpecToConfigValueCli sensitive entrySpec = case entrySpec of - Spec.CmdEntry{} -> throwM CommandKeyOnPlainCli +entrySpecToConfigValueCli cvType isSensitive entrySpec = case entrySpec of + Spec.CmdEntry{} -> throwM CommandKeyOnPlainCli - Spec.PlainEntry specSettings -> return (settingsToJsonCli sensitive specSettings) + Spec.PlainEntry specSettings -> + return (settingsToJsonCli cvType isSensitive specSettings) configValueSpecToCli :: (MonadThrow m) => Text + -> Spec.ConfigValueType -> Bool -> Spec.ConfigSources () -> Opt.Parser ConfigValue -> m (Opt.Parser ConfigValue) -configValueSpecToCli specEntryKey sensitive sources acc = +configValueSpecToCli specEntryKey cvType isSensitive sources acc = let updateAccConfigOptParser configValueParser accOptParser = (\configValue accSubConfig -> case accSubConfig of ConfigValue{} -> accSubConfig @@ -53,7 +57,7 @@ configValueSpecToCli specEntryKey sensitive sources acc = Nothing -> return acc Just entrySpec -> do - jsonOptParser <- entrySpecToConfigValueCli sensitive entrySpec + jsonOptParser <- entrySpecToConfigValueCli cvType isSensitive entrySpec let configValueParser = jsonToConfigValue <$> jsonOptParser @@ -88,8 +92,8 @@ specToConfigValueCli -> (Text, Spec.ConfigValue ()) -> m (Opt.Parser ConfigValue) specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of - Spec.ConfigValue _ sensitive sources -> - configValueSpecToCli specEntryKey sensitive sources acc + Spec.ConfigValue { 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 43e14b6..1742045 100644 --- a/etc/src/System/Etc/Internal/Resolver/Default.hs +++ b/etc/src/System/Etc/Internal/Resolver/Default.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} - module System.Etc.Internal.Resolver.Default (resolveDefault) where import RIO @@ -13,15 +13,15 @@ import System.Etc.Internal.Types toDefaultConfigValue :: Bool -> JSON.Value -> ConfigValue toDefaultConfigValue sensitive = - ConfigValue . Set.singleton . Default . boolToValue sensitive + ConfigValue . Set.singleton . Default . 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 def sensitive _ -> - let mConfigSource = toDefaultConfigValue sensitive <$> def + Spec.ConfigValue { Spec.defaultValue, Spec.isSensitive } -> + let mConfigSource = toDefaultConfigValue isSensitive <$> defaultValue updateConfig = writeInSubConfig specKey <$> mConfigSource <*> mConfig in updateConfig <|> mConfig diff --git a/etc/src/System/Etc/Internal/Resolver/Env.hs b/etc/src/System/Etc/Internal/Resolver/Env.hs index dc5a0df..df94923 100644 --- a/etc/src/System/Etc/Internal/Resolver/Env.hs +++ b/etc/src/System/Etc/Internal/Resolver/Env.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} - module System.Etc.Internal.Resolver.Env (resolveEnv, resolveEnvPure) where import RIO @@ -8,44 +8,54 @@ import qualified RIO.Set as Set import qualified RIO.Text as Text import System.Environment (getEnvironment) -import Control.Arrow ((***)) -import qualified Data.Aeson as JSON +import Control.Arrow ((***)) import qualified System.Etc.Internal.Spec.Types as Spec import System.Etc.Internal.Types resolveEnvVarSource - :: (Text -> Maybe Text) -> Bool -> Spec.ConfigSources cmd -> Maybe ConfigSource -resolveEnvVarSource lookupEnv sensitive specSources = - let toEnvSource varname envValue = - envValue & JSON.String & boolToValue sensitive & Env varname + :: (Text -> Maybe Text) + -> Spec.ConfigValueType + -> Bool + -> Spec.ConfigSources cmd + -> Maybe ConfigSource +resolveEnvVarSource lookupEnv configValueType isSensitive specSources = + let envTextToJSON envValue = Spec.parseBytesToConfigValueJSON configValueType envValue + + toEnvSource varname envValue = + Env varname . markAsSensitive isSensitive <$> envTextToJSON envValue in do varname <- Spec.envVar specSources - toEnvSource varname <$> lookupEnv varname + envText <- lookupEnv varname + toEnvSource varname envText buildEnvVarResolver :: (Text -> Maybe Text) -> Spec.ConfigSpec cmd -> Maybe ConfigValue buildEnvVarResolver lookupEnv spec = - let resolverReducer - :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue - resolverReducer specKey specValue mConfig = case specValue of - Spec.ConfigValue _ sensitive sources -> - let updateConfig = do - envSource <- resolveEnvVarSource lookupEnv sensitive sources - writeInSubConfig specKey (ConfigValue $ Set.singleton envSource) - <$> mConfig - in updateConfig <|> mConfig + let + 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.SubConfig specConfigMap -> - let mSubConfig = - specConfigMap - & HashMap.foldrWithKey resolverReducer (Just emptySubConfig) - & filterMaybe isEmptySubConfig + Spec.SubConfig specConfigMap -> + let mSubConfig = + specConfigMap + & HashMap.foldrWithKey resolverReducer (Just emptySubConfig) + & filterMaybe isEmptySubConfig - updateConfig = writeInSubConfig specKey <$> mSubConfig <*> mConfig - in updateConfig <|> mConfig - in Spec.specConfigValues spec - & HashMap.foldrWithKey resolverReducer (Just emptySubConfig) - & filterMaybe isEmptySubConfig + updateConfig = writeInSubConfig specKey <$> mSubConfig <*> mConfig + in updateConfig <|> mConfig + in + Spec.specConfigValues spec + & HashMap.foldrWithKey resolverReducer (Just emptySubConfig) + & filterMaybe isEmptySubConfig {-| Gathers all OS Environment Variable values (@env@ entries) from the @etc/spec@ @@ -67,7 +77,7 @@ resolveEnvPure spec envMap0 = {-| Gathers all OS Environment Variable values (@env@ entries) from the @etc/spec@ -entries inside a @ConfigSpec@. +entries inside a @ConfigSpec@ -} resolveEnv diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs index 7da0094..68b5177 100644 --- a/etc/src/System/Etc/Internal/Resolver/File.hs +++ b/etc/src/System/Etc/Internal/Resolver/File.hs @@ -61,7 +61,7 @@ parseConfigValue mSpec fileIndex fileSource json = case json of let mToValue = do spec <- mSpec case spec of - Spec.ConfigValue{} -> return $ boolToValue (Spec.isSensitive spec) + Spec.ConfigValue{} -> return $ markAsSensitive (Spec.isSensitive spec) _ -> fail "configuration spec and configuration value are different" toValue = fromMaybe Plain mToValue diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs index 8ced1ed..b00d971 100644 --- a/etc/src/System/Etc/Internal/Spec/Types.hs +++ b/etc/src/System/Etc/Internal/Spec/Types.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Spec.Types where -import Prelude (fail) +import Prelude (fail) + import RIO -import qualified RIO.HashMap as HashMap +import qualified RIO.HashMap as HashMap +import qualified RIO.Text as Text +import qualified RIO.Vector.Partial as Vector (head) import Data.Aeson ((.:), (.:?)) @@ -18,7 +22,7 @@ data ConfigurationError = InvalidConfiguration !(Maybe Text) !Text | InvalidConfigKeyPath ![Text] | ConfigurationFileNotFound !Text - deriving (Show) + deriving (Generic, Show) instance Exception ConfigurationError @@ -28,28 +32,26 @@ data CliOptValueType = StringOpt | NumberOpt | SwitchOpt - deriving (Show, Eq) + deriving (Generic, Show, Eq) data CliArgValueType = StringArg | NumberArg - deriving (Show, Eq) + deriving (Generic, Show, Eq) data CliEntryMetadata = Opt { - optLong :: !(Maybe Text) - , optShort :: !(Maybe Text) - , optMetavar :: !(Maybe Text) - , optHelp :: !(Maybe Text) - , optRequired :: !Bool - , optValueType :: !CliOptValueType + optLong :: !(Maybe Text) + , optShort :: !(Maybe Text) + , optMetavar :: !(Maybe Text) + , optHelp :: !(Maybe Text) + , optRequired :: !Bool } | Arg { - argMetavar :: !(Maybe Text) - , optRequired :: !Bool - , argValueType :: !CliArgValueType + argMetavar :: !(Maybe Text) + , optRequired :: !Bool } - deriving (Show, Eq) + deriving (Generic, Show, Eq) data CliEntrySpec cmd = CmdEntry { @@ -59,32 +61,44 @@ data CliEntrySpec cmd | PlainEntry { cliEntryMetadata :: !CliEntryMetadata } - deriving (Show, Eq) + deriving (Generic, Show, Eq) data CliCmdSpec = CliCmdSpec { cliCmdDesc :: !Text , cliCmdHeader :: !Text } - deriving (Show, Eq) + deriving (Generic, Show, Eq) data ConfigSources cmd = ConfigSources { envVar :: !(Maybe Text) , cliEntry :: !(Maybe (CliEntrySpec cmd)) } - deriving (Show, Eq) + deriving (Generic, Show, Eq) + +data ConfigValuePrimitive + = CVTString + | CVTNumber + | CVTBool + deriving (Generic, Show, Eq) + +data ConfigValueType + = CVTSingle ConfigValuePrimitive + | CVTArray ConfigValuePrimitive + deriving (Generic, Show, Eq) data ConfigValue cmd = ConfigValue { - defaultValue :: !(Maybe JSON.Value) - , isSensitive :: !Bool - , configSources :: !(ConfigSources cmd) + defaultValue :: !(Maybe JSON.Value) + , configValueType :: !ConfigValueType + , isSensitive :: !Bool + , configSources :: !(ConfigSources cmd) } | SubConfig { subConfig :: !(HashMap Text (ConfigValue cmd)) } - deriving (Show, Eq) + deriving (Generic, Show, Eq) data CliProgramSpec = CliProgramSpec { @@ -143,24 +157,7 @@ cliArgTypeParser object = do cliArgParser :: JSON.Object -> JSON.Parser CliEntryMetadata cliArgParser object = - Arg - <$> (object .:? "metavar") - <*> (fromMaybe True <$> (object .:? "required")) - <*> cliArgTypeParser object - -cliOptTypeParser :: JSON.Object -> JSON.Parser CliOptValueType -cliOptTypeParser object = do - mvalue <- object .:? "type" - case mvalue of - Just value@(JSON.String typeName) - | typeName == "string" -> return StringOpt - | typeName == "number" -> return NumberOpt - | typeName == "switch" -> return SwitchOpt - | otherwise -> JSON.typeMismatch "CliOptValueType (string, number, switch)" value - - Just value -> JSON.typeMismatch "CliOptValueType" value - - Nothing -> fail "CLI Option type is required" + Arg <$> (object .:? "metavar") <*> (fromMaybe True <$> (object .:? "required")) cliOptParser :: JSON.Object -> JSON.Parser CliEntryMetadata cliOptParser object = do @@ -175,10 +172,9 @@ cliOptParser object = do <*> (object .:? "metavar") <*> (object .:? "help") <*> (fromMaybe True <$> (object .:? "required")) - <*> cliOptTypeParser object cliArgKeys :: [Text] -cliArgKeys = ["input", "commands", "metavar", "required", "type"] +cliArgKeys = ["input", "commands", "metavar", "required"] cliOptKeys :: [Text] cliOptKeys = ["short", "long", "help"] ++ cliArgKeys @@ -217,33 +213,103 @@ instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where _ -> JSON.typeMismatch "CliEntryMetadata" json +instance JSON.FromJSON ConfigValueType where + parseJSON = JSON.withText "ConfigValueType (string, number, bool)" $ \tyText -> + case Text.toLower tyText of + "string" -> pure $ CVTSingle CVTString + "number" -> pure $ CVTSingle CVTNumber + "bool" -> pure $ CVTSingle CVTBool + "[string]" -> pure $ CVTArray CVTString + "[number]" -> pure $ CVTArray CVTNumber + "[bool]" -> pure $ CVTArray CVTBool + _ -> JSON.typeMismatch "ConfigValueType (string, number, bool)" (JSON.String tyText) + +inferErrorMsg :: String +inferErrorMsg = "could not infer type from given default value" + +parseBytesToConfigValueJSON :: ConfigValueType -> Text -> Maybe JSON.Value +parseBytesToConfigValueJSON cvType content = do + case JSON.eitherDecodeStrict' (Text.encodeUtf8 content) of + Right value | matchesConfigValueType value cvType -> return value + | otherwise -> Nothing + Left _err + | matchesConfigValueType (JSON.String content) cvType -> return (JSON.String content) + | otherwise -> Nothing + +jsonToConfigValueType :: JSON.Value -> Either String ConfigValueType +jsonToConfigValueType json = case json of + JSON.String{} -> Right $ CVTSingle CVTString + JSON.Number{} -> Right $ CVTSingle CVTNumber + JSON.Bool{} -> Right $ CVTSingle CVTBool + JSON.Array arr + | null arr -> Left inferErrorMsg + | otherwise -> case jsonToConfigValueType (Vector.head arr) of + Right (CVTArray{} ) -> Left "nested arrays values are not supported" + Right (CVTSingle ty) -> Right $ CVTArray ty + Left err -> Left err + _ -> Left inferErrorMsg + +matchesConfigValueType :: JSON.Value -> ConfigValueType -> Bool +matchesConfigValueType json cvType = case (json, cvType) of + (JSON.Null, CVTSingle _) -> True + (JSON.String{}, CVTSingle CVTString) -> True + (JSON.Number{}, CVTSingle CVTNumber) -> True + (JSON.Bool{} , CVTSingle CVTBool ) -> True + (JSON.Array arr, CVTArray inner) -> + if null arr then True else all (flip matchesConfigValueType (CVTSingle inner)) arr + _ -> False + +assertMatchingConfigValueType :: Monad m => JSON.Value -> ConfigValueType -> m () +assertMatchingConfigValueType json cvType + | matchesConfigValueType json cvType = return () + | otherwise = fail $ "JSON value type does not match specified type " <> show cvType + +getConfigValueType + :: Maybe JSON.Value -> Maybe ConfigValueType -> JSON.Parser ConfigValueType +getConfigValueType mdefValue mCvType = case (mdefValue, mCvType) of + (Just JSON.Null, Just cvType) -> + pure cvType + + (Just defValue, Just cvType) -> do + assertMatchingConfigValueType defValue cvType + return cvType + + (Nothing , Just cvType) -> pure cvType + + (Just defValue, Nothing ) -> either fail pure $ jsonToConfigValueType defValue + + (Nothing , Nothing ) -> fail inferErrorMsg + instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where parseJSON json = case json of - JSON.Array _ -> - fail "Entries cannot have arrays as values" JSON.Object object -> case HashMap.lookup "etc/spec" object of -- normal object Nothing -> do - result <- foldM - (\result (key, value) -> do + subConfigMap <- foldM + (\subConfigMap (key, value) -> do innerValue <- JSON.parseJSON value - return $ HashMap.insert key innerValue result) + return $ HashMap.insert key innerValue subConfigMap) HashMap.empty (HashMap.toList object) - if HashMap.null result then + if HashMap.null subConfigMap then fail "Entries cannot have empty maps as values" else - return (SubConfig result) + return (SubConfig subConfigMap) -- etc spec value object Just (JSON.Object fieldSpec) -> if HashMap.size object == 1 then do - mSensitive <- fieldSpec .:? "sensitive" + -- NOTE: not using .:? here as it casts JSON.Null to Nothing, we + -- want (Just JSON.Null) returned + mDefaultValue <- pure $ maybe Nothing Just $ HashMap.lookup "default" fieldSpec + mSensitive <- fieldSpec .:? "sensitive" + mCvType <- fieldSpec .:? "type" let sensitive = fromMaybe False mSensitive ConfigValue - <$> fieldSpec .:? "default" + <$> pure mDefaultValue + <*> getConfigValueType mDefaultValue mCvType <*> pure sensitive <*> (ConfigSources <$> fieldSpec .:? "env" <*> fieldSpec .:? "cli") @@ -254,13 +320,15 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where Just _ -> fail "etc/spec value must be a JSON object" - _ -> + _ -> do + cvType <- either fail pure $ jsonToConfigValueType json return ConfigValue { - defaultValue = Just json - , isSensitive = False - , configSources = ConfigSources Nothing Nothing + defaultValue = Just json + , configValueType = cvType + , isSensitive = False + , configSources = ConfigSources Nothing Nothing } diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs index 0c0126d..9ab0cf7 100644 --- a/etc/src/System/Etc/Internal/Types.hs +++ b/etc/src/System/Etc/Internal/Types.hs @@ -50,8 +50,8 @@ instance Applicative Value where instance IsString a => IsString (Value a) where fromString = Plain . fromString -boolToValue :: Bool -> (a -> Value a) -boolToValue = bool Plain Sensitive +markAsSensitive :: Bool -> (a -> Value a) +markAsSensitive = bool Plain Sensitive data FileSource = FilePathSource { fileSourcePath :: !Text } diff --git a/etc/test/System/Etc/Extra/EnvMisspellTest.hs b/etc/test/System/Etc/Extra/EnvMisspellTest.hs index 327ee41..d1d4c97 100644 --- a/etc/test/System/Etc/Extra/EnvMisspellTest.hs +++ b/etc/test/System/Etc/Extra/EnvMisspellTest.hs @@ -18,7 +18,7 @@ tests = testGroup [ testCase "it warns when misspell is present" $ do let input = mconcat [ "{\"etc/entries\": {" - , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + , " \"greeting\": { \"etc/spec\":{\"type\":\"string\",\"env\": \"GREETING\"}}}}" ] (spec :: ConfigSpec ()) <- parseConfigSpec input diff --git a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs index e412d2e..045f3aa 100644 --- a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs +++ b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs @@ -25,11 +25,11 @@ with_command_option_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" , " , \"commands\": [\"test\"]" , "}}}}}" ] @@ -52,11 +52,11 @@ with_command_option_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" , " , \"commands\": [\"test\"]" , "}}}}}" ] @@ -82,11 +82,11 @@ with_command_option_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"number\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" , " , \"long\": \"greeting\"" - , " , \"type\": \"number\"" , " , \"commands\": [\"test\"]" , "}}}}}" ] @@ -110,11 +110,11 @@ with_command_option_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" , " , \"required\": false" , " , \"commands\": [\"test1\"]" , "}}}}}" @@ -139,13 +139,13 @@ with_command_option_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" - , " , \"required\": true" - , " , \"commands\": [\"test\"]" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"required\": true" + , " , \"commands\": [\"test\"]" , "}}}}}" ] (spec :: ConfigSpec Text) <- parseConfigSpec input @@ -172,9 +172,9 @@ with_command_argument_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"number\"" + , " , \"cli\": {" , " \"input\": \"argument\"" - , " , \"type\": \"number\"" , " , \"metavar\": \"GREETING\"" , " , \"commands\": [\"test\"]" , "}}}}}" @@ -198,9 +198,9 @@ with_command_argument_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"argument\"" - , " , \"type\": \"string\"" , " , \"metavar\": \"GREETING\"" , " , \"required\": false" , " , \"commands\": [\"test\"]" @@ -226,9 +226,9 @@ with_command_argument_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"argument\"" - , " , \"type\": \"string\"" , " , \"metavar\": \"GREETING\"" , " , \"required\": true" , " , \"commands\": [\"test\"]" @@ -254,10 +254,10 @@ with_command_argument_tests = testGroup , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" - , " , \"type\": \"string\"" , " , \"metavar\": \"GREETING\"" , " , \"required\": false" , " , \"commands\": [\"test\", \"other\"]" @@ -289,10 +289,10 @@ without_command = testCase "fails when command not given" $ do , ", \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" + , " \"type\": \"string\"" + , " , \"cli\": {" , " \"input\": \"option\"" , " , \"short\": \"g\"" - , " , \"type\": \"string\"" , " , \"metavar\": \"GREETING\"" , " , \"required\": true" , " , \"commands\": [\"test\"]" @@ -306,7 +306,5 @@ without_command = testCase "fails when command not given" $ do _ -> assertFailure ("Expecting sub-command to be required; got " <> show err) Right _ -> assertFailure "Expecting sub-command to be required; it wasn't" - - tests :: TestTree tests = testGroup "command" [with_command, without_command] diff --git a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs index 0a01261..28cfc2d 100644 --- a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs +++ b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs @@ -7,10 +7,35 @@ import RIO import qualified RIO.Set as Set import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, assertFailure, testCase) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) import qualified System.Etc as SUT +resolver_tests :: TestTree +resolver_tests = testGroup + "resolver" + [ testCase "throws an error when input type does not match with spec type" $ do + let input = mconcat + [ "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"type\": \"[number]\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"required\": true" + , "}}}}}" + ] + (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input + eConfig <- try $ SUT.resolvePlainCliPure spec "program" ["-g", "hello world"] + + case eConfig of + Left (SUT.CliEvalExited{}) -> assertBool "" True + _ -> + assertFailure $ "Expecting CliEvalExited error; got this instead " <> show eConfig + ] + option_tests :: TestTree option_tests = testGroup "option input" @@ -19,11 +44,11 @@ option_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -38,11 +63,11 @@ option_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -57,11 +82,11 @@ option_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"number\"" + , " \"type\": \"number\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -79,12 +104,12 @@ option_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" - , " , \"required\": false" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"required\": false" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -100,12 +125,12 @@ option_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"option\"" - , " , \"short\": \"g\"" - , " , \"long\": \"greeting\"" - , " , \"type\": \"string\"" - , " , \"required\": true" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"required\": true" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -117,6 +142,26 @@ option_tests = testGroup assertFailure ("Expecting required validation to work on cli; got " <> show err) Right _ -> assertFailure "Expecting required option to fail cli resolving" + , testCase "does parse array of numbers correctly" $ do + let input = mconcat + [ "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"type\": \"[number]\"" + , " , \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"required\": true" + , "}}}}}" + ] + (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input + config <- SUT.resolvePlainCliPure spec "program" ["-g", "[1,2,3]"] + + case SUT.getConfigValue ["greeting"] config of + Right arr -> assertEqual "did not parse an array" ([1, 2, 3] :: [Int]) arr + + (Left err) -> assertFailure ("expecting to parse an array, but didn't " <> show err) ] argument_tests :: TestTree @@ -127,10 +172,10 @@ argument_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"argument\"" - , " , \"type\": \"number\"" - , " , \"metavar\": \"GREETING\"" + , " \"type\": \"number\"" + , " , \"cli\": {" + , " \"input\": \"argument\"" + , " , \"metavar\": \"GREETING\"" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -147,11 +192,11 @@ argument_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"argument\"" - , " , \"type\": \"string\"" - , " , \"metavar\": \"GREETING\"" - , " , \"required\": false" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"argument\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": false" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -167,11 +212,11 @@ argument_tests = testGroup [ "{ \"etc/entries\": {" , " \"greeting\": {" , " \"etc/spec\": {" - , " \"cli\": {" - , " \"input\": \"argument\"" - , " , \"type\": \"string\"" - , " , \"metavar\": \"GREETING\"" - , " , \"required\": true" + , " \"type\": \"string\"" + , " , \"cli\": {" + , " \"input\": \"argument\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": true" , "}}}}}" ] (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input @@ -186,4 +231,4 @@ argument_tests = testGroup ] tests :: TestTree -tests = testGroup "plain" [option_tests, argument_tests] +tests = testGroup "plain" [resolver_tests, option_tests, argument_tests] diff --git a/etc/test/System/Etc/Resolver/DefaultTest.hs b/etc/test/System/Etc/Resolver/DefaultTest.hs index 9256ee4..3b4a323 100644 --- a/etc/test/System/Etc/Resolver/DefaultTest.hs +++ b/etc/test/System/Etc/Resolver/DefaultTest.hs @@ -30,14 +30,16 @@ tests = testGroup (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec assertDefaultValue config ["greeting"] "hello default 1" + , testCase "default can be raw JSON value on entries spec" $ do - let input = mconcat ["{\"etc/entries\": {", " \"greeting\": \"hello default 2\"}}"] + let input = mconcat ["{\"etc/entries\": {\"greeting\": \"hello default 2\"}}"] (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec assertDefaultValue config ["greeting"] "hello default 2" + , testCase "default can be a null JSON value" $ do - let input = mconcat ["{\"etc/entries\": {", " \"greeting\": null}}"] + let input = mconcat ["{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\":\"number\",\"default\":null}}}}"] (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec diff --git a/etc/test/System/Etc/Resolver/EnvTest.hs b/etc/test/System/Etc/Resolver/EnvTest.hs index d30f83d..c3bd5da 100644 --- a/etc/test/System/Etc/Resolver/EnvTest.hs +++ b/etc/test/System/Etc/Resolver/EnvTest.hs @@ -22,7 +22,7 @@ tests = testGroup [ testCase "env entry is present when env var is defined" $ do let input = mconcat [ "{\"etc/entries\": {" - , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + , " \"greeting\":{\"etc/spec\":{\"type\":\"string\",\"env\":\"GREETING\"}}}}" ] (spec :: ConfigSpec ()) <- parseConfigSpec input @@ -40,7 +40,7 @@ tests = testGroup , "\"" <> Text.pack jsonFilepath <> "\"" , "]," , " \"etc/entries\": {" - , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + , " \"greeting\":{\"etc/spec\":{\"type\":\"string\",\"env\": \"GREETING\"}}}}" ] (spec :: ConfigSpec ()) <- parseConfigSpec input (configFile, _) <- resolveFiles spec @@ -56,10 +56,11 @@ tests = testGroup ("hello env" :: Text) result , testCase "does not add entries to config if env var is not present" $ do - let input = mconcat - [ "{\"etc/entries\": {" - , " \"nested\": {\"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}}" - ] + let + input = mconcat + [ "{\"etc/entries\": {" + , " \"nested\":{\"greeting\":{ \"etc/spec\":{\"type\":\"string\",\"env\": \"GREETING\" }}}}}" + ] (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveEnvPure spec [] @@ -71,4 +72,64 @@ tests = testGroup assertEqual "expecting to not have an entry for key" (Nothing :: Maybe Text) (getConfigValue ["nested", "greeting"] config) + , testCase "does parse numbers correctly" $ do + let + input = mconcat + [ "{\"etc/entries\": {\"greeting\":{ \"etc/spec\":{\"type\":\"number\",\"env\": \"GREETING\"}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let config = resolveEnvPure spec [("GREETING", "123")] + + assertEqual "expecting to not have an entry for key" + (Just 123 :: Maybe Int) + (getConfigValue ["greeting"] config) + , testCase "does parse array of numbers correctly" $ do + let + input = mconcat + [ "{\"etc/entries\": {\"greeting\":{ \"etc/spec\":{\"type\":\"[number]\",\"env\": \"GREETING\"}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let config = resolveEnvPure spec [("GREETING", "[123, 456]")] + + assertEqual "expecting to not have an entry for key" + (Just [123, 456] :: Maybe [Int]) + (getConfigValue ["greeting"] config) + , testCase "does parse array of strings correctly" $ do + let + input = mconcat + [ "{\"etc/entries\": {\"greeting\":{ \"etc/spec\":{\"type\":\"[string]\",\"env\": \"GREETING\"}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let config = resolveEnvPure spec [("GREETING", "[\"hello\", \"world\"]")] + + assertEqual "expecting to not have an entry for key" + (Just ["hello", "world"] :: Maybe [Text]) + (getConfigValue ["greeting"] config) + , testCase "does parse array of bools correctly" $ do + let + input = mconcat + [ "{\"etc/entries\": {\"greeting\":{ \"etc/spec\":{\"type\":\"[bool]\",\"env\": \"GREETING\"}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let config = resolveEnvPure spec [("GREETING", "[false, true]")] + + assertEqual "expecting to not have an entry for key" + (Just [False, True] :: Maybe [Bool]) + (getConfigValue ["greeting"] config) + , testCase "does not add entries to config if env var value has invalid type" $ do + let + input = mconcat + [ "{\"etc/entries\": {\"greeting\":{ \"etc/spec\":{\"type\":\"number\",\"env\": \"GREETING\"}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let config = resolveEnvPure spec [] + + assertEqual "expecting to not have an entry for key" + (Nothing :: Maybe Int) + (getConfigValue ["greeting"] config) ] diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs index 04a3cfd..8812478 100644 --- a/etc/test/System/Etc/SpecTest.hs +++ b/etc/test/System/Etc/SpecTest.hs @@ -7,6 +7,7 @@ module System.Etc.SpecTest (tests) where import RIO import qualified RIO.HashMap as HashMap +import qualified RIO.Vector as Vector import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) @@ -44,6 +45,22 @@ general_tests = testGroup case parseConfigSpec input of Nothing -> assertFailure "should not fail if no etc/entries key is present" Just (_ :: ConfigSpec ()) -> assertBool "" True + , testCase "fails when default JSON value doesn't correspond to type entry" $ do + let + input + = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[123],\"type\":\"[string]\"}}}}" + + case parseConfigSpec input of + Left err -> case fromException err of + Just (InvalidConfiguration{}) -> assertBool "" True + + _ -> + assertFailure + $ "expecting to get an InvalidConfiguration error; but got " + <> show err + + Right (_ :: ConfigSpec ()) -> + assertFailure "Expecting config spec parsing to fail, but didn't" , testCase "entries cannot finish in an empty map" $ do let input = "{\"etc/entries\":{\"greeting\":{}}}" @@ -63,13 +80,50 @@ general_tests = testGroup keys = ["greeting"] config <- 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 (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 <- 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 (JSON.Array (Vector.fromList [JSON.Number 123]))) + (defaultValue value) + , testCase "entries with empty arrays as values fail because type cannot be infered" $ do + let input = "{\"etc/entries\":{\"greeting\": []}}" + case parseConfigSpec input of + Left err -> case fromException err of + Just (InvalidConfiguration{}) -> assertBool "" True + _ -> + assertFailure $ "expecting InvalidConfiguration error; got instead " <> show err + + Right (_configSpec :: ConfigSpec ()) -> + assertFailure "expecting config spec parse to fail, but didn't" + , testCase "entries with empty arrays as default values and a type do not fail" $ do + let + input + = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[],\"type\":\"[string]\"}}}}" + keys = ["greeting"] + + config <- 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 + "should contain default array value" + (Just (JSON.Array (Vector.fromList []))) + (defaultValue value) , testCase "entries can have many levels of nesting" $ do let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}" keys = ["english", "greeting"] @@ -145,7 +199,7 @@ cli_tests = , testCase "cli option entry requires either short or long" $ do let - input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\"}}}}}" + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\", \"cli\":{\"input\":\"option\"}}}}}" case parseConfigSpec input of Just (result :: ConfigSpec ()) -> @@ -155,7 +209,7 @@ cli_tests = , testCase "cli option entry works when setting short and type" $ do let - input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"short\":\"g\",\"type\":\"string\"}}}}}" + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\":\"string\",\"cli\":{\"input\":\"option\",\"short\":\"g\"}}}}}" keys = ["greeting"] (config :: ConfigSpec ()) <- parseConfigSpec input @@ -163,9 +217,9 @@ cli_tests = let result = do value <- getConfigValue keys (specConfigValues config) + let valueType = configValueType value PlainEntry metadata <- cliEntry (configSources value) short <- optShort metadata - valueType <- pure $ optValueType metadata return (short, valueType) case result of @@ -173,21 +227,21 @@ cli_tests = assertFailure (show keys ++ " should map to a config value, got sub config map instead") Just (short, valueType) -> do assertEqual "should contain short" "g" short - assertEqual "should contain option type" StringOpt valueType + assertEqual "should contain option type" (CVTSingle CVTString) valueType , testCase "cli option entry works when setting long and type" $ do let - input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\"}}}}}" + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"cli\":{\"input\":\"option\",\"long\":\"greeting\"}}}}}" keys = ["greeting"] (config :: ConfigSpec ()) <- parseConfigSpec input let result = do - value <- getConfigValue keys (specConfigValues config) + value <- getConfigValue keys (specConfigValues config) + let valueType = configValueType value PlainEntry metadata <- cliEntry (configSources value) long <- optLong metadata - valueType <- pure $ optValueType metadata return (long, valueType) case result of @@ -195,11 +249,11 @@ cli_tests = assertFailure (show keys ++ " should map to a config value, got sub config map instead") Just (long, valueType) -> do assertEqual "should contain long" "greeting" long - assertEqual "should contain option type" StringOpt valueType + assertEqual "should contain option type" (CVTSingle CVTString) valueType , testCase "cli entry accepts command" $ do let - input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\",\"commands\":[\"foo\"]}}}}}" + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"commands\":[\"foo\"]}}}}}" keys = ["greeting"] (config :: ConfigSpec Text) <- parseConfigSpec input @@ -207,9 +261,9 @@ cli_tests = let result = do value <- getConfigValue keys (specConfigValues config) + let valueType = configValueType value CmdEntry cmd metadata <- cliEntry (configSources value) long <- optLong metadata - valueType <- pure $ optValueType metadata return (cmd, long, valueType) case result of @@ -218,7 +272,7 @@ cli_tests = Just (cmd, long, valueType) -> do assertEqual "should contain cmd" ["foo"] cmd assertEqual "should contain long" "greeting" long - assertEqual "should contain option type" StringOpt valueType + assertEqual "should contain option type" (CVTSingle CVTString) valueType , testCase "cli entry does not accept unrecognized keys" $ do let @@ -238,8 +292,10 @@ envvar_tests :: TestTree envvar_tests = testGroup "env" [ testCase "env key creates an ENV source" $ do - let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"env\":\"GREETING\"}}}}" - keys = ["greeting"] + let + input + = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"env\":\"GREETING\"}}}}" + keys = ["greeting"] (config :: ConfigSpec ()) <- parseConfigSpec input diff --git a/etc/test/fixtures/config.spec.yaml b/etc/test/fixtures/config.spec.yaml index d0dfe0f..b104fa1 100644 --- a/etc/test/fixtures/config.spec.yaml +++ b/etc/test/fixtures/config.spec.yaml @@ -1,4 +1,5 @@ etc/entries: greeting: etc/spec: + type: string env: "GREETING" From 9774e9d3085caece528c6d600560111b7731292f Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Sat, 28 Apr 2018 05:15:09 +0000 Subject: [PATCH 2/6] Ensure configuration files contains entries from spec (closes #26) --- etc/CHANGELOG.md | 4 +- etc/src/System/Etc/Internal/Resolver/File.hs | 74 ++++++++++++-------- etc/src/System/Etc/Internal/Spec/Types.hs | 7 +- etc/test/System/Etc/Extra/EnvMisspellTest.hs | 9 +-- etc/test/System/Etc/Resolver/DefaultTest.hs | 7 +- etc/test/System/Etc/Resolver/FileTest.hs | 35 +++++++-- 6 files changed, 89 insertions(+), 47 deletions(-) diff --git a/etc/CHANGELOG.md b/etc/CHANGELOG.md index 5edecd2..8a9d762 100644 --- a/etc/CHANGELOG.md +++ b/etc/CHANGELOG.md @@ -4,9 +4,11 @@ * Add new `type` field to `etc/spec` with support for `string`, `number`, `bool`, `[string]`, `[number]` and `[bool]` * Remove `type` field in `cli` spec in favor of `type` on `etc/spec` -* Allow ENV vars to accept supported types (only strings were allowed) +* Allow ENV vars to accept supported types (only strings were allowed) (closes #30) * Allow CLI options to accept supported types (only strings and numbers were allowed) * Allow spec file to have array as default values +* Return a warning and an empty config whenever configuration files contain + entries not defined in the spec (closes #26) 0.3.2.0 ---- diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs index 68b5177..8e2502a 100644 --- a/etc/src/System/Etc/Internal/Resolver/File.hs +++ b/etc/src/System/Etc/Internal/Resolver/File.hs @@ -35,37 +35,55 @@ data ConfigFile parseConfigValue :: Monad m - => Maybe (Spec.ConfigValue cmd) + => [Text] + -> Maybe (Spec.ConfigValue cmd) -> Int -> FileSource -> JSON.Value -> m ConfigValue -parseConfigValue mSpec fileIndex fileSource json = case json of - JSON.Object object -> SubConfig <$> foldM - (\acc (key, subConfigValue) -> do - let msubConfigSpec = do - spec <- mSpec - case spec of - Spec.SubConfig hsh -> HashMap.lookup key hsh - _ -> - -- TODO: This should be an error given the config doesn't match spec - fail "configuration spec and configuration value are different" - - value1 <- parseConfigValue msubConfigSpec fileIndex fileSource subConfigValue - return $ HashMap.insert key value1 acc - ) - HashMap.empty - (HashMap.toList object) - - _ -> - let mToValue = do - spec <- mSpec - case spec of - Spec.ConfigValue{} -> return $ markAsSensitive (Spec.isSensitive spec) - _ -> fail "configuration spec and configuration value are different" - - toValue = fromMaybe Plain mToValue - in return $ ConfigValue (Set.singleton $ File fileIndex fileSource (toValue json)) +parseConfigValue keys mSpec fileIndex fileSource json = + + let currentKey = Text.intercalate "." $ reverse keys + in + case json of + JSON.Object object -> SubConfig <$> foldM + (\acc (key, subConfigValue) -> do + let msubConfigSpec = do + spec <- mSpec + case spec of + Spec.SubConfig hsh -> HashMap.lookup key hsh + _ -> + -- TODO: This should be an error given the config doesn't match spec + fail "configuration spec and configuration value are different" + + value1 <- parseConfigValue (key : keys) + msubConfigSpec + fileIndex + fileSource + subConfigValue + return $ HashMap.insert key value1 acc + ) + HashMap.empty + (HashMap.toList object) + + _ -> case mSpec of + Just Spec.ConfigValue { Spec.isSensitive, Spec.configValueType } -> do + Spec.assertMatchingConfigValueType json configValueType + return $ ConfigValue + (Set.singleton $ File fileIndex fileSource $ markAsSensitive isSensitive json) + Just _ -> + fail + $ Text.unpack + $ "Configuration entry `" + <> currentKey + <> "` does not follow spec" + + Nothing -> + fail + $ Text.unpack + $ "Configuration entry `" + <> currentKey + <> "` is not present on spec" eitherDecode :: ConfigFile -> Either String JSON.Value @@ -89,7 +107,7 @@ parseConfig spec fileIndex fileSource contents = case eitherDecode contents of Left err -> throwM $ InvalidConfiguration Nothing (Text.pack err) Right json -> - case JSON.iparse (parseConfigValue (Just spec) fileIndex fileSource) json of + case JSON.iparse (parseConfigValue [] (Just spec) fileIndex fileSource) json of JSON.IError _ err -> throwM $ InvalidConfiguration Nothing (Text.pack err) JSON.ISuccess result -> return (Config result) diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs index b00d971..bcfd6a1 100644 --- a/etc/src/System/Etc/Internal/Spec/Types.hs +++ b/etc/src/System/Etc/Internal/Spec/Types.hs @@ -251,7 +251,7 @@ jsonToConfigValueType json = case json of matchesConfigValueType :: JSON.Value -> ConfigValueType -> Bool matchesConfigValueType json cvType = case (json, cvType) of - (JSON.Null, CVTSingle _) -> True + (JSON.Null , CVTSingle _ ) -> True (JSON.String{}, CVTSingle CVTString) -> True (JSON.Number{}, CVTSingle CVTNumber) -> True (JSON.Bool{} , CVTSingle CVTBool ) -> True @@ -267,10 +267,9 @@ assertMatchingConfigValueType json cvType getConfigValueType :: Maybe JSON.Value -> Maybe ConfigValueType -> JSON.Parser ConfigValueType getConfigValueType mdefValue mCvType = case (mdefValue, mCvType) of - (Just JSON.Null, Just cvType) -> - pure cvType + (Just JSON.Null, Just cvType) -> pure cvType - (Just defValue, Just cvType) -> do + (Just defValue , Just cvType) -> do assertMatchingConfigValueType defValue cvType return cvType diff --git a/etc/test/System/Etc/Extra/EnvMisspellTest.hs b/etc/test/System/Etc/Extra/EnvMisspellTest.hs index d1d4c97..9927ef8 100644 --- a/etc/test/System/Etc/Extra/EnvMisspellTest.hs +++ b/etc/test/System/Etc/Extra/EnvMisspellTest.hs @@ -16,10 +16,11 @@ tests :: TestTree tests = testGroup "env misspells" [ testCase "it warns when misspell is present" $ do - let input = mconcat - [ "{\"etc/entries\": {" - , " \"greeting\": { \"etc/spec\":{\"type\":\"string\",\"env\": \"GREETING\"}}}}" - ] + let + input = mconcat + [ "{\"etc/entries\": {" + , " \"greeting\": { \"etc/spec\":{\"type\":\"string\",\"env\": \"GREETING\"}}}}" + ] (spec :: ConfigSpec ()) <- parseConfigSpec input diff --git a/etc/test/System/Etc/Resolver/DefaultTest.hs b/etc/test/System/Etc/Resolver/DefaultTest.hs index 3b4a323..a9b0016 100644 --- a/etc/test/System/Etc/Resolver/DefaultTest.hs +++ b/etc/test/System/Etc/Resolver/DefaultTest.hs @@ -30,16 +30,17 @@ tests = testGroup (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec assertDefaultValue config ["greeting"] "hello default 1" - , testCase "default can be raw JSON value on entries spec" $ do let input = mconcat ["{\"etc/entries\": {\"greeting\": \"hello default 2\"}}"] (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec assertDefaultValue config ["greeting"] "hello default 2" - , testCase "default can be a null JSON value" $ do - let input = mconcat ["{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\":\"number\",\"default\":null}}}}"] + let + input = mconcat + [ "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\":\"number\",\"default\":null}}}}" + ] (spec :: ConfigSpec ()) <- parseConfigSpec input let config = resolveDefault spec diff --git a/etc/test/System/Etc/Resolver/FileTest.hs b/etc/test/System/Etc/Resolver/FileTest.hs index 8fa886b..6843872 100644 --- a/etc/test/System/Etc/Resolver/FileTest.hs +++ b/etc/test/System/Etc/Resolver/FileTest.hs @@ -6,9 +6,10 @@ module System.Etc.Resolver.FileTest (tests) where import RIO -import qualified RIO.Set as Set -import qualified RIO.Text as Text -import qualified RIO.Vector as Vector +import qualified RIO.Set as Set +import qualified RIO.Text as Text +import qualified RIO.Vector as Vector +import qualified RIO.Vector.Partial as Vector (head) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) @@ -32,6 +33,22 @@ tests = testGroup Left (InvalidConfiguration _ _) -> return () _ -> assertFailure ("Expecting InvalidConfigurationError; got instead " <> show espec) + , testCase "fails when file has key not defined in spec" $ do + jsonFilepath <- getDataFileName "test/fixtures/config.json" + let input = "{\"etc/filepaths\": [\"" <> Text.pack jsonFilepath <> "\"]}" + (spec :: ConfigSpec ()) <- parseConfigSpec input + (_config, warnings) <- resolveFiles spec + assertBool "There should be warnings" (not $ null warnings) + case fromException (Vector.head warnings) of + Just (InvalidConfiguration _ errMsg) -> assertEqual + "Expecting key not present in spec error" + "Configuration entry `greeting` is not present on spec" + errMsg + + err -> + assertFailure + $ "Expecting InvalidConfigurationError; got other error instead: " + <> show err , filePathsTests , filesTest ] @@ -54,7 +71,8 @@ filePathsTests = testGroup , ", \"" <> Text.pack yamlFilepath <> "\"" , ", \"" <> Text.pack ymlFilepath <> "\"" #endif - , "]}" + , "]" + , ", \"etc/entries\": {\"greeting\": \"hello default\"}}" ] (spec :: ConfigSpec ()) <- parseConfigSpec input @@ -101,7 +119,9 @@ filePathsTests = testGroup [ "{\"etc/filepaths\": [" , "\"" <> Text.pack jsonFilepath <> "\"" , ", \"unknown_file.json\"" - , "]}" + , "]" + , ", \"etc/entries\":{\"greeting\":\"hello default\"}" + , "}" ] (spec :: ConfigSpec ()) <- parseConfigSpec input @@ -176,10 +196,11 @@ filesTest = testGroup jsonFilepath <- getDataFileName "test/fixtures/config.json" envFilePath <- getDataFileName "test/fixtures/config.env.json" let input = mconcat - [ "{\"etc/files\": {" + [ "{\"etc/files\":{" , " \"env\": \"ENV_FILE_TEST\"," , " \"paths\": [\"" <> Text.pack jsonFilepath <> "\"]" - , "}}" + , "}," + , "\"etc/entries\":{\"greeting\":\"hello default\"}}" ] envFileTest = "ENV_FILE_TEST" From cbdf170a17e0ad51dbf4c7fc54658de72dc5c653 Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Wed, 2 May 2018 02:28:38 +0000 Subject: [PATCH 3/6] Improvements on printer (closes #13) * Allow Array types on configuration values * Allow Printer to work with Array values --- etc/src/System/Etc/Internal/Extra/Printer.hs | 209 +++++++++++-------- 1 file changed, 123 insertions(+), 86 deletions(-) diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs index a38a52b..92ac7f0 100644 --- a/etc/src/System/Etc/Internal/Extra/Printer.hs +++ b/etc/src/System/Etc/Internal/Extra/Printer.hs @@ -12,125 +12,162 @@ module System.Etc.Internal.Extra.Printer ( import RIO hiding ((<>)) import qualified RIO.HashMap as HashMap import RIO.List (intersperse) -import RIO.List.Partial (maximum) import qualified RIO.Set as Set import qualified RIO.Text as Text +import qualified RIO.Vector as Vector import qualified Data.Aeson as JSON -import Text.PrettyPrint.ANSI.Leijen +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) import System.Etc.Internal.Types -renderJsonValue :: Text -> Value JSON.Value -> (Doc, Int) -renderJsonValue key value' = case value' of - Plain JSON.Null -> (text "null", 4) - - Plain (JSON.String str) -> (text $ Text.unpack str, Text.length str) - - Plain (JSON.Number scientific) -> - let number = show scientific in (text number, length number) - Plain (JSON.Bool bool') -> if bool' then (text "true", 5) else (text "false", 5) - Sensitive _ -> (text "<>", 13) - _ -> - value' - & tshow - & ("Invalid configuration value creation " `mappend`) - & InvalidConfiguration (Just key) - & show - & error - data ColorFn = ColorFn { greenColor :: !(Doc -> Doc) , blueColor :: !(Doc -> Doc) } -renderConfig' :: ColorFn -> Config -> Doc -renderConfig' ColorFn { greenColor, blueColor } (Config configValue0) = +renderConfigValueJSON :: JSON.Value -> Either Text Doc +renderConfigValueJSON value = case value of + JSON.Null -> Right $ text "null" + JSON.String str -> Right $ text $ Text.unpack str + JSON.Number scientific -> Right $ text $ show scientific + JSON.Bool b -> Right $ if b then text "true" else text "false" + _ -> + Left $ "Trying to render Unsupported JSON value " `mappend` (tshow value) + +renderConfigValue :: (JSON.Value -> Either Text Doc) -> Value JSON.Value -> Either Text [Doc] +renderConfigValue f value = + case value of + Plain (JSON.Array jsonArray) -> + fmap Vector.toList <$> forM jsonArray $ \jsonValue -> do + valueDoc <- f jsonValue + return $ text "-" <+> valueDoc + Plain jsonValue -> fmap return (f jsonValue) + Sensitive {} -> Right $ return $ text "<>" + +renderConfigSource :: (JSON.Value -> Either Text Doc) -> ConfigSource -> Either Text ([Doc], Doc) +renderConfigSource f configSource = + case configSource of + Default value -> do + let sourceDoc = text "Default" + valueDoc <- renderConfigValue f value + return (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) + in do + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + Env varname value -> do + let sourceDoc = text "Env:" <+> text (Text.unpack varname) + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + Cli value -> do + let sourceDoc = text "Cli" + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + None -> + return (mempty, mempty) + +renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc +renderConfig_ ColorFn { blueColor } (Config configMap) = let - brackets' = enclose (lbracket <> space) (space <> rbracket) - - renderSource :: Text -> ConfigSource -> ((Doc, Int), Doc) - renderSource key source' = case source' of - Default value' -> (renderJsonValue key value', brackets' (fill 10 (text "Default"))) - - File _index fileSource value' -> case fileSource of - FilePathSource filepath' -> - ( renderJsonValue key value' - , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath'))) - ) - EnvVarFileSource envVar filepath' -> - ( renderJsonValue key value' - , brackets' - (fill - 10 - (text "File:" <+> text (Text.unpack envVar) <> "=" <> text - (Text.unpack filepath') - ) - ) - ) - - Env varname value' -> - ( renderJsonValue key value' - , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname))) - ) - - Cli value' -> (renderJsonValue key value', brackets' (fill 10 (text "Cli"))) - - None -> ((mempty, 0), mempty) - - renderSources :: Text -> [ConfigSource] -> Doc - renderSources keys sources0 = + renderSources :: MonadThrow m => Text -> [ConfigSource] -> m Doc + renderSources keyPath sources = let - -- NOTE: I've already checked for the list to not be empty, - -- so is safe to do this destructuring here - sources@(((selValueDoc, _), selSourceDoc) : others) = - map (renderSource keys) sources0 + eSourceDocs = + mapM (renderConfigSource renderConfigValueJSON) sources + + brackets' = enclose (lbracket <> space) (space <> rbracket) + + layoutSourceValueDoc valueDocs sourceDoc = + case valueDocs of + [] -> + throwM $ InvalidConfiguration (Just keyPath) "Trying to render config entry with no values" + + [singleValueDoc] -> + -- [Default] + -- Value 1 + -- + return $ sourceDoc <$$> indent 2 singleValueDoc + + multipleValues -> + -- [Default] + -- - Value 1 + -- - Value 2 + -- - Value 3 + -- + return $ sourceDoc <$$> (indent 2 $ align (vsep multipleValues)) + in + case eSourceDocs of + Left err -> + throwM $ InvalidConfiguration (Just keyPath) err - -- NOTE: I've already checked for the list to not be empty, - -- so is safe to use partial function maximum here - fillingWidth = sources & map (snd . fst) & maximum & max 10 + Right [] -> + throwM $ InvalidConfiguration (Just keyPath) "Trying to render config entry with no values" - selectedValue = [greenColor $ fill fillingWidth selValueDoc <+> selSourceDoc] + -- [ (*) CLI ] + -- - Value 1 + -- [ Default ] + -- - Value + Right ((selectedValueDoc, selectedSourceDoc) : otherSourceDocs) -> do + selectedDoc <- + layoutSourceValueDoc selectedValueDoc + $ brackets' (parens (text "*") <+> selectedSourceDoc) - otherValues = map - (\((valueDoc, _), sourceDoc) -> fill fillingWidth valueDoc <+> sourceDoc) - others - in - selectedValue & flip mappend otherValues & vcat & indent 2 + othersDoc <- forM otherSourceDocs $ \(value, source) -> + layoutSourceValueDoc value $ brackets' source - configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc] - configEntryRenderer keys resultDoc configKey configValue = - resultDoc `mappend` loop (configKey : keys) configValue + return $ indent 2 $ vsep $ selectedDoc : othersDoc + renderConfigEntry :: MonadThrow m => [Text] -> [Doc] -> Text -> ConfigValue -> m [Doc] + renderConfigEntry keyPath accDoc configKey configValue = do + currentDoc <- loop (configKey : keyPath) configValue + return $ accDoc `mappend` currentDoc + + loop :: MonadThrow m => [Text] -> ConfigValue -> m [Doc] loop keys configValue = case configValue of SubConfig subConfigm -> - HashMap.foldlWithKey' (configEntryRenderer keys) mempty subConfigm + foldM (\acc (k,v) -> renderConfigEntry keys acc k v) + mempty + (HashMap.toList subConfigm) ConfigValue sources0 -> let - configKey = keys & reverse & Text.intercalate "." - - sources = Set.toDescList sources0 + keyPathText = Text.intercalate "." $ reverse keys + sources = Set.toDescList sources0 in if null sources then - [] - else - [blueColor (text (Text.unpack configKey)) <$$> renderSources configKey sources] - in - loop [] configValue0 & intersperse (linebreak <> linebreak) & hcat & (<> linebreak) + return [] + else do + configSources <- renderSources keyPathText sources + return [ blueColor (text $ Text.unpack keyPathText) <$$> configSources ] + in do + result <- loop [] configMap + return $ (hcat $ intersperse (linebreak <> linebreak) $ result) <> linebreak -renderConfigColor :: Config -> Doc -renderConfigColor = renderConfig' ColorFn {greenColor = green, blueColor = blue} +renderConfigColor :: MonadThrow m => Config -> m Doc +renderConfigColor = renderConfig_ ColorFn {greenColor = green, blueColor = blue} -renderConfig :: Config -> Doc -renderConfig = renderConfig' ColorFn {greenColor = id, blueColor = id} +renderConfig :: MonadThrow m => Config -> m Doc +renderConfig = renderConfig_ ColorFn {greenColor = id, blueColor = id} printPrettyConfig :: Config -> IO () -printPrettyConfig = putDoc . renderConfig +printPrettyConfig = putDoc <=< renderConfigColor hPrintPrettyConfig :: Handle -> Config -> IO () -hPrintPrettyConfig handle' = hPutDoc handle' . renderConfig +hPrintPrettyConfig someHandle = hPutDoc someHandle <=< renderConfigColor From 8444e0f6f81de7c653082cc00f665678bd5160d7 Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Sat, 12 May 2018 17:57:43 +0000 Subject: [PATCH 4/6] Add [object] type for configuration values --- etc/src/System/Etc/Internal/Extra/Printer.hs | 185 +++++++++---------- etc/src/System/Etc/Internal/Spec/Types.hs | 23 ++- etc/test/System/Etc/SpecTest.hs | 17 ++ 3 files changed, 125 insertions(+), 100 deletions(-) diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs index 92ac7f0..10db0f0 100644 --- a/etc/src/System/Etc/Internal/Extra/Printer.hs +++ b/etc/src/System/Etc/Internal/Extra/Printer.hs @@ -9,12 +9,12 @@ module System.Etc.Internal.Extra.Printer ( , hPrintPrettyConfig ) where -import RIO hiding ((<>)) -import qualified RIO.HashMap as HashMap -import RIO.List (intersperse) -import qualified RIO.Set as Set -import qualified RIO.Text as Text -import qualified RIO.Vector as Vector +import RIO hiding ((<>)) +import qualified RIO.HashMap as HashMap +import RIO.List (intersperse) +import qualified RIO.Set as Set +import qualified RIO.Text as Text +import qualified RIO.Vector as Vector import qualified Data.Aeson as JSON @@ -30,72 +30,68 @@ data ColorFn renderConfigValueJSON :: JSON.Value -> Either Text Doc renderConfigValueJSON value = case value of - JSON.Null -> Right $ text "null" - JSON.String str -> Right $ text $ Text.unpack str + JSON.Null -> Right $ text "null" + JSON.String str -> Right $ text $ Text.unpack str JSON.Number scientific -> Right $ text $ show scientific - JSON.Bool b -> Right $ if b then text "true" else text "false" - _ -> - Left $ "Trying to render Unsupported JSON value " `mappend` (tshow value) - -renderConfigValue :: (JSON.Value -> Either Text Doc) -> Value JSON.Value -> Either Text [Doc] -renderConfigValue f value = - case value of - Plain (JSON.Array jsonArray) -> - fmap Vector.toList <$> forM jsonArray $ \jsonValue -> do - valueDoc <- f jsonValue - return $ text "-" <+> valueDoc - Plain jsonValue -> fmap return (f jsonValue) - Sensitive {} -> Right $ return $ text "<>" - -renderConfigSource :: (JSON.Value -> Either Text Doc) -> ConfigSource -> Either Text ([Doc], Doc) -renderConfigSource f configSource = - case configSource of - Default value -> do - let sourceDoc = text "Default" - valueDoc <- renderConfigValue f value - return (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) - in do - valueDoc <- renderConfigValue f value - return (valueDoc, sourceDoc) - - Env varname value -> do - let sourceDoc = text "Env:" <+> text (Text.unpack varname) - valueDoc <- renderConfigValue f value - return (valueDoc, sourceDoc) - - Cli value -> do - let sourceDoc = text "Cli" - valueDoc <- renderConfigValue f value - return (valueDoc, sourceDoc) - - None -> - return (mempty, mempty) + JSON.Bool b -> Right $ if b then text "true" else text "false" + JSON.Object obj -> do + values <- forM (HashMap.toList obj) $ \(k, v) -> do + v1 <- renderConfigValueJSON v + return $ text (Text.unpack k) <> ":" <+> v1 + return $ align (vsep values) + _ -> Left $ "Trying to render Unsupported JSON value " `mappend` (tshow value) + +renderConfigValue + :: (JSON.Value -> Either Text Doc) -> Value JSON.Value -> Either Text [Doc] +renderConfigValue f value = case value of + Plain (JSON.Array jsonArray) -> fmap Vector.toList <$> forM jsonArray $ \jsonValue -> do + valueDoc <- f jsonValue + return $ text "-" <+> valueDoc + Plain jsonValue -> fmap return (f jsonValue) + Sensitive{} -> Right $ return $ text "<>" + +renderConfigSource + :: (JSON.Value -> Either Text Doc) -> ConfigSource -> Either Text ([Doc], Doc) +renderConfigSource f configSource = case configSource of + Default value -> do + let sourceDoc = text "Default" + valueDoc <- renderConfigValue f value + return (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) + in do + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + Env varname value -> do + let sourceDoc = text "Env:" <+> text (Text.unpack varname) + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + Cli value -> do + let sourceDoc = text "Cli" + valueDoc <- renderConfigValue f value + return (valueDoc, sourceDoc) + + None -> return (mempty, mempty) renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc renderConfig_ ColorFn { blueColor } (Config configMap) = let renderSources :: MonadThrow m => Text -> [ConfigSource] -> m Doc renderSources keyPath sources = - let - eSourceDocs = - mapM (renderConfigSource renderConfigValueJSON) sources + let eSourceDocs = mapM (renderConfigSource renderConfigValueJSON) sources - brackets' = enclose (lbracket <> space) (space <> rbracket) + brackets' = enclose (lbracket <> space) (space <> rbracket) - layoutSourceValueDoc valueDocs sourceDoc = - case valueDocs of - [] -> - throwM $ InvalidConfiguration (Just keyPath) "Trying to render config entry with no values" + layoutSourceValueDoc valueDocs sourceDoc = case valueDocs of + [] -> throwM $ InvalidConfiguration + (Just keyPath) + "Trying to render config entry with no values" [singleValueDoc] -> -- [Default] @@ -110,27 +106,25 @@ renderConfig_ ColorFn { blueColor } (Config configMap) = -- - Value 3 -- return $ sourceDoc <$$> (indent 2 $ align (vsep multipleValues)) - in - case eSourceDocs of - Left err -> - throwM $ InvalidConfiguration (Just keyPath) err + in case eSourceDocs of + Left err -> throwM $ InvalidConfiguration (Just keyPath) err - Right [] -> - throwM $ InvalidConfiguration (Just keyPath) "Trying to render config entry with no values" + Right [] -> throwM $ InvalidConfiguration + (Just keyPath) + "Trying to render config entry with no values" - -- [ (*) CLI ] - -- - Value 1 - -- [ Default ] - -- - Value - Right ((selectedValueDoc, selectedSourceDoc) : otherSourceDocs) -> do - selectedDoc <- - layoutSourceValueDoc selectedValueDoc - $ brackets' (parens (text "*") <+> selectedSourceDoc) + -- [ (*) CLI ] + -- - Value 1 + -- [ Default ] + -- - Value + Right ((selectedValueDoc, selectedSourceDoc) : otherSourceDocs) -> do + selectedDoc <- layoutSourceValueDoc selectedValueDoc + $ brackets' (parens (text "*") <+> selectedSourceDoc) - othersDoc <- forM otherSourceDocs $ \(value, source) -> - layoutSourceValueDoc value $ brackets' source + othersDoc <- forM otherSourceDocs + $ \(value, source) -> layoutSourceValueDoc value $ brackets' source - return $ indent 2 $ vsep $ selectedDoc : othersDoc + return $ indent 2 $ vsep $ selectedDoc : othersDoc renderConfigEntry :: MonadThrow m => [Text] -> [Doc] -> Text -> ConfigValue -> m [Doc] renderConfigEntry keyPath accDoc configKey configValue = do @@ -139,25 +133,22 @@ renderConfig_ ColorFn { blueColor } (Config configMap) = loop :: MonadThrow m => [Text] -> ConfigValue -> m [Doc] loop keys configValue = case configValue of - SubConfig subConfigm -> - foldM (\acc (k,v) -> renderConfigEntry keys acc k v) - mempty - (HashMap.toList subConfigm) + SubConfig subConfigm -> foldM (\acc (k, v) -> renderConfigEntry keys acc k v) + mempty + (HashMap.toList subConfigm) ConfigValue sources0 -> - let - keyPathText = Text.intercalate "." $ reverse keys - sources = Set.toDescList sources0 - in - if null sources - then - return [] - else do - configSources <- renderSources keyPathText sources - return [ blueColor (text $ Text.unpack keyPathText) <$$> configSources ] - in do - result <- loop [] configMap - return $ (hcat $ intersperse (linebreak <> linebreak) $ result) <> linebreak + let keyPathText = Text.intercalate "." $ reverse keys + sources = Set.toDescList sources0 + in if null sources + then return [] + else do + configSources <- renderSources keyPathText sources + return [blueColor (text $ Text.unpack keyPathText) <$$> configSources] + in + do + result <- loop [] configMap + return $ (hcat $ intersperse (linebreak <> linebreak) $ result) <> linebreak renderConfigColor :: MonadThrow m => Config -> m Doc diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs index bcfd6a1..1a9ea2a 100644 --- a/etc/src/System/Etc/Internal/Spec/Types.hs +++ b/etc/src/System/Etc/Internal/Spec/Types.hs @@ -77,17 +77,32 @@ data ConfigSources cmd } deriving (Generic, Show, Eq) -data ConfigValuePrimitive +data SingleConfigValueType = CVTString | CVTNumber | CVTBool + | CVTObject deriving (Generic, Show, Eq) +instance Display SingleConfigValueType where + display value = + case value of + CVTString -> "string" + CVTNumber -> "number" + CVTBool -> "bool" + CVTObject -> "object" + data ConfigValueType - = CVTSingle ConfigValuePrimitive - | CVTArray ConfigValuePrimitive + = CVTSingle !SingleConfigValueType + | CVTArray !SingleConfigValueType deriving (Generic, Show, Eq) +instance Display ConfigValueType where + display value = + case value of + CVTSingle singleVal -> display singleVal + CVTArray singleVal -> display $ "[" <> display singleVal <> "]" + data ConfigValue cmd = ConfigValue { defaultValue :: !(Maybe JSON.Value) @@ -222,6 +237,7 @@ instance JSON.FromJSON ConfigValueType where "[string]" -> pure $ CVTArray CVTString "[number]" -> pure $ CVTArray CVTNumber "[bool]" -> pure $ CVTArray CVTBool + "[object]" -> pure $ CVTArray CVTObject _ -> JSON.typeMismatch "ConfigValueType (string, number, bool)" (JSON.String tyText) inferErrorMsg :: String @@ -255,6 +271,7 @@ matchesConfigValueType json cvType = case (json, cvType) of (JSON.String{}, CVTSingle CVTString) -> True (JSON.Number{}, CVTSingle CVTNumber) -> True (JSON.Bool{} , CVTSingle CVTBool ) -> True + (JSON.Object{}, CVTSingle CVTObject) -> True (JSON.Array arr, CVTArray inner) -> if null arr then True else all (flip matchesConfigValueType (CVTSingle inner)) arr _ -> False diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs index 8812478..dfd042b 100644 --- a/etc/test/System/Etc/SpecTest.hs +++ b/etc/test/System/Etc/SpecTest.hs @@ -124,6 +124,23 @@ general_tests = testGroup "should contain default array value" (Just (JSON.Array (Vector.fromList []))) (defaultValue value) + , 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 <- 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 + "should contain default array value" + (Just + (JSON.Array (Vector.fromList [JSON.object ["hello" JSON..= ("world" :: Text)]])) + ) + (defaultValue value) , testCase "entries can have many levels of nesting" $ do let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}" keys = ["english", "greeting"] From 569ddf31b983ae068491b9ce59bdd0cb8cf35208 Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Sat, 12 May 2018 18:10:03 +0000 Subject: [PATCH 5/6] Bump version to 0.4.0.0 --- etc/CHANGELOG.md | 3 ++- etc/etc.cabal | 2 +- make/sdist.make | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/etc/CHANGELOG.md b/etc/CHANGELOG.md index 8a9d762..7a109c9 100644 --- a/etc/CHANGELOG.md +++ b/etc/CHANGELOG.md @@ -2,7 +2,8 @@ ---- **BREAKING CHANGES** -* Add new `type` field to `etc/spec` with support for `string`, `number`, `bool`, `[string]`, `[number]` and `[bool]` +* Add new `type` field to `etc/spec` with support for `string`, `number`, + `bool`, `[string]`, `[number]` and `[bool]`, `[object]` * Remove `type` field in `cli` spec in favor of `type` on `etc/spec` * Allow ENV vars to accept supported types (only strings were allowed) (closes #30) * Allow CLI options to accept supported types (only strings and numbers were allowed) diff --git a/etc/etc.cabal b/etc/etc.cabal index 82dda59..be197ee 100644 --- a/etc/etc.cabal +++ b/etc/etc.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: etc -version: 0.3.3.0 +version: 0.4.0.0 synopsis: Declarative configuration spec for Haskell projects description: `etc` gathers configuration values from multiple sources (cli options, OS environment variables, files) using a declarative spec file that defines where diff --git a/make/sdist.make b/make/sdist.make index f24320f..accde26 100644 --- a/make/sdist.make +++ b/make/sdist.make @@ -2,7 +2,7 @@ ################################################################################ PROJECT_NAME := etc -PROJECT_VERSION := 0.3.2.0 +PROJECT_VERSION := 0.4.0.0 STACK := stack --resolver nightly From 15af0e8cc8bb89612d825919559b66f3bb18bc6e Mon Sep 17 00:00:00 2001 From: Roman Gonzalez Date: Sun, 13 May 2018 01:53:51 +0000 Subject: [PATCH 6/6] Remove .travis.yml in favor of circleCI --- .travis.yml | 171 ---------------------------------------------------- 1 file changed, 171 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 6c120f3..0000000 --- a/.travis.yml +++ /dev/null @@ -1,171 +0,0 @@ -# Use new container infrastructure to enable caching -sudo: false - -# Do not choose a language; we provide our own build tools. -language: generic - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.local/bin - - $HOME/.ghc - - $HOME/.cabal - - $HOME/.stack - - $TRAVIS_BUILD_DIR/.stack-work - - $TRAVIS_BUILD_DIR/tools/bin - -matrix: - include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.0.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.2.2" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # Build with the newest GHC and cabal-install. This is an accepted failure, - # see below. - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC HEAD" - addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS - # variable, such as using --stack-yaml to point to a different file. - - env: BUILD=stack STACK_ARGS="" - compiler: ": #stack default" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack STACK_ARGS="--resolver lts-7" - compiler: ": #stack 8.0.1" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack STACK_ARGS="--resolver lts-9" - compiler: ": #stack 8.0.2" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack STACK_ARGS="--resolver lts-11" - compiler: ": #stack 8.2.2" - addons: {apt: {packages: [libgmp-dev]}} - - # Nightly builds are allowed to fail - - env: BUILD=stack STACK_ARGS="--resolver nightly" - compiler: ": #stack nightly" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=sdist - compiler: ": #stack nightly" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=lint - compiler: ": #stack default" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=format - compiler: ": #stack default" - addons: {apt: {packages: [libgmp-dev]}} - - allow_failures: - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - - env: BUILD=stack STACK_ARGS="--resolver nightly" - -before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH -- mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - if [ "$CABALVER" != "1.16" ] - then - echo 'jobs: $ncpus' >> $HOME/.cabal/config - fi - -install: -- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" -- if [ -f configure.ac ]; then autoreconf -i; fi -- | - set -ex - case "$BUILD" in - stack) - # Add in extra-deps for older snapshots, as necessary - make -f make/solver.make fix-solver - - # Build the dependencies - stack --no-terminal $STACK_ARGS test --bench --only-dependencies - ;; - cabal) - cabal --version - travis_retry cabal update - - # Get the list of packages from the stack.yaml file. Note that - # this will also implicitly run hpack as necessary to generate - # the .cabal files needed by cabal-install. - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@' | grep -v 'example') - - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - ;; - esac - set +ex - -script: -- | - set -ex - case "$BUILD" in - stack) - make test - ;; - cabal) - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - - ORIGDIR=$(pwd) - for dir in $PACKAGES - do - cd $dir - cabal check || [ "$CABALVER" == "1.16" ] - cabal sdist - PKGVER=$(cabal info . | awk '{print $2;exit}') - SRC_TGZ=$PKGVER.tar.gz - cd dist - tar zxfv "$SRC_TGZ" - cd "$PKGVER" - cabal configure --enable-tests - cabal build - cabal test - cd $ORIGDIR - done - ;; - lint) - make -f make/tools.make lint - ;; - format) - make -f make/tools.make format - ;; - sdist) - make -f make/solver.make cabal - make -f make/sdist.make test-sdist - ;; - esac - set +ex - -notifications: - email: false