[54] Move Spec.ConfigValue to its own attribute records

roman · Jul 20, 2018 · 5402f67 · 5402f67
1 parent 4296d5f
commit 5402f67
Show file tree

Hide file tree

Showing 9 changed files with 114 additions and 93 deletions.
diff --git a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs
@@ -34,7 +34,7 @@ data EnvMisspell
 lookupSpecEnvKeys :: ConfigSpec a -> Vector Text
 lookupSpecEnvKeys spec =
   let foldEnvSettings val acc = case val of
-        ConfigValue { configSources } ->
+        ConfigValue ConfigValueData { configSources } ->
           maybe acc (`Vector.cons` acc) (envVar configSources)
         SubConfig hsh -> HashMap.foldr foldEnvSettings acc hsh
   in  foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty

diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs
@@ -113,8 +113,8 @@ specToConfigValueCli
   -> (Text, Spec.ConfigValue cmd)
   -> m (HashMap cmd (Opt.Parser ConfigValue))
 specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of
-  Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } ->
-    configValueSpecToCli acc specEntryKey configValueType isSensitive configSources
+  Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources }
+    -> configValueSpecToCli acc specEntryKey configValueType isSensitive configSources
 
   Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc
 

diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs
@@ -92,8 +92,8 @@ specToConfigValueCli
   -> (Text, Spec.ConfigValue ())
   -> m (Opt.Parser ConfigValue)
 specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of
-  Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } ->
-    configValueSpecToCli specEntryKey configValueType isSensitive configSources acc
+  Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources }
+    -> configValueSpecToCli specEntryKey configValueType isSensitive configSources acc
 
   Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc
 

diff --git a/etc/src/System/Etc/Internal/Resolver/Default.hs b/etc/src/System/Etc/Internal/Resolver/Default.hs
@@ -20,7 +20,7 @@ buildDefaultResolver spec =
   let resolverReducer
         :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue
       resolverReducer specKey specValue mConfig = case specValue of
-        Spec.ConfigValue { Spec.defaultValue, Spec.isSensitive } ->
+        Spec.ConfigValue Spec.ConfigValueData { Spec.defaultValue, Spec.isSensitive } ->
           let mConfigSource = toDefaultConfigValue isSensitive <$> defaultValue
 
               updateConfig  = writeInSubConfig specKey <$> mConfigSource <*> mConfig

diff --git a/etc/src/System/Etc/Internal/Resolver/Env.hs b/etc/src/System/Etc/Internal/Resolver/Env.hs
@@ -36,14 +36,15 @@ buildEnvVarResolver lookupEnv spec =
     resolverReducer
       :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue
     resolverReducer specKey specValue mConfig = case specValue of
