etc 0.2.0.0 → 0.3.0.0

raw patch · 29 files changed

+1628/−2156 lines, 29 filesdep +riodep +typed-processdep +unliftiodep −bytestringdep −containersdep −directorydep ~aesondep ~ansi-wl-pprintdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: rio, typed-process, unliftio

Dependencies removed: bytestring, containers, directory, exceptions, protolude, tasty-rerun, unordered-containers, vector

Dependency ranges changed: aeson, ansi-wl-pprint, base, edit-distance, hashable, optparse-applicative, tasty, tasty-hunit, text, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• etc.cabal +118/−129
• src/System/Etc.hs +5/−3
• src/System/Etc/Internal/Config.hs +60/−109
• src/System/Etc/Internal/Extra/EnvMisspell.hs +36/−45
• src/System/Etc/Internal/Extra/Printer.hs +73/−100
• src/System/Etc/Internal/Resolver/Cli.hs +1/−1
• src/System/Etc/Internal/Resolver/Cli/Command.hs +124/−186
• src/System/Etc/Internal/Resolver/Cli/Common.hs +75/−131
• src/System/Etc/Internal/Resolver/Cli/Plain.hs +75/−128
• src/System/Etc/Internal/Resolver/Default.hs +25/−41
• src/System/Etc/Internal/Resolver/Env.hs +38/−68
• src/System/Etc/Internal/Resolver/File.hs +83/−84
• src/System/Etc/Internal/Spec/JSON.hs +10/−19
• src/System/Etc/Internal/Spec/Types.hs +68/−79
• src/System/Etc/Internal/Spec/YAML.hs +8/−15
• src/System/Etc/Internal/Types.hs +79/−59
• src/System/Etc/Spec.hs +12/−16
• test/System/Etc/ConfigTest.hs +30/−0
• test/System/Etc/Extra/EnvMisspellTest.hs +9/−17
• test/System/Etc/Resolver/Cli/CommandTest.hs +248/−328
• test/System/Etc/Resolver/Cli/PlainTest.hs +149/−218
• test/System/Etc/Resolver/CliTest.hs +3/−6
• test/System/Etc/Resolver/DefaultTest.hs +29/−64
• test/System/Etc/Resolver/EnvTest.hs +47/−71
• test/System/Etc/Resolver/FileTest.hs +96/−87
• test/System/Etc/SpecTest.hs +94/−140
• test/TestSuite.hs +15/−12
• test/fixtures/config.null.json +3/−0

@@ -1,3 +1,18 @@+0.3.0.0+----+**BREAKING CHANGES**++* Bump resolver to lts-11+* Replace `protolude` in favor of `rio`+* Update `parseConfigSpec` to no longer attempt to parse JSON when `yaml` cabal+   flag is set+* Add `sensitive` setting to `etc/spec` entries+* Add `Value` type to deal with sensitive values+* Update examples with `sensitive` values+* Add optional key context to the `InvalidConfiguration` error (issue #12)+* Add config printer function that renders config map with/without colors (issue #15)+* Give precedence to values that do not contain inner `JSON.Null` values (issue #16)+ 0.2.0.0 ---- * Move `Config` API to typeclass `IConfig`

@@ -1,150 +1,139 @@--- This file has been generated from package.yaml by hpack version 0.17.0.------ see: https://github.com/sol/hpack--name:           etc-version:        0.2.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-tested-with:    GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2-license:        MIT-license-file:   LICENSE-build-type:     Simple-cabal-version:  >= 1.10+name: etc+version: 0.3.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: 2017, 2018 Roman Gonzalez+maintainer: open-source@roman-gonzalez.info+homepage: https://github.com/roman/Haskell-etc+synopsis: Declarative configuration spec for Haskell projects+description:+    `etc` gathers configuration values from multiple sources (cli options, OS+    environment variables, files) using a declarative spec file that defines where+    these values are to be found and located in a configuration map.+category: Configuration, System+author: Roman Gonzalez+tested-with: GHC ==8.0.1 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.2 data-files:     test/fixtures/config.foo     test/fixtures/config.json+    test/fixtures/config.null.json     test/fixtures/config.spec.yaml     test/fixtures/config.yaml     test/fixtures/config.yml extra-source-files:-  README.md-  CHANGELOG.md+    README.md+    CHANGELOG.md  source-repository head-  type: git-  location: https://github.com/roman/Haskell-etc+    type: git+    location: https://github.com/roman/Haskell-etc  flag extra-  description: Include extra utilities-  manual: False-  default: False+    description:+        Include extra utilities+    default: False  flag cli-  description: Include support for cli arguments-  manual: False-  default: False+    description:+        Include support for cli arguments+    default: False  flag yaml-  description: Include support to parse YAML files-  manual: False-  default: False+    description:+        Include support to parse YAML files+    default: False  library-  hs-source-dirs: src-  ghc-options: -Wall-  build-depends:-      base >=4.7 && <5-    , aeson >=0.11 && <1.3-    , 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.2 && <1.4-    , exceptions >=0.8 && <0.9-    , hashable >=1.2 && <1.3-    , vector >=0.11 && <0.13---  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(extra)-    cpp-options: -DWITH_EXTRA-    build-depends:-      ansi-wl-pprint >=0.6 && <0.7,-      edit-distance >=0.2 && <0.3--    exposed-modules:-      System.Etc.Internal.Extra.Printer-      System.Etc.Internal.Extra.EnvMisspell--  if flag(cli)-    cpp-options: -DWITH_CLI-    build-depends:-      optparse-applicative >=0.12 && <0.14+    +    if flag(extra)+        exposed-modules:+            System.Etc.Internal.Extra.Printer+            System.Etc.Internal.Extra.EnvMisspell+        build-depends:+            ansi-wl-pprint >=0.6,+            edit-distance >=0.2+        cpp-options: -DWITH_EXTRA+    +    if flag(cli)+        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+        build-depends:+            optparse-applicative >=0.12+        cpp-options: -DWITH_CLI+    +    if flag(yaml)+        exposed-modules:+            System.Etc.Internal.Spec.YAML+        build-depends:+            yaml >=0.8+        cpp-options: -DWITH_YAML     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+        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     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 >=0.11 && <1.3-    , 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.13-    , tasty >=0.11 && <0.12-    , tasty-hunit >=0.9 && <0.10-    , tasty-rerun >=1.1 && <1.2-    , etc+        base >=4.7 && <5,+        aeson >=0.11,+        hashable >=1.2,+        rio >=0.0.1.0,+        text >=0.0.1.0,+        typed-process >=0.1.1,+        unliftio >=0.1.1.0+    default-language: Haskell2010+    hs-source-dirs: src+    other-modules:+        Paths_etc+    ghc-options: -Wall -  if flag(cli)-    cpp-options: -DWITH_CLI-    build-depends:-      optparse-applicative >=0.12 && <0.14-  if flag(yaml)-    cpp-options: -DWITH_YAML-    build-depends:-      yaml >=0.8 && <0.9-  if flag(extra)-    cpp-options: -DWITH_EXTRA+test-suite  etc-testsuite+    +    if flag(cli)+        build-depends:+            optparse-applicative >=0.12+        cpp-options: -DWITH_CLI+        other-modules:+            System.Etc.Resolver.CliTest+            System.Etc.Resolver.Cli.PlainTest+            System.Etc.Resolver.Cli.CommandTest+    +    if flag(yaml)+        build-depends:+            yaml >=0.8+        cpp-options: -DWITH_YAML+    +    if flag(extra)+        build-depends:+            edit-distance >=0.2+        cpp-options: -DWITH_EXTRA+        other-modules:+            System.Etc.Extra.EnvMisspellTest+    type: exitcode-stdio-1.0+    main-is: TestSuite.hs     build-depends:-      edit-distance >=0.2 && <0.3-  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.Extra.EnvMisspellTest-      System.Etc.SpecTest-  default-language: Haskell2010+        base >=4.7,+        aeson >=0.11,+        rio >=0.0.1.0,+        tasty >=0.11,+        tasty-hunit >=0.9,+        etc -any+    default-language: Haskell2010+    hs-source-dirs: test+    other-modules:+        Paths_etc+        System.Etc.Resolver.DefaultTest+        System.Etc.Resolver.EnvTest+        System.Etc.Resolver.FileTest+        System.Etc.SpecTest+        System.Etc.ConfigTest+    ghc-options: -Wall

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} + {-|  -}@@ -11,6 +11,7 @@   -- $config     Config   , IConfig+  , Value(..)   , getConfigValue   , getConfigValueWith   , getSelectedConfigSource@@ -48,6 +49,7 @@   -- * Extra utilities   -- $extra   , renderConfig+  , renderConfigColor   , printPrettyConfig   , hPrintPrettyConfig @@ -62,7 +64,7 @@  import System.Etc.Internal.Resolver.Default (resolveDefault) import System.Etc.Internal.Types-    (Config, ConfigSource (..), ConfigValue, IConfig (..))+    (Config, ConfigSource (..), ConfigValue, IConfig (..), Value (..)) import System.Etc.Spec     (ConfigSpec, ConfigurationError (..), parseConfigSpec, readConfigSpec) @@ -82,7 +84,7 @@     , reportEnvMisspellingWarnings     ) import System.Etc.Internal.Extra.Printer-    (hPrintPrettyConfig, printPrettyConfig, renderConfig)+    (hPrintPrettyConfig, printPrettyConfig, renderConfig, renderConfigColor) #endif  import System.Etc.Internal.Config ()

