etc 0.4.0.3 → 0.4.1.0

raw patch · 23 files changed

+1043/−506 lines, 23 filesdep +template-haskelldep −hashablePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

Dependencies removed: hashable

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• etc.cabal +8/−3
• src/System/Etc.hs +28/−2
• src/System/Etc/Internal/Config.hs +4/−11
• src/System/Etc/Internal/Errors.hs +102/−0
• src/System/Etc/Internal/Extra/Printer.hs +50/−66
• src/System/Etc/Internal/Resolver/Cli/Command.hs +0/−1
• src/System/Etc/Internal/Resolver/Cli/Common.hs +40/−18
• src/System/Etc/Internal/Resolver/Env.hs +2/−1
• src/System/Etc/Internal/Resolver/File.hs +53/−58
• src/System/Etc/Internal/Spec/JSON.hs +11/−5
• src/System/Etc/Internal/Spec/JSON/TH.hs +25/−0
• src/System/Etc/Internal/Spec/Parser.hs +301/−0
• src/System/Etc/Internal/Spec/Types.hs +148/−275
• src/System/Etc/Internal/Spec/YAML.hs +17/−5
• src/System/Etc/Internal/Spec/YAML/TH.hs +24/−0
• src/System/Etc/Internal/Types.hs +1/−1
• src/System/Etc/Spec.hs +22/−6
• test/System/Etc/ConfigTest.hs +5/−4
• test/System/Etc/Resolver/Cli/PlainTest.hs +124/−5
• test/System/Etc/Resolver/FileTest.hs +31/−13
• test/System/Etc/SpecTest.hs +32/−32
• test/fixtures/config.spec.invalid.yaml +2/−0