-      Spec.ConfigValue { Spec.isSensitive, Spec.configValueType, Spec.configSources } ->
-        let updateConfig = do
-              envSource' <- resolveEnvVarSource lookupEnv
-                                                configValueType
-                                                isSensitive
-                                                configSources
-              writeInSubConfig specKey (ConfigValue $ Set.singleton envSource') <$> mConfig
-        in  updateConfig <|> mConfig
+      Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType, Spec.configSources }
+        -> let updateConfig = do
+                 envSource' <- resolveEnvVarSource lookupEnv
+                                                   configValueType
+                                                   isSensitive
+                                                   configSources
+                 writeInSubConfig specKey (ConfigValue $ Set.singleton envSource')
+                   <$> mConfig
+           in  updateConfig <|> mConfig
 
       Spec.SubConfig specConfigMap ->
         let mSubConfig =

diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs
@@ -67,13 +67,14 @@ parseConfigValue keys spec fileIndex fileSource' json =
 
       (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json
 
-      (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do
-        either throwM return $ Spec.assertMatchingConfigValueType json configValueType
-        return $ ConfigValue
-          (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive
-            isSensitive
-            json
-          )
+      (Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType }, _)
+        -> do
+          either throwM return $ Spec.assertMatchingConfigValueType json configValueType
+          return $ ConfigValue
+            (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive
+              isSensitive
+              json
+            )
 
 
 

diff --git a/etc/src/System/Etc/Internal/Spec/Parser.hs b/etc/src/System/Etc/Internal/Spec/Parser.hs
@@ -222,13 +222,14 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
               mSensitive    <- fieldSpec .:? "sensitive"
               mCvType       <- fieldSpec .:? "type"
               let sensitive = fromMaybe False mSensitive
-              ConfigValue
-                <$> pure mDefaultValue
-                <*> getConfigValueType mDefaultValue mCvType
-                <*> pure sensitive
-                <*> (ConfigSources <$> fieldSpec .:? "env"
-                                   <*> fieldSpec .:? "cli")
-                <*> pure json
+              ConfigValue <$>
+                (ConfigValueData
+                  <$> pure mDefaultValue
+                  <*> getConfigValueType mDefaultValue mCvType
+                  <*> pure sensitive
+                  <*> (ConfigSources <$> fieldSpec .:? "env"
+                                     <*> fieldSpec .:? "cli")
+                  <*> pure json)
             else
               fail "etc/spec object can only contain one key"
 
@@ -239,14 +240,15 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
       _ -> do
         cvType <- either fail pure $ jsonToConfigValueType json
         return
-          ConfigValue
-          {
-            defaultValue    = Just json
-          , configValueType = cvType
-          , isSensitive     = False
-          , configSources   = ConfigSources Nothing Nothing
-          , rawConfigValue  = json
-          }
+          $ ConfigValue
+              ConfigValueData
+                {
+                  defaultValue    = Just json
+                , configValueType = cvType
+                , isSensitive     = False
+                , configSources   = ConfigSources Nothing Nothing
+                , rawConfigValue  = json
+                }
 
 parseFiles :: JSON.Value -> JSON.Parser FilesSpec
 parseFiles = JSON.withObject "FilesSpec" $ \object -> do

diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs
@@ -142,23 +142,29 @@ instance Display ConfigValueType where
       CVTSingle singleVal -> display singleVal
       CVTArray  singleVal -> display $ "[" <> display singleVal <> "]"
 
-data ConfigValue cmd
-  = ConfigValue {
+data ConfigValueData cmd =
+  ConfigValueData {
     defaultValue    :: !(Maybe JSON.Value)
   , configValueType :: !ConfigValueType
   , isSensitive     :: !Bool
   , configSources   :: !(ConfigSources cmd)
   , rawConfigValue  :: !JSON.Value
   }
-  | SubConfig {
-    subConfig :: !(HashMap Text (ConfigValue cmd))
-  }
+  deriving (Generic, Show, Eq)
+
+instance Lift cmd => Lift (ConfigValueData cmd) where
+  lift ConfigValueData {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } =
+    [| ConfigValueData defaultValue configValueType isSensitive configSources rawConfigValue |]
+
+data ConfigValue cmd
+  = ConfigValue !(ConfigValueData cmd)
+  | SubConfig   !(HashMap Text (ConfigValue cmd))
   deriving (Generic, Show, Eq)
 
 instance Lift cmd => Lift (ConfigValue cmd) where
-  lift ConfigValue {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } =
-    [| ConfigValue defaultValue configValueType isSensitive configSources rawConfigValue |]
-  lift SubConfig {subConfig} =
+  lift (ConfigValue configValueData) =
+    [| ConfigValue configValueData |]
+  lift (SubConfig subConfig) =
     [| SubConfig (HashMap.fromList $ map (first Text.pack) subConfigList) |]
     where
       subConfigList = map (first Text.unpack) $ HashMap.toList subConfig

diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs
@@ -79,26 +79,26 @@ general_tests = testGroup
     let input = "{\"etc/entries\":{\"greeting\":123}}"
         keys  = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
+      Just (ConfigValue value) -> assertEqual "should contain default value"
+                                              (Just (JSON.Number 123))
+                                              (defaultValue value)
+      _ -> assertFailure
         (show keys ++ " should map to a config value, got sub config map instead")
-      Just (value :: ConfigValue ()) -> assertEqual "should contain default value"
-                                                    (Just (JSON.Number 123))
-                                                    (defaultValue value)
   , testCase "entries that finish with arrays sets them as default value" $ do
     let input = "{\"etc/entries\":{\"greeting\":[123]}}"
         keys  = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to a config value, got sub config map instead")
-      Just (value :: ConfigValue ()) -> assertEqual
+      Just (ConfigValue value) -> assertEqual
         "should contain default value"
         (Just (JSON.Array (Vector.fromList [JSON.Number 123])))
         (defaultValue value)
+      _ -> assertFailure
+        (show keys ++ " should map to a config value, got sub config map instead")
   , testCase "entries with empty arrays as values fail because type cannot be infered" $ do
     let input = "{\"etc/entries\":{\"greeting\": []}}"
     case SUT.parseConfigSpec input of
@@ -115,44 +115,43 @@ general_tests = testGroup
         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[],\"type\":\"[string]\"}}}}"
       keys = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to an array config value, got sub config map instead")
+      Just (ConfigValue value) -> assertEqual "should contain default array value"
+                                              (Just (JSON.Array (Vector.fromList [])))
+                                              (defaultValue value)
 
-      Just (value :: ConfigValue ()) -> assertEqual
-        "should contain default array value"
-        (Just (JSON.Array (Vector.fromList [])))
-        (defaultValue value)
+      _ -> assertFailure
+        (show keys ++ " should map to an array config value, got sub config map instead")
   , testCase "entries with array of objects do not fail" $ do
     let
       input
         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[{\"hello\":\"world\"}],\"type\":\"[object]\"}}}}"
       keys = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to an array config value, got sub config map instead")
-
-      Just (value :: ConfigValue ()) -> assertEqual
+      Just (ConfigValue value) -> assertEqual
         "should contain default array value"
         (Just
           (JSON.Array (Vector.fromList [JSON.object ["hello" JSON..= ("world" :: Text)]]))
         )
         (defaultValue value)
+
+      _ -> assertFailure
+        (show keys ++ " should map to an array config value, got sub config map instead")
   , testCase "entries can have many levels of nesting" $ do
     let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}"
         keys  = ["english", "greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
+      Just (ConfigValue value) -> assertEqual "should contain default value"
+                                              (Just (JSON.String "hello"))
+                                              (defaultValue value)
+      _ -> assertFailure
         (show keys ++ " should map to a config value, got sub config map instead")
-      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\":{}}}"
 
@@ -233,11 +232,15 @@ cli_tests =
 
       let
         result = do
-          value    <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          PlainEntry metadata <- cliEntry (configSources value)
-          short <- optShort metadata
-          return (short, valueType)
+          configValue    <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            ConfigValue value -> do
+              let valueType = configValueType value
+              PlainEntry metadata <- cliEntry (configSources value)
+              short <- optShort metadata
+              return (short, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -255,11 +258,15 @@ cli_tests =
 
       let
         result = do
-          value  <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          PlainEntry metadata <- cliEntry (configSources value)
-          long <- optLong metadata
-          return (long, valueType)
+          configValue  <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            ConfigValue value -> do
+              let valueType = configValueType value
+              PlainEntry metadata <- cliEntry (configSources value)
+              long <- optLong metadata
+              return (long, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -277,11 +284,15 @@ cli_tests =
 
       let
         result = do
-          value <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          CmdEntry cmd metadata <- cliEntry (configSources value)
-          long <- optLong metadata
-          return (cmd, long, valueType)
+          configValue <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            (ConfigValue value) -> do
+              let valueType = configValueType value
+              CmdEntry cmd metadata <- cliEntry (configSources value)
+              long <- optLong metadata
+              return (cmd, long, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -317,11 +328,11 @@ envvar_tests = testGroup
       (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
       case getConfigValue keys (specConfigValues config) of
-        Nothing -> assertFailure
+        Just (ConfigValue value) -> assertEqual "should contain EnvVar value"
+                                                (ConfigSources (Just "GREETING") Nothing)
+                                                (configSources value)
+        _ -> assertFailure
           (show keys ++ " should map to a config value, got sub config map instead")
-        Just value -> assertEqual "should contain EnvVar value"
-                                  (ConfigSources (Just "GREETING") Nothing)
-                                  (configSources value)
   ]
 
 #ifdef WITH_YAML
@@ -341,13 +352,13 @@ yaml_tests =
 
         Right (config :: ConfigSpec ()) ->
           case getConfigValue keys (specConfigValues config) of
-            Nothing ->
-              assertFailure (show keys ++ " should map to a config value, got sub config map instead")
-
-            Just value ->
+            Just (ConfigValue value) ->
               assertEqual "should contain EnvVar value"
                           (ConfigSources (Just "GREETING") Nothing)
                           (configSources value)
+            _ ->
+              assertFailure (show keys ++ " should map to a config value, got sub config map instead")
+
   ]
 #endif