@@ -4,153 +4,104 @@ {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Config where -import Protolude--import Control.Monad.Catch (MonadThrow (..))+import           RIO+import qualified RIO.HashMap as HashMap+import qualified RIO.Set     as Set+import qualified RIO.Text    as Text  import qualified Data.Aeson          as JSON import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse) import qualified Data.Aeson.Types    as JSON (Parser)-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+configValueToJsonObject configValue = case configValue of+  ConfigValue sources -> case Set.maxView sources of+    Nothing          -> error "this should not happen" -        Just (source, _) ->-          value source+    Just (source, _) -> fromValue $ value source -    SubConfig configm ->-      configm+  SubConfig configm ->+    configm       & HashMap.foldrWithKey           (\key innerConfigValue acc ->-              HashMap.insert key (configValueToJsonObject innerConfigValue) acc)+            HashMap.insert key (configValueToJsonObject innerConfigValue) acc+          )           HashMap.empty       & JSON.Object  _getConfigValueWith-  :: MonadThrow m-  => (JSON.Value -> JSON.Parser result)-  -> [Text]-  -> Config-  -> m result+  :: MonadThrow m => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result _getConfigValueWith parser keys0 (Config configValue0) =   let-    loop keys configValue =-      case (keys, configValue) of-        ([], ConfigValue sources) ->-          case Set.maxView sources of-            Nothing ->-              throwM $ InvalidConfigKeyPath keys0+    loop keys configValue = case (keys, configValue) of+      ([], ConfigValue sources) -> case Set.maxView sources of+        Nothing          -> throwM $ InvalidConfigKeyPath keys0 -            Just (None, _) ->-              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+        Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of -                JSON.ISuccess result ->-                  return result+          JSON.IError path err ->+            let key = keys0 & reverse & Text.intercalate "."+            in  JSON.formatError path err+                & Text.pack+                & InvalidConfiguration (Just key)+                & throwM -        ([], 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 -            JSON.ISuccess result ->-              return result+      ([], innerConfigValue) ->+        case JSON.iparse parser (configValueToJsonObject innerConfigValue) of+          JSON.IError path err ->+            let key = keys0 & reverse & Text.intercalate "."+            in  JSON.formatError path err+                & Text.pack+                & InvalidConfiguration (Just key)+                & throwM -        (k:keys1, SubConfig configm) ->-          case HashMap.lookup k configm of-            Nothing ->-              throwM $ InvalidConfigKeyPath keys0-            Just configValue1 ->-              loop keys1 configValue1+          JSON.ISuccess result -> return result -        _ ->-          throwM $ InvalidConfigKeyPath keys0-  in-    loop keys0 configValue0+      (k : keys1, SubConfig configm) -> case HashMap.lookup k configm of+        Nothing           -> throwM $ InvalidConfigKeyPath keys0+        Just configValue1 -> loop keys1 configValue1 -_getSelectedConfigSource-  :: (MonadThrow m)-  => [Text]-  -> Config-  -> m ConfigSource+      _ -> 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+  let loop keys configValue = case (keys, configValue) of+        ([], ConfigValue sources) -> case Set.maxView sources of+          Nothing          -> throwM $ InvalidConfigKeyPath keys0 -            Just (source, _) ->-              return source+          Just (source, _) -> return source -        (k:keys1, SubConfig configm) ->-          case HashMap.lookup k configm of-            Nothing ->-              throwM $ InvalidConfigKeyPath keys0-            Just configValue1 ->-              loop keys1 configValue1+        (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+        _ -> throwM $ InvalidConfigKeyPath keys0+  in  loop keys0 configValue0  -_getAllConfigSources-  :: (MonadThrow m)-  => [Text]-  -> Config-  -> m (Set ConfigSource)+_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set ConfigSource) _getAllConfigSources keys0 (Config configValue0) =-  let-    loop keys configValue =-      case (keys, configValue) of-        ([], ConfigValue sources) ->-          return sources+  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+        (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+        _ -> throwM $ InvalidConfigKeyPath keys0+  in  loop keys0 configValue0 -_getConfigValue-  :: (MonadThrow m, JSON.FromJSON result)-  => [Text]-  -> Config-  -> m result-_getConfigValue =-  _getConfigValueWith JSON.parseJSON+_getConfigValue :: (MonadThrow m, JSON.FromJSON result) => [Text] -> Config -> m result+_getConfigValue = _getConfigValueWith JSON.parseJSON   instance IConfig Config where

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Extra.EnvMisspell (@@ -10,15 +11,14 @@   , reportEnvMisspellingWarnings   ) where -import Protolude hiding ((<$>), (<>))+import           RIO         hiding ((<$>), (<>))+import qualified RIO.HashMap as HashMap+import qualified RIO.Text    as Text+import qualified RIO.Vector  as Vector -import Data.Vector        (Vector) import System.Environment (getEnvironment) -import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text           as Text-import qualified Data.Vector         as Vector-import qualified Text.EditDistance   as Distance+import qualified Text.EditDistance as Distance  import System.Etc.Internal.Spec.Types import Text.PrettyPrint.ANSI.Leijen@@ -32,74 +32,65 @@  lookupSpecEnvKeys :: ConfigSpec a -> Vector Text lookupSpecEnvKeys spec =-  let-    foldEnvSettings val acc =-      case val of-        ConfigValue _ sources ->+  let foldEnvSettings val acc = case val of+        ConfigValue _defVal _sensitive sources ->           maybe acc (`Vector.cons` acc) (envVar sources)-        SubConfig hsh ->-          HashMap.foldr foldEnvSettings acc hsh-  in-    foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty+        SubConfig hsh -> HashMap.foldr foldEnvSettings acc hsh+  in  foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty  {-|  -} getEnvMisspellingsPure :: ConfigSpec a -> Vector Text -> Vector EnvMisspell getEnvMisspellingsPure spec env = do-   specEnvName  <- lookupSpecEnvKeys spec-   currentEnvName <- env+  specEnvName    <- lookupSpecEnvKeys spec+  currentEnvName <- env -   let-     distance =-       Distance.levenshteinDistance-           Distance.defaultEditCosts-           (Text.unpack specEnvName)-           (Text.unpack currentEnvName)+  let distance = Distance.levenshteinDistance Distance.defaultEditCosts+                                              (Text.unpack specEnvName)+                                              (Text.unpack currentEnvName) -   guard (distance >= 1 && distance < 4)-   return $ EnvMisspell currentEnvName specEnvName+  guard (distance >= 1 && distance < 4)+  return $ EnvMisspell currentEnvName specEnvName  {-|  -} getEnvMisspellings :: ConfigSpec a -> IO (Vector EnvMisspell) getEnvMisspellings spec =-  getEnvironment-  & fmap (Vector.fromList . map (Text.pack . fst))-  & fmap (getEnvMisspellingsPure spec)+  getEnvironment & fmap (Vector.fromList . map (Text.pack . fst)) & fmap+    (getEnvMisspellingsPure spec)  {-|  -} renderEnvMisspellings :: Vector EnvMisspell -> Doc renderEnvMisspellings misspells-  | Vector.null misspells =-      mempty-  | otherwise =-      misspells-      & Vector.map-            (\misspell ->-                text "WARNING: Environment variable `"-                <> text (Text.unpack $ currentText misspell)-                <> text "' found, perhaps you meant `"-                <> text (Text.unpack $ suggestionText misspell)-                <> text "'")-      & Vector.foldl' (<$>) mempty-      & (<$> mempty)-      & (<$> mempty)+  | Vector.null misspells+  = mempty+  | otherwise+  = misspells+    & Vector.map+        (\misspell ->+          text "WARNING: Environment variable `"+            <> text (Text.unpack $ currentText misspell)+            <> text "' found, perhaps you meant `"+            <> text (Text.unpack $ suggestionText misspell)+            <> text "'"+        )+    & Vector.foldl' (<$>) mempty+    & (<$> mempty)+    & (<$> mempty)  {-|  -} hPrintEnvMisspellings :: Handle -> Vector EnvMisspell -> IO ()-hPrintEnvMisspellings h =-  hPutDoc h . renderEnvMisspellings+hPrintEnvMisspellings h = hPutDoc h . renderEnvMisspellings  {-|  -} reportEnvMisspellingWarnings :: ConfigSpec a -> IO () reportEnvMisspellingWarnings spec =-  getEnvMisspellings spec >>=-  hPrintEnvMisspellings stderr+  getEnvMisspellings spec >>= hPrintEnvMisspellings stderr

@@ -1,147 +1,120 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Extra.Printer (     renderConfig+  , renderConfigColor   , printPrettyConfig   , hPrintPrettyConfig   ) where -import Protolude hiding ((<>))+import           RIO         hiding ((<>))+import qualified RIO.HashMap as HashMap+import           RIO.List    (intersperse, maximum)+import qualified RIO.Set     as Set+import qualified RIO.Text    as Text -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 Data.Aeson as JSON  import Text.PrettyPrint.ANSI.Leijen  import System.Etc.Internal.Types -renderJsonValue :: JSON.Value -> (Doc, Int)-renderJsonValue value' =-  case value' of-    JSON.Null ->-      (text "null", 4)+renderJsonValue :: Text -> Value JSON.Value -> (Doc, Int)+renderJsonValue key value' = case value' of+  Plain JSON.Null         -> (text "null", 4) -    JSON.String str ->-      (text $ Text.unpack str, Text.length str)+  Plain (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+  Plain (JSON.Number scientific) ->+    let number = show scientific in (text number, length number)+  Plain     (JSON.Bool bool') -> if bool' then (text "true", 5) else (text "false", 5)+  Sensitive _                 -> (text "<<sensitive>>", 13)+  _ ->+    value'+      & tshow       & ("Invalid configuration value creation " `mappend`)-      & InvalidConfiguration+      & InvalidConfiguration (Just key)       & show       & error +data ColorFn+  = ColorFn {+    greenColor :: !(Doc -> Doc)+  , blueColor  :: !(Doc -> Doc)+  } -renderConfig :: Config -> Doc-renderConfig (Config configValue0) =+renderConfig' :: ColorFn -> Config -> Doc+renderConfig' ColorFn { greenColor, blueColor } (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"))-          )+    renderSource :: Text -> ConfigSource -> ((Doc, Int), Doc)+    renderSource key source' = case source' of+      Default value' -> (renderJsonValue key value', brackets' (fill 10 (text "Default"))) -        File _index filepath' value' ->-          ( renderJsonValue value'-          , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))-          )+      File _index filepath' value' ->+        ( renderJsonValue key value'+        , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))+        ) -        Env varname value' ->-          ( renderJsonValue value'-          , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname)))-          )+      Env varname value' ->+        ( renderJsonValue key value'+        , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname)))+        ) -        Cli value' ->-          ( renderJsonValue value'-          , brackets' (fill 10 (text "Cli"))-          )+      Cli value' -> (renderJsonValue key value', brackets' (fill 10 (text "Cli"))) -        None ->-          ( (mempty, 0)-          , mempty-          )+      None       -> ((mempty, 0), mempty) -    renderSources :: [ConfigSource] -> Doc-    renderSources sources0 =+    renderSources :: Text -> [ConfigSource] -> Doc+    renderSources keys sources0 =       let-        sources@(((selValueDoc, _), selSourceDoc):others) =-          map renderSource sources0+        sources@(((selValueDoc, _), selSourceDoc) : others) =+          map (renderSource keys) sources0 -        fillingWidth =-          sources-          & map (snd . fst)-          & maximum-          & max 10+        fillingWidth  = sources & map (snd . fst) & maximum & max 10 -        selectedValue =-          [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ]+        selectedValue = [greenColor $ fill fillingWidth selValueDoc <+> selSourceDoc] -        otherValues =-          map (\((valueDoc, _), sourceDoc) ->-                  fill fillingWidth valueDoc <+> sourceDoc)-              others+        otherValues   = map+          (\((valueDoc, _), sourceDoc) -> fill fillingWidth valueDoc <+> sourceDoc)+          others       in-        selectedValue-        & flip mappend otherValues-        & vcat-        & indent 2+        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+    loop keys configValue = case configValue of+      SubConfig subConfigm ->+        HashMap.foldlWithKey' (configEntryRenderer keys) mempty subConfigm -        ConfigValue sources0 ->-          let-            configKey =-              keys-              & reverse-              & Text.intercalate "."+      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 ]+          sources   = Set.toDescList sources0+        in+          if null sources+          then+            []+          else+            [blueColor (text (Text.unpack configKey)) <$$> renderSources configKey sources]   in-    loop [] configValue0-    & intersperse (linebreak <> linebreak)-    & hcat-    & (<> linebreak)+    loop [] configValue0 & intersperse (linebreak <> linebreak) & hcat & (<> linebreak) ++renderConfigColor :: Config -> Doc+renderConfigColor = renderConfig' ColorFn {greenColor = green, blueColor = blue}++renderConfig :: Config -> Doc+renderConfig = renderConfig' ColorFn {greenColor = id, blueColor = id}+ printPrettyConfig :: Config -> IO ()-printPrettyConfig =-  putDoc . renderConfig+printPrettyConfig = putDoc . renderConfig  hPrintPrettyConfig :: Handle -> Config -> IO ()-hPrintPrettyConfig handle' =-  hPutDoc handle' . renderConfig+hPrintPrettyConfig handle' = hPutDoc handle' . renderConfig

@@ -1,5 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+ module System.Etc.Internal.Resolver.Cli   ( PlainConfigSpec   -- , resolveCommandCli

@@ -3,17 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure) where -import Protolude+import           RIO+import qualified RIO.HashMap as HashMap+import qualified RIO.Text    as Text -import Control.Monad.Catch (MonadThrow, throwM)-import Data.Hashable       (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.Vector         (Vector)-import System.Environment  (getProgName)+import Data.Hashable      (Hashable)+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@@ -25,194 +22,148 @@  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-             )+  => Bool+  -> Spec.CliEntrySpec cmd+  -> m (Vector cmd, Opt.Parser (Maybe (Value JSON.Value)))+entrySpecToJsonCli sensitive entrySpec = case entrySpec of+  Spec.CmdEntry commandJsonValue specSettings ->+    return (commandJsonValue, settingsToJsonCli sensitive specSettings) -    Spec.PlainEntry {} ->-      throwM CommandKeyMissing+  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+  => HashMap cmd (Opt.Parser ConfigValue)+  -> Text+  -> Bool+  -> Spec.ConfigSources cmd+  -> m (HashMap cmd (Opt.Parser ConfigValue))+configValueSpecToCli acc0 specEntryKey sensitive 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+            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+        Just entrySpec -> do+          (commands, jsonOptParser) <- entrySpecToJsonCli sensitive entrySpec -        let-          configValueParser =-            jsonToConfigValue <$> jsonOptParser+          let configValueParser = jsonToConfigValue <$> jsonOptParser -        foldM (\acc command ->-                 acc-                   & HashMap.alter-                        (\mAccParser ->-                          mAccParser-                            & fromMaybe (pure mempty)-                            & updateAccConfigOptParser configValueParser-                            & Just)-                        command-                   & return)-              acc0-              commands+          foldM+            (\acc command ->+              acc+                & HashMap.alter+                    (\mAccParser ->+                      mAccParser+                        & fromMaybe (pure mempty)+                        & 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))+  => 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+  let updateAccConfigOptParser subConfigParser accOptParser =+        (\subConfig accSubConfig -> case accSubConfig of+            ConfigValue{} -> accSubConfig              SubConfig subConfigMap ->-              subConfigMap-                & HashMap.alter (const $ Just subConfig) specEntryKey-                & SubConfig)-        <$> subConfigParser-        <*> accOptParser+              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)+      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)+          Just accOptParser -> Just $ updateAccConfigOptParser subConfigParser accOptParser+        )         command--  in do-     parserPerCommand <--       foldM specToConfigValueCli-             HashMap.empty-             (HashMap.toList subConfigSpec)+  in  do+        parserPerCommand <- foldM specToConfigValueCli+                                  HashMap.empty+                                  (HashMap.toList subConfigSpec) -     parserPerCommand-       & HashMap.foldrWithKey-                  addSubParserCommand-                  acc-       & return+        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+  => HashMap cmd (Opt.Parser ConfigValue)+  -> (Text, Spec.ConfigValue cmd)+  -> m (HashMap cmd (Opt.Parser ConfigValue))+specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of+  Spec.ConfigValue _ sensitive sources ->+    configValueSpecToCli acc specEntryKey sensitive sources -    Spec.SubConfig subConfigSpec ->-      subConfigSpecToCli-        specEntryKey-        subConfigSpec-        acc+  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))+  => 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+  let zeroParser   = pure $ SubConfig HashMap.empty -  in-    case commandsSpec of-      Nothing ->-        throwM CommandsKeyNotDefined+      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)+        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)-    => HashMap cmd (Opt.Parser ConfigValue)-    -> m (Opt.Parser (cmd, Config))+  => 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 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+              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)+              [acc] & (++ commandParsers) & mconcat & return+  in  Opt.subparser <$> foldM joinParser Opt.idm (HashMap.toList parserPerCommand)  specToConfigCli   :: (MonadThrow m, JSON.FromJSON cmd, JSON.ToJSON cmd, Eq cmd, Hashable cmd)-    => Spec.ConfigSpec cmd-    -> m (Opt.Parser (cmd, Config))+  => Spec.ConfigSpec cmd+  -> m (Opt.Parser (cmd, Config)) specToConfigCli spec = do-  acc <- configValueCliAccInit spec-  parsers <--    foldM specToConfigValueCli-          acc-          (HashMap.toList $ Spec.specConfigValues spec)+  acc     <- configValueCliAccInit spec+  parsers <- foldM specToConfigValueCli acc (HashMap.toList $ Spec.specConfigValues spec)    joinCommandParsers parsers @@ -228,37 +179,25 @@ -} 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+  => 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+    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+    programParser = Opt.info (Opt.helper <*> configParser) programModFlags      programResult =-      args-        & map Text.unpack-        & Opt.execParserPure Opt.defaultPrefs programParser+      args & map Text.unpack & Opt.execParserPure Opt.defaultPrefs programParser    programResultToResolverResult progName programResult @@ -275,11 +214,10 @@ -} 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+  => 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+  handleCliResult $ resolveCommandCliPure configSpec progName args

@@ -4,19 +4,21 @@ {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Resolver.Cli.Common where -import qualified Prelude   as P-import           Protolude+import qualified Prelude as P -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           RIO+import qualified RIO.ByteString.Lazy as BL (toStrict)+import qualified RIO.Set             as Set+import qualified RIO.Text            as Text+import qualified RIO.Vector          as Vector +import qualified Data.Aeson          as JSON+import qualified Data.Aeson.Internal as JSON (IResult (..), iparse)+import qualified Data.Text.IO        as Text+import qualified Options.Applicative as Opt++import System.Exit+ import qualified System.Etc.Internal.Spec.Types as Spec import           System.Etc.Internal.Types @@ -57,144 +59,86 @@ --------------------------------------------------------------------------------  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)+  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)+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+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.toStrict+      & Text.decodeUtf8'+      & either tshow id+      & InvalidCliCommandKey+      & throwM -settingsToJsonCli-  :: Spec.CliEntryMetadata-    -> Opt.Parser (Maybe JSON.Value)-settingsToJsonCli specSettings =-  let-    requiredCombinator =-        if Spec.optRequired specSettings then-          (Just <$>)-        else-          Opt.optional+settingsToJsonCli :: Bool -> Spec.CliEntryMetadata -> Opt.Parser (Maybe (Value JSON.Value))+settingsToJsonCli sensitive 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)+    requiredCombinator $ case specSettings of+      Spec.Opt{} -> case Spec.optValueType specSettings of+        Spec.StringOpt -> (boolToValue sensitive . JSON.String . Text.pack)+          <$> Opt.strOption (specToCliVarFieldMod specSettings) -          Spec.NumberOpt ->-            (JSON.Number . fromInteger)+        Spec.NumberOpt ->+          (boolToValue sensitive . JSON.Number . fromInteger)             <$> Opt.option Opt.auto (specToCliVarFieldMod specSettings) -          Spec.SwitchOpt ->-            JSON.Bool-            <$> Opt.switch (specToCliSwitchFieldMod specSettings)+        Spec.SwitchOpt -> (boolToValue sensitive . 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))+      Spec.Arg{} -> case Spec.argValueType specSettings of+        Spec.StringArg ->+          (boolToValue sensitive . JSON.String . Text.pack) <$> Opt.strArgument+            (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack))+        Spec.NumberArg ->+          (boolToValue sensitive . JSON.Number . fromInteger) <$> Opt.argument+            Opt.auto+            (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack)) -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)+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+  JSON.ISuccess result  -> return result -jsonToConfigValue-  :: Maybe JSON.Value-    -> ConfigValue+jsonToConfigValue :: Maybe (Value JSON.Value) -> ConfigValue jsonToConfigValue specEntryDefVal =-  ConfigValue-    $ Set.fromList-    $ maybe [] ((:[]) . Cli) specEntryDefVal+  ConfigValue $ Set.fromList $ maybe [] ((: []) . Cli) specEntryDefVal -handleCliResult-  :: Either SomeException a -> IO a-handleCliResult result =-  case result of-    Right config ->-      return config+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+  Left  err    -> case fromException err of+    Just (CliEvalExited ExitSuccess (GetErrorMessage getMsg)) -> do+      getMsg >>= Text.putStrLn+      exitSuccess -        Just (CliEvalExited exitCode (GetErrorMessage getMsg)) -> do-          getMsg >>= Text.hPutStrLn stderr-          exitWith exitCode+    Just (CliEvalExited exitCode (GetErrorMessage getMsg)) -> do+      getMsg >>= Text.hPutStrLn stderr+      exitWith exitCode -        _ ->-          throwIO err+    _ -> throwIO err -programResultToResolverResult-  :: MonadThrow m-    => Text-    -> Opt.ParserResult a-    -> m a-programResultToResolverResult progName programResult =-  case programResult of-    Opt.Success result ->-      return result+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.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)+  Opt.CompletionInvoked compl ->+    let getMsg = Text.pack <$> Opt.execCompletion compl (Text.unpack progName)+    in  throwM $ CliEvalExited ExitSuccess (GetErrorMessage getMsg)

@@ -1,15 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+ module System.Etc.Internal.Resolver.Cli.Plain (PlainConfigSpec, resolvePlainCli, resolvePlainCliPure) where -import Protolude+import           RIO+import qualified RIO.HashMap as HashMap+import qualified RIO.Text    as Text -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  (getProgName)+import           System.Environment  (getArgs, getProgName)  import           System.Etc.Internal.Resolver.Cli.Common import qualified System.Etc.Internal.Spec.Types          as Spec@@ -24,133 +23,94 @@  entrySpecToConfigValueCli   :: (MonadThrow m)-    => Spec.CliEntrySpec ()-    -> m (Opt.Parser (Maybe JSON.Value))-entrySpecToConfigValueCli entrySpec =-  case entrySpec of-    Spec.CmdEntry {} ->-      throwM CommandKeyOnPlainCli+  => Bool+  -> Spec.CliEntrySpec ()+  -> m (Opt.Parser (Maybe (Value JSON.Value)))+entrySpecToConfigValueCli sensitive entrySpec = case entrySpec of+  Spec.CmdEntry{}              -> throwM CommandKeyOnPlainCli -    Spec.PlainEntry specSettings ->-      return (settingsToJsonCli specSettings)+  Spec.PlainEntry specSettings -> return (settingsToJsonCli sensitive 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+  => Text+  -> Bool+  -> Spec.ConfigSources ()+  -> Opt.Parser ConfigValue+  -> m (Opt.Parser ConfigValue)+configValueSpecToCli specEntryKey sensitive 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+            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+        Just entrySpec -> do+          jsonOptParser <- entrySpecToConfigValueCli sensitive entrySpec -        let-          configValueParser =-            jsonToConfigValue <$> jsonOptParser+          let configValueParser = jsonToConfigValue <$> jsonOptParser -        return $ updateAccConfigOptParser configValueParser acc+          return $ updateAccConfigOptParser configValueParser acc  subConfigSpecToCli   :: (MonadThrow m)-    => Text-    -> HashMap.HashMap Text (Spec.ConfigValue ())-    -> Opt.Parser ConfigValue-    -> m (Opt.Parser ConfigValue)+  => 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+  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)+              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+        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+  => Opt.Parser ConfigValue+  -> (Text, Spec.ConfigValue ())+  -> m (Opt.Parser ConfigValue)+specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of+  Spec.ConfigValue _ sensitive sources ->+    configValueSpecToCli specEntryKey sensitive sources acc -    Spec.SubConfig subConfigSpec ->-      subConfigSpecToCli-        specEntryKey-        subConfigSpec-        acc+  Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc -configValueCliAccInit-  :: (MonadThrow m)-    => Spec.ConfigSpec ()-    -> m (Opt.Parser ConfigValue)+configValueCliAccInit :: (MonadThrow m) => Spec.ConfigSpec () -> m (Opt.Parser ConfigValue) configValueCliAccInit spec =-  let-    zeroParser =-      pure $ SubConfig HashMap.empty+  let zeroParser   = pure $ SubConfig HashMap.empty -    commandsSpec = do-      programSpec <- Spec.specCliProgramSpec spec-      Spec.cliCommands programSpec-  in-    case commandsSpec of-      Nothing ->-        return zeroParser+      commandsSpec = do+        programSpec <- Spec.specCliProgramSpec spec+        Spec.cliCommands programSpec+  in  case commandsSpec of+        Nothing -> return zeroParser -      Just _ ->-        throwM CommandKeyOnPlainCli+        Just _  -> throwM CommandKeyOnPlainCli -specToConfigCli-  :: (MonadThrow m)-    => Spec.ConfigSpec ()-    -> m (Opt.Parser Config)+specToConfigCli :: (MonadThrow m) => Spec.ConfigSpec () -> m (Opt.Parser Config) specToConfigCli spec = do-  acc <- configValueCliAccInit spec-  parser <--    foldM specToConfigValueCli-          acc-          (HashMap.toList $ Spec.specConfigValues spec)+  acc    <- configValueCliAccInit spec+  parser <- foldM specToConfigValueCli acc (HashMap.toList $ Spec.specConfigValues spec) -  parser-    & (Config <$>)-    & return+  parser & (Config <$>) & return  {-| @@ -172,29 +132,17 @@   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+    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+    programParser = Opt.info (Opt.helper <*> configParser) programModFlags      programResult =-      args-        & map Text.unpack-        & Opt.execParserPure Opt.defaultPrefs programParser+      args & map Text.unpack & Opt.execParserPure Opt.defaultPrefs programParser    programResultToResolverResult progName programResult @@ -215,5 +163,4 @@   progName <- Text.pack <$> getProgName   args     <- map Text.pack <$> getArgs -  handleCliResult-    $ resolvePlainCliPure configSpec progName args+  handleCliResult $ resolvePlainCliPure configSpec progName args

@@ -1,55 +1,42 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+ module System.Etc.Internal.Resolver.Default (resolveDefault) where -import Protolude+import           RIO+import qualified RIO.HashMap as HashMap+import qualified RIO.Set     as Set -import qualified Data.Aeson          as JSON-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Set            as Set+import qualified Data.Aeson as JSON  import qualified System.Etc.Internal.Spec.Types as Spec import           System.Etc.Internal.Types -toDefaultConfigValue :: JSON.Value -> ConfigValue-toDefaultConfigValue =-  ConfigValue . Set.singleton . Default+toDefaultConfigValue :: Bool -> JSON.Value -> ConfigValue+toDefaultConfigValue sensitive =+  ConfigValue . Set.singleton . Default . boolToValue sensitive  buildDefaultResolver :: Spec.ConfigSpec cmd -> Maybe ConfigValue buildDefaultResolver spec =-  let-    resolverReducer :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue-    resolverReducer specKey specValue mConfig =-      case specValue of-        Spec.ConfigValue def _ ->-          let-            mConfigSource =-              toDefaultConfigValue <$> def+  let resolverReducer+        :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue+      resolverReducer specKey specValue mConfig = case specValue of+        Spec.ConfigValue def sensitive _ ->+          let mConfigSource = toDefaultConfigValue sensitive <$> def -            updateConfig =-              writeInSubConfig specKey <$> mConfigSource <*> mConfig-          in-            updateConfig <|> mConfig+              updateConfig  = writeInSubConfig specKey <$> mConfigSource <*> mConfig+          in  updateConfig <|> mConfig          Spec.SubConfig specConfigMap ->-          let-            mSubConfig =-              specConfigMap-              & HashMap.foldrWithKey-                    resolverReducer-                    (Just emptySubConfig)-              & filterMaybe isEmptySubConfig+          let mSubConfig =+                specConfigMap+                  & HashMap.foldrWithKey resolverReducer (Just emptySubConfig)+                  & filterMaybe isEmptySubConfig -            updateConfig =-              writeInSubConfig specKey <$> mSubConfig <*> mConfig-          in-            updateConfig <|> mConfig-  in-    Spec.specConfigValues spec-    & HashMap.foldrWithKey-          resolverReducer-          (Just emptySubConfig)-    & filterMaybe isEmptySubConfig+              updateConfig = writeInSubConfig specKey <$> mSubConfig <*> mConfig+          in  updateConfig <|> mConfig+  in  Spec.specConfigValues spec+      & HashMap.foldrWithKey resolverReducer (Just emptySubConfig)+      & filterMaybe isEmptySubConfig  {-| @@ -59,7 +46,4 @@ resolveDefault   :: Spec.ConfigSpec cmd -- ^ ConfigSpec   -> Config              -- ^ returns Configuration Map with default values included-resolveDefault spec =-  maybe (Config emptySubConfig)-        Config-        (buildDefaultResolver spec)+resolveDefault spec = maybe (Config emptySubConfig) Config (buildDefaultResolver spec)

@@ -1,70 +1,51 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+ module System.Etc.Internal.Resolver.Env (resolveEnv, resolveEnvPure) where -import Protolude-import System.Environment (getEnvironment)+import           RIO+import qualified RIO.HashMap        as HashMap+import qualified RIO.Set            as Set+import qualified RIO.Text           as Text+import           System.Environment (getEnvironment) -import           Control.Arrow       ((***))-import qualified Data.Aeson          as JSON-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Set            as Set-import qualified Data.Text           as Text+import           Control.Arrow ((***))+import qualified Data.Aeson    as JSON  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+  :: (Text -> Maybe Text) -> Bool -> Spec.ConfigSources cmd -> Maybe ConfigSource+resolveEnvVarSource lookupEnv sensitive specSources =+  let toEnvSource varname envValue =+        envValue & JSON.String & boolToValue sensitive & 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+  let resolverReducer+        :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue+      resolverReducer specKey specValue mConfig = case specValue of+        Spec.ConfigValue _ sensitive sources ->+          let updateConfig = do+                envSource <- resolveEnvVarSource lookupEnv sensitive sources+                writeInSubConfig specKey (ConfigValue $ Set.singleton envSource)+                  <$> mConfig+          in  updateConfig <|> mConfig          Spec.SubConfig specConfigMap ->-          let-            mSubConfig =-              specConfigMap-              & HashMap.foldrWithKey-                   resolverReducer-                   (Just emptySubConfig)-              & filterMaybe isEmptySubConfig+          let mSubConfig =+                specConfigMap+                  & HashMap.foldrWithKey resolverReducer (Just emptySubConfig)+                  & filterMaybe isEmptySubConfig -            updateConfig =-              writeInSubConfig specKey <$> mSubConfig <*> mConfig-          in-            updateConfig <|> mConfig-  in-    Spec.specConfigValues spec-    & HashMap.foldrWithKey-          resolverReducer-          (Just emptySubConfig)-    & filterMaybe isEmptySubConfig+              updateConfig = writeInSubConfig specKey <$> mSubConfig <*> mConfig+          in  updateConfig <|> mConfig+  in  Spec.specConfigValues spec+      & HashMap.foldrWithKey resolverReducer (Just emptySubConfig)+      & filterMaybe isEmptySubConfig {-|  Gathers all OS Environment Variable values (@env@ entries) from the @etc/spec@@@ -77,16 +58,10 @@   -> [(Text, Text)]      -- ^ Environment Variable tuples   -> Config              -- ^ returns Configuration Map with Environment Variables values filled in resolveEnvPure spec envMap0 =-  let-    envMap =-      HashMap.fromList envMap0+  let envMap = HashMap.fromList envMap0 -    lookupEnv key =-      HashMap.lookup key envMap-  in-    maybe (Config emptySubConfig)-          Config-          (buildEnvVarResolver lookupEnv spec)+      lookupEnv key = HashMap.lookup key envMap+  in  maybe (Config emptySubConfig) Config (buildEnvVarResolver lookupEnv spec)   {-|@@ -99,10 +74,5 @@   :: 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+  let getEnvironmentTxt = map (Text.pack *** Text.pack) <$> getEnvironment+  in  resolveEnvPure spec <$> getEnvironmentTxt

@@ -3,24 +3,20 @@ {-# 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)-+import           RIO+import           RIO.Directory (doesFileExist)+import qualified RIO.HashMap   as HashMap+import qualified RIO.Set       as Set+import qualified RIO.Text      as Text+import qualified RIO.Vector    as Vector  #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 Data.Aeson          as JSON+import qualified Data.Aeson.Internal as JSON (IResult (..), iparse)+import qualified RIO.ByteString.Lazy as LB8  import qualified System.Etc.Internal.Spec.Types as Spec import           System.Etc.Internal.Types      hiding (filepath)@@ -35,28 +31,36 @@ --------------------------------------------------------------------------------  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)+  :: Monad m => Maybe (Spec.ConfigValue cmd) -> Int -> Text -> JSON.Value -> m ConfigValue+parseConfigValue mSpec fileIndex filepath json = case json of+  JSON.Object object -> SubConfig <$> foldM+    (\acc (key, subConfigValue) -> do+      let msubConfigSpec = do+            spec <- mSpec+            case spec of+              Spec.SubConfig hsh -> HashMap.lookup key hsh+              _ ->+                -- TODO: This should be an error given the config doesn't match spec+                fail "configuration spec and configuration value are different" -    _ ->-      return $-        ConfigValue (Set.singleton $ File fileIndex filepath json)+      value1 <- parseConfigValue msubConfigSpec fileIndex filepath subConfigValue+      return $ HashMap.insert key value1 acc+    )+    HashMap.empty+    (HashMap.toList object) +  _ ->+    let mToValue = do+          spec <- mSpec+          case spec of+            Spec.ConfigValue{} -> return $ boolToValue (Spec.isSensitive spec)+            _ -> fail "configuration spec and configuration value are different" -eitherDecode :: ConfigFile -> Either [Char] JSON.Value+        toValue = fromMaybe Plain mToValue+    in  return $ ConfigValue (Set.singleton $ File fileIndex filepath (toValue json))+++eitherDecode :: ConfigFile -> Either String JSON.Value #ifdef WITH_YAML eitherDecode contents0 =   case contents0 of@@ -65,66 +69,61 @@     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)+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)+parseConfig :: MonadThrow m => Spec.ConfigValue cmd -> Int -> Text -> ConfigFile -> m Config+parseConfig spec fileIndex filepath contents = case eitherDecode contents of+  Left  err  -> throwM $ InvalidConfiguration Nothing (Text.pack err) -    Right json ->-      case JSON.iparse (parseConfigValue fileIndex filepath) json of-        JSON.IError _ err ->-          throwM $ InvalidConfiguration (Text.pack err)+  Right json -> case JSON.iparse (parseConfigValue (Just spec) fileIndex filepath) json of+    JSON.IError _ err    -> throwM $ InvalidConfiguration Nothing (Text.pack err) -        JSON.ISuccess result ->-          return (Config result)+    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+  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 Nothing "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 `mappend` current, errs))-             (mempty, [])-             <$>)+readConfigFromFiles :: Spec.ConfigSpec cmd -> IO (Config, [SomeException])+readConfigFromFiles spec =+  Spec.specConfigFilepaths spec+    & zip [1 ..]+    & mapM+        (\(fileIndex, filepath) -> do+          mContents <- readConfigFile filepath+          return+            (   mContents+            >>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec)+                            fileIndex+                            filepath+            )+        )+    & (foldl'+        (\(result, errs) eCurrent -> case eCurrent of+          Left  err     -> (result, err : errs)+          Right current -> (result `mappend` current, errs)+        )+        (mempty, []) <$>+      )  {-| @@ -138,5 +137,5 @@   :: 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)+  (config, exceptions) <- readConfigFromFiles spec   return (config, Vector.fromList exceptions)

@@ -1,30 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module System.Etc.Internal.Spec.JSON where -import Protolude+module System.Etc.Internal.Spec.JSON where -import Control.Monad.Catch (MonadThrow (..))+import qualified Data.Text.IO        as Text (readFile)+import           RIO+import qualified RIO.ByteString.Lazy as LBS+import qualified RIO.Text            as Text -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 qualified Data.Aeson as JSON  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)+parseConfigSpec :: (MonadThrow m, JSON.FromJSON cmd) => Text -> m (ConfigSpec cmd)+parseConfigSpec input = case JSON.eitherDecode (LBS.fromStrict $ encodeUtf8 input) of+  Left  err    -> throwM $ InvalidConfiguration Nothing (Text.pack err) -    Right result ->-      return result+  Right result -> return result  readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) readConfigSpec filepath = do

@@ -2,24 +2,22 @@ {-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Spec.Types where -import Prelude   (fail)-import Protolude+import           Prelude     (fail)+import           RIO+import qualified RIO.HashMap as HashMap -import Data.Aeson          ((.:), (.:?))-import Data.HashMap.Strict (HashMap)-import Data.Vector         (Vector)+import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson          as JSON-import qualified Data.Aeson.Types    as JSON (Parser, typeMismatch)-import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson       as JSON+import qualified Data.Aeson.Types as JSON (Parser, typeMismatch)  -------------------------------------------------------------------------------- -- Error Types  data ConfigurationError-  = InvalidConfiguration Text-  | InvalidConfigKeyPath [Text]-  | ConfigurationFileNotFound Text+  = InvalidConfiguration !(Maybe Text) !Text+  | InvalidConfigKeyPath ![Text]+  | ConfigurationFileNotFound !Text   deriving (Show)  instance Exception ConfigurationError@@ -39,67 +37,68 @@  data CliEntryMetadata   = Opt {-    optLong      :: Maybe Text-  , optShort     :: Maybe Text-  , optMetavar   :: Maybe Text-  , optHelp      :: Maybe Text-  , optRequired  :: Bool-  , optValueType :: CliOptValueType+    optLong      :: !(Maybe Text)+  , optShort     :: !(Maybe Text)+  , optMetavar   :: !(Maybe Text)+  , optHelp      :: !(Maybe Text)+  , optRequired  :: !Bool+  , optValueType :: !CliOptValueType   }   | Arg {-    argMetavar   :: Maybe Text-  , optRequired  :: Bool-  , argValueType :: CliArgValueType+    argMetavar   :: !(Maybe Text)+  , optRequired  :: !Bool+  , argValueType :: !CliArgValueType   }   deriving (Show, Eq)  data CliEntrySpec cmd   = CmdEntry {-    cliEntryCmdValue :: Vector cmd-  , cliEntryMetadata :: CliEntryMetadata+    cliEntryCmdValue :: !(Vector cmd)+  , cliEntryMetadata :: !CliEntryMetadata   }   | PlainEntry {-    cliEntryMetadata :: CliEntryMetadata+    cliEntryMetadata :: !CliEntryMetadata   }   deriving (Show, Eq)  data CliCmdSpec   = CliCmdSpec {-    cliCmdDesc   :: Text-  , cliCmdHeader :: Text+    cliCmdDesc   :: !Text+  , cliCmdHeader :: !Text   }   deriving (Show, Eq)  data ConfigSources cmd   = ConfigSources {-    envVar   :: Maybe Text-  , cliEntry :: Maybe (CliEntrySpec cmd)+    envVar   :: !(Maybe Text)+  , cliEntry :: !(Maybe (CliEntrySpec cmd))   }   deriving (Show, Eq)  data ConfigValue cmd   = ConfigValue {-    defaultValue  :: Maybe JSON.Value-  , configSources :: ConfigSources cmd+    defaultValue  :: !(Maybe JSON.Value)+  , isSensitive   :: !Bool+  , configSources :: !(ConfigSources cmd)   }   | SubConfig {-    subConfig :: HashMap Text (ConfigValue cmd)+    subConfig :: !(HashMap Text (ConfigValue cmd))   }   deriving (Show, Eq)  data CliProgramSpec   = CliProgramSpec {-    cliProgramDesc   :: Text-  , cliProgramHeader :: Text-  , cliCommands      :: Maybe (HashMap Text CliCmdSpec)+    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)+    specConfigFilepaths :: ![Text]+  , specCliProgramSpec  :: !(Maybe CliProgramSpec)+  , specConfigValues    :: !(HashMap Text (ConfigValue cmd))   }   deriving (Show, Eq) @@ -127,63 +126,45 @@       _ ->         JSON.typeMismatch "CliProgramSpec" json -cliArgTypeParser-  :: JSON.Object-    -> JSON.Parser CliArgValueType+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+      | 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 :: JSON.Object -> JSON.Parser CliEntryMetadata cliArgParser object =   Arg     <$> (object .:? "metavar")     <*> (fromMaybe True <$> (object .:? "required"))     <*> cliArgTypeParser object -cliOptTypeParser-  :: JSON.Object-    -> JSON.Parser CliOptValueType+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+      | 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+    Just value -> JSON.typeMismatch "CliOptValueType" value -    Nothing ->-      fail "CLI Option type is required"+    Nothing    -> fail "CLI Option type is required" -cliOptParser-  :: JSON.Object-    -> JSON.Parser CliEntryMetadata+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+  if isNothing long && isNothing short+    then fail "'option' field input requires either 'long' or 'short' settings"+    else+      Opt       <$> pure long       <*> pure short       <*> (object .:? "metavar")@@ -252,12 +233,15 @@               return (SubConfig result)            -- etc spec value object-          Just (JSON.Object spec) ->-            if HashMap.size object == 1 then+          Just (JSON.Object fieldSpec) ->+            if HashMap.size object == 1 then do+              mSensitive <- fieldSpec .:? "sensitive"+              let sensitive = fromMaybe False mSensitive               ConfigValue-                <$> spec .:? "default"-                <*> (ConfigSources <$> (spec .:? "env")-                                   <*> (spec .:? "cli"))+                <$> fieldSpec .:? "default"+                <*> pure sensitive+                <*> (ConfigSources <$> fieldSpec .:? "env"+                                   <*> fieldSpec .:? "cli")             else               fail "etc/spec object can only contain one key" @@ -266,8 +250,13 @@             fail "etc/spec value must be a JSON object"        _ ->-        return $-          ConfigValue (Just json) (ConfigSources Nothing Nothing)+        return+          ConfigValue+          {+            defaultValue = Just json+          , isSensitive = False+          , configSources = ConfigSources Nothing Nothing+          }  instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where   parseJSON json  =

@@ -1,30 +1,23 @@+ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module System.Etc.Internal.Spec.YAML where -import Protolude+module System.Etc.Internal.Spec.YAML where -import Control.Monad.Catch (MonadThrow (..))+import           RIO+import qualified RIO.Text as Text  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)+parseConfigSpec :: (MonadThrow m, JSON.FromJSON cmd) => Text -> m (ConfigSpec cmd)+parseConfigSpec input = case YAML.decodeEither (Text.encodeUtf8 input) of+  Left  err    -> throwM $ InvalidConfiguration Nothing (Text.pack err) -    Right result ->-      return result+  Right result -> return result  readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) readConfigSpec filepath = do

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE RankNTypes                 #-}@@ -7,35 +8,66 @@   , module System.Etc.Internal.Spec.Types   ) where -import Control.Monad.Catch (MonadThrow)-import Data.HashMap.Strict (HashMap)-import Protolude+import           RIO+import qualified RIO.HashMap as HashMap+import qualified RIO.Set     as Set -import qualified Data.Aeson          as JSON-import qualified Data.Aeson.Types    as JSON (Parser)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Set            as Set+import           Data.Bool      (bool)+import qualified Data.Semigroup as Semigroup +import qualified Data.Aeson       as JSON+import qualified Data.Aeson.Types as JSON (Parser)+ import System.Etc.Internal.Spec.Types (ConfigurationError (..))  -------------------- -- Configuration Types +data Value a+  = Plain { fromValue :: !a }+  | Sensitive { fromValue :: !a }+  deriving (Generic, Eq, Ord)++instance Show a => Show (Value a) where+  show (Plain a)     = show a+  show (Sensitive _) = "<<sensitive>>"++instance Functor Value where+  fmap f val =+    case val of+      Plain a     -> Plain (f a)+      Sensitive a -> Sensitive (f a)++instance Applicative Value where+  pure a = Plain a+  (<*>) vf va =+    case (vf, va) of+      (Plain f, Plain a)         -> Plain (f a)+      (Sensitive f, Sensitive a) -> Sensitive (f a)+      (Sensitive f, Plain a)     -> Sensitive (f a)+      (Plain f, Sensitive a)     -> Sensitive (f a)++instance IsString a => IsString (Value a) where+  fromString = Plain . fromString++boolToValue :: Bool -> (a -> Value a)+boolToValue = bool Plain Sensitive+ data ConfigSource   = File {-      configIndex :: Int-    , filepath    :: Text-    , value       :: JSON.Value+      configIndex :: !Int+    , filepath    :: !Text+    , value       :: !(Value JSON.Value)     }   | Env {-      envVar :: Text-    , value  :: JSON.Value+      envVar :: !Text+    , value  :: !(Value JSON.Value)     }   | Cli {-      value :: JSON.Value+      value :: !(Value JSON.Value)     }   | Default {-      value :: JSON.Value+      value :: !(Value JSON.Value)     }   | None   deriving (Show, Eq)@@ -52,6 +84,10 @@         (_, None) ->           GT +        (_, _)+          | fromValue (value a) == JSON.Null -> LT+          | fromValue (value b) == JSON.Null -> GT+         (Default {}, _) ->           LT @@ -75,71 +111,55 @@  data ConfigValue   = ConfigValue {-      configSource :: Set ConfigSource+      configSource :: !(Set ConfigSource)     }   | SubConfig {-      configMap :: HashMap Text ConfigValue+      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+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.Semigroup ConfigValue where+  (<>) = deepMerge+ instance Monoid ConfigValue where   mempty  = emptySubConfig-  mappend = deepMerge+  mappend = (Semigroup.<>)  newtype Config   = Config { fromConfig :: ConfigValue }-  deriving (Eq, Show, Monoid)+  deriving (Eq, Show, Semigroup, Monoid)  isEmptySubConfig :: ConfigValue -> Bool-isEmptySubConfig val =-  case val of-    SubConfig hsh ->-      HashMap.null hsh-    ConfigValue {} ->-      False+isEmptySubConfig val = case val of+  SubConfig hsh -> HashMap.null hsh+  ConfigValue{} -> False  emptySubConfig :: ConfigValue-emptySubConfig =-  SubConfig HashMap.empty+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+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+filterMaybe pfn mvalue = case mvalue of+  Just a | pfn a     -> Nothing+         | otherwise -> mvalue+  Nothing -> Nothing   class IConfig config where

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE OverloadedStrings   #-}+ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Spec (     module Types@@ -8,22 +8,21 @@   , readConfigSpec   ) where -import Protolude hiding (catch)+import qualified Data.Text.IO as Text (readFile)+import           RIO+import qualified RIO.Text     as Text  import System.Etc.Internal.Spec.Types as Types     (ConfigSpec, ConfigValue, ConfigurationError (..)) -import Control.Monad.Catch (MonadCatch (..))- #ifdef WITH_CLI import qualified Data.Aeson as JSON #endif-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+#else+import qualified System.Etc.Internal.Spec.JSON as JSONSpec #endif  {-|@@ -34,23 +33,20 @@ -} #ifdef WITH_CLI parseConfigSpec-  :: (MonadCatch m, JSON.FromJSON cmd)+  :: (MonadThrow m, JSON.FromJSON cmd)     => Text               -- ^ Text to be parsed     -> m (ConfigSpec cmd) -- ^ returns ConfigSpec #else parseConfigSpec-  :: (MonadCatch m)-    => Text               -- ^ Text to be parsed-    -> m (ConfigSpec ()) -- ^ returns ConfigSpec+  :: (MonadThrow m)+  => Text               -- ^ Text to be parsed+  -> m (ConfigSpec ()) -- ^ returns ConfigSpec #endif  #ifdef WITH_YAML-parseConfigSpec input =-   catch (JSON.parseConfigSpec input)-         (\(_ :: SomeException) ->  YAML.parseConfigSpec input)+parseConfigSpec = YAML.parseConfigSpec #else-parseConfigSpec =-  JSON.parseConfigSpec+parseConfigSpec = JSONSpec.parseConfigSpec #endif  {-|

@@ -0,0 +1,30 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module System.Etc.ConfigTest where++import RIO++import Test.Tasty       (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, assertFailure, testCase)++import qualified System.Etc as SUT++tests :: TestTree+tests = testGroup+  "System.Etc.Config"+  [ testCase "InvalidConfiguration error contains key when types don't match" $ do+      let input = "{\"etc/entries\":{\"greeting\":123}}"++      (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+      let config = SUT.resolveDefault spec+      case SUT.getConfigValue ["greeting"] config of+        Left err -> case fromException err of+          Just (SUT.InvalidConfiguration key _) ->+            assertEqual "expecting key to be greeting, but wasn't" (Just "greeting") key+          _ ->+            assertFailure+              $  "expecting InvalidConfiguration; got something else: "+              <> show err+        Right (_ :: Text) -> assertFailure "expecting error; got none"+  ]

@@ -4,36 +4,28 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Extra.EnvMisspellTest where -import Protolude+import           RIO+import qualified RIO.Vector as Vector  import Test.Tasty       (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, testCase) -import qualified Data.Vector as Vector- import System.Etc  tests :: TestTree-tests =-  testGroup "env misspells"-  [-    testCase "it warns when misspell is present" $ do-      let-        input =-          mconcat-            [-              "{\"etc/entries\": {"+tests = testGroup+  "env misspells"+  [ testCase "it warns when misspell is present" $ do+      let input = mconcat+            [ "{\"etc/entries\": {"             , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}"             ]        (spec :: ConfigSpec ()) <- parseConfigSpec input -      let-        result =-          getEnvMisspellingsPure spec ["GREEING"]+      let result = getEnvMisspellingsPure spec ["GREEING"] -      assertBool "expecting to get a warning for typo"-                 (not $ Vector.null result)+      assertBool "expecting to get a warning for typo" (not $ Vector.null result)        assertEqual "expecting to get typo for key GREETING"                   (EnvMisspell "GREEING" "GREETING")

@@ -3,359 +3,254 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Resolver.Cli.CommandTest where -import Protolude+import           RIO+import qualified RIO.Set as Set  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+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"] -      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)+    assertEqual "invalid command output" "test" cmd +    case getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Cli "hello cli") aSet)   , 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"]+    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 -      assertEqual "invalid command output" "test" cmd+    (cmd, config)             <- resolveCommandCliPure spec+                                                       "program"+                                                       ["test", "--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)+    assertEqual "invalid command output" "test" cmd +    case getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Cli "hello cli") aSet)   , 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+    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 ()+    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)+        _ -> assertFailure ("Expecting type validation to work on cli; got " <> show err)  -        Right _ ->-          assertFailure "Expecting type validation to work on cli"-+      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+    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"] -      case getConfigValue ["greeting"] config of-        Just set ->-          assertFailure ("expecting to have no entry for greeting; got\n"-                       <> show set)+    assertEqual "invalid command output" "test" cmd -        (_ :: Maybe ()) ->-          return ()+    case getConfigValue ["greeting"] config of+      Just aSet ->+        assertFailure ("expecting to have no entry for greeting; got\n" <> show aSet) +      (_ :: 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 ()+    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)+        _ ->+          assertFailure ("Expecting required validation to work on cli; got " <> show err) -        Right _ ->-          assertFailure "Expecting required option to fail cli resolving"+      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 ()+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 -            _ ->-              assertFailure ("Expecting type validation to work on cli; got "-                             <> show err)+    case resolveCommandCliPure spec "program" ["test", "hello cli"] of+      Left err -> case fromException err of+        Just CliEvalExited{} -> return () -        Right _ ->-          assertFailure "Expecting type validation to work on cli"+        _ -> 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+    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"] -      case getConfigValue ["greeting"] config of-        (Nothing :: Maybe ()) ->-          return ()+    assertEqual "invalid command output" "test" cmd -        Just set ->-          assertFailure ("expecting to have no entry for greeting; got\n"-                       <> show set)+    case getConfigValue ["greeting"] config of+      (Nothing :: Maybe ()) -> return () +      Just aSet ->+        assertFailure ("expecting to have no entry for greeting; got\n" <> show aSet)   , 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)+    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 () -        Right _ ->-          assertFailure "Expecting required argument to fail cli resolving"+        _ ->+          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\": {"+    let input = mconcat+          [ "{ \"etc/cli\": {"           , "    \"desc\": \"\""           , "  , \"header\": \"\""           , "  , \"commands\": {"-          , "      \"test\": {\"header\": \"\", \"desc\": \"\"}}}"+          , "      \"test\": {\"header\": \"\", \"desc\": \"\"}"+          , "    , \"other\": {\"header\": \"\", \"desc\": \"\"}}}"           , ", \"etc/entries\": {"           , "    \"greeting\": {"           , "      \"etc/spec\": {"@@ -364,29 +259,54 @@           , "        , \"short\": \"g\""           , "        , \"type\": \"string\""           , "        , \"metavar\": \"GREETING\""-          , "        , \"required\": true"-          , "        , \"commands\": [\"test\"]"+          , "        , \"required\": false"+          , "        , \"commands\": [\"test\", \"other\"]"           , "}}}}}"           ]     (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"+    (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-  ]+tests = testGroup "command" [with_command, without_command]

@@ -3,256 +3,187 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Resolver.Cli.PlainTest where -import Protolude+import           RIO+import qualified RIO.Set as Set  import Test.Tasty       (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase) -import qualified Data.Set as Set--import System.Etc+import qualified System.Etc as SUT  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)+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 :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    config <- SUT.resolvePlainCliPure spec "program" ["-g", "hello cli"] +    case SUT.getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (SUT.Cli "hello cli") aSet)   , 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)+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"option\""+          , "        , \"short\": \"g\""+          , "        , \"long\": \"greeting\""+          , "        , \"type\": \"string\""+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    config <- SUT.resolvePlainCliPure spec "program" ["--greeting", "hello cli"] +    case SUT.getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (SUT.Cli "hello cli") aSet)   , 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+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"option\""+          , "        , \"short\": \"g\""+          , "        , \"long\": \"greeting\""+          , "        , \"type\": \"number\""+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input -      case resolvePlainCliPure spec "program" ["--greeting", "hello cli"] of-        Left err ->-          case fromException err of-            Just CliEvalExited {} ->-              return ()+    case SUT.resolvePlainCliPure spec "program" ["--greeting", "hello cli"] of+      Left err -> case fromException err of+        Just SUT.CliEvalExited{} -> return () -            _ ->-              assertFailure ("Expecting type validation to work on cli; got "-                             <> show err)+        _ -> assertFailure ("Expecting type validation to work on cli; got " <> show err)  -        Right _ ->-          assertFailure "Expecting type validation to work on cli"-+      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)+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"option\""+          , "        , \"short\": \"g\""+          , "        , \"long\": \"greeting\""+          , "        , \"type\": \"string\""+          , "        , \"required\": false"+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    config                      <- SUT.resolvePlainCliPure spec "program" [] -        (_ :: Maybe ()) ->-          return ()+    case SUT.getConfigValue ["greeting"] config of+      Just aSet ->+        assertFailure ("expecting to have no entry for greeting; got\n" <> show aSet) +      (_ :: 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)+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"option\""+          , "        , \"short\": \"g\""+          , "        , \"long\": \"greeting\""+          , "        , \"type\": \"string\""+          , "        , \"required\": true"+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    case SUT.resolvePlainCliPure spec "program" [] of+      Left err -> case fromException err of+        Just SUT.CliEvalExited{} -> return () -        Right _ ->-          assertFailure "Expecting required option to fail cli resolving"+        _ ->+          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 ()+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 :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input -            _ ->-              assertFailure ("Expecting type validation to work on cli; got "-                             <> show err)+    case SUT.resolvePlainCliPure spec "program" ["hello cli"] of+      Left err -> case fromException err of+        Just SUT.CliEvalExited{} -> return () -        Right _ ->-          assertFailure "Expecting type validation to work on cli"+        _ -> 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 ()+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"argument\""+          , "        , \"type\": \"string\""+          , "        , \"metavar\": \"GREETING\""+          , "        , \"required\": false"+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    config                      <- SUT.resolvePlainCliPure spec "program" [] -        Just set ->-          assertFailure ("expecting to have no entry for greeting; got\n"-                       <> show set)+    case SUT.getConfigValue ["greeting"] config of+      (Nothing :: Maybe ()) -> return () +      Just aSet ->+        assertFailure ("expecting to have no entry for greeting; got\n" <> show aSet)   , 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"+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"cli\": {"+          , "          \"input\": \"argument\""+          , "        , \"type\": \"string\""+          , "        , \"metavar\": \"GREETING\""+          , "        , \"required\": true"+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    case SUT.resolvePlainCliPure spec "program" [] of+      Left err -> case fromException err of+        Just SUT.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-  ]+tests = testGroup "plain" [option_tests, argument_tests]

@@ -10,9 +10,6 @@   tests :: TestTree-tests =-  testGroup "cli"-  [-    System.Etc.Resolver.Cli.CommandTest.tests-  , System.Etc.Resolver.Cli.PlainTest.tests-  ]+tests = testGroup+  "cli"+  [System.Etc.Resolver.Cli.CommandTest.tests, System.Etc.Resolver.Cli.PlainTest.tests]

@@ -3,86 +3,51 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Resolver.DefaultTest (tests) where -import Protolude+import           RIO+import qualified RIO.Set as Set  import qualified Data.Aeson       as JSON 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+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 -      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)+    let config = resolveDefault spec +    case getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Default "hello default") aSet)   , 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+    let input = mconcat ["{\"etc/entries\": {", " \"greeting\": \"hello default\"}}"]+    (spec :: ConfigSpec ()) <- parseConfigSpec input -      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)+    let config = resolveDefault spec +    case getAllConfigSources ["greeting"] config of+      Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Default "hello default") aSet)   , testCase "default can be a null JSON value" $ do-      let-        input =-          mconcat-            [-              "{\"etc/entries\": {"-            , " \"greeting\": null}}"-            ]-      (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 JSON.Null) set)+    let input = mconcat ["{\"etc/entries\": {", " \"greeting\": null}}"]+    (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 aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Default $ Plain JSON.Null) aSet)   ]

@@ -3,96 +3,72 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Resolver.EnvTest where -import Protolude+import           RIO+import qualified RIO.Set  as Set+import qualified RIO.Text as Text  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")]+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 -      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)+    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 aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)+                              (Set.member (Env "GREETING" "hello env") aSet)   , 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")]+    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 -        config =-            configEnv `mappend` configFile+    let configEnv = resolveEnvPure spec [("GREETING", "hello env")] -      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+        config    = configEnv `mappend` 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 input = mconcat+          [ "{\"etc/entries\": {"+          , " \"nested\": {\"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}}"+          ]+    (spec :: ConfigSpec ()) <- parseConfigSpec input -      let-        config =-          resolveEnvPure spec []+    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"] config) -      assertEqual "expecting to not have an entry for key"-                  (Nothing :: Maybe Text)-                  (getConfigValue ["nested", "greeting"] config)+    assertEqual "expecting to not have an entry for key"+                (Nothing :: Maybe Text)+                (getConfigValue ["nested", "greeting"] config)   ]

@@ -5,127 +5,136 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Resolver.FileTest (tests) where -import Protolude+import           RIO+import qualified RIO.Set    as Set+import qualified RIO.Text   as Text+import qualified RIO.Vector as Vector  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 qualified Data.Aeson as JSON+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"+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"+    yamlFilepath <- getDataFileName "test/fixtures/config.yaml"+    ymlFilepath  <- getDataFileName "test/fixtures/config.yml" #endif -      let-        input =-          mconcat-            [-              "{\"etc/filepaths\": ["-            , "\"" <> Text.pack jsonFilepath <> "\""+    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+    (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)+    case getAllConfigSources ["greeting"] config of+      Nothing -> assertFailure+        ("expecting to get entries for greeting (check fixtures)\n" <> show config)+      Just aSet -> assertBool+        ("expecting to see entry from json config file " <> show aSet)+        (Set.member (File 1 (Text.pack jsonFilepath) "hello json") aSet)  #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 yaml config file " <> show aSet)+                     (Set.member (File 2 (Text.pack jsonFilepath) "hello yaml") aSet) -          assertBool ("expecting to see entry from yml config file " <> show set)-                     (Set.member (File 3 (Text.pack jsonFilepath) "hello yml") set)+       >> assertBool ("expecting to see entry from yml config file " <> show aSet)+                     (Set.member (File 3 (Text.pack jsonFilepath) "hello yml") aSet) #endif-   , testCase "does not support any other file extension" $ do-      fooFilepath <- getDataFileName "test/fixtures/config.foo"-      let-        input =-          mconcat-            [-              "{\"etc/filepaths\": ["-            , "\"" <> Text.pack fooFilepath <> "\""-            , "]}"-            ]+    fooFilepath <- getDataFileName "test/fixtures/config.foo"+    let input =+          mconcat ["{\"etc/filepaths\": [", "\"" <> Text.pack fooFilepath <> "\"", "]}"] -      (spec :: ConfigSpec ()) <- parseConfigSpec input-      (config, errs) <- resolveFiles spec+    (spec :: ConfigSpec ()) <- parseConfigSpec input+    (config, errs)          <- resolveFiles spec -      assertEqual "config should be empty" mempty config+    assertEqual "config should be empty" mempty config -      if Vector.null errs then-        assertFailure "expecting one error, got none"+    if Vector.null errs+      then assertFailure "expecting one error, got none"       else-        let-          err = Vector.head errs+        let err = Vector.head errs         in           case fromException err of-            Just (InvalidConfiguration _) ->-              return ()-            _ ->-              assertFailure ("Expecting InvalidConfigurationError; got instead "-                             <> show err)--+            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\""-            , "]}"-            ]+    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+    (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)+    case getAllConfigSources ["greeting"] config of+      Nothing -> assertFailure+        ("expecting to get entries for greeting (check fixtures)\n" <> show config)+      Just aSet -> assertBool+        ("expecting to see entry from json config file " <> show aSet)+        (Set.member (File 1 (Text.pack jsonFilepath) "hello json") aSet) -      if Vector.null errs then-        assertFailure "expecting one error, got none"+    if Vector.null errs+      then assertFailure "expecting one error, got none"       else-        let-          err =-            Vector.head errs+        let err = Vector.head errs         in           case fromException err of-            Just (ConfigurationFileNotFound _) ->-              return ()-            _ ->-              assertFailure ("Expecting ConfigurationFileNotFound; got instead "-                             <> show err)+            Just (ConfigurationFileNotFound _) -> return ()+            _ -> assertFailure+              ("Expecting ConfigurationFileNotFound; got instead " <> show err)+  , testCase "null file input has no precedence over default values" $ do+    jsonFilepath <- getDataFileName "test/fixtures/config.null.json"+    let input = mconcat+          [ "{\"etc/filepaths\": ["+          , "\"" <> Text.pack jsonFilepath <> "\""+          , "]"+          , ", \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"default\": \"hola\""+          , "}}}}"+          ]++    (spec :: ConfigSpec ()) <- parseConfigSpec input+    (configFiles, _errs)    <- resolveFiles spec+    let configDef = resolveDefault spec+        config    = configDef <> configFiles++    case getAllConfigSources ["greeting"] config of+      Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config)+      Just aSet ->+        let result = any+              (\entry -> case entry of+                File _ _ (Plain JSON.Null) -> True+                _                          -> False+              )+              aSet+        in  assertBool ("expecting to see entry from env; got " <> show aSet) result++    case getConfigValue ["greeting"] config of+      Just greeting -> assertEqual "Didn't take default value, despite CLI being null"+                                   ("hola" :: Text)+                                   greeting+      Nothing -> assertFailure "Expecting config value, but got nothing"   ]

@@ -5,15 +5,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.SpecTest (tests) where -import Protolude+import           RIO+import qualified RIO.HashMap as HashMap  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 qualified Data.Aeson as JSON  import System.Etc.Internal.Spec.Types import System.Etc.Spec@@ -23,151 +21,111 @@ import           Paths_etc (getDataFileName) #endif - getConfigValue :: [Text] -> HashMap Text (ConfigValue cmd) -> Maybe (ConfigValue cmd) getConfigValue keys hsh =   -- NOTE: For some reason, pattern matching doesn't work on lts-6, using   -- if/else instead-  if null keys then-      Nothing+                          if null keys+  then Nothing   else do-    let-      (k:ks) =-        keys+    let (k : ks) = keys     cv <- HashMap.lookup k hsh     case cv of-      SubConfig hsh1 ->-        getConfigValue ks hsh1-      value ->-        if null ks then-          Just value-        else-          Nothing+      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+general_tests = testGroup+  "general"+  [ testCase "does not fail when etc/entries is not defined" $ do+    let input = "{}" +    case parseConfigSpec input of+      Nothing -> assertFailure "should not fail if no etc/entries key is present"+      Just (_ :: 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+    let input = "{\"etc/entries\":{\"greeting\":{}}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "entries should not accept empty maps as values " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":[]}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "entries should not accept arrays as values " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":123}}"+        keys  = ["greeting"] -      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)+    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+    let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}"+        keys  = ["english", "greeting"] -      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)+    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+    let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not be an empty object " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":[]}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not be an array " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":true}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not be a boolean " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":\"hello\"}}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not be a string " ++ show result+      Nothing -> 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+    let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":123}}}" +    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not be a number " ++ show result+      Nothing -> 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}}}"+    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+    case parseConfigSpec input of+      Just (result :: ConfigSpec ()) ->+        assertFailure $ "etc/spec map should not contain more than one key " ++ show result+      Nothing -> assertBool "" True   ]  #ifdef WITH_CLI@@ -180,9 +138,9 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{}}}}}"        case parseConfigSpec input of-        Right (result :: ConfigSpec ()) ->+        Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should require a type " ++ show result-        Left _ ->+        Nothing ->           assertBool "" True    , testCase "cli option entry requires either short or long" $ do@@ -190,9 +148,9 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\"}}}}}"        case parseConfigSpec input of-        Right (result :: ConfigSpec ()) ->+        Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should require a type " ++ show result-        Left _ ->+        Nothing ->           assertBool "" True    , testCase "cli option entry works when setting short and type" $ do@@ -268,32 +226,29 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\",\"command\":[\"foo\"]}}}}}"        case parseConfigSpec input of-        Right (result :: ConfigSpec ()) ->+        Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should fail on invalid entry " ++ show result-        Left _ ->+        Nothing ->           assertBool "" True    ] #endif  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"]+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)+        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@@ -324,10 +279,9 @@ #endif  tests :: TestTree-tests =-  testGroup "spec"-  [-    general_tests+tests = testGroup+  "spec"+  [ general_tests #ifdef WITH_YAML   , yaml_tests #endif

@@ -3,12 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Protolude+import RIO -import Test.Tasty                   (defaultMainWithIngredients, testGroup)-import Test.Tasty.Ingredients.Rerun (rerunningTests)-import Test.Tasty.Runners           (consoleTestReporter, listingTests)+import Test.Tasty         (defaultMainWithIngredients, testGroup)+import Test.Tasty.Runners (consoleTestReporter, listingTests) +import qualified System.Etc.ConfigTest import qualified System.Etc.Resolver.DefaultTest import qualified System.Etc.Resolver.EnvTest import qualified System.Etc.Resolver.FileTest@@ -23,13 +23,15 @@ #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+main = defaultMainWithIngredients+  [listingTests, consoleTestReporter]+  (testGroup+    "etc"+    [ System.Etc.SpecTest.tests+    , System.Etc.ConfigTest.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@@ -37,4 +39,5 @@ #ifdef WITH_EXTRA                      , System.Etc.Extra.EnvMisspellTest.tests #endif-                     ])+    ]+  )

@@ -0,0 +1,3 @@+{+    "greeting": null+}