@@ -1,3 +1,16 @@+0.4.1.0 (Release Candidate)+----++* Add `parseConfigSpecTH` functionality, now we can parse the `ConfigSpec`+  record at compilation time (closes #47)+* Remove bug on CLI option parser, now it will coerce numbers and+  booleans to string when specifying numbers and booleans over CLI+  and the field type is a string (closes #48)+* Improve Error Types to be more granular and descriptive+* Re-organize `Spec` parser functions in its own module+* Add `switch` input for CLI spec (closes #41)++ 0.4.0.3 ---- 

@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: etc-version: 0.4.0.3+version: 0.4.1.0 license: MIT license-file: LICENSE copyright: 2017, 2018 Roman Gonzalez@@ -21,6 +21,7 @@     test/fixtures/config.env.json     test/fixtures/config.null.json     test/fixtures/config.spec.yaml+    test/fixtures/config.spec.invalid.yaml     test/fixtures/config.yaml     test/fixtures/config.yml extra-source-files:@@ -51,8 +52,11 @@         System.Etc         System.Etc.Spec         System.Etc.Internal.Config+        System.Etc.Internal.Errors         System.Etc.Internal.Spec.JSON+        System.Etc.Internal.Spec.JSON.TH         System.Etc.Internal.Spec.Types+        System.Etc.Internal.Spec.Parser         System.Etc.Internal.Types         System.Etc.Internal.Resolver.Default         System.Etc.Internal.Resolver.File@@ -65,11 +69,11 @@     build-depends:         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+        unliftio >=0.1.1.0,+        template-haskell >=2.11.0.0          if flag(extra)         exposed-modules:@@ -93,6 +97,7 @@     if flag(yaml)         exposed-modules:             System.Etc.Internal.Spec.YAML+            System.Etc.Internal.Spec.YAML.TH         cpp-options: -DWITH_YAML         build-depends:             yaml >=0.8

@@ -16,10 +16,23 @@   , ConfigSource (..)   , ConfigValue   , ConfigSpec-  , ConfigurationError (..)   , parseConfigSpec   , readConfigSpec+  , readConfigSpecTH +  -- * Exceptions+  , InvalidConfigKeyPath (..)+  , ConfigValueParserFailed (..)+  , UnknownConfigKeyFound (..)+  , SubConfigEntryExpected (..)+  , ConfigValueTypeMismatchFound (..)+  , ConfigurationFileNotFound (..)+  , UnsupportedFileExtensionGiven (..)+  , ConfigInvalidSyntaxFound (..)+  , SpecInvalidSyntaxFound (..)+++   -- ** Resolvers   -- $resolvers   , resolveDefault@@ -60,7 +73,20 @@ import System.Etc.Internal.Types     (Config, ConfigSource (..), ConfigValue, IConfig (..), Value (..)) import System.Etc.Spec-    (ConfigSpec, ConfigurationError (..), parseConfigSpec, readConfigSpec)+    ( ConfigInvalidSyntaxFound (..)+    , ConfigSpec+    , ConfigValueParserFailed (..)+    , ConfigValueTypeMismatchFound (..)+    , ConfigurationFileNotFound (..)+    , InvalidConfigKeyPath (..)+    , SpecInvalidSyntaxFound (..)+    , SubConfigEntryExpected (..)+    , UnknownConfigKeyFound (..)+    , UnsupportedFileExtensionGiven (..)+    , parseConfigSpec+    , readConfigSpec+    , readConfigSpecTH+    )  #ifdef WITH_CLI import System.Etc.Internal.Resolver.Cli.Command (resolveCommandCli, resolveCommandCliPure)

@@ -1,7 +1,7 @@+{-# LANGUAGE NamedFieldPuns    #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} module System.Etc.Internal.Config where  import           RIO@@ -13,6 +13,7 @@ import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse) import qualified Data.Aeson.Types    as JSON (Parser) +import System.Etc.Internal.Errors import System.Etc.Internal.Types  --------------------------------------------------------------------------------@@ -46,22 +47,14 @@         Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of            JSON.IError path err ->-            let key = keys0 & Text.intercalate "."-            in  JSON.formatError path err-                & Text.pack-                & InvalidConfiguration (Just key)-                & throwM+            JSON.formatError path err & Text.pack & ConfigValueParserFailed keys0 & throwM            JSON.ISuccess result -> return result        ([], innerConfigValue) ->         case JSON.iparse parser (configValueToJsonObject innerConfigValue) of           JSON.IError path err ->-            let key = keys0 & Text.intercalate "."-            in  JSON.formatError path err-                & Text.pack-                & InvalidConfiguration (Just key)-                & throwM+            JSON.formatError path err & Text.pack & ConfigValueParserFailed keys0 & throwM            JSON.ISuccess result -> return result 

@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE NoImplicitPrelude     #-}+module System.Etc.Internal.Errors where++import RIO++import qualified Data.Aeson as JSON++import System.Etc.Internal.Spec.Types++-- | Thrown when calling the 'getConfig' or 'getConfigWith' functions on a key+-- that does not exist in the configuration spec+newtype InvalidConfigKeyPath = InvalidConfigKeyPath {+    inputKeys :: [Text] -- ^ Input Keys+  }+  deriving (Generic, Show, Read, Eq)++instance Exception InvalidConfigKeyPath++-- | Thrown when there is a type mismatch in a JSON parser given via+-- 'getConfigWith'+data ConfigValueParserFailed = ConfigValueParserFailed {+      inputKeys          :: ![Text] -- ^ Input Keys+    , parserErrorMessage :: !Text   -- ^ Parser Error Message+    }+  deriving (Generic, Show, Read, Eq)++instance Exception ConfigValueParserFailed++-- | Thrown when the 'resolveFile' function finds a key on a configuration+-- file that is not specified in the given configuration spec+data UnknownConfigKeyFound = UnknownConfigKeyFound {+      parentKeys  :: ![Text] -- ^ Parent Keys+    , keyName     :: !Text   -- ^ Key Name+    , siblingKeys :: ![Text] -- ^ Sibling Keys (other keys in the same level)+    }+  deriving (Generic, Show, Read, Eq)++instance Exception UnknownConfigKeyFound++-- | Thrown when there is a type mismatch on a configuration entry,+-- specifically, when there is a raw value instead of a sub-config in a+-- configuration file+data SubConfigEntryExpected =+  SubConfigEntryExpected {+      keyName     :: !Text -- ^ Key Name+    , configValue :: !JSON.Value -- ^ Config Value+    }+  deriving (Generic, Show, Read, Eq)++instance Exception SubConfigEntryExpected++-- | This error is thrown when a type mismatch is found in a raw value when+-- calling 'resolveFile'+data ConfigValueTypeMismatchFound = ConfigValueTypeMismatchFound {+      keyName              :: !Text -- ^ Key Name+    , configValueEntry     :: !JSON.Value -- ^ Config Value+    , configValueEntryType :: !ConfigValueType -- ^ Config Value Type+    }+  deriving (Generic, Show, Read, Eq)++instance Exception ConfigValueTypeMismatchFound++-- | Thrown when a specified configuration file is not found in the system+newtype ConfigurationFileNotFound =+  ConfigurationFileNotFound {+      configFilepath :: Text -- ^ Config FilePath+    }+  deriving (Generic, Show, Read, Eq)++instance Exception ConfigurationFileNotFound++-- | Thrown when an input configuration file contains an unsupported file+-- extension+newtype UnsupportedFileExtensionGiven =+  UnsupportedFileExtensionGiven {+      configFilepath :: Text -- ^ Config FilePath+  }+  deriving (Generic, Show, Read, Eq)++instance Exception UnsupportedFileExtensionGiven++-- | Thrown when an input configuration file contains invalid syntax+data ConfigInvalidSyntaxFound+  = ConfigInvalidSyntaxFound {+      configFilepath     :: !Text -- ^ Config FilePath+    , parserErrorMessage :: !Text -- ^ Parser Error Message+    }+  deriving (Generic, Show, Read, Eq)++instance Exception ConfigInvalidSyntaxFound++-- | Thrown when an configuration spec file contains invalid syntax+data SpecInvalidSyntaxFound = SpecInvalidSyntaxFound {+     specFilepath      :: !(Maybe Text) -- ^ Spec FilePath+   , parseErrorMessage :: !Text -- ^ Parser Error Message+   }+  deriving (Generic, Show, Read, Eq)++instance Exception SpecInvalidSyntaxFound

@@ -20,7 +20,7 @@  import qualified Data.Aeson as JSON -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Text.PrettyPrint.ANSI.Leijen  import System.Etc.Internal.Types @@ -30,13 +30,13 @@   , blueColor  :: !(Doc -> Doc)   } -renderConfigValueJSON :: JSON.Value -> Either Text Doc+renderConfigValueJSON :: JSON.Value -> Doc renderConfigValueJSON value = case value of-  JSON.Null                         -> Right $ text "null"-  JSON.String str                   -> Right $ text $ Text.unpack str-  JSON.Number scientific            -> Right $ text $ show scientific-  JSON.Bool   b                     -> Right $ if b then text "true" else text "false"-  JSON.Array  (Vector.null -> True) -> return $ text "[]"+  JSON.Null                         -> text "null"+  JSON.String str                   -> text $ Text.unpack str+  JSON.Number scientific            -> text $ show scientific+  JSON.Bool   b                     -> if b then text "true" else text "false"+  JSON.Array  (Vector.null -> True) -> text "[]"   JSON.Array  arr                   -> do     -- unsafeHead is not unsafe here because of previous check; also we are     -- assuming all values in the array are of the same type@@ -49,104 +49,91 @@       -- - foo: bar       --   baz: wat       ---      JSON.Object{} -> do-        values <- forM arr $ \v -> do-          v1 <- renderConfigValueJSON v-          return $ hang 2 ("-" <+> v1)--        return $ align (vsep $ Vector.toList values)+      JSON.Object{} -> align+        (vsep $ Vector.toList $ Vector.map+          (\v -> hang 2 ("-" <+> renderConfigValueJSON v))+          arr+        )        -- When rendering primitive values:       --       -- - hello       -- - world       ---      _ -> do-        values <- forM arr $ \v -> do-          v1 <- renderConfigValueJSON v-          return $ "-" <+> v1--        return $ align (vsep $ Vector.toList values)+      _ -> align+        (vsep $ Vector.toList $ Vector.map (\v -> "-" <+> renderConfigValueJSON v) arr) -  JSON.Object obj -> do-    values <- forM (HashMap.toList obj) $ \(k, v) -> case v of+  JSON.Object obj -> align $ vsep $ map+    (\(k, v) -> case v of         -- When rendering Objects within Objects; output:         --         -- attr1:         --  attr2: hello         ---      JSON.Object{} -> do-        v1 <- renderConfigValueJSON v-        return $ nest 2 (text (Text.unpack k) <> ":" <> hardline <> v1)+      JSON.Object{} ->+        nest 2 (text (Text.unpack k) <> ":" <> hardline <> renderConfigValueJSON v)        -- When rendering Arrays within Objects; output:       --       -- attr1:       -- - hello       ---      JSON.Array{} -> do-        v1 <- renderConfigValueJSON v-        return $ text (Text.unpack k) <> ":" <> hardline <> v1+      JSON.Array{} -> text (Text.unpack k) <> ":" <> hardline <> renderConfigValueJSON v        -- When rendering primitive values       --       -- hello: world       --       ---      _ -> do-        v1 <- renderConfigValueJSON v-        return $ text (Text.unpack k) <> ":" <+> v1--    return $ align (vsep values)+      _            -> text (Text.unpack k) <> ":" <+> renderConfigValueJSON v+    )+    (HashMap.toList obj)  -renderConfigValue-  :: (JSON.Value -> Either Text Doc) -> Value JSON.Value -> Either Text [Doc]+renderConfigValue :: (JSON.Value -> Doc) -> Value JSON.Value -> [Doc] renderConfigValue f value = case value of-  Plain (JSON.Array jsonArray) -> fmap Vector.toList <$> forM jsonArray $ \jsonValue -> do-    valueDoc <- f jsonValue-    return $ text "-" <+> valueDoc-  Plain jsonValue -> fmap return (f jsonValue)-  Sensitive{}     -> Right $ return $ text "<<sensitive>>"+  Plain (JSON.Array jsonArray) ->+    Vector.toList $ Vector.map (\jsonValue -> text "-" <+> f jsonValue) jsonArray+  Plain jsonValue -> return $ f jsonValue+  Sensitive{}     -> return $ text "<<sensitive>>" -renderConfigSource-  :: (JSON.Value -> Either Text Doc) -> ConfigSource -> Either Text ([Doc], Doc)+renderConfigSource :: (JSON.Value -> Doc) -> ConfigSource -> ([Doc], Doc) renderConfigSource f configSource = case configSource of-  Default value -> do+  Default value ->     let sourceDoc = text "Default"-    valueDoc <- renderConfigValue f value-    return (valueDoc, sourceDoc)+        valueDoc  = renderConfigValue f value+    in  (valueDoc, sourceDoc)    File _index fileSource value ->     let sourceDoc = case fileSource of           FilePathSource filepath -> text "File:" <+> text (Text.unpack filepath)           EnvVarFileSource envVar filepath ->             text "File:" <+> text (Text.unpack envVar) <> "=" <> text (Text.unpack filepath)-    in  do-          valueDoc <- renderConfigValue f value-          return (valueDoc, sourceDoc)+        valueDoc = renderConfigValue f value+    in  (valueDoc, sourceDoc) -  Env varname value -> do+  Env varname value ->     let sourceDoc = text "Env:" <+> text (Text.unpack varname)-    valueDoc <- renderConfigValue f value-    return (valueDoc, sourceDoc)+        valueDoc  = renderConfigValue f value+    in  (valueDoc, sourceDoc) -  Cli value -> do+  Cli value ->     let sourceDoc = text "Cli"-    valueDoc <- renderConfigValue f value-    return (valueDoc, sourceDoc)+        valueDoc  = renderConfigValue f value+    in  (valueDoc, sourceDoc) -  None -> return (mempty, mempty)+  None -> (mempty, mempty)  renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc renderConfig_ ColorFn { blueColor } (Config configMap) =   let-    renderSources :: MonadThrow m => Text -> [ConfigSource] -> m Doc-    renderSources keyPath sources =-      let eSourceDocs = mapM (renderConfigSource renderConfigValueJSON) sources+    renderSources :: MonadThrow m => [ConfigSource] -> m Doc+    renderSources sources =+      let sourceDocs = map (renderConfigSource renderConfigValueJSON) sources -          brackets'   = enclose (lbracket <> space) (space <> rbracket)+          brackets'  = enclose (lbracket <> space) (space <> rbracket) +          layoutSourceValueDoc :: MonadThrow m => [Doc] -> Doc -> m Doc           layoutSourceValueDoc valueDocs sourceDoc = case valueDocs of             [] ->               -- [Default]@@ -166,18 +153,15 @@               --   - Value 3               --               return $ sourceDoc <$$> indent 2 (align (vsep multipleValues))-      in  case eSourceDocs of-            Left  err -> throwM $ InvalidConfiguration (Just keyPath) err--            Right []  -> throwM $ InvalidConfiguration-              (Just keyPath)-              "Trying to render config entry with no values"+      in  case sourceDocs of+            -- No Value Found+            [] -> return $ indent 2 $ text "No Value Found"              -- [ (*) CLI ]             --   - Value 1             -- [ Default ]             --   - Value-            Right ((selectedValueDoc, selectedSourceDoc) : otherSourceDocs) -> do+            ((selectedValueDoc, selectedSourceDoc) : otherSourceDocs) -> do               selectedDoc <- layoutSourceValueDoc selectedValueDoc                 $ brackets' (parens (text "*") <+> selectedSourceDoc) @@ -203,7 +187,7 @@         in  if null sources               then return []               else do-                configSources <- renderSources keyPathText sources+                configSources <- renderSources sources                 return [blueColor (text $ Text.unpack keyPathText) <$$> configSources]   in     do

@@ -8,7 +8,6 @@ import qualified RIO.HashMap as HashMap import qualified RIO.Text    as Text -import Data.Hashable      (Hashable) import System.Environment (getArgs, getProgName)  import qualified Data.Aeson          as JSON

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP               #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}@@ -19,7 +20,8 @@  import System.Exit -import qualified System.Etc.Internal.Spec.Types as Spec+import qualified System.Etc.Internal.Spec.Parser as Spec+import qualified System.Etc.Internal.Spec.Types  as Spec import           System.Etc.Internal.Types  --------------------------------------------------------------------------------@@ -58,18 +60,28 @@  -------------------------------------------------------------------------------- -specToCliSwitchFieldMod specSettings =-  maybe Opt.idm (Opt.long . Text.unpack) (Spec.optLong specSettings)+#if MIN_VERSION_optparse_applicative(0,14,0)+specToCliOptFieldMod :: Opt.HasName f => Spec.CliOptMetadata -> Opt.Mod f a+#endif+specToCliOptFieldMod meta =+  maybe Opt.idm (Opt.long . Text.unpack) (Spec.optLong meta)     `mappend` maybe Opt.idm Opt.short                shortOption-    `mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.optHelp specSettings)+    `mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.optHelp meta)  where   shortOption = do-    shortStr <- Spec.optShort specSettings+    shortStr <- Spec.optShort meta     fst <$> Text.uncons shortStr -specToCliVarFieldMod specSettings = specToCliSwitchFieldMod specSettings-  `mappend` maybe Opt.idm (Opt.metavar . Text.unpack) (Spec.optMetavar specSettings)+#if MIN_VERSION_optparse_applicative(0,14,0)+specToCliSwitchFieldMod :: Opt.HasName f => Spec.CliSwitchMetadata -> Opt.Mod f a+#endif+specToCliSwitchFieldMod meta =+  Opt.long (Text.unpack $ Spec.switchLong meta)+    `mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.switchHelp meta) +specToCliArgFieldMod :: Spec.CliArgMetadata -> Opt.Mod f a+specToCliArgFieldMod meta = maybe Opt.idm (Opt.help . Text.unpack) (Spec.argHelp meta)+ commandToKey :: (MonadThrow m, JSON.ToJSON cmd) => cmd -> m [Text] commandToKey cmd = case JSON.toJSON cmd of   JSON.String commandStr -> return [commandStr]@@ -88,25 +100,35 @@   let contentText = Text.pack content       jsonValue   = fromMaybe (JSON.String contentText)                               (JSON.decodeStrict' $ Text.encodeUtf8 contentText)-  in  if Spec.matchesConfigValueType jsonValue cvType-        then Right $ markAsSensitive isSensitive jsonValue-        else Left "input is not valid"+  in  case Spec.coerceConfigValueType contentText jsonValue cvType of+        Nothing -> Left "input is not valid"+        Just jsonValue1+          | Spec.matchesConfigValueType jsonValue1 cvType -> Right+          $ markAsSensitive isSensitive jsonValue1+          | otherwise -> Left "input is not valid"  settingsToJsonCli   :: Spec.ConfigValueType   -> Bool   -> Spec.CliEntryMetadata   -> Opt.Parser (Maybe (Value JSON.Value))-settingsToJsonCli cvType isSensitive specSettings =-  let requiredCombinator =-        if Spec.optRequired specSettings then (Just <$>) else Opt.optional-  in  requiredCombinator $ case specSettings of-        Spec.Opt{} -> Opt.option (Opt.eitherReader $ jsonOptReader cvType isSensitive)-                                 (specToCliVarFieldMod specSettings)+settingsToJsonCli cvType isSensitive specSettings = case specSettings of+  Spec.Opt meta ->+    let requiredCombinator = if Spec.optRequired meta then (Just <$>) else Opt.optional+    in  requiredCombinator $ Opt.option+          (Opt.eitherReader $ jsonOptReader cvType isSensitive)+          (specToCliOptFieldMod meta) -        Spec.Arg{} -> Opt.argument+  Spec.Arg meta ->+    let requiredCombinator = if Spec.argRequired meta then (Just <$>) else Opt.optional+    in  requiredCombinator $ Opt.argument           (Opt.eitherReader $ jsonOptReader cvType isSensitive)-          (specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack))+          (specToCliArgFieldMod meta)++  Spec.Switch meta ->+    let requiredCombinator = fmap (Just . Plain . JSON.Bool)+    in  requiredCombinator (Opt.switch (specToCliSwitchFieldMod meta)) <|> pure Nothing+   parseCommandJsonValue :: (MonadThrow m, JSON.FromJSON a) => JSON.Value -> m a

@@ -10,7 +10,8 @@  import Control.Arrow ((***)) -import qualified System.Etc.Internal.Spec.Types as Spec+import qualified System.Etc.Internal.Spec.Parser as Spec+import qualified System.Etc.Internal.Spec.Types  as Spec import           System.Etc.Internal.Types  resolveEnvVarSource

@@ -1,7 +1,8 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Internal.Resolver.File (resolveFiles) where  import           RIO@@ -12,17 +13,19 @@ import qualified RIO.Vector    as Vector  #ifdef WITH_YAML-import qualified Data.Yaml as YAML+import System.Etc.Internal.Spec.YAML (decodeYaml) #endif -import qualified Data.Aeson          as JSON-import qualified Data.Aeson.Internal as JSON (IResult (..), iparse)+import qualified Data.Aeson as JSON+-- import qualified Data.Aeson.Internal as JSON (IResult (..), iparse) import qualified RIO.ByteString.Lazy as LB8  import System.Environment (lookupEnv) -import qualified System.Etc.Internal.Spec.Types as Spec-import           System.Etc.Internal.Types      hiding (filepath)+import           System.Etc.Internal.Errors+import qualified System.Etc.Internal.Spec.Parser as Spec+import qualified System.Etc.Internal.Spec.Types  as Spec+import           System.Etc.Internal.Types       hiding (filepath)  -------------------------------------------------------------------------------- @@ -34,56 +37,39 @@ --------------------------------------------------------------------------------  parseConfigValue-  :: Monad m+  :: (MonadThrow m)   => [Text]-  -> Maybe (Spec.ConfigValue cmd)+  -> Spec.ConfigValue cmd   -> Int   -> FileSource   -> JSON.Value   -> m ConfigValue-parseConfigValue keys mSpec fileIndex fileSource json =--  let currentKey = Text.intercalate "." $ reverse keys-  in-    case json of-      JSON.Object object -> SubConfig <$> foldM-        (\acc (key, subConfigValue) -> do-          let msubConfigSpec = do-                spec <- mSpec-                case spec of-                  Spec.SubConfig hsh -> HashMap.lookup key hsh-                  _ ->-                    -- TODO: This should be an error given the config doesn't match spec-                    fail "configuration spec and configuration value are different"+parseConfigValue keys spec fileIndex fileSource json =+  let parentKeys = reverse keys+      currentKey = Text.intercalate "." parentKeys+  in  case (spec, json) of+        (Spec.SubConfig currentSpec, JSON.Object object) -> SubConfig <$> foldM+          (\acc (key, subConfigValue) -> case HashMap.lookup key currentSpec of+            Nothing ->+              throwM $ UnknownConfigKeyFound parentKeys key (HashMap.keys currentSpec)+            Just subConfigSpec -> do+              value1 <- parseConfigValue (key : keys)+                                         subConfigSpec+                                         fileIndex+                                         fileSource+                                         subConfigValue+              return $ HashMap.insert key value1 acc+          )+          HashMap.empty+          (HashMap.toList object) -          value1 <- parseConfigValue (key : keys)-                                     msubConfigSpec-                                     fileIndex-                                     fileSource-                                     subConfigValue-          return $ HashMap.insert key value1 acc-        )-        HashMap.empty-        (HashMap.toList object)+        (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json -      _ -> case mSpec of-        Just Spec.ConfigValue { Spec.isSensitive, Spec.configValueType } -> do-          Spec.assertMatchingConfigValueType json configValueType+        (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do+          either throwM return $ Spec.assertMatchingConfigValueType json configValueType           return $ ConfigValue             (Set.singleton $ File fileIndex fileSource $ markAsSensitive isSensitive json)-        Just _ ->-          fail-            $  Text.unpack-            $  "Configuration entry `"-            <> currentKey-            <> "` does not follow spec" -        Nothing ->-          fail-            $  Text.unpack-            $  "Configuration entry `"-            <> currentKey-            <> "` is not present on spec"   eitherDecode :: ConfigFile -> Either String JSON.Value@@ -93,7 +79,7 @@     JsonFile _ contents ->       JSON.eitherDecode contents     YamlFile _ contents ->-      YAML.decodeEither (LB8.toStrict contents)+      decodeYaml (LB8.toStrict contents) #else eitherDecode contents0 = case contents0 of   JsonFile _        contents -> JSON.eitherDecode contents@@ -104,12 +90,17 @@ parseConfig   :: MonadThrow m => Spec.ConfigValue cmd -> Int -> FileSource -> ConfigFile -> m Config parseConfig spec fileIndex fileSource contents = case eitherDecode contents of-  Left err -> throwM $ InvalidConfiguration Nothing (Text.pack err)--  Right json ->-    case JSON.iparse (parseConfigValue [] (Just spec) fileIndex fileSource) json of-      JSON.IError _ err    -> throwM $ InvalidConfiguration Nothing (Text.pack err)-      JSON.ISuccess result -> return (Config result)+  Left err -> throwM $ ConfigInvalidSyntaxFound (fileSourcePath fileSource) (Text.pack err)+  -- Right json ->+  --   case JSON.iparse (parseConfigValue [] spec fileIndex fileSource) json of+  --     JSON.IError _ err    ->+  --       case readMaybe err of+  --         Just (e :: ConfigError) ->+  --           throwM e+  --         _ ->+  --           throwM $ InvalidConfiguration Nothing (Text.pack err)+  --     JSON.ISuccess result -> return (Config result)+  Right json -> Config <$> parseConfigValue [] spec fileIndex fileSource json  readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile) readConfigFile filepath =@@ -126,8 +117,7 @@           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 $ UnsupportedFileExtensionGiven filepath)         else return $ throwM $ ConfigurationFileNotFound filepath  readConfigFromFileSources@@ -184,3 +174,8 @@ resolveFiles spec = do   (config, exceptions) <- processFilesSpec spec   return (config, Vector.fromList exceptions)+++-- validateConfigFiles :: Spec.ConfigSpec cmd -> Config -> IO ()+-- validateConfigFiles Spec.ConfigSpec {Spec.specConfigFilepaths, Spec.specConfigValues} =+--   undefined

@@ -9,15 +9,21 @@  import qualified Data.Aeson as JSON +import System.Etc.Internal.Errors+import System.Etc.Internal.Spec.Parser () import System.Etc.Internal.Spec.Types -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)+parseConfigSpec_+  :: (MonadThrow m, JSON.FromJSON cmd) => Maybe Text -> Text -> m (ConfigSpec cmd)+parseConfigSpec_ mFilePath input =+  case JSON.eitherDecode (LBS.fromStrict $ encodeUtf8 input) of+    Left  err    -> throwM $ SpecInvalidSyntaxFound mFilePath (Text.pack err)+    Right result -> return result -  Right result -> return result+parseConfigSpec :: (MonadThrow m, JSON.FromJSON cmd) => Text -> m (ConfigSpec cmd)+parseConfigSpec = parseConfigSpec_ Nothing  readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) readConfigSpec filepath = do   contents <- Text.readFile (Text.unpack filepath)-  parseConfigSpec contents+  parseConfigSpec_ (Just filepath) contents

