diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2017 Roman Gonzalez + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# etc + +`etc` gathers configuration values from multiple sources (cli options, OS +environment variables, files) using a declarative spec file that defines where +this values are to be found and located in a configuration map. + +For more information about `etc` API and how to use it, see +the [`etc` homepage](https://github.com/roman/Haskell-etc) diff --git a/etc.cabal b/etc.cabal new file mode 100644 --- /dev/null +++ b/etc.cabal @@ -0,0 +1,140 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: etc +version: 0.0.0.0 +synopsis: Declarative configuration spec for Haskell projects +description: Please see README.md +category: Configuration, System +homepage: https://github.com/roman/Haskell-etc +author: Roman Gonzalez +maintainer: romanandreg@gmail.com +copyright: 2017 Roman Gonzalez +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +data-files: + test/fixtures/config.foo + test/fixtures/config.json + test/fixtures/config.spec.yaml + test/fixtures/config.yaml + test/fixtures/config.yml +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/roman/Haskell-etc + +flag printer + description: Include support for config printer + manual: False + default: False + +flag cli + description: Include support for cli arguments + manual: False + default: False + +flag yaml + description: Include support to parse YAML files + manual: False + default: False + +library + hs-source-dirs: src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , aeson >=1.0 && <1.1 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , text >=1.2 && <1.3 + , protolude >=0.1 && <0.2 + , unordered-containers >=0.2 && <0.3 + , directory >=1.3 && <1.4 + , exceptions >=0.8 && <0.9 + , hashable >=1.2 && <1.3 + , vector >=0.11 && <0.12 + + + exposed-modules: + System.Etc + System.Etc.Spec + System.Etc.Internal.Config + System.Etc.Internal.Spec.JSON + System.Etc.Internal.Spec.Types + System.Etc.Internal.Types + System.Etc.Internal.Resolver.Default + System.Etc.Internal.Resolver.File + System.Etc.Internal.Resolver.Env + + other-modules: + Paths_etc + + default-language: Haskell2010 + + if flag(printer) + cpp-options: -DWITH_PRINTER + build-depends: + ansi-wl-pprint >=0.6 && <0.7 + exposed-modules: + System.Etc.Internal.Printer + + if flag(cli) + cpp-options: -DWITH_CLI + build-depends: + optparse-applicative >=0.13 && <0.14 + exposed-modules: + System.Etc.Internal.Resolver.Cli + System.Etc.Internal.Resolver.Cli.Common + System.Etc.Internal.Resolver.Cli.Plain + System.Etc.Internal.Resolver.Cli.Command + + if flag(yaml) + cpp-options: -DWITH_YAML + build-depends: + yaml >=0.8 && <0.9 + exposed-modules: + System.Etc.Internal.Spec.YAML + +test-suite etc-testsuite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , aeson >=1.0 && <1.1 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , text >=1.2 && <1.3 + , protolude >=0.1 && <0.2 + , unordered-containers >=0.2 && <0.3 + , vector >=0.11 && <0.12 + , tasty >=0.11 && <0.12 + , tasty-hunit >=0.9 && <0.10 + , tasty-rerun >=1.1 && <1.2 + , etc + + if flag(cli) + cpp-options: -DWITH_CLI + build-depends: + optparse-applicative >=0.13 && <0.14 + if flag(yaml) + cpp-options: -DWITH_YAML + build-depends: + yaml >=0.8 && <0.9 + other-modules: + Paths_etc + System.Etc.Resolver.CliTest + System.Etc.Resolver.Cli.CommandTest + System.Etc.Resolver.Cli.PlainTest + System.Etc.Resolver.DefaultTest + System.Etc.Resolver.EnvTest + System.Etc.Resolver.FileTest + System.Etc.SpecTest + default-language: Haskell2010 diff --git a/src/System/Etc.hs b/src/System/Etc.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + +-} + +module System.Etc ( + -- * Config + -- $config + Config + , getConfigValue + , getConfigValueWith + , getSelectedConfigSource + , getAllConfigSources + + -- * ConfigSpec + -- $config_spec + , ConfigSource (..) + , ConfigValue + , ConfigSpec + , ConfigurationError (..) + , parseConfigSpec + , readConfigSpec + + -- ** Resolvers + -- $resolvers + , resolveDefault + , resolveFiles + , resolveEnvPure + , resolveEnv + +#ifdef WITH_CLI + + , resolvePlainCliPure + , resolveCommandCliPure + , resolvePlainCli + , resolveCommandCli + + -- ** CLI Resolver Error type + , getErrorMessage + , CliConfigError(..) +#endif + +#ifdef WITH_PRINTER + -- * Printer + -- $printer + , renderConfig + , printPrettyConfig + , hPrintPrettyConfig +#endif + ) where + +import System.Etc.Internal.Resolver.Default (resolveDefault) +import System.Etc.Internal.Types (Config, ConfigSource (..), ConfigValue) +import System.Etc.Spec + (ConfigSpec, ConfigurationError (..), parseConfigSpec, readConfigSpec) + +#ifdef WITH_CLI +import System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure) +import System.Etc.Internal.Resolver.Cli.Common (CliConfigError (..), getErrorMessage) +import System.Etc.Internal.Resolver.Cli.Plain (resolvePlainCli, resolvePlainCliPure) +#endif + +#ifdef WITH_PRINTER +import System.Etc.Internal.Printer (hPrintPrettyConfig, printPrettyConfig, renderConfig) +#endif + +import System.Etc.Internal.Config + (getAllConfigSources, getConfigValue, getConfigValueWith, getSelectedConfigSource) +import System.Etc.Internal.Resolver.Env (resolveEnv, resolveEnvPure) +import System.Etc.Internal.Resolver.File (resolveFiles) + +{- $config + + Use this functions to fetch values from the Etc.Config and cast them to types + that make sense in your program +-} + +{- $config_spec + + Use this functions to read the configuration spec. Remember you can + use JSON or YAML(*) filepaths + + * The yaml cabal flag must be used to support yaml syntax +-} + +{- $resolvers + + Use this functions to gather configuration values from different sources + (environment variables, command lines or files). Then compose results + together using the mappend function +-} + +{- $printer + + Use these function to render the configuration map and understand how the + resolving was performed. +-} diff --git a/src/System/Etc/Internal/Config.hs b/src/System/Etc/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Config.hs @@ -0,0 +1,152 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Config where + +import Protolude + +import Control.Monad.Catch (MonadThrow (..)) + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text + +import System.Etc.Internal.Types + +-------------------------------------------------------------------------------- + +configValueToJsonObject :: ConfigValue -> JSON.Value +configValueToJsonObject configValue = + case configValue of + ConfigValue sources -> + case Set.maxView sources of + Nothing -> + undefined + + Just (source, _) -> + value source + + SubConfig configm -> + configm + & HashMap.foldrWithKey + (\key innerConfigValue acc -> + HashMap.insert key (configValueToJsonObject innerConfigValue) acc) + HashMap.empty + & JSON.Object + +-- Can't add signature given JSON.Parser is not exposed ¯\_(ツ)_/¯ +-- getConfigValueWith +-- :: MonadThrow m +-- => (JSON.Value -> JSON.Parser value) +-- -> [Text] +-- -> Config +-- -> m value +getConfigValueWith parser keys0 (Config configValue0) = + let + loop keys configValue = + case (keys, configValue) of + ([], ConfigValue sources) -> + case Set.maxView sources of + Nothing -> + throwM $ InvalidConfigKeyPath keys0 + + Just (None, _) -> + throwM $ InvalidConfigKeyPath keys0 + + Just (source, _) -> + case JSON.iparse parser (value source) of + JSON.IError path err -> + JSON.formatError path err + & Text.pack + & InvalidConfiguration + & throwM + + JSON.ISuccess result -> + return result + + ([], innerConfigValue) -> + case JSON.iparse parser (configValueToJsonObject innerConfigValue) of + JSON.IError path err -> + JSON.formatError path err + & Text.pack + & InvalidConfiguration + & throwM + + JSON.ISuccess result -> + return result + + (k:keys1, SubConfig configm) -> + case HashMap.lookup k configm of + Nothing -> + throwM $ InvalidConfigKeyPath keys0 + Just configValue1 -> + loop keys1 configValue1 + + _ -> + throwM $ InvalidConfigKeyPath keys0 + in + loop keys0 configValue0 + +getSelectedConfigSource + :: (MonadThrow m) + => [Text] + -> Config + -> m ConfigSource +getSelectedConfigSource keys0 (Config configValue0) = + let + loop keys configValue = + case (keys, configValue) of + ([], ConfigValue sources) -> + case Set.maxView sources of + Nothing -> + throwM $ InvalidConfigKeyPath keys0 + + Just (source, _) -> + return source + + (k:keys1, SubConfig configm) -> + case HashMap.lookup k configm of + Nothing -> + throwM $ InvalidConfigKeyPath keys0 + Just configValue1 -> + loop keys1 configValue1 + + _ -> + throwM $ InvalidConfigKeyPath keys0 + in + loop keys0 configValue0 + + +getAllConfigSources + :: (MonadThrow m) + => [Text] + -> Config + -> m (Set ConfigSource) +getAllConfigSources keys0 (Config configValue0) = + let + loop keys configValue = + case (keys, configValue) of + ([], ConfigValue sources) -> + return sources + + (k:keys1, SubConfig configm) -> + case HashMap.lookup k configm of + Nothing -> + throwM $ InvalidConfigKeyPath keys0 + Just configValue1 -> + loop keys1 configValue1 + + _ -> + throwM $ InvalidConfigKeyPath keys0 + in + loop keys0 configValue0 + +getConfigValue + :: (MonadThrow m, JSON.FromJSON result) + => [Text] + -> Config + -> m result +getConfigValue = + getConfigValueWith JSON.parseJSON diff --git a/src/System/Etc/Internal/Printer.hs b/src/System/Etc/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Printer.hs @@ -0,0 +1,145 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Printer ( + renderConfig + , printPrettyConfig + , hPrintPrettyConfig + ) where + +import Protolude hiding ((<>)) + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Text.PrettyPrint.ANSI.Leijen + +import System.Etc.Internal.Spec.Types (ConfigurationError (..)) +import System.Etc.Internal.Types + +renderJsonValue :: JSON.Value -> (Doc, Int) +renderJsonValue value' = + case value' of + JSON.String str -> + (text $ Text.unpack str, Text.length str) + + JSON.Number scientific -> + let + number = + show scientific + in + (text number, length number) + JSON.Bool bool' -> + if bool' then + (text "true", 5) + else + (text "false", 5) + _ -> + value' + & show + & ("Invalid configuration value creation " `mappend`) + & InvalidConfiguration + & show + & error + + +renderConfig :: Config -> Doc +renderConfig (Config configValue0) = + let + brackets' = enclose (lbracket <> space) (space <> rbracket) + + renderSource :: ConfigSource -> ((Doc, Int), Doc) + renderSource source' = + case source' of + Default value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Default")) + ) + + File _index filepath' value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath'))) + ) + + Env varname value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname))) + ) + + Cli value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Cli")) + ) + + None -> + ( (mempty, 0) + , mempty + ) + + renderSources :: [ConfigSource] -> Doc + renderSources sources0 = + let + sources@(((selValueDoc, _), selSourceDoc):others) = + map renderSource sources0 + + fillingWidth = + sources + & map (snd . fst) + & maximum + & max 10 + + selectedValue = + [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ] + + otherValues = + map (\((valueDoc, _), sourceDoc) -> + fill fillingWidth valueDoc <+> sourceDoc) + others + in + selectedValue + & flip mappend otherValues + & vcat + & indent 2 + + configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc] + configEntryRenderer keys resultDoc configKey configValue = + resultDoc `mappend` loop (configKey : keys) configValue + + loop keys configValue = + case configValue of + SubConfig subConfigm -> + HashMap.foldlWithKey' + (configEntryRenderer keys) + mempty + subConfigm + + ConfigValue sources0 -> + let + configKey = + keys + & reverse + & Text.intercalate "." + + sources = + Set.toDescList sources0 + in + if null sources then + [] + else + [ blue (text (Text.unpack configKey)) + <$$> renderSources sources ] + in + loop [] configValue0 + & intersperse (linebreak <> linebreak) + & hcat + & (<> linebreak) + +printPrettyConfig :: Config -> IO () +printPrettyConfig = + putDoc . renderConfig + +hPrintPrettyConfig :: Handle -> Config -> IO () +hPrintPrettyConfig handle' = + hPutDoc handle' . renderConfig diff --git a/src/System/Etc/Internal/Resolver/Cli.hs b/src/System/Etc/Internal/Resolver/Cli.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Cli.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Cli + ( PlainConfigSpec + -- , resolveCommandCli + -- , resolveCommandCliPure + , resolvePlainCli + , resolvePlainCliPure + ) where + +-- import System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure) +import System.Etc.Internal.Resolver.Cli.Plain + (PlainConfigSpec, resolvePlainCli, resolvePlainCliPure) diff --git a/src/System/Etc/Internal/Resolver/Cli/Command.hs b/src/System/Etc/Internal/Resolver/Cli/Command.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Cli/Command.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure) where + +import Protolude + +import Control.Monad.Catch (MonadThrow, throwM) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.Maybe (fromMaybe) +import Data.Vector (Vector) +import System.Environment (getArgs, getProgName) + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Options.Applicative as Opt + +import System.Etc.Internal.Resolver.Cli.Common +import System.Etc.Internal.Types + +import qualified System.Etc.Internal.Spec.Types as Spec + +-------------------------------------------------------------------------------- + +entrySpecToJsonCli + :: (MonadThrow m) + => Spec.CliEntrySpec cmd + -> m (Vector cmd, Opt.Parser (Maybe JSON.Value)) +entrySpecToJsonCli entrySpec = + case entrySpec of + Spec.CmdEntry commandJsonValue specSettings -> + return ( commandJsonValue + , settingsToJsonCli specSettings + ) + + Spec.PlainEntry {} -> + throwM CommandKeyMissing + +configValueSpecToCli + :: (MonadThrow m, Eq cmd, Hashable cmd) + => HashMap cmd (Opt.Parser ConfigValue) + -> Text + -> Spec.ConfigSources cmd + -> m (HashMap cmd (Opt.Parser ConfigValue)) +configValueSpecToCli acc0 specEntryKey sources = + let + updateAccConfigOptParser configValueParser accOptParser = + (\configValue accSubConfig -> + case accSubConfig of + ConfigValue {} -> + accSubConfig + + SubConfig subConfigMap -> + subConfigMap + & HashMap.alter (const $ Just configValue) specEntryKey + & SubConfig) + <$> configValueParser + <*> accOptParser + in + case Spec.cliEntry sources of + Nothing -> + return acc0 + + Just entrySpec -> do + (commands, jsonOptParser) <- + entrySpecToJsonCli entrySpec + + let + configValueParser = + jsonToConfigValue <$> jsonOptParser + + foldM (\acc command -> + acc + & HashMap.alter + (\mAccParser -> + mAccParser + & fromMaybe (pure $ SubConfig HashMap.empty) + & updateAccConfigOptParser configValueParser + & Just) + command + & return) + acc0 + commands + +subConfigSpecToCli + :: (MonadThrow m, JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => Text + -> HashMap.HashMap Text (Spec.ConfigValue cmd) + -> HashMap cmd (Opt.Parser ConfigValue) + -> m (HashMap cmd (Opt.Parser ConfigValue)) +subConfigSpecToCli specEntryKey subConfigSpec acc = + let + updateAccConfigOptParser subConfigParser accOptParser = + (\subConfig accSubConfig -> + case accSubConfig of + ConfigValue {} -> + accSubConfig + + SubConfig subConfigMap -> + subConfigMap + & HashMap.alter (const $ Just subConfig) specEntryKey + & SubConfig) + <$> subConfigParser + <*> accOptParser + + addSubParserCommand command subConfigParser = + HashMap.alter + (\mAccOptParser -> + case mAccOptParser of + Nothing -> do + commandText <- commandToKey command + throwM $ UnknownCommandKey (Text.intercalate ", " commandText) + + Just accOptParser -> + Just + $ updateAccConfigOptParser subConfigParser accOptParser) + command + + in do + parserPerCommand <- + foldM specToConfigValueCli + HashMap.empty + (HashMap.toList subConfigSpec) + + parserPerCommand + & HashMap.foldrWithKey + addSubParserCommand + acc + & return + +specToConfigValueCli + :: (MonadThrow m, JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => HashMap cmd (Opt.Parser ConfigValue) + -> ( Text, Spec.ConfigValue cmd ) + -> m (HashMap cmd (Opt.Parser ConfigValue)) +specToConfigValueCli acc (specEntryKey, specConfigValue) = + case specConfigValue of + Spec.ConfigValue _ sources -> + configValueSpecToCli + acc + specEntryKey + sources + + Spec.SubConfig subConfigSpec -> + subConfigSpecToCli + specEntryKey + subConfigSpec + acc + +configValueCliAccInit + :: (MonadThrow m, JSON.FromJSON cmd, Eq cmd, Hashable cmd) + => Spec.ConfigSpec cmd + -> m (HashMap cmd (Opt.Parser ConfigValue)) +configValueCliAccInit spec = + let + zeroParser = + pure $ SubConfig HashMap.empty + + commandsSpec = do + programSpec <- Spec.specCliProgramSpec spec + Spec.cliCommands programSpec + + in + case commandsSpec of + Nothing -> + throwM CommandsKeyNotDefined + + Just commands -> + foldM (\acc (commandVal, _) -> do + command <- parseCommandJsonValue (JSON.String commandVal) + return $ HashMap.insert command zeroParser acc) + HashMap.empty + (HashMap.toList commands) + +joinCommandParsers + :: (MonadThrow m, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => HashMap cmd (Opt.Parser ConfigValue) + -> m (Opt.Parser (cmd, Config)) +joinCommandParsers parserPerCommand = + let + joinParser acc (command, subConfigParser) = + let + parser = + fmap (\subConfig -> (command, Config subConfig)) + subConfigParser + in do + commandTexts <- commandToKey command + + let + commandParsers = + map (\commandText -> + Opt.command (Text.unpack commandText) + (Opt.info (Opt.helper <*> parser) Opt.idm)) + commandTexts + + [acc] + & (++ commandParsers) + & mconcat + & return + in do + mergedParsers <- + foldM joinParser Opt.idm (HashMap.toList parserPerCommand) + return (Opt.subparser mergedParsers) + +specToConfigCli + :: (MonadThrow m, JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => Spec.ConfigSpec cmd + -> m (Opt.Parser (cmd, Config)) +specToConfigCli spec = do + acc <- configValueCliAccInit spec + parsers <- + foldM specToConfigValueCli + acc + (HashMap.toList $ Spec.specConfigValues spec) + + joinCommandParsers parsers + +{-| + +Dynamically generate an OptParser CLI with sub-commands from the spec settings +declared on the @ConfigSpec@. This will process the OptParser from given input +rather than fetching it from the OS. + +This will return the selected record parsed from the sub-command input and the +configuration map with keys defined for that sub-command. + +-} +resolveCommandCliPure + :: (MonadThrow m, JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => Spec.ConfigSpec cmd -- ^ Config Spec (normally parsed from json or yaml file)-- ^ The + -> Text -- ^ Name of the program running the CLI + -> [Text] -- ^ Arglist for the program + -> m (cmd, Config) -- ^ Selected command and Configuration Map +resolveCommandCliPure configSpec progName args = do + configParser <- specToConfigCli configSpec + + let + programModFlags = + case Spec.specCliProgramSpec configSpec of + Just programSpec -> + Opt.fullDesc + `mappend` (programSpec + & Spec.cliProgramDesc + & Text.unpack + & Opt.progDesc) + `mappend` (programSpec + & Spec.cliProgramHeader + & Text.unpack + & Opt.header) + Nothing -> + mempty + + programParser = + Opt.info (Opt.helper <*> configParser) + programModFlags + + programResult = + args + & map Text.unpack + & Opt.execParserPure Opt.defaultPrefs programParser + + programResultToResolverResult progName programResult + + +{-| + +Dynamically generate an OptParser CLI with sub-commands from the spec settings +declared on the @ConfigSpec@. + +Once it generates the CLI and gathers the input, it will return the selected +record parsed from the sub-command input and the configuration map with keys +defined for that sub-command. + +-} +resolveCommandCli + :: (JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd) + => Spec.ConfigSpec cmd -- ^ Config Spec (normally parsed from json or yaml file) + -> IO (cmd, Config) -- ^ Selected command and Configuration Map +resolveCommandCli configSpec = do + progName <- Text.pack <$> getProgName + args <- map Text.pack <$> getArgs + + handleCliResult + $ resolveCommandCliPure configSpec progName args diff --git a/src/System/Etc/Internal/Resolver/Cli/Common.hs b/src/System/Etc/Internal/Resolver/Cli/Common.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Cli/Common.hs @@ -0,0 +1,200 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Cli.Common where + +import qualified Prelude as P +import Protolude + +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Internal as JSON (IResult (..), iparse) +import qualified Data.ByteString.Lazy.Char8 as BL (unpack) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Vector as Vector +import qualified Options.Applicative as Opt + +import qualified System.Etc.Internal.Spec.Types as Spec +import System.Etc.Internal.Types + +-------------------------------------------------------------------------------- + +{-| A wrapper for sub-routines that return an error message; this was + created for error report purposes. +-} +newtype GetErrorMessage + = GetErrorMessage { + -- | Unwrap IO action with error message + getErrorMessage :: IO Text + } + +instance Show GetErrorMessage where + show _ = "<>" + +{-| Error when evaluating the ConfigSpec or when executing the OptParser + +-} +data CliConfigError + -- | The type of the Command Key is invalid + = InvalidCliCommandKey Text + -- | Trying to use command for an entry without setting commands section + | CommandsKeyNotDefined + -- | Trying to use a command that is not defined in commands section + | UnknownCommandKey Text + -- | The command setting is missing on a Command Cli + | CommandKeyMissing + -- | There is a command setting on a plain Cli + | CommandKeyOnPlainCli + -- | The internal OptParser API failed + | CliEvalExited ExitCode GetErrorMessage + deriving (Show) + +instance Exception CliConfigError + +-------------------------------------------------------------------------------- + +specToCliSwitchFieldMod specSettings = + maybe Opt.idm + (Opt.long . Text.unpack) + (Spec.optLong specSettings) + `mappend` maybe Opt.idm + (Opt.short . Text.head) + (Spec.optShort specSettings) + `mappend` maybe Opt.idm + (Opt.help . Text.unpack) + (Spec.optHelp 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] + JSON.Array jsonList -> + jsonList + & Vector.toList + & mapM commandToKey + & (concat <$>) + _ -> + cmd + & JSON.encode + & BL.unpack + & Text.pack + & InvalidCliCommandKey + & throwM + +settingsToJsonCli + :: Spec.CliEntryMetadata + -> Opt.Parser (Maybe JSON.Value) +settingsToJsonCli 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 -> + (JSON.String . Text.pack) + <$> Opt.strOption (specToCliVarFieldMod specSettings) + + Spec.NumberOpt -> + (JSON.Number . fromInteger) + <$> Opt.option Opt.auto (specToCliVarFieldMod specSettings) + + Spec.SwitchOpt -> + JSON.Bool + <$> Opt.switch (specToCliSwitchFieldMod specSettings) + + Spec.Arg {} -> + case Spec.argValueType specSettings of + Spec.StringArg -> + (JSON.String . Text.pack) + <$> Opt.strArgument ( specSettings + & Spec.argMetavar + & maybe Opt.idm (Opt.metavar . Text.unpack)) + Spec.NumberArg -> + (JSON.Number . fromInteger) + <$> Opt.argument Opt.auto + ( 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 + JSON.IError _path err -> + throwM (InvalidCliCommandKey $ Text.pack err) + + JSON.ISuccess result -> + return result + +jsonToConfigValue + :: Maybe JSON.Value + -> ConfigValue +jsonToConfigValue specEntryDefVal = + ConfigValue + $ Set.fromList + $ maybe [] ((:[]) . Cli) specEntryDefVal + +handleCliResult + :: Either SomeException a -> IO a +handleCliResult result = + case result of + Right config -> + return config + + Left err -> + case fromException err of + Just (CliEvalExited ExitSuccess (GetErrorMessage getMsg)) -> do + getMsg >>= putStrLn + exitSuccess + + Just (CliEvalExited exitCode (GetErrorMessage getMsg)) -> do + getMsg >>= Text.hPutStrLn stderr + exitWith exitCode + + _ -> + throwIO err + +programResultToResolverResult + :: MonadThrow m + => Text + -> Opt.ParserResult a + -> m a +programResultToResolverResult progName programResult = + case programResult of + Opt.Success result -> + return result + + Opt.Failure failure -> + let + (outputMsg, exitCode) = + Opt.renderFailure failure $ Text.unpack progName + in + throwM + $ CliEvalExited exitCode (GetErrorMessage $ return (Text.pack outputMsg)) + + Opt.CompletionInvoked compl -> + let + getMsg = + Text.pack <$> Opt.execCompletion compl (Text.unpack progName) + in + throwM + $ CliEvalExited ExitSuccess (GetErrorMessage getMsg) diff --git a/src/System/Etc/Internal/Resolver/Cli/Plain.hs b/src/System/Etc/Internal/Resolver/Cli/Plain.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Cli/Plain.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Cli.Plain (PlainConfigSpec, resolvePlainCli, resolvePlainCliPure) where + +import Protolude + +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Options.Applicative as Opt +import System.Environment (getArgs, getProgName) + +import System.Etc.Internal.Resolver.Cli.Common +import qualified System.Etc.Internal.Spec.Types as Spec +import System.Etc.Internal.Types + +-------------------------------------------------------------------------------- + +type PlainConfigSpec = + Spec.ConfigSpec () + +-------------------------------------------------------------------------------- + +entrySpecToConfigValueCli + :: (MonadThrow m) + => Spec.CliEntrySpec () + -> m (Opt.Parser (Maybe JSON.Value)) +entrySpecToConfigValueCli entrySpec = + case entrySpec of + Spec.CmdEntry {} -> + throwM CommandKeyOnPlainCli + + Spec.PlainEntry specSettings -> + return (settingsToJsonCli specSettings) + + +configValueSpecToCli + :: (MonadThrow m) + => Text + -> Spec.ConfigSources () + -> Opt.Parser ConfigValue + -> m (Opt.Parser ConfigValue) +configValueSpecToCli specEntryKey sources acc = + let + updateAccConfigOptParser configValueParser accOptParser = + (\configValue accSubConfig -> + case accSubConfig of + ConfigValue {} -> + accSubConfig + + SubConfig subConfigMap -> + subConfigMap + & HashMap.alter (const $ Just configValue) specEntryKey + & SubConfig) + <$> configValueParser + <*> accOptParser + in + case Spec.cliEntry sources of + Nothing -> + return acc + + Just entrySpec -> do + jsonOptParser <- entrySpecToConfigValueCli entrySpec + + let + configValueParser = + jsonToConfigValue <$> jsonOptParser + + return $ updateAccConfigOptParser configValueParser acc + +subConfigSpecToCli + :: (MonadThrow m) + => Text + -> HashMap.HashMap Text (Spec.ConfigValue ()) + -> Opt.Parser ConfigValue + -> m (Opt.Parser ConfigValue) +subConfigSpecToCli specEntryKey subConfigSpec acc = + let + updateAccConfigOptParser subConfigParser accOptParser = + (\subConfig accSubConfig -> + case accSubConfig of + ConfigValue {} -> + accSubConfig + + SubConfig subConfigMap -> + subConfigMap + & HashMap.alter (const $ Just subConfig) specEntryKey + & SubConfig) + <$> subConfigParser + <*> accOptParser + in do + configOptParser <- + foldM specToConfigValueCli + (pure $ SubConfig HashMap.empty) + (HashMap.toList subConfigSpec) + + return + $ updateAccConfigOptParser configOptParser acc + +specToConfigValueCli + :: (MonadThrow m) + => Opt.Parser ConfigValue + -> (Text, Spec.ConfigValue ()) + -> m (Opt.Parser ConfigValue) +specToConfigValueCli acc (specEntryKey, specConfigValue) = + case specConfigValue of + Spec.ConfigValue _ sources -> + configValueSpecToCli + specEntryKey + sources + acc + + Spec.SubConfig subConfigSpec -> + subConfigSpecToCli + specEntryKey + subConfigSpec + acc + +configValueCliAccInit + :: (MonadThrow m) + => Spec.ConfigSpec () + -> m (Opt.Parser ConfigValue) +configValueCliAccInit spec = + let + zeroParser = + pure $ SubConfig HashMap.empty + + commandsSpec = do + programSpec <- Spec.specCliProgramSpec spec + Spec.cliCommands programSpec + in + case commandsSpec of + Nothing -> + return zeroParser + + Just _ -> + throwM CommandKeyOnPlainCli + +specToConfigCli + :: (MonadThrow m) + => Spec.ConfigSpec () + -> m (Opt.Parser Config) +specToConfigCli spec = do + acc <- configValueCliAccInit spec + parser <- + foldM specToConfigValueCli + acc + (HashMap.toList $ Spec.specConfigValues spec) + + parser + & (Config <$>) + & return + +{-| + +Dynamically generate an OptParser CLI from the spec settings declared on the +@ConfigSpec@. This will process the OptParser from given input +rather than fetching it from the OS. + +Once it generates the CLI and gathers the input, it will return the +configuration map with keys defined for the program on @ConfigSpec@. + +-} +resolvePlainCliPure + :: MonadThrow m + => PlainConfigSpec -- ^ Plain ConfigSpec (no sub-commands) + -> Text -- ^ Name of the program running the CLI + -> [Text] -- ^ Arglist for the program + -> m Config -- ^ returns Configuration Map +resolvePlainCliPure configSpec progName args = do + configParser <- specToConfigCli configSpec + + let + programModFlags = + case Spec.specCliProgramSpec configSpec of + Just programSpec -> + Opt.fullDesc + `mappend` (programSpec + & Spec.cliProgramDesc + & Text.unpack + & Opt.progDesc) + `mappend` (programSpec + & Spec.cliProgramHeader + & Text.unpack + & Opt.header) + Nothing -> + mempty + + programParser = + Opt.info (Opt.helper <*> configParser) + programModFlags + + programResult = + args + & map Text.unpack + & Opt.execParserPure Opt.defaultPrefs programParser + + programResultToResolverResult progName programResult + + +{-| + +Dynamically generate an OptParser CLI from the spec settings declared on the +@ConfigSpec@. + +Once it generates the CLI and gathers the input, it will return the +configuration map with keys defined for the program on @ConfigSpec@. + +-} +resolvePlainCli + :: PlainConfigSpec -- ^ Plain ConfigSpec (no sub-commands) + -> IO Config -- ^ returns Configuration Map +resolvePlainCli configSpec = do + progName <- Text.pack <$> getProgName + args <- map Text.pack <$> getArgs + + handleCliResult + $ resolvePlainCliPure configSpec progName args diff --git a/src/System/Etc/Internal/Resolver/Default.hs b/src/System/Etc/Internal/Resolver/Default.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Default.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Default (resolveDefault) where + +import Protolude + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set + +import qualified System.Etc.Internal.Spec.Types as Spec +import System.Etc.Internal.Types + +toDefaultConfigValue :: JSON.Value -> ConfigValue +toDefaultConfigValue = + ConfigValue . Set.singleton . Default + +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 _ -> + let + mConfigSource = + toDefaultConfigValue <$> def + + updateConfig = + writeInSubConfig specKey <$> mConfigSource <*> mConfig + in + updateConfig <|> mConfig + + 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 + +{-| + +Gathers all default values from the @etc/spec@ entries inside a @ConfigSpec@ + +-} +resolveDefault + :: Spec.ConfigSpec cmd -- ^ ConfigSpec + -> Config -- ^ returns Configuration Map with default values included +resolveDefault spec = + maybe (Config emptySubConfig) + Config + (buildDefaultResolver spec) diff --git a/src/System/Etc/Internal/Resolver/Env.hs b/src/System/Etc/Internal/Resolver/Env.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/Env.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.Env (resolveEnv, resolveEnvPure) where + +import Protolude +import System.Environment (getEnvironment) + +import Control.Arrow ((***)) +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text + +import qualified System.Etc.Internal.Spec.Types as Spec +import System.Etc.Internal.Types + +resolveEnvVarSource + :: (Text -> Maybe Text) + -> Spec.ConfigSources cmd + -> Maybe ConfigSource +resolveEnvVarSource lookupEnv specSources = + let + toEnvSource varname envValue = + envValue + & JSON.String + & Env varname + in do + varname <- Spec.envVar specSources + toEnvSource varname <$> lookupEnv varname + +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 _ sources -> + let + updateConfig = do + envSource <- resolveEnvVarSource lookupEnv sources + writeInSubConfig specKey (ConfigValue $ Set.singleton envSource) <$> mConfig + in + updateConfig <|> mConfig + + 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 +{-| + +Gathers all OS Environment Variable values (@env@ entries) from the @etc/spec@ +entries inside a @ConfigSpec@. This version of the function gathers the input +from a list of tuples rather than the OS. + +-} +resolveEnvPure + :: Spec.ConfigSpec cmd -- ^ ConfigSpec + -> [(Text, Text)] -- ^ Environment Variable tuples + -> Config -- ^ returns Configuration Map with Environment Variables values filled in +resolveEnvPure spec envMap0 = + let + envMap = + HashMap.fromList envMap0 + + lookupEnv key = + HashMap.lookup key envMap + in + maybe (Config emptySubConfig) + Config + (buildEnvVarResolver lookupEnv spec) + + +{-| + +Gathers all OS Environment Variable values (@env@ entries) from the @etc/spec@ +entries inside a @ConfigSpec@. + +-} +resolveEnv + :: Spec.ConfigSpec cmd -- ^ Config Spec + -> IO Config -- ^ returns Configuration Map with Environment Variables values filled in +resolveEnv spec = + let + getEnvironmentTxt = + map (Text.pack *** Text.pack) + <$> getEnvironment + in + resolveEnvPure spec + <$> getEnvironmentTxt diff --git a/src/System/Etc/Internal/Resolver/File.hs b/src/System/Etc/Internal/Resolver/File.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Resolver/File.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Resolver.File (resolveFiles) where + +import Protolude + +import Control.Monad.Catch (MonadThrow (..)) +import Data.Vector (Vector) +import System.Directory (doesFileExist) + + +#ifdef WITH_YAML +import qualified Data.Yaml as YAML +#endif + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Internal as JSON (IResult (..), iparse) +import qualified Data.ByteString.Lazy.Char8 as LB8 +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +import qualified System.Etc.Internal.Spec.Types as Spec +import System.Etc.Internal.Types hiding (filepath) + +-------------------------------------------------------------------------------- + +data ConfigFile + = JsonFile Text LB8.ByteString + | YamlFile Text LB8.ByteString + deriving (Show, Eq) + +-------------------------------------------------------------------------------- + +parseConfigValue + :: Monad m + => Int + -> Text + -> JSON.Value + -> m ConfigValue +parseConfigValue fileIndex filepath json = + case json of + JSON.Object object -> + SubConfig + <$> foldM + (\acc (key, subconfigValue) -> do + value1 <- parseConfigValue fileIndex filepath subconfigValue + return $ HashMap.insert key value1 acc) + HashMap.empty + (HashMap.toList object) + + _ -> + return $ + ConfigValue (Set.singleton $ File fileIndex filepath json) + + +eitherDecode :: ConfigFile -> Either [Char] JSON.Value +#ifdef WITH_YAML +eitherDecode contents0 = + case contents0 of + JsonFile _ contents -> + JSON.eitherDecode contents + YamlFile _ contents -> + YAML.decodeEither (LB8.toStrict contents) +#else +eitherDecode contents0 = + case contents0 of + JsonFile _ contents -> + JSON.eitherDecode contents + YamlFile filepath _ -> + Left ("Unsupported yaml file: " <> Text.unpack filepath) +#endif + + +parseConfig + :: MonadThrow m + => Int + -> Text + -> ConfigFile + -> m Config +parseConfig fileIndex filepath contents = + case eitherDecode contents of + Left err -> + throwM $ InvalidConfiguration (Text.pack err) + + Right json -> + case JSON.iparse (parseConfigValue fileIndex filepath) json of + JSON.IError _ err -> + throwM $ InvalidConfiguration (Text.pack err) + + JSON.ISuccess result -> + return (Config result) + +readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile) +readConfigFile filepath = + let + filepathStr = Text.unpack filepath + in do + fileExists <- doesFileExist filepathStr + if fileExists then do + contents <- LB8.readFile filepathStr + if ".json" `Text.isSuffixOf` filepath then + return $ return (JsonFile filepath contents) + else if (".yaml" `Text.isSuffixOf` filepath) || + (".yml" `Text.isSuffixOf` filepath) then + return $ return (YamlFile filepath contents) else + return (throwM $ InvalidConfiguration "Unsupported file extension") + else + return $ throwM $ ConfigurationFileNotFound filepath + +readConfigFromFiles :: [Text] -> IO (Config, [SomeException]) +readConfigFromFiles files = + files + & zip [1..] + & mapM (\(fileIndex, filepath) -> do + mContents <- readConfigFile filepath + return (mContents >>= parseConfig fileIndex filepath)) + & (foldl' (\(result, errs) eCurrent -> + case eCurrent of + Left err -> + (result, err:errs) + Right current -> + (result <> current, errs)) + (mempty, []) + <$>) + +{-| + +Gathers configuration values from a list of files specified on the +@etc/filepaths@ entry of a Config Spec. This will return a Configuration Map +with values from all filepaths merged in, and a list of errors in case there was +an error reading one of the filepaths. + +-} +resolveFiles + :: Spec.ConfigSpec cmd -- ^ Config Spec + -> IO (Config, Vector SomeException) -- ^ Configuration Map with all values from files filled in and a list of warnings +resolveFiles spec = do + (config, exceptions) <- readConfigFromFiles (Spec.specConfigFilepaths spec) + return (config, Vector.fromList exceptions) diff --git a/src/System/Etc/Internal/Spec/JSON.hs b/src/System/Etc/Internal/Spec/JSON.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Spec/JSON.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Spec.JSON where + +import Protolude + +import Control.Monad.Catch (MonadThrow (..)) + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.IO as Text (readFile) +import qualified Data.Text.Lazy as Text (fromStrict) +import qualified Data.Text.Lazy.Encoding as Text (encodeUtf8) + +import System.Etc.Internal.Spec.Types + +parseConfigSpec + :: (MonadThrow m, JSON.FromJSON cmd) + => Text + -> m (ConfigSpec cmd) +parseConfigSpec input = + case JSON.eitherDecode (Text.encodeUtf8 $ Text.fromStrict input) of + Left err -> + throwM $ InvalidConfiguration (Text.pack err) + + Right result -> + return result + +readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) +readConfigSpec filepath = do + contents <- Text.readFile (Text.unpack filepath) + parseConfigSpec contents diff --git a/src/System/Etc/Internal/Spec/Types.hs b/src/System/Etc/Internal/Spec/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Spec/Types.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Spec.Types where + +import Prelude (fail) +import Protolude + +import Data.Aeson ((.:), (.:?)) +import Data.HashMap.Strict (HashMap) +import Data.Vector (Vector) + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON (Parser, typeMismatch) +import qualified Data.HashMap.Strict as HashMap + +-------------------------------------------------------------------------------- +-- Error Types + +data ConfigurationError + = InvalidConfiguration Text + | InvalidConfigKeyPath [Text] + | ConfigurationFileNotFound Text + deriving (Show) + +instance Exception ConfigurationError + +-------------------------------------------------------------------------------- + +data CliOptValueType + = StringOpt + | NumberOpt + | SwitchOpt + deriving (Show, Eq) + +data CliArgValueType + = StringArg + | NumberArg + deriving (Show, Eq) + +data CliEntryMetadata + = Opt { + optLong :: Maybe Text + , optShort :: Maybe Text + , optMetavar :: Maybe Text + , optHelp :: Maybe Text + , optRequired :: Bool + , optValueType :: CliOptValueType + } + | Arg { + argMetavar :: Maybe Text + , optRequired :: Bool + , argValueType :: CliArgValueType + } + deriving (Show, Eq) + +data CliEntrySpec cmd + = CmdEntry { + cliEntryCmdValue :: Vector cmd + , cliEntryMetadata :: CliEntryMetadata + } + | PlainEntry { + cliEntryMetadata :: CliEntryMetadata + } + deriving (Show, Eq) + +data CliCmdSpec + = CliCmdSpec { + cliCmdDesc :: Text + , cliCmdHeader :: Text + } + deriving (Show, Eq) + +data ConfigSources cmd + = ConfigSources { + envVar :: Maybe Text + , cliEntry :: Maybe (CliEntrySpec cmd) + } + deriving (Show, Eq) + +data ConfigValue cmd + = ConfigValue { + defaultValue :: Maybe JSON.Value + , configSources :: ConfigSources cmd + } + | SubConfig { + subConfig :: HashMap Text (ConfigValue cmd) + } + deriving (Show, Eq) + +data CliProgramSpec + = CliProgramSpec { + cliProgramDesc :: Text + , cliProgramHeader :: Text + , cliCommands :: Maybe (HashMap Text CliCmdSpec) + } + deriving (Show, Eq) + +data ConfigSpec cmd + = ConfigSpec { + specConfigFilepaths :: [Text] + , specCliProgramSpec :: Maybe CliProgramSpec + , specConfigValues :: HashMap Text (ConfigValue cmd) + } + deriving (Show, Eq) + +-------------------------------------------------------------------------------- +-- JSON Parsers + +instance JSON.FromJSON CliCmdSpec where + parseJSON json = + case json of + JSON.Object object -> + CliCmdSpec + <$> object .: "desc" + <*> object .: "header" + _ -> + JSON.typeMismatch "CliCmdSpec" json + +instance JSON.FromJSON CliProgramSpec where + parseJSON json = + case json of + JSON.Object object -> + CliProgramSpec + <$> object .: "desc" + <*> object .: "header" + <*> object .:? "commands" + _ -> + JSON.typeMismatch "CliProgramSpec" json + +cliArgTypeParser + :: JSON.Object + -> JSON.Parser CliArgValueType +cliArgTypeParser object = do + value <- object .: "type" + case value of + JSON.String typeName + | typeName == "string" -> + return StringArg + | typeName == "number" -> + return NumberArg + | otherwise -> + JSON.typeMismatch "CliArgValueType (string, number)" value + _ -> + JSON.typeMismatch "CliArgValueType (string, number)" value + +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" + +cliOptParser + :: JSON.Object + -> JSON.Parser CliEntryMetadata +cliOptParser object = do + long <- object .:? "long" + short <- object .:? "short" + if isNothing long && isNothing short then + fail "'option' field input requires either 'long' or 'short' settings" + else + Opt + <$> pure long + <*> pure short + <*> (object .:? "metavar") + <*> (object .:? "help") + <*> (fromMaybe True <$> (object .:? "required")) + <*> cliOptTypeParser object + +cliArgKeys :: [Text] +cliArgKeys = ["input", "commands", "metavar", "required", "type"] + +cliOptKeys :: [Text] +cliOptKeys = ["short", "long", "help"] ++ cliArgKeys + +instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where + parseJSON json = + case json of + JSON.Object object -> do + cmdValue <- object .:? "commands" + value <- object .: "input" + + let + optParseEntryCtor = + maybe PlainEntry CmdEntry cmdValue + + case value of + JSON.String inputName + | inputName == "option" -> do + forM_ (HashMap.keys object) $ \key -> + when (not (key `elem` cliOptKeys)) + (fail $ "cli option contains invalid key " ++ show key) + + optParseEntryCtor <$> cliOptParser object + + | inputName == "argument" -> do + forM_ (HashMap.keys object) $ \key -> + when (not (key `elem` cliArgKeys)) + (fail $ "cli option contains invalid key " ++ show key) + + optParseEntryCtor <$> cliArgParser object + + | otherwise -> + JSON.typeMismatch "CliEntryMetadata (invalid input)" value + _ -> + JSON.typeMismatch "CliEntryMetadata (invalid input)" value + _ -> + JSON.typeMismatch "CliEntryMetadata" json + +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 + innerValue <- JSON.parseJSON value + return $ HashMap.insert key innerValue result) + HashMap.empty + (HashMap.toList object) + if HashMap.null result then + fail "Entries cannot have empty maps as values" + else + return (SubConfig result) + + -- etc spec value object + Just (JSON.Object spec) -> + if HashMap.size object == 1 then + ConfigValue + <$> spec .:? "default" + <*> (ConfigSources <$> (spec .:? "env") + <*> (spec .:? "cli")) + else + fail "etc/spec object can only contain one key" + + -- any other JSON value + Just _ -> + fail "etc/spec value must be a JSON object" + + _ -> + return $ + ConfigValue (Just json) (ConfigSources Nothing Nothing) + +instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where + parseJSON json = + case json of + JSON.Object object -> + ConfigSpec + <$> (fromMaybe [] <$> (object .:? "etc/filepaths")) + <*> (object .:? "etc/cli") + <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries")) + _ -> + JSON.typeMismatch "ConfigSpec" json diff --git a/src/System/Etc/Internal/Spec/YAML.hs b/src/System/Etc/Internal/Spec/YAML.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Spec/YAML.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Spec.YAML where + +import Protolude + +import Control.Monad.Catch (MonadThrow (..)) + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text (encodeUtf8) +import qualified Data.Text.IO as Text (readFile) +import qualified Data.Yaml as YAML + +import System.Etc.Internal.Spec.Types + +parseConfigSpec + :: (MonadThrow m, JSON.FromJSON cmd) + => Text + -> m (ConfigSpec cmd) +parseConfigSpec input = + case YAML.decodeEither (Text.encodeUtf8 input) of + Left err -> + throwM $ InvalidConfiguration (Text.pack err) + + Right result -> + return result + +readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) +readConfigSpec filepath = do + contents <- Text.readFile $ Text.unpack filepath + parseConfigSpec contents diff --git a/src/System/Etc/Internal/Types.hs b/src/System/Etc/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +module System.Etc.Internal.Types + ( module System.Etc.Internal.Types + , module System.Etc.Internal.Spec.Types + ) where + +import Protolude + +import qualified Data.Aeson as JSON +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set + +import System.Etc.Internal.Spec.Types (ConfigurationError (..)) + +-------------------- +-- Configuration Types + +data ConfigSource + = File { + configIndex :: Int + , filepath :: Text + , value :: JSON.Value + } + | Env { + envVar :: Text + , value :: JSON.Value + } + | Cli { + value :: JSON.Value + } + | Default { + value :: JSON.Value + } + | None + deriving (Show, Eq) + +instance Ord ConfigSource where + compare a b = + if a == b then + EQ + else + case (a, b) of + (None, _) -> + LT + + (_, None) -> + GT + + (Default {}, _) -> + LT + + (Cli {}, _) -> + GT + + (_, Cli {}) -> + LT + + (Env {}, _) -> + GT + + (_, Env {}) -> + LT + + (File {}, File {}) -> + comparing configIndex a b + + (File {}, _) -> + GT + +data ConfigValue + = ConfigValue { + configSource :: Set ConfigSource + } + | SubConfig { + configMap :: HashMap Text ConfigValue + } + deriving (Eq, Show) + +deepMerge :: ConfigValue -> ConfigValue -> ConfigValue +deepMerge left right = + case (left, right) of + (SubConfig leftm, SubConfig rightm) -> + SubConfig $ + HashMap.foldrWithKey + (\key rightv result -> + case HashMap.lookup key result of + Just leftv -> + HashMap.insert key (deepMerge leftv rightv) result + _ -> + HashMap.insert key rightv result) + leftm + rightm + (ConfigValue leftSources, ConfigValue rightSources) -> + ConfigValue $ Set.union leftSources rightSources + _ -> + right + +instance Semigroup ConfigValue where + (<>) = deepMerge + +newtype Config + = Config { fromConfig :: ConfigValue } + deriving (Eq, Show, Semigroup) + +instance Monoid Config where + mempty = Config $ SubConfig HashMap.empty + mappend (Config a) (Config b) = Config (a <> b) + +isEmptySubConfig :: ConfigValue -> Bool +isEmptySubConfig val = + case val of + SubConfig hsh -> + HashMap.null hsh + ConfigValue {} -> + False + +emptySubConfig :: ConfigValue +emptySubConfig = + SubConfig HashMap.empty + +writeInSubConfig :: Text -> ConfigValue -> ConfigValue -> ConfigValue +writeInSubConfig key val subConfig = + case subConfig of + SubConfig hsh -> + SubConfig + $ HashMap.insert key val hsh + _ -> + subConfig + +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe pfn mvalue = + case mvalue of + Just a + | pfn a -> + Nothing + | otherwise -> + mvalue + Nothing -> + Nothing diff --git a/src/System/Etc/Spec.hs b/src/System/Etc/Spec.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Spec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Spec ( + module Types + , parseConfigSpec + , readConfigSpec + ) where + +import Protolude hiding (catch) + +import System.Etc.Internal.Spec.Types as Types + (ConfigSpec, ConfigValue, ConfigurationError (..)) + +import Control.Monad.Catch (MonadCatch (..), MonadThrow (..)) + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.IO as Text (readFile) + +import qualified System.Etc.Internal.Spec.JSON as JSON +#ifdef WITH_YAML +import qualified System.Etc.Internal.Spec.YAML as YAML +#endif + +{-| + +Parses a text input into a @ConfigSpec@, input can be JSON or YAML (if cabal +flag is set). + +-} +parseConfigSpec + :: (MonadCatch m, MonadThrow m, JSON.FromJSON cmd) + => Text -- ^ Text to be parsed + -> m (ConfigSpec cmd) -- ^ returns ConfigSpec +#ifdef WITH_YAML +parseConfigSpec input = + catch (JSON.parseConfigSpec input) + (\(_ :: SomeException) -> YAML.parseConfigSpec input) +#else +parseConfigSpec = + JSON.parseConfigSpec +#endif + +{-| + +Reads contents of a file and parses into a @ConfigSpec@, file contents can be +either JSON or YAML (if cabal flag is set). + +-} +readConfigSpec + :: JSON.FromJSON cmd + => Text -- ^ Filepath where contents are going to be read from and parsed + -> IO (ConfigSpec cmd) -- ^ returns ConfigSpec +readConfigSpec filepath = do + contents <- Text.readFile $ Text.unpack filepath + parseConfigSpec contents diff --git a/test/System/Etc/Resolver/Cli/CommandTest.hs b/test/System/Etc/Resolver/Cli/CommandTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/Cli/CommandTest.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.Cli.CommandTest where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import qualified Data.Set as Set + +import System.Etc + +with_command_option_tests :: TestTree +with_command_option_tests = + testGroup "option input" + [ + testCase "entry accepts short" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + (cmd, config) <- resolveCommandCliPure spec "program" ["test", "-g", "hello cli"] + + assertEqual "invalid command output" "test" cmd + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Cli "hello cli") set) + + , testCase "entry accepts long" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + + (cmd, config) <- resolveCommandCliPure spec "program" ["test", "--greeting", "hello cli"] + + assertEqual "invalid command output" "test" cmd + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Cli "hello cli") set) + + , testCase "entry gets validated with a type" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"number\"" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + + case resolveCommandCliPure spec "program" ["test", "--greeting", "hello cli"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting type validation to work on cli; got " + <> show err) + + + Right _ -> + assertFailure "Expecting type validation to work on cli" + + , testCase "entry with required false does not barf" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"required\": false" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + (cmd, config) <- resolveCommandCliPure spec "program" ["test"] + + assertEqual "invalid command output" "test" cmd + + case getConfigValue ["greeting"] config of + Just set -> + assertFailure ("expecting to have no entry for greeting; got\n" + <> show set) + + (_ :: Maybe ()) -> + return () + + , testCase "entry with required fails when option not given" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"required\": true" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + case resolveCommandCliPure spec "program" ["test"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting required validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting required option to fail cli resolving" + ] + +with_command_argument_tests :: TestTree +with_command_argument_tests = + testGroup "argument input" + [ + testCase "entry gets validated with a type" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"number\"" + , " , \"metavar\": \"GREETING\"" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + + case resolveCommandCliPure spec "program" ["test", "hello cli"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting type validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting type validation to work on cli" + + , testCase "entry with required false does not barf" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": false" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + (cmd, config) <- resolveCommandCliPure spec "program" ["test"] + + assertEqual "invalid command output" "test" cmd + + case getConfigValue ["greeting"] config of + (Nothing :: Maybe ()) -> + return () + + Just set -> + assertFailure ("expecting to have no entry for greeting; got\n" + <> show set) + + , testCase "entry with required fails when argument not given" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": true" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + case resolveCommandCliPure spec "program" ["test"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting required validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting required argument to fail cli resolving" + + , testCase "supports same cli input on multiple arguments" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}" + , " , \"other\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": false" + , " , \"commands\": [\"test\", \"other\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + + (cmd1, config1) <- resolveCommandCliPure spec "program" ["test", "-g", "hello"] + (cmd2, config2) <- resolveCommandCliPure spec "program" ["other", "-g", "hello"] + + assertEqual "" "test" cmd1 + assertEqual "" "other" cmd2 + assertEqual "" config1 config2 + ] + + +with_command :: TestTree +with_command = + testGroup "when command given" + [ + with_command_option_tests + , with_command_argument_tests + ] + +without_command :: TestTree +without_command = + testCase "fails when command not given" $ do + let + input = + mconcat + [ + "{ \"etc/cli\": {" + , " \"desc\": \"\"" + , " , \"header\": \"\"" + , " , \"commands\": {" + , " \"test\": {\"header\": \"\", \"desc\": \"\"}}}" + , ", \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": true" + , " , \"commands\": [\"test\"]" + , "}}}}}" + ] + (spec :: ConfigSpec Text) <- parseConfigSpec input + case resolveCommandCliPure spec "program" [] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + 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/test/System/Etc/Resolver/Cli/PlainTest.hs b/test/System/Etc/Resolver/Cli/PlainTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/Cli/PlainTest.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.Cli.PlainTest where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) + +import qualified Data.Set as Set + +import System.Etc + +option_tests :: TestTree +option_tests = + testGroup "option input" + [ + testCase "entry accepts short" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + config <- resolvePlainCliPure spec "program" ["-g", "hello cli"] + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Cli "hello cli") set) + + , testCase "entry accepts long" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + config <- resolvePlainCliPure spec "program" ["--greeting", "hello cli"] + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Cli "hello cli") set) + + , testCase "entry gets validated with a type" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"number\"" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + case resolvePlainCliPure spec "program" ["--greeting", "hello cli"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting type validation to work on cli; got " + <> show err) + + + Right _ -> + assertFailure "Expecting type validation to work on cli" + + , testCase "entry with required false does not barf" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"required\": false" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + config <- resolvePlainCliPure spec "program" [] + + case getConfigValue ["greeting"] config of + Just set -> + assertFailure ("expecting to have no entry for greeting; got\n" + <> show set) + + (_ :: Maybe ()) -> + return () + + , testCase "entry with required fails when option not given" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"option\"" + , " , \"short\": \"g\"" + , " , \"long\": \"greeting\"" + , " , \"type\": \"string\"" + , " , \"required\": true" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + case resolvePlainCliPure spec "program" [] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting required validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting required option to fail cli resolving" + + ] + +argument_tests :: TestTree +argument_tests = + testGroup "argument input" + [ + testCase "entry gets validated with a type" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"number\"" + , " , \"metavar\": \"GREETING\"" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + case resolvePlainCliPure spec "program" ["hello cli"] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting type validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting type validation to work on cli" + + , testCase "entry with required false does not barf" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": false" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + config <- resolvePlainCliPure spec "program" [] + + case getConfigValue ["greeting"] config of + (Nothing :: Maybe ()) -> + return () + + Just set -> + assertFailure ("expecting to have no entry for greeting; got\n" + <> show set) + + , testCase "entry with required fails when argument not given" $ do + let + input = + mconcat + [ + "{ \"etc/entries\": {" + , " \"greeting\": {" + , " \"etc/spec\": {" + , " \"cli\": {" + , " \"input\": \"argument\"" + , " , \"type\": \"string\"" + , " , \"metavar\": \"GREETING\"" + , " , \"required\": true" + , "}}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + case resolvePlainCliPure spec "program" [] of + Left err -> + case fromException err of + Just CliEvalExited {} -> + return () + + _ -> + assertFailure ("Expecting required validation to work on cli; got " + <> show err) + + Right _ -> + assertFailure "Expecting required argument to fail cli resolving" + + + ] + +tests :: TestTree +tests = + testGroup "plain" + [ + option_tests + , argument_tests + ] diff --git a/test/System/Etc/Resolver/CliTest.hs b/test/System/Etc/Resolver/CliTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/CliTest.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.CliTest where + +import Test.Tasty (TestTree, testGroup) + +import qualified System.Etc.Resolver.Cli.CommandTest +import qualified System.Etc.Resolver.Cli.PlainTest + + +tests :: TestTree +tests = + testGroup "cli" + [ + System.Etc.Resolver.Cli.CommandTest.tests + , System.Etc.Resolver.Cli.PlainTest.tests + ] diff --git a/test/System/Etc/Resolver/DefaultTest.hs b/test/System/Etc/Resolver/DefaultTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/DefaultTest.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.DefaultTest (tests) where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) + + +import qualified Data.Set as Set + +import System.Etc + +tests :: TestTree +tests = + testGroup "default" + [ + testCase "default is used when defined on spec" $ do + let + input = + mconcat + [ + "{\"etc/entries\": {" + , " \"greeting\": { \"etc/spec\": { \"default\": \"hello default\" }}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let + config = + resolveDefault spec + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Default "hello default") set) + + , testCase "default can be raw JSON value on entries spec" $ do + let + input = + mconcat + [ + "{\"etc/entries\": {" + , " \"greeting\": \"hello default\"}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let + config = + resolveDefault spec + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Default "hello default") set) + + ] diff --git a/test/System/Etc/Resolver/EnvTest.hs b/test/System/Etc/Resolver/EnvTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/EnvTest.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.EnvTest where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + + +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Paths_etc (getDataFileName) + +import System.Etc + + +tests :: TestTree +tests = + testGroup "env" + [ + testCase "env entry is present when env var is defined" $ do + let + input = + mconcat + [ + "{\"etc/entries\": {" + , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let + config = + resolveEnvPure spec [("GREETING", "hello env")] + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting (check fixtures)\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from env; got " <> show set) + (Set.member (Env "GREETING" "hello env") set) + + , testCase "has precedence over default and file values" $ do + jsonFilepath <- getDataFileName "test/fixtures/config.json" + let + input = + mconcat + [ + "{\"etc/filepaths\": [" + , "\"" <> Text.pack jsonFilepath <> "\"" + , "]," + , " \"etc/entries\": {" + , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + (configFile, _) <- resolveFiles spec + + let + configEnv = + resolveEnvPure spec [("GREETING", "hello env")] + + config = + configEnv <> configFile + + case getConfigValue ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting (check fixtures)\n" + <> show config) + Just result -> + assertEqual ("expecting to see entry from env " <> show result) + ("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\" }}}}}" + ] + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let + config = + resolveEnvPure spec [] + + assertEqual "expecting to not have an entry for key" + (Nothing :: Maybe Text) + (getConfigValue ["nested"] config) + + assertEqual "expecting to not have an entry for key" + (Nothing :: Maybe Text) + (getConfigValue ["nested", "greeting"] config) + ] diff --git a/test/System/Etc/Resolver/FileTest.hs b/test/System/Etc/Resolver/FileTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Resolver/FileTest.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Resolver.FileTest (tests) where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +import Paths_etc (getDataFileName) + +import System.Etc + + +tests :: TestTree +tests = + testGroup "file" + [ + testCase "supports json, yaml and yml extensions" $ do + jsonFilepath <- getDataFileName "test/fixtures/config.json" +#ifdef WITH_YAML + yamlFilepath <- getDataFileName "test/fixtures/config.yaml" + ymlFilepath <- getDataFileName "test/fixtures/config.yml" +#endif + + let + input = + mconcat + [ + "{\"etc/filepaths\": [" + , "\"" <> Text.pack jsonFilepath <> "\"" +#ifdef WITH_YAML + , ", \"" <> Text.pack yamlFilepath <> "\"" + , ", \"" <> Text.pack ymlFilepath <> "\"" +#endif + , "]}" + ] + + (spec :: ConfigSpec ()) <- parseConfigSpec input + (config, _) <- resolveFiles spec + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting (check fixtures)\n" + <> show config) + Just set -> do + assertBool ("expecting to see entry from json config file " <> show set) + (Set.member (File 1 (Text.pack jsonFilepath) "hello json") set) + +#ifdef WITH_YAML + assertBool ("expecting to see entry from yaml config file " <> show set) + (Set.member (File 2 (Text.pack jsonFilepath) "hello yaml") set) + + assertBool ("expecting to see entry from yml config file " <> show set) + (Set.member (File 3 (Text.pack jsonFilepath) "hello yml") set) +#endif + + , testCase "does not support any other file extension" $ do + fooFilepath <- getDataFileName "test/fixtures/config.foo" + let + input = + mconcat + [ + "{\"etc/filepaths\": [" + , "\"" <> Text.pack fooFilepath <> "\"" + , "]}" + ] + + (spec :: ConfigSpec ()) <- parseConfigSpec input + (config, errs) <- resolveFiles spec + + assertEqual "config should be empty" mempty config + + if Vector.null errs then + assertFailure "expecting one error, got none" + else + let + err = Vector.head errs + in + case fromException err of + Just (InvalidConfiguration _) -> + return () + _ -> + assertFailure ("Expecting InvalidConfigurationError; got instead " + <> show err) + + + , testCase "does not fail if file doesn't exist" $ do + jsonFilepath <- getDataFileName "test/fixtures/config.json" + let + input = + mconcat + [ + "{\"etc/filepaths\": [" + , "\"" <> Text.pack jsonFilepath <> "\"" + , ", \"unknown_file.json\"" + , "]}" + ] + + (spec :: ConfigSpec ()) <- parseConfigSpec input + (config, errs) <- resolveFiles spec + + case getAllConfigSources ["greeting"] config of + Nothing -> + assertFailure ("expecting to get entries for greeting (check fixtures)\n" + <> show config) + Just set -> + assertBool ("expecting to see entry from json config file " <> show set) + (Set.member (File 1 (Text.pack jsonFilepath) "hello json") set) + + if Vector.null errs then + assertFailure "expecting one error, got none" + else + let + err = + Vector.head errs + in + case fromException err of + Just (ConfigurationFileNotFound _) -> + return () + _ -> + assertFailure ("Expecting ConfigurationFileNotFound; got instead " + <> show err) + ] diff --git a/test/System/Etc/SpecTest.hs b/test/System/Etc/SpecTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/SpecTest.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.SpecTest (tests) where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +import Data.HashMap.Strict (HashMap) + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap + +import System.Etc.Internal.Spec.Types +import System.Etc.Spec + +#ifdef WITH_YAML +import qualified Data.Yaml as YAML +import Paths_etc (getDataFileName) +#endif + + +getConfigValue :: [Text] -> HashMap Text (ConfigValue cmd) -> Maybe (ConfigValue cmd) +getConfigValue keys hsh = + case keys of + [] -> + Nothing + (k:ks) -> do + cv <- HashMap.lookup k hsh + case cv of + SubConfig hsh1 -> + getConfigValue ks hsh1 + value -> + if null ks then + Just value + else + Nothing + + +general_tests :: TestTree +general_tests = + testGroup "general" + [ + testCase "does not fail when etc/entries is not defined" $ do + let + input = "{}" + + case parseConfigSpec input of + Left _ -> + assertFailure "should not fail if no etc/entries key is present" + Right (_ :: ConfigSpec ()) -> + assertBool "" True + + , testCase "entries cannot finish in an empty map" $ do + let + input = "{\"etc/entries\":{\"greeting\":{}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "entries should not accept empty maps as values " ++ show result + Left _ -> + assertBool "" True + + , testCase "entries cannot finish in an array" $ do + let + input = "{\"etc/entries\":{\"greeting\":[]}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "entries should not accept arrays as values " ++ show result + Left _ -> + assertBool "" True + + , testCase "entries that finish with raw values 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.Number 123)) + (defaultValue value) + + , testCase "entries can have many levels of nesting" $ do + let + input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}" + keys = ["english", "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.String "hello")) + (defaultValue value) + + , testCase "spec map cannot be empty object" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not be an empty object " ++ show result + Left _ -> + assertBool "" True + + , testCase "spec map cannot be a JSON array" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":[]}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not be an array " ++ show result + Left _ -> + assertBool "" True + + , testCase "spec map cannot be a JSON bool" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":true}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not be a boolean " ++ show result + Left _ -> + assertBool "" True + + , testCase "spec map cannot be a JSON string" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":\"hello\"}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not be a string " ++ show result + Left _ -> + assertBool "" True + + , testCase "spec map cannot be a JSON number" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":123}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not be a number " ++ show result + Left _ -> + assertBool "" True + + , testCase "spec map cannot have any other key that is not etc/spec" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":\"hello\"},\"foobar\":123}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "etc/spec map should not contain more than one key " ++ show result + Left _ -> + assertBool "" True + ] + +cli_tests :: TestTree +cli_tests = + testGroup "cli" + [ + testCase "cli entry settings requires an input" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{}}}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "cli entry should require a type " ++ show result + Left _ -> + assertBool "" True + + , testCase "cli option entry requires either short or long" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\"}}}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "cli entry should require a type " ++ show result + Left _ -> + assertBool "" True + + , 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\"}}}}}" + keys = ["greeting"] + + (config :: ConfigSpec ()) <- parseConfigSpec input + + let + result = do + value <- getConfigValue keys (specConfigValues config) + PlainEntry metadata <- cliEntry (configSources value) + short <- optShort metadata + valueType <- pure $ optValueType metadata + return (short, valueType) + + case result of + Nothing -> + 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 + + , 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\"}}}}}" + keys = ["greeting"] + + (config :: ConfigSpec ()) <- parseConfigSpec input + + let + result = do + value <- getConfigValue keys (specConfigValues config) + PlainEntry metadata <- cliEntry (configSources value) + long <- optLong metadata + valueType <- pure $ optValueType metadata + return (long, valueType) + + case result of + Nothing -> + 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 + + , testCase "cli entry accepts command" $ do + let + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\",\"commands\":[\"foo\"]}}}}}" + keys = ["greeting"] + + (config :: ConfigSpec Text) <- parseConfigSpec input + + let + result = do + value <- getConfigValue keys (specConfigValues config) + CmdEntry cmd metadata <- cliEntry (configSources value) + long <- optLong metadata + valueType <- pure $ optValueType metadata + return (cmd, long, valueType) + + case result of + Nothing -> + assertFailure (show config) + Just (cmd, long, valueType) -> do + assertEqual "should contain cmd" ["foo"] cmd + assertEqual "should contain long" "greeting" long + assertEqual "should contain option type" StringOpt valueType + + , testCase "cli entry does not accept unrecognized keys" $ do + let + -- error is a typo on key command (instead of command_s_) + input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\",\"command\":[\"foo\"]}}}}}" + + case parseConfigSpec input of + Right (result :: ConfigSpec ()) -> + assertFailure $ "cli entry should fail on invalid entry " ++ show result + Left _ -> + assertBool "" True + + ] + +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"] + + (config :: ConfigSpec ()) <- 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" + (ConfigSources (Just "GREETING") Nothing) + (configSources value) + ] + +#ifdef WITH_YAML +yaml_tests :: TestTree +yaml_tests = + testGroup "yaml parser" + [ + testCase "should work with Aeson instances" $ do + let + keys = ["greeting"] + path <- getDataFileName "test/fixtures/config.spec.yaml" + mconfig <- YAML.decodeFile path + + case mconfig of + Nothing -> + assertFailure "yaml file did not have a configuration spec" + + Just (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 -> + assertEqual "should contain EnvVar value" + (ConfigSources (Just "GREETING") Nothing) + (configSources value) + ] +#endif + +tests :: TestTree +tests = + testGroup "spec" + [ + general_tests +#ifdef WITH_YAML + , yaml_tests +#endif + , envvar_tests + , cli_tests + ] diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Protolude + +import Test.Tasty (defaultMainWithIngredients, testGroup) +import Test.Tasty.Ingredients.Rerun (rerunningTests) +import Test.Tasty.Runners (consoleTestReporter, listingTests) + +import qualified System.Etc.Resolver.DefaultTest +import qualified System.Etc.Resolver.EnvTest +import qualified System.Etc.Resolver.FileTest +import qualified System.Etc.SpecTest + +#ifdef WITH_CLI +import qualified System.Etc.Resolver.CliTest +#endif + +main :: IO () +main = + defaultMainWithIngredients + [ rerunningTests [listingTests, consoleTestReporter] ] + (testGroup "etc" [ System.Etc.SpecTest.tests + , System.Etc.Resolver.DefaultTest.tests + , System.Etc.Resolver.FileTest.tests + , System.Etc.Resolver.EnvTest.tests +#ifdef WITH_CLI + , System.Etc.Resolver.CliTest.tests +#endif + ]) diff --git a/test/fixtures/config.foo b/test/fixtures/config.foo new file mode 100644 --- /dev/null +++ b/test/fixtures/config.foo @@ -0,0 +1,1 @@ +{ "greeting": "hello foo" } diff --git a/test/fixtures/config.json b/test/fixtures/config.json new file mode 100644 --- /dev/null +++ b/test/fixtures/config.json @@ -0,0 +1,3 @@ +{ + "greeting": "hello json" +} diff --git a/test/fixtures/config.spec.yaml b/test/fixtures/config.spec.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/config.spec.yaml @@ -0,0 +1,4 @@ +etc/entries: + greeting: + etc/spec: + env: "GREETING" diff --git a/test/fixtures/config.yaml b/test/fixtures/config.yaml new file mode 100644 --- /dev/null +++ b/test/fixtures/config.yaml @@ -0,0 +1,1 @@ +greeting: "hello yaml" diff --git a/test/fixtures/config.yml b/test/fixtures/config.yml new file mode 100644 --- /dev/null +++ b/test/fixtures/config.yml @@ -0,0 +1,1 @@ +greeting: "hello yml"