@@ -0,0 +1,25 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+module System.Etc.Internal.Spec.JSON.TH where++import RIO++import Data.Proxy (Proxy)++import Language.Haskell.TH        (ExpQ, runIO)+import Language.Haskell.TH.Syntax (Lift)++import qualified Data.Aeson as JSON++import System.Etc.Internal.Spec.JSON  (readConfigSpec)+import System.Etc.Internal.Spec.Types (ConfigSpec)++readConfigSpecTH_ :: (Lift k) => Proxy k -> (Text -> IO (ConfigSpec k)) -> Text -> ExpQ+readConfigSpecTH_ _ readSpec filepath = do+  configSpec <- runIO $ readSpec filepath+  [| configSpec |]++readConfigSpecTH :: (Lift k, JSON.FromJSON k) => Proxy k -> Text -> ExpQ+readConfigSpecTH = flip readConfigSpecTH_ readConfigSpec

@@ -0,0 +1,301 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module System.Etc.Internal.Spec.Parser where++import RIO++import qualified RIO.HashMap as HashMap+import qualified RIO.Text    as Text++import Prelude (fail)++import qualified RIO.Vector.Partial as Vector (head)++import Data.Aeson ((.:), (.:?))++import qualified Data.Aeson       as JSON+import qualified Data.Aeson.Types as JSON (Parser, typeMismatch)++import System.Etc.Internal.Errors+import System.Etc.Internal.Spec.Types++--------------------------------------------------------------------------------+-- CLI++instance JSON.FromJSON CliCmdSpec where+  parseJSON json =+    case json of+      JSON.Object object ->+        CliCmdSpec+        <$> object .: "desc"+        <*> object .: "header"+      _ ->+        JSON.typeMismatch "CliCmdSpec" json++instance JSON.FromJSON CliProgramSpec where+  parseJSON json =+    case json of+      JSON.Object object ->+        CliProgramSpec+        <$> object .: "desc"+        <*> object .: "header"+        <*> object .:? "commands"+      _ ->+        JSON.typeMismatch "CliProgramSpec" json++cliArgTypeParser :: JSON.Object -> JSON.Parser CliArgValueType+cliArgTypeParser object = do+  value <- object .: "type"+  case value of+    JSON.String typeName+      | typeName == "string" -> return StringArg+      | typeName == "number" -> return NumberArg+      | otherwise            -> JSON.typeMismatch "CliArgValueType (string, number)" value+    _ -> JSON.typeMismatch "CliArgValueType (string, number)" value++cliArgParser :: JSON.Object -> JSON.Parser CliEntryMetadata+cliArgParser object =+  Arg+    <$> (   CliArgMetadata+        <$> (object .:? "metavar")+        <*> (object .:? "help")+        <*> (fromMaybe True <$> (object .:? "required"))+        )++cliOptParser :: JSON.Object -> JSON.Parser CliEntryMetadata+cliOptParser object = do+  long  <- object .:? "long"+  short <- object .:? "short"+  if isNothing long && isNothing short+    then fail "'option' field input requires either 'long' or 'short' settings"+    else+      Opt+        <$> (   CliOptMetadata+            <$> pure long+            <*> pure short+            <*> (object .:? "metavar")+            <*> (object .:? "help")+            <*> (fromMaybe True <$> (object .:? "required"))+            )++cliSwitchParser :: JSON.Object -> JSON.Parser CliEntryMetadata+cliSwitchParser object =+  Switch <$> (CliSwitchMetadata <$> (object .: "long") <*> (object .:? "help"))+++cliArgKeys :: [Text]+cliArgKeys = ["input", "commands", "metavar", "required"]++cliOptKeys :: [Text]+cliOptKeys = ["short", "long", "help"] ++ cliArgKeys++instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where+  parseJSON json =+      case json of+        JSON.Object object -> do+          cmdValue   <- object .:? "commands"+          value <- object .: "input"++          let+            optParseEntryCtor =+              maybe PlainEntry CmdEntry cmdValue++          case value of+            JSON.String inputName+              | inputName == "option" -> do+                forM_ (HashMap.keys object) $ \key ->+                  when (not (key `elem` cliOptKeys))+                    (fail $ "cli option contains invalid key " ++ show key)++                optParseEntryCtor <$> cliOptParser object++              | inputName == "argument" -> do+                forM_ (HashMap.keys object) $ \key ->+                  when (not (key `elem` cliArgKeys))+                    (fail $ "cli option contains invalid key " ++ show key)++                optParseEntryCtor <$> cliArgParser object++              | inputName == "switch" -> do+                forM_ (HashMap.keys object) $ \key ->+                  when (not (key `elem` cliOptKeys))+                    (fail $ "cli option contains invalid key " ++ show key)++                optParseEntryCtor <$> cliSwitchParser object++              | otherwise ->+                JSON.typeMismatch "Invalid input (option, argument, switch)" value+            _ ->+              JSON.typeMismatch "Invalid input (option, argument, switch)" value+        _ ->+          JSON.typeMismatch "Invalid input (option, argument, switch)" json++--------------------------------------------------------------------------------++instance JSON.FromJSON ConfigValueType where+  parseJSON = JSON.withText "ConfigValueType (string, number, bool)" $ \tyText ->+    case Text.toLower tyText of+      "string"   -> pure $ CVTSingle CVTString+      "number"   -> pure $ CVTSingle CVTNumber+      "bool"     -> pure $ CVTSingle CVTBool+      "[string]" -> pure $ CVTArray CVTString+      "[number]" -> pure $ CVTArray CVTNumber+      "[bool]"   -> pure $ CVTArray CVTBool+      "[object]" -> pure $ CVTArray CVTObject+      _  -> JSON.typeMismatch "ConfigValueType (string, number, bool)" (JSON.String tyText)++inferErrorMsg :: String+inferErrorMsg = "could not infer type from given default value"++parseBytesToConfigValueJSON :: ConfigValueType -> Text -> Maybe JSON.Value+parseBytesToConfigValueJSON cvType content =+  case JSON.eitherDecodeStrict' (Text.encodeUtf8 content) of+    Right value | matchesConfigValueType value cvType -> return value+                | otherwise                           -> Nothing+    Left _err+      | matchesConfigValueType (JSON.String content) cvType -> return (JSON.String content)+      | otherwise -> Nothing++jsonToConfigValueType :: JSON.Value -> Either String ConfigValueType+jsonToConfigValueType json = case json of+  JSON.String{} -> Right $ CVTSingle CVTString+  JSON.Number{} -> Right $ CVTSingle CVTNumber+  JSON.Bool{}   -> Right $ CVTSingle CVTBool+  JSON.Array arr+    | null arr -> Left inferErrorMsg+    | otherwise -> case jsonToConfigValueType (Vector.head arr) of+      Right CVTArray{}     -> Left "nested arrays values are not supported"+      Right (CVTSingle ty) -> Right $ CVTArray ty+      Left  err            -> Left err+  _ -> Left inferErrorMsg++coerceConfigValueType :: Text -> JSON.Value -> ConfigValueType -> Maybe JSON.Value+coerceConfigValueType rawValue json cvType = case (json, cvType) of+  (JSON.Null    , CVTSingle _        ) -> Just JSON.Null+  (JSON.String{}, CVTSingle CVTString) -> Just json+  (JSON.Number{}, CVTSingle CVTNumber) -> Just json+  (JSON.Bool{}  , CVTSingle CVTBool  ) -> Just json+  (JSON.Object{}, CVTSingle CVTObject) -> Just json+  (JSON.Array{} , CVTArray{}         ) -> Just json+  (JSON.Number{}, CVTSingle CVTString) -> Just (JSON.String rawValue)+  (JSON.Bool{}  , CVTSingle CVTString) -> Just (JSON.String rawValue)+  _                                    -> Nothing++matchesConfigValueType :: JSON.Value -> ConfigValueType -> Bool+matchesConfigValueType json cvType = case (json, cvType) of+  (JSON.Null    , CVTSingle _        ) -> True+  (JSON.String{}, CVTSingle CVTString) -> True+  (JSON.Number{}, CVTSingle CVTNumber) -> True+  (JSON.Bool{}  , CVTSingle CVTBool  ) -> True+  (JSON.Object{}, CVTSingle CVTObject) -> True+  (JSON.Array arr, CVTArray inner) ->+    if null arr then True else all (`matchesConfigValueType` CVTSingle inner) arr+  _ -> False++assertMatchingConfigValueType :: JSON.Value -> ConfigValueType -> Either SomeException ()+assertMatchingConfigValueType json cvType+  | matchesConfigValueType json cvType = Right ()+  | otherwise = Left $ toException $ ConfigValueTypeMismatchFound "" json cvType++getConfigValueType+  :: Maybe JSON.Value -> Maybe ConfigValueType -> JSON.Parser ConfigValueType+getConfigValueType mdefValue mCvType = case (mdefValue, mCvType) of+  (Just JSON.Null, Just cvType) -> pure cvType++  (Just defValue , Just cvType) -> do+    either (fail . show) return $ assertMatchingConfigValueType defValue cvType+    return cvType++  (Nothing      , Just cvType) -> pure cvType++  (Just defValue, Nothing    ) -> either fail pure $ jsonToConfigValueType defValue++  (Nothing      , Nothing    ) -> fail inferErrorMsg++instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where+  parseJSON json  =+    case json of+      JSON.Object object ->+        case HashMap.lookup "etc/spec" object of+          -- normal object+          Nothing -> do+            subConfigMap <- foldM+                        (\subConfigMap (key, value) -> do+                            innerValue <- JSON.parseJSON value+                            return $ HashMap.insert key innerValue subConfigMap)+                        HashMap.empty+                        (HashMap.toList object)+            if HashMap.null subConfigMap then+              fail "Entries cannot have empty maps as values"+            else+              return (SubConfig subConfigMap)++          -- etc spec value object+          Just (JSON.Object fieldSpec) ->+            if HashMap.size object == 1 then do+              -- NOTE: not using .:? here as it casts JSON.Null to Nothing, we+              -- want (Just JSON.Null) returned+              let mDefaultValue = maybe Nothing Just $ HashMap.lookup "default" fieldSpec+              mSensitive    <- fieldSpec .:? "sensitive"+              mCvType       <- fieldSpec .:? "type"+              let sensitive = fromMaybe False mSensitive+              ConfigValue+                <$> pure mDefaultValue+                <*> getConfigValueType mDefaultValue mCvType+                <*> pure sensitive+                <*> (ConfigSources <$> fieldSpec .:? "env"+                                   <*> fieldSpec .:? "cli")+            else+              fail "etc/spec object can only contain one key"++          -- any other JSON value+          Just _ ->+            fail "etc/spec value must be a JSON object"++      _ -> do+        cvType <- either fail pure $ jsonToConfigValueType json+        return+          ConfigValue+          {+            defaultValue    = Just json+          , configValueType = cvType+          , isSensitive     = False+          , configSources   = ConfigSources Nothing Nothing+          }++parseFiles :: JSON.Value -> JSON.Parser FilesSpec+parseFiles = JSON.withObject "FilesSpec" $ \object -> do+  files  <- object .: "etc/files"+  mEnv   <- files .:? "env"+  mPaths <- files .:? "paths"+  if isNothing mEnv && isNothing mPaths+    then fail "either `env` or a `paths` keys are required when using `etc/files`"+    else return $ FilesSpec mEnv (fromMaybe [] mPaths)++parseFilePaths :: JSON.Value -> JSON.Parser FilesSpec+parseFilePaths =+  JSON.withObject "FilesSpec" $ \object -> FilePathsSpec <$> object .: "etc/filepaths"++parseFileSpec :: JSON.Value -> JSON.Parser (Maybe FilesSpec)+parseFileSpec json@(JSON.Object object) = do+  mFiles     <- object .:? "etc/files"+  mFilePaths <- object .:? "etc/filepaths"+  if isJust (mFiles :: Maybe JSON.Value) && isJust (mFilePaths :: Maybe JSON.Value)+    then fail "either the `etc/files` or `etc/filepaths` key can be used; not both"+    else if isJust mFiles+      then Just <$> parseFiles json+      else if isJust mFilePaths then Just <$> parseFilePaths json else pure Nothing+parseFileSpec _ = pure Nothing++instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where+  parseJSON json =+    case json of+      JSON.Object object ->+        ConfigSpec+        <$> parseFileSpec json+        <*> (object .:? "etc/cli")+        <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))+      _ ->+        JSON.typeMismatch "ConfigSpec" json

@@ -1,58 +1,116 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP                        #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes      #-}+#else+{-# LANGUAGE TemplateHaskell            #-}+#endif+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveLift                 #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE OverloadedStrings          #-} module System.Etc.Internal.Spec.Types where -import Prelude (fail)  import           RIO import qualified RIO.HashMap        as HashMap import qualified RIO.Text           as Text-import qualified RIO.Vector.Partial as Vector (head)+import qualified RIO.Vector         as Vector -import Data.Aeson ((.:), (.:?))+import Language.Haskell.TH.Syntax (Lift(..))  import qualified Data.Aeson       as JSON-import qualified Data.Aeson.Types as JSON (Parser, typeMismatch)  ----------------------------------------------------------------------------------- Error Types--data ConfigurationError-  = InvalidConfiguration !(Maybe Text) !Text-  | InvalidConfigKeyPath ![Text]-  | ConfigurationFileNotFound !Text-  deriving (Generic, Show)--instance Exception ConfigurationError----------------------------------------------------------------------------------+-- Cli  data CliOptValueType   = StringOpt   | NumberOpt   | SwitchOpt-  deriving (Generic, Show, Eq)+  deriving (Generic, Show, Eq, Lift)  data CliArgValueType   = StringArg   | NumberArg-  deriving (Generic, Show, Eq)+  deriving (Generic, Show, Eq, Lift) -data CliEntryMetadata-  = Opt {+data CliOptMetadata+  = CliOptMetadata {     optLong     :: !(Maybe Text)   , optShort    :: !(Maybe Text)   , optMetavar  :: !(Maybe Text)   , optHelp     :: !(Maybe Text)   , optRequired :: !Bool   }-  | Arg {+  deriving (Generic, Show, Eq)++instance Lift CliOptMetadata where+  lift CliOptMetadata {optLong, optShort, optMetavar, optHelp, optRequired} =+    [| CliOptMetadata+           { optLong = fmap Text.pack optLongStr+           , optShort = fmap Text.pack optShortStr+           , optMetavar = fmap Text.pack optMetavarStr+           , optHelp = fmap Text.pack optHelpStr+           , optRequired = optRequired+           } |]+    where+      optLongStr = fmap Text.unpack optLong+      optShortStr = fmap Text.unpack optShort+      optMetavarStr = fmap Text.unpack optMetavar+      optHelpStr = fmap Text.unpack optHelp++data CliArgMetadata+  = CliArgMetadata {     argMetavar  :: !(Maybe Text)-  , optRequired :: !Bool+  , argHelp     :: !(Maybe Text)+  , argRequired :: !Bool   }   deriving (Generic, Show, Eq) +instance Lift CliArgMetadata where+  lift CliArgMetadata {argMetavar, argHelp, argRequired} =+    [| CliArgMetadata {+          argMetavar = fmap Text.pack argMetavarStr+        , argHelp    = fmap Text.pack argHelpStr+        , argRequired = argRequired+        }+     |]+    where+      argMetavarStr = fmap Text.unpack argMetavar+      argHelpStr = fmap Text.unpack argHelp++data CliSwitchMetadata+  = CliSwitchMetadata {+    switchLong     :: !Text+  , switchHelp     :: !(Maybe Text)+  }+  deriving (Generic, Show, Eq)++instance Lift CliSwitchMetadata where+  lift CliSwitchMetadata {switchLong, switchHelp} =+    [| CliSwitchMetadata+           { switchLong = Text.pack switchLongStr+           , switchHelp = fmap Text.pack switchHelpStr+           } |]+    where+      switchLongStr = Text.unpack switchLong+      switchHelpStr = fmap Text.unpack switchHelp+++data CliEntryMetadata+  = Opt CliOptMetadata+  | Arg CliArgMetadata+  | Switch CliSwitchMetadata+  deriving (Generic, Show, Eq)++instance Lift CliEntryMetadata where+  lift (Opt metadata)    = [| Opt metadata |]+  lift (Arg metadata)    = [| Arg metadata |]+  lift (Switch metadata) = [| Switch metadata |]+ data CliEntrySpec cmd   = CmdEntry {     cliEntryCmdValue :: !(Vector cmd)@@ -63,6 +121,15 @@   }   deriving (Generic, Show, Eq) +instance Lift cmd => Lift (CliEntrySpec cmd) where+  lift CmdEntry {cliEntryCmdValue, cliEntryMetadata} =+    [| CmdEntry { cliEntryCmdValue = Vector.fromList cliEntryCmdValueList+                , cliEntryMetadata = cliEntryMetadata } |]+    where+      cliEntryCmdValueList = Vector.toList cliEntryCmdValue+  lift PlainEntry {cliEntryMetadata} =+    [| PlainEntry { cliEntryMetadata = cliEntryMetadata } |]+ data CliCmdSpec   = CliCmdSpec {     cliCmdDesc   :: !Text@@ -70,6 +137,15 @@   }   deriving (Generic, Show, Eq) +instance Lift CliCmdSpec where+  lift CliCmdSpec {cliCmdDesc, cliCmdHeader} =+    [| CliCmdSpec { cliCmdDesc = Text.pack cliCmdDescStr, cliCmdHeader = Text.pack cliCmdHeaderStr } |]+    where+      cliCmdDescStr = Text.unpack cliCmdDesc+      cliCmdHeaderStr = Text.unpack cliCmdHeader++--------------------------------------------------------------------------------+ data ConfigSources cmd   = ConfigSources {     envVar   :: !(Maybe Text)@@ -77,12 +153,18 @@   }   deriving (Generic, Show, Eq) +instance Lift cmd => Lift (ConfigSources cmd) where+  lift ConfigSources {envVar, cliEntry} =+    [| ConfigSources (fmap Text.pack envVarStr) cliEntry |]+    where+      envVarStr = fmap Text.unpack envVar+ data SingleConfigValueType   = CVTString   | CVTNumber   | CVTBool   | CVTObject-  deriving (Generic, Show, Eq)+  deriving (Generic, Show, Read, Eq, Lift)  instance Display SingleConfigValueType where   display value =@@ -95,7 +177,7 @@ data ConfigValueType   = CVTSingle !SingleConfigValueType   | CVTArray  !SingleConfigValueType-  deriving (Generic, Show, Eq)+  deriving (Generic, Show, Read, Eq, Lift)  instance Display ConfigValueType where   display value =@@ -115,270 +197,61 @@   }   deriving (Generic, Show, Eq) +instance Lift cmd => Lift (ConfigValue cmd) where+  lift ConfigValue {defaultValue, configValueType, isSensitive, configSources} =+    [| ConfigValue defaultValue configValueType isSensitive configSources |]+  lift SubConfig {subConfig} =+    [| SubConfig (HashMap.fromList $ map (first Text.pack) subConfigList) |]+    where+      subConfigList = map (first Text.unpack) $ HashMap.toList subConfig+ data CliProgramSpec   = CliProgramSpec {     cliProgramDesc   :: !Text   , cliProgramHeader :: !Text   , cliCommands      :: !(Maybe (HashMap Text CliCmdSpec))   }-  deriving (Show, Eq)+  deriving (Generic, Show, Eq) +instance Lift CliProgramSpec where+  lift CliProgramSpec {cliProgramDesc, cliProgramHeader, cliCommands} =+    [| CliProgramSpec (Text.pack cliProgramDescStr)+                      (Text.pack cliProgramHeaderStr)+                      (fmap (HashMap.fromList . map (first Text.pack)) cliCommandList) |]+    where+      cliProgramDescStr   = Text.unpack cliProgramDesc+      cliProgramHeaderStr = Text.unpack cliProgramHeader+      cliCommandList      = fmap (map (first Text.unpack) . HashMap.toList) cliCommands+ data FilesSpec   = FilePathsSpec ![Text]   | FilesSpec { fileLocationEnvVar :: !(Maybe Text), fileLocationPaths :: ![Text] }-  deriving (Show, Eq)+  deriving (Generic, Show, Eq) +instance Lift FilesSpec where+  lift (FilePathsSpec pathsList) =+    [| FilePathsSpec $ map Text.pack pathsListStr |]+    where+      pathsListStr = map Text.unpack pathsList+  lift FilesSpec { fileLocationEnvVar, fileLocationPaths } =+    [| FilesSpec (fmap Text.pack fileLocationEnvVarStr)+                 (fmap Text.pack fileLocationsPathsStr)  |]+    where+      fileLocationEnvVarStr = fmap Text.unpack fileLocationEnvVar+      fileLocationsPathsStr = fmap Text.unpack fileLocationPaths+ data ConfigSpec cmd   = ConfigSpec {     specConfigFilepaths :: !(Maybe FilesSpec)   , specCliProgramSpec  :: !(Maybe CliProgramSpec)   , specConfigValues    :: !(HashMap Text (ConfigValue cmd))   }-  deriving (Show, Eq)------------------------------------------------------------------------------------- JSON Parsers--instance JSON.FromJSON CliCmdSpec where-  parseJSON json =-    case json of-      JSON.Object object ->-        CliCmdSpec-        <$> object .: "desc"-        <*> object .: "header"-      _ ->-        JSON.typeMismatch "CliCmdSpec" json--instance JSON.FromJSON CliProgramSpec where-  parseJSON json =-    case json of-      JSON.Object object ->-        CliProgramSpec-        <$> object .: "desc"-        <*> object .: "header"-        <*> object .:? "commands"-      _ ->-        JSON.typeMismatch "CliProgramSpec" json--cliArgTypeParser :: JSON.Object -> JSON.Parser CliArgValueType-cliArgTypeParser object = do-  value <- object .: "type"-  case value of-    JSON.String typeName-      | typeName == "string" -> return StringArg-      | typeName == "number" -> return NumberArg-      | otherwise            -> JSON.typeMismatch "CliArgValueType (string, number)" value-    _ -> JSON.typeMismatch "CliArgValueType (string, number)" value--cliArgParser :: JSON.Object -> JSON.Parser CliEntryMetadata-cliArgParser object =-  Arg <$> (object .:? "metavar") <*> (fromMaybe True <$> (object .:? "required"))--cliOptParser :: JSON.Object -> JSON.Parser CliEntryMetadata-cliOptParser object = do-  long  <- object .:? "long"-  short <- object .:? "short"-  if isNothing long && isNothing short-    then fail "'option' field input requires either 'long' or 'short' settings"-    else-      Opt-      <$> pure long-      <*> pure short-      <*> (object .:? "metavar")-      <*> (object .:? "help")-      <*> (fromMaybe True <$> (object .:? "required"))--cliArgKeys :: [Text]-cliArgKeys = ["input", "commands", "metavar", "required"]--cliOptKeys :: [Text]-cliOptKeys = ["short", "long", "help"] ++ cliArgKeys--instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where-  parseJSON json =-      case json of-        JSON.Object object -> do-          cmdValue   <- object .:? "commands"-          value <- object .: "input"--          let-            optParseEntryCtor =-              maybe PlainEntry CmdEntry cmdValue--          case value of-            JSON.String inputName-              | inputName == "option" -> do-                forM_ (HashMap.keys object) $ \key ->-                  when (not (key `elem` cliOptKeys))-                    (fail $ "cli option contains invalid key " ++ show key)--                optParseEntryCtor <$> cliOptParser object--              | inputName == "argument" -> do-                forM_ (HashMap.keys object) $ \key ->-                  when (not (key `elem` cliArgKeys))-                    (fail $ "cli option contains invalid key " ++ show key)--                optParseEntryCtor <$> cliArgParser object--              | otherwise ->-                JSON.typeMismatch "CliEntryMetadata (invalid input)" value-            _ ->-              JSON.typeMismatch "CliEntryMetadata (invalid input)" value-        _ ->-          JSON.typeMismatch "CliEntryMetadata" json--instance JSON.FromJSON ConfigValueType where-  parseJSON = JSON.withText "ConfigValueType (string, number, bool)" $ \tyText ->-    case Text.toLower tyText of-      "string"   -> pure $ CVTSingle CVTString-      "number"   -> pure $ CVTSingle CVTNumber-      "bool"     -> pure $ CVTSingle CVTBool-      "[string]" -> pure $ CVTArray CVTString-      "[number]" -> pure $ CVTArray CVTNumber-      "[bool]"   -> pure $ CVTArray CVTBool-      "[object]" -> pure $ CVTArray CVTObject-      _  -> JSON.typeMismatch "ConfigValueType (string, number, bool)" (JSON.String tyText)--inferErrorMsg :: String-inferErrorMsg = "could not infer type from given default value"--parseBytesToConfigValueJSON :: ConfigValueType -> Text -> Maybe JSON.Value-parseBytesToConfigValueJSON cvType content =-  case JSON.eitherDecodeStrict' (Text.encodeUtf8 content) of-    Right value | matchesConfigValueType value cvType -> return value-                | otherwise                           -> Nothing-    Left _err-      | matchesConfigValueType (JSON.String content) cvType -> return (JSON.String content)-      | otherwise -> Nothing--jsonToConfigValueType :: JSON.Value -> Either String ConfigValueType-jsonToConfigValueType json = case json of-  JSON.String{} -> Right $ CVTSingle CVTString-  JSON.Number{} -> Right $ CVTSingle CVTNumber-  JSON.Bool{}   -> Right $ CVTSingle CVTBool-  JSON.Array arr-    | null arr -> Left inferErrorMsg-    | otherwise -> case jsonToConfigValueType (Vector.head arr) of-      Right CVTArray{}     -> Left "nested arrays values are not supported"-      Right (CVTSingle ty) -> Right $ CVTArray ty-      Left  err            -> Left err-  _ -> Left inferErrorMsg--matchesConfigValueType :: JSON.Value -> ConfigValueType -> Bool-matchesConfigValueType json cvType = case (json, cvType) of-  (JSON.Null    , CVTSingle _        ) -> True-  (JSON.String{}, CVTSingle CVTString) -> True-  (JSON.Number{}, CVTSingle CVTNumber) -> True-  (JSON.Bool{}  , CVTSingle CVTBool  ) -> True-  (JSON.Object{}, CVTSingle CVTObject) -> True-  (JSON.Array arr, CVTArray inner) ->-    if null arr then True else all (`matchesConfigValueType` CVTSingle inner) arr-  _ -> False--assertMatchingConfigValueType :: Monad m => JSON.Value -> ConfigValueType -> m ()-assertMatchingConfigValueType json cvType-  | matchesConfigValueType json cvType = return ()-  | otherwise = fail $ "JSON value type does not match specified type " <> show cvType--getConfigValueType-  :: Maybe JSON.Value -> Maybe ConfigValueType -> JSON.Parser ConfigValueType-getConfigValueType mdefValue mCvType = case (mdefValue, mCvType) of-  (Just JSON.Null, Just cvType) -> pure cvType--  (Just defValue , Just cvType) -> do-    assertMatchingConfigValueType defValue cvType-    return cvType--  (Nothing      , Just cvType) -> pure cvType--  (Just defValue, Nothing    ) -> either fail pure $ jsonToConfigValueType defValue--  (Nothing      , Nothing    ) -> fail inferErrorMsg--instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where-  parseJSON json  =-    case json of-      JSON.Object object ->-        case HashMap.lookup "etc/spec" object of-          -- normal object-          Nothing -> do-            subConfigMap <- foldM-                        (\subConfigMap (key, value) -> do-                            innerValue <- JSON.parseJSON value-                            return $ HashMap.insert key innerValue subConfigMap)-                        HashMap.empty-                        (HashMap.toList object)-            if HashMap.null subConfigMap then-              fail "Entries cannot have empty maps as values"-            else-              return (SubConfig subConfigMap)--          -- etc spec value object-          Just (JSON.Object fieldSpec) ->-            if HashMap.size object == 1 then do-              -- NOTE: not using .:? here as it casts JSON.Null to Nothing, we-              -- want (Just JSON.Null) returned-              let mDefaultValue = maybe Nothing Just $ HashMap.lookup "default" fieldSpec-              mSensitive    <- fieldSpec .:? "sensitive"-              mCvType       <- fieldSpec .:? "type"-              let sensitive = fromMaybe False mSensitive-              ConfigValue-                <$> pure mDefaultValue-                <*> getConfigValueType mDefaultValue mCvType-                <*> pure sensitive-                <*> (ConfigSources <$> fieldSpec .:? "env"-                                   <*> fieldSpec .:? "cli")-            else-              fail "etc/spec object can only contain one key"--          -- any other JSON value-          Just _ ->-            fail "etc/spec value must be a JSON object"--      _ -> do-        cvType <- either fail pure $ jsonToConfigValueType json-        return-          ConfigValue-          {-            defaultValue    = Just json-          , configValueType = cvType-          , isSensitive     = False-          , configSources   = ConfigSources Nothing Nothing-          }---parseFiles :: JSON.Value -> JSON.Parser FilesSpec-parseFiles = JSON.withObject "FilesSpec" $ \object -> do-  files  <- object .: "etc/files"-  mEnv   <- files .:? "env"-  mPaths <- files .:? "paths"-  if isNothing mEnv && isNothing mPaths-    then fail "either `env` or a `paths` keys are required when using `etc/files`"-    else return $ FilesSpec mEnv (fromMaybe [] mPaths)--parseFilePaths :: JSON.Value -> JSON.Parser FilesSpec-parseFilePaths =-  JSON.withObject "FilesSpec" $ \object -> FilePathsSpec <$> object .: "etc/filepaths"--parseFileSpec :: JSON.Value -> JSON.Parser (Maybe FilesSpec)-parseFileSpec json@(JSON.Object object) = do-  mFiles     <- object .:? "etc/files"-  mFilePaths <- object .:? "etc/filepaths"-  if isJust (mFiles :: Maybe JSON.Value) && isJust (mFilePaths :: Maybe JSON.Value)-    then fail "either the `etc/files` or `etc/filepaths` key can be used; not both"-    else if isJust mFiles-      then Just <$> parseFiles json-      else if isJust mFilePaths then Just <$> parseFilePaths json else pure Nothing-parseFileSpec _ = pure Nothing+  deriving (Generic, Show, Eq) -instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where-  parseJSON json =-    case json of-      JSON.Object object ->-        ConfigSpec-        <$> parseFileSpec json-        <*> (object .:? "etc/cli")-        <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))-      _ ->-        JSON.typeMismatch "ConfigSpec" json+instance Lift cmd => Lift (ConfigSpec cmd) where+  lift ConfigSpec {specConfigFilepaths, specCliProgramSpec, specConfigValues} =+    [| ConfigSpec specConfigFilepaths+                  specCliProgramSpec+                  (HashMap.fromList $ map (first Text.pack) configValuesList) |]+    where+      configValuesList = map (first Text.unpack) $ HashMap.toList specConfigValues

@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP               #-} {-# LANGUAGE NoImplicitPrelude #-}  module System.Etc.Internal.Spec.YAML where@@ -11,15 +11,27 @@ import qualified Data.Text.IO       as Text (readFile) import qualified Data.Yaml          as YAML +import System.Etc.Internal.Errors+import System.Etc.Internal.Spec.Parser () 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 Nothing (Text.pack err)+decodeYaml :: JSON.FromJSON a => ByteString -> Either String a+decodeYaml =+#if MIN_VERSION_yaml(0,8,3)+  mapLeft show . YAML.decodeEither'+#else+  YAML.decodeEither+#endif +parseConfigSpec_ :: (MonadThrow m, JSON.FromJSON cmd) => Maybe Text -> Text -> m (ConfigSpec cmd)+parseConfigSpec_ mFilepath input = case decodeYaml (Text.encodeUtf8 input) of+  Left  err    -> throwM $ SpecInvalidSyntaxFound mFilepath (Text.pack err)   Right result -> return result +parseConfigSpec :: (MonadThrow m, JSON.FromJSON cmd) => Text -> m (ConfigSpec cmd)+parseConfigSpec = parseConfigSpec_ Nothing+ readConfigSpec :: JSON.FromJSON cmd => Text -> IO (ConfigSpec cmd) readConfigSpec filepath = do   contents <- Text.readFile $ Text.unpack filepath-  parseConfigSpec contents+  parseConfigSpec_ (Just filepath) contents

@@ -0,0 +1,24 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+module System.Etc.Internal.Spec.YAML.TH where++import RIO++import Data.Proxy (Proxy)++import Language.Haskell.TH        (ExpQ, runIO)+import Language.Haskell.TH.Syntax (Lift)++import qualified Data.Aeson as JSON++import System.Etc.Internal.Spec.Types (ConfigSpec)+import System.Etc.Internal.Spec.YAML  (readConfigSpec)++readConfigSpecTH_ :: (Lift k) => Proxy k -> (Text -> IO (ConfigSpec k)) -> Text -> ExpQ+readConfigSpecTH_ _ readSpec filepath = do+  configSpec <- runIO $ readSpec filepath+  [| configSpec |]++readConfigSpecTH :: (Lift k, JSON.FromJSON k) => Proxy k -> Text -> ExpQ+readConfigSpecTH = flip readConfigSpecTH_ readConfigSpec

@@ -18,7 +18,7 @@ import qualified Data.Aeson       as JSON import qualified Data.Aeson.Types as JSON (Parser) -import System.Etc.Internal.Spec.Types (ConfigurationError (..))+import System.Etc.Internal.Spec.Types (ConfigValueType)  -------------------- -- Configuration Types

@@ -4,7 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module System.Etc.Spec (     module Types+  , module Errors   , parseConfigSpec+  , readConfigSpecTH   , readConfigSpec   ) where @@ -12,17 +14,22 @@ import           RIO import qualified RIO.Text     as Text -import System.Etc.Internal.Spec.Types as Types-    (ConfigSpec, ConfigValue, ConfigurationError (..))+import Data.Proxy (Proxy) -#ifdef WITH_CLI+import Language.Haskell.TH        (ExpQ)+import Language.Haskell.TH.Syntax (Lift)++import System.Etc.Internal.Errors     as Errors+import System.Etc.Internal.Spec.Types as Types (ConfigSpec, ConfigValue)+ import qualified Data.Aeson as JSON-#endif  #ifdef WITH_YAML-import qualified System.Etc.Internal.Spec.YAML as YAML+import qualified System.Etc.Internal.Spec.YAML    as YAML+import qualified System.Etc.Internal.Spec.YAML.TH as YAML #else-import qualified System.Etc.Internal.Spec.JSON as JSONSpec+import qualified System.Etc.Internal.Spec.JSON    as JSONSpec+import qualified System.Etc.Internal.Spec.JSON.TH as JSONSpec #endif  {-|@@ -68,3 +75,12 @@ readConfigSpec filepath = do   contents <- Text.readFile $ Text.unpack filepath   parseConfigSpec contents+++-- | Reads a specified 'FilePath' and parses a 'ConfigSpec' at compilation time.+readConfigSpecTH :: (Lift k, JSON.FromJSON k) => Proxy k -> Text -> ExpQ+#ifdef WITH_YAML+readConfigSpecTH = YAML.readConfigSpecTH+#else+readConfigSpecTH = JSONSpec.readConfigSpecTH+#endif

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE NoImplicitPrelude   #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -13,18 +14,18 @@ tests :: TestTree tests = testGroup   "System.Etc.Config"-  [ testCase "InvalidConfiguration error contains key when types don't match" $ do+  [ testCase "ConfigValueParserFailed 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+          Just (SUT.ConfigValueParserFailed inputKeys _) ->+            assertEqual "expecting key to be greeting, but wasn't" ["greeting"] inputKeys           _ ->             assertFailure-              $  "expecting InvalidConfiguration; got something else: "+              $  "expecting ConfigValueParserFailed; got something else: "               <> show err         Right (_ :: Text) -> assertFailure "expecting error; got none"   ]

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE NoImplicitPrelude   #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -17,11 +18,28 @@ resolver_tests :: TestTree resolver_tests = testGroup   "resolver"-  [ testCase "throws an error when input type does not match with spec type" $ do+  [ testCase "inputs with type string should accept numbers" $ do     let input = mconcat           [ "{ \"etc/entries\": {"           , "    \"greeting\": {"           , "      \"etc/spec\": {"+          , "        \"type\": \"string\""+          , "        , \"cli\": {"+          , "            \"input\": \"option\""+          , "          , \"short\": \"g\""+          , "          , \"long\": \"greeting\""+          , "          , \"required\": true"+          , "}}}}}"+          ]+    (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input+    config                      <- SUT.resolvePlainCliPure spec "program" ["-g", "1234"]+    str                         <- SUT.getConfigValue ["greeting"] config+    assertEqual "Expected String; got something else" ("1234" :: Text) str+  , testCase "throws an error when input type does not match with spec type" $ do+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"           , "        \"type\": \"[number]\""           , "        , \"cli\": {"           , "            \"input\": \"option\""@@ -49,10 +67,12 @@      case SUT.getConfigValueWith parseDb ["database"] config of       Left err -> case fromException err of-        Just (SUT.InvalidConfiguration key _) ->-          assertEqual "expecting key to be database, but wasn't" (Just "database") key+        Just (SUT.ConfigValueParserFailed inputKeys _) ->+          assertEqual "expecting key to be database, but wasn't" ["database"] inputKeys         _ ->-          assertFailure $ "expecting InvalidConfiguration; got something else: " <> show err+          assertFailure+            $  "expecting ConfigValueParserFailed; got something else: "+            <> show err       Right (_ :: (Text, Text)) -> assertFailure "expecting error; got none"   ] @@ -250,5 +270,104 @@       Right _ -> assertFailure "Expecting required argument to fail cli resolving"   ] +switch_tests :: TestTree+switch_tests = testGroup+  "switch input"+  [ testCase "fails if etc/spec.type is not bool" $ do+    let input = mconcat+          [ "{ \"etc/entries\": {"+          , "    \"greeting\": {"+          , "      \"etc/spec\": {"+          , "        \"default\": false"+          , "        , \"type\": \"string\""+          , "        , \"cli\": {"+          , "            \"input\": \"switch\""+          , "          , \"long\": \"valid\""+          , "}}}}}"+          ]+    (spec :: Either SomeException (SUT.ConfigSpec ())) <- try $ SUT.parseConfigSpec input++    case spec of+      Left err -> case fromException err of+        Just SUT.SpecInvalidSyntaxFound{} -> return ()+        _ -> assertFailure ("Expecting type validation to work on cli; got " <> show err)++      Right _ -> assertFailure "Expecting type validation to work on cli"+  , testGroup+    "when etc/spec.default is false"+    [ testCase "returns false when flag not given" $ do+      let input = mconcat+            [ "{ \"etc/entries\": {"+            , "    \"greeting\": {"+            , "      \"etc/spec\": {"+            , "        \"default\": false"+            , "        , \"type\": \"bool\""+            , "        , \"cli\": {"+            , "            \"input\": \"switch\""+            , "          , \"long\": \"valid\""+            , "}}}}}"+            ]+      (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input++      case SUT.resolvePlainCliPure spec "program" [] of+        Left err ->+          assertFailure ("Expecting default to work on cli; but didn't: " <> show err)++        Right config -> do+          greeting <- SUT.getConfigValue ["greeting"] config+          assertBool "Expecting default to be false, but wasn't" (not greeting)+    , testCase "returns true when flag given" $ do+      let input = mconcat+            [ "{ \"etc/entries\": {"+            , "    \"greeting\": {"+            , "      \"etc/spec\": {"+            , "        \"default\": false"+            , "        , \"type\": \"bool\""+            , "        , \"cli\": {"+            , "            \"input\": \"switch\""+            , "          , \"long\": \"valid\""+            , "}}}}}"+            ]+      (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input++      case SUT.resolvePlainCliPure spec "program" ["--valid"] of+        Left err ->+          assertFailure ("Expecting default to work on cli; but didn't: " <> show err)++        Right config -> do+          greeting <- SUT.getConfigValue ["greeting"] config+          assertBool "Expecting result to be true, but wasn't" greeting+    ]+  -- TODO: This testcase is failing, and it is because the optparse-applicative+  -- API _always_ returns a value, if the flag is not present, it will return+  -- false. Once refactoring of parser is done, we need to make use of the+  -- default value to change the behavior of the optparse-applicative API to+  -- return the appropiate result+  -- , testGroup "when default is true"+  --   [+  --     testCase "entry should use default when not specified (true case)" $ do+  --     let input = mconcat+  --           [ "{ \"etc/entries\": {"+  --           , "    \"greeting\": {"+  --           , "      \"etc/spec\": {"+  --           , "        \"default\": true"+  --           , "        , \"type\": \"bool\""+  --           , "        , \"cli\": {"+  --           , "            \"input\": \"switch\""+  --           , "          , \"long\": \"invalid\""+  --           , "}}}}}"+  --           ]+  --     (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input++  --     case SUT.resolvePlainCliPure spec "program" [] of+  --       Left err ->+  --         assertFailure ("Expecting default to work on cli; but didn't: " <> show err)++  --       Right config -> do+  --         greeting <- SUT.getConfigValue ["greeting"] config+  --         assertBool "Expecting default to be true, but wasn't" greeting+  --   ]+  ]+ tests :: TestTree-tests = testGroup "plain" [resolver_tests, option_tests, argument_tests]+tests = testGroup "plain" [resolver_tests, option_tests, argument_tests, switch_tests]

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP                 #-}+{-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE NoImplicitPrelude   #-} {-# LANGUAGE OverloadedLists     #-} {-# LANGUAGE OverloadedStrings   #-}@@ -28,9 +29,9 @@   [ testCase "fail if using both `etc/files` and `etc/filepaths`" $ do     let input = "{\"etc/files\": {}, \"etc/filepaths\": []}" -    (espec :: Either ConfigurationError (ConfigSpec ())) <- try $ parseConfigSpec input+    (espec :: Either SpecInvalidSyntaxFound (ConfigSpec ())) <- try $ parseConfigSpec input     case espec of-      Left (InvalidConfiguration _ _) -> return ()+      Left _ -> return ()       _ ->         assertFailure ("Expecting InvalidConfigurationError; got instead " <> show espec)   , testCase "fails when file has key not defined in spec" $ do@@ -40,15 +41,33 @@     (_config, warnings)     <- resolveFiles spec     assertBool "There should be warnings" (not $ null warnings)     case fromException (Vector.head warnings) of-      Just (InvalidConfiguration _ errMsg) -> assertEqual-        "Expecting key not present in spec error"-        "Configuration entry `greeting` is not present on spec"-        errMsg+      Just (UnknownConfigKeyFound _ keyName _) ->+        assertEqual "Expecting key not present in spec error" "greeting" keyName        err ->         assertFailure           $  "Expecting InvalidConfigurationError; got other error instead: "           <> show err+  , testCase "fails when file has key with value different from spec" $ do+    jsonFilepath <- getDataFileName "test/fixtures/config.json"+    let+      input =+        "{\"etc/filepaths\": [\""+          <> Text.pack jsonFilepath+          <> "\"], \"etc/entries\": { \"greeting\": {\"etc/spec\": { \"type\": \"number\" }}}}"+    (spec :: ConfigSpec ()) <- parseConfigSpec input+    (_config, warnings)     <- resolveFiles spec+    assertBool "Expecting warnings in the resolveFiles call" (Vector.length warnings > 0)+    let err = Vector.head warnings+    case fromException err of+      Just (ConfigValueTypeMismatchFound keyName _ _) ->+        -- TODO: This should return "greeting" instead+        assertEqual "Expecting config value type mismatch error" "" keyName++      _ ->+        assertFailure+          $  "Expecting InvalidConfigurationError; got other error instead: "+          <> show err   , filePathsTests   , filesTest   ]@@ -110,9 +129,9 @@               fromException e         in           case err of-            Just (InvalidConfiguration _ _) -> return ()-            _                               -> assertFailure-              ("Expecting InvalidConfigurationError; got instead " <> show err)+            Just UnsupportedFileExtensionGiven{} -> return ()+            _ -> assertFailure+              ("Expecting UnsupportedFileExtensionGiven; got instead " <> show err)   , testCase "does not fail if file doesn't exist" $ do     jsonFilepath <- getDataFileName "test/fixtures/config.json"     let input = mconcat@@ -187,11 +206,10 @@   [ testCase "at least the `env` or `paths` keys must be present" $ do     let input = "{\"etc/files\": {}}" -    (espec :: Either ConfigurationError (ConfigSpec ())) <- try $ parseConfigSpec input+    (espec :: Either SpecInvalidSyntaxFound (ConfigSpec ())) <- try $ parseConfigSpec input     case espec of-      Left (InvalidConfiguration _ _) -> return ()-      _ ->-        assertFailure ("Expecting InvalidConfigurationError; got instead " <> show espec)+      Left _ -> return ()+      _ -> assertFailure ("Expecting SpecInvalidSyntaxFound; got instead " <> show espec)   , testCase "environment variable has precedence over all others" $ do     jsonFilepath <- getDataFileName "test/fixtures/config.json"     envFilePath  <- getDataFileName "test/fixtures/config.env.json"

@@ -14,8 +14,8 @@  import qualified Data.Aeson as JSON -import System.Etc.Internal.Spec.Types-import System.Etc.Spec+import           System.Etc.Internal.Spec.Types+import qualified System.Etc.Spec                as SUT  #ifdef WITH_YAML import qualified Data.Yaml as YAML@@ -42,7 +42,7 @@   [ testCase "does not fail when etc/entries is not defined" $ do     let input = "{}" -    case parseConfigSpec input of+    case SUT.parseConfigSpec input of       Nothing -> assertFailure "should not fail if no etc/entries key is present"       Just (_ :: ConfigSpec ()) -> assertBool "" True   , testCase "fails when default JSON value doesn't correspond to type entry" $ do@@ -50,13 +50,13 @@       input         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[123],\"type\":\"[string]\"}}}}" -    case parseConfigSpec input of+    case SUT.parseConfigSpec input of       Left err -> case fromException err of-        Just InvalidConfiguration{} -> assertBool "" True+        Just SUT.SpecInvalidSyntaxFound{} -> assertBool "" True          _ ->           assertFailure-            $  "expecting to get an InvalidConfiguration error; but got "+            $  "expecting to get an SpecInvalidSyntaxFound error; but got "             <> show err        Right (_ :: ConfigSpec ()) ->@@ -64,14 +64,14 @@   , testCase "entries cannot finish in an empty map" $ do     let input = "{\"etc/entries\":{\"greeting\":{}}}" -    case parseConfigSpec input of+    case SUT.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+    case SUT.parseConfigSpec input of       Just (result :: ConfigSpec ()) ->         assertFailure $ "entries should not accept arrays as values " ++ show result       Nothing -> assertBool "" True@@ -79,7 +79,7 @@     let input = "{\"etc/entries\":{\"greeting\":123}}"         keys  = ["greeting"] -    config <- parseConfigSpec input+    config <- SUT.parseConfigSpec input     case getConfigValue keys (specConfigValues config) of       Nothing -> assertFailure         (show keys ++ " should map to a config value, got sub config map instead")@@ -90,7 +90,7 @@     let input = "{\"etc/entries\":{\"greeting\":[123]}}"         keys  = ["greeting"] -    config <- parseConfigSpec input+    config <- SUT.parseConfigSpec input      case getConfigValue keys (specConfigValues config) of       Nothing -> assertFailure@@ -101,11 +101,11 @@         (defaultValue value)   , testCase "entries with empty arrays as values fail because type cannot be infered" $ do     let input = "{\"etc/entries\":{\"greeting\": []}}"-    case parseConfigSpec input of+    case SUT.parseConfigSpec input of       Left err -> case fromException err of-        Just InvalidConfiguration{} -> assertBool "" True+        Just SUT.SpecInvalidSyntaxFound{} -> assertBool "" True         _ ->-          assertFailure $ "expecting InvalidConfiguration error; got instead " <> show err+          assertFailure $ "expecting SpecInvalidSyntaxFound error; got instead " <> show err        Right (_configSpec :: ConfigSpec ()) ->         assertFailure "expecting config spec parse to fail, but didn't"@@ -115,7 +115,7 @@         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[],\"type\":\"[string]\"}}}}"       keys = ["greeting"] -    config <- parseConfigSpec input+    config <- SUT.parseConfigSpec input     case getConfigValue keys (specConfigValues config) of       Nothing -> assertFailure         (show keys ++ " should map to an array config value, got sub config map instead")@@ -130,7 +130,7 @@         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[{\"hello\":\"world\"}],\"type\":\"[object]\"}}}}"       keys = ["greeting"] -    config <- parseConfigSpec input+    config <- SUT.parseConfigSpec input     case getConfigValue keys (specConfigValues config) of       Nothing -> assertFailure         (show keys ++ " should map to an array config value, got sub config map instead")@@ -145,7 +145,7 @@     let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}"         keys  = ["english", "greeting"] -    config <- parseConfigSpec input+    config <- SUT.parseConfigSpec input      case getConfigValue keys (specConfigValues config) of       Nothing -> assertFailure@@ -156,35 +156,35 @@   , testCase "spec map cannot be empty object" $ do     let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}" -    case parseConfigSpec input of+    case SUT.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+    case SUT.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+    case SUT.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+    case SUT.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+    case SUT.parseConfigSpec input of       Just (result :: ConfigSpec ()) ->         assertFailure $ "etc/spec map should not be a number " ++ show result       Nothing -> assertBool "" True@@ -193,7 +193,7 @@       input         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":\"hello\"},\"foobar\":123}}}" -    case parseConfigSpec input of+    case SUT.parseConfigSpec input of       Just (result :: ConfigSpec ()) ->         assertFailure $ "etc/spec map should not contain more than one key " ++ show result       Nothing -> assertBool "" True@@ -208,7 +208,7 @@       let         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{}}}}}" -      case parseConfigSpec input of+      case SUT.parseConfigSpec input of         Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should require a type " ++ show result         Nothing ->@@ -218,7 +218,7 @@       let         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\", \"cli\":{\"input\":\"option\"}}}}}" -      case parseConfigSpec input of+      case SUT.parseConfigSpec input of         Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should require a type " ++ show result         Nothing ->@@ -229,13 +229,13 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\":\"string\",\"cli\":{\"input\":\"option\",\"short\":\"g\"}}}}}"         keys  = ["greeting"] -      (config :: ConfigSpec ()) <- parseConfigSpec input+      (config :: ConfigSpec ()) <- SUT.parseConfigSpec input        let         result = do           value    <- getConfigValue keys (specConfigValues config)           let valueType = configValueType value-          PlainEntry metadata <- cliEntry (configSources value)+          PlainEntry (Opt metadata) <- cliEntry (configSources value)           short <- optShort metadata           return (short, valueType) @@ -251,13 +251,13 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"cli\":{\"input\":\"option\",\"long\":\"greeting\"}}}}}"         keys  = ["greeting"] -      (config :: ConfigSpec ()) <- parseConfigSpec input+      (config :: ConfigSpec ()) <- SUT.parseConfigSpec input        let         result = do           value  <- getConfigValue keys (specConfigValues config)           let valueType = configValueType value-          PlainEntry metadata <- cliEntry (configSources value)+          PlainEntry (Opt metadata) <- cliEntry (configSources value)           long <- optLong metadata           return (long, valueType) @@ -273,13 +273,13 @@         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"commands\":[\"foo\"]}}}}}"         keys  = ["greeting"] -      (config :: ConfigSpec Text) <- parseConfigSpec input+      (config :: ConfigSpec Text) <- SUT.parseConfigSpec input        let         result = do           value <- getConfigValue keys (specConfigValues config)           let valueType = configValueType value-          CmdEntry cmd metadata <- cliEntry (configSources value)+          CmdEntry cmd (Opt metadata) <- cliEntry (configSources value)           long <- optLong metadata           return (cmd, long, valueType) @@ -296,7 +296,7 @@         -- error is a typo on key command (instead of command_s_)         input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"cli\":{\"input\":\"option\",\"long\":\"greeting\",\"type\":\"string\",\"command\":[\"foo\"]}}}}}" -      case parseConfigSpec input of+      case SUT.parseConfigSpec input of         Just (result :: ConfigSpec ()) ->           assertFailure $ "cli entry should fail on invalid entry " ++ show result         Nothing ->@@ -314,7 +314,7 @@           = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"type\": \"string\",\"env\":\"GREETING\"}}}}"         keys = ["greeting"] -      (config :: ConfigSpec ()) <- parseConfigSpec input+      (config :: ConfigSpec ()) <- SUT.parseConfigSpec input        case getConfigValue keys (specConfigValues config) of         Nothing -> assertFailure

@@ -0,0 +1,2 @@+etc/entries:+  greeting: {}