Merge pull request #21 from roman/20-file-from-envvars

[20] Add support for environment variables on filepaths (closes #20)
roman · Apr 5, 2018 · 3934780 · 3934780
2 parents 102a995 + 3fcde4b
commit 3934780
Show file tree

Hide file tree

Showing 13 changed files with 203 additions and 47 deletions.
diff --git a/README.md b/README.md
@@ -1,5 +1,5 @@
 [![Build Status](https://travis-ci.org/roman/Haskell-etc.svg?branch=master)](https://travis-ci.org/roman/Haskell-etc)
-[![Github](https://img.shields.io/github/commits-since/roman/haskell-etc/v0.3.0.0.svg)](https://img.shields.io/github/commits-since/roman/haskell-etc/v0.3.0.0.svg)
+[![Github](https://img.shields.io/github/commits-since/roman/haskell-etc/v0.3.1.0.svg)](https://img.shields.io/github/commits-since/roman/haskell-etc/v0.3.1.0.svg)
 [![Hackage](https://img.shields.io/hackage/v/etc.svg)](https://img.shields.io/hackage/v/etc.svg)
 [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/etc.svg)](https://img.shields.io/hackage/v/etc.svg)
 [![Stackage LTS](http://stackage.org/package/etc/badge/lts)](http://stackage.org/lts/package/etc)

diff --git a/etc/CHANGELOG.md b/etc/CHANGELOG.md
@@ -1,3 +1,10 @@
+0.3.1.0
+----
+
+* Add new `etc/files` entry to the spec file which allows to specify an
+  environment variable to fetch a file
+
+
 0.3.0.0
 ----
 **BREAKING CHANGES**

diff --git a/etc/etc.cabal b/etc/etc.cabal
@@ -3,7 +3,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           etc
-version:        0.3.0.0
+version:        0.3.1.0
 synopsis:       Declarative configuration spec for Haskell projects
 description:    `etc` gathers configuration values from multiple sources (cli options, OS
                 environment variables, files) using a declarative spec file that defines where
@@ -21,6 +21,7 @@ cabal-version:  >= 1.10
 data-files:
     test/fixtures/config.foo
     test/fixtures/config.json
+    test/fixtures/config.env.json
     test/fixtures/config.null.json
     test/fixtures/config.spec.yaml
     test/fixtures/config.yaml

diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs
@@ -54,10 +54,21 @@ renderConfig' ColorFn { greenColor, blueColor } (Config configValue0) =
     renderSource key source' = case source' of
       Default value' -> (renderJsonValue key value', brackets' (fill 10 (text "Default")))
 
-      File _index filepath' value' ->
-        ( renderJsonValue key value'
-        , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))
-        )
+      File _index fileSource value' -> case fileSource of
+        FilePathSource filepath' ->
+          ( renderJsonValue key value'
+          , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))
+          )
+        EnvVarFileSource envVar filepath' ->
+          ( renderJsonValue key value'
+          , brackets'
+            (fill
+              10
+              (text "File:" <+> text (Text.unpack envVar) <> "=" <> text
+                (Text.unpack filepath')
+              )
+            )
+          )
 
       Env varname value' ->
         ( renderJsonValue key value'

diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP               #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 module System.Etc.Internal.Resolver.File (resolveFiles) where
@@ -18,6 +19,8 @@ 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)
 
@@ -31,8 +34,13 @@ data ConfigFile
 --------------------------------------------------------------------------------
 
 parseConfigValue
-  :: Monad m => Maybe (Spec.ConfigValue cmd) -> Int -> Text -> JSON.Value -> m ConfigValue
-parseConfigValue mSpec fileIndex filepath json = case json of
+  :: Monad m
+  => Maybe (Spec.ConfigValue cmd)
+  -> Int
+  -> FileSource
+  -> JSON.Value
+  -> m ConfigValue
+parseConfigValue mSpec fileIndex fileSource json = case json of
   JSON.Object object -> SubConfig <$> foldM
     (\acc (key, subConfigValue) -> do
       let msubConfigSpec = do
@@ -43,7 +51,7 @@ parseConfigValue mSpec fileIndex filepath json = case json of
                 -- TODO: This should be an error given the config doesn't match spec
                 fail "configuration spec and configuration value are different"
 
-      value1 <- parseConfigValue msubConfigSpec fileIndex filepath subConfigValue
+      value1 <- parseConfigValue msubConfigSpec fileIndex fileSource subConfigValue
       return $ HashMap.insert key value1 acc
     )
     HashMap.empty
@@ -57,7 +65,7 @@ parseConfigValue mSpec fileIndex filepath json = case json of
             _ -> fail "configuration spec and configuration value are different"
 
         toValue = fromMaybe Plain mToValue
-    in  return $ ConfigValue (Set.singleton $ File fileIndex filepath (toValue json))
+    in  return $ ConfigValue (Set.singleton $ File fileIndex fileSource (toValue json))
 
 
 eitherDecode :: ConfigFile -> Either String JSON.Value
@@ -75,14 +83,15 @@ eitherDecode contents0 = case contents0 of
 #endif
 
 
-parseConfig :: MonadThrow m => Spec.ConfigValue cmd -> Int -> Text -> ConfigFile -> m Config
-parseConfig spec fileIndex filepath contents = case eitherDecode contents of
-  Left  err  -> throwM $ InvalidConfiguration Nothing (Text.pack err)
-
-  Right json -> case JSON.iparse (parseConfigValue (Just spec) fileIndex filepath) json of
-    JSON.IError _ err    -> throwM $ InvalidConfiguration Nothing (Text.pack err)
+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)
 
-    JSON.ISuccess result -> return (Config result)
+  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)
 
 readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile)
 readConfigFile filepath =
@@ -103,18 +112,19 @@ readConfigFile filepath =
                 (throwM $ InvalidConfiguration Nothing "Unsupported file extension")
         else return $ throwM $ ConfigurationFileNotFound filepath
 
-readConfigFromFiles :: Spec.ConfigSpec cmd -> IO (Config, [SomeException])
-readConfigFromFiles spec =
-  Spec.specConfigFilepaths spec
+readConfigFromFileSources
+  :: Spec.ConfigSpec cmd -> [FileSource] -> IO (Config, [SomeException])
+readConfigFromFileSources spec fileSources =
+  fileSources
     & zip [1 ..]
     & mapM
-        (\(fileIndex, filepath) -> do
-          mContents <- readConfigFile filepath
+        (\(fileIndex, fileSource) -> do
+          mContents <- readConfigFile (fileSourcePath fileSource)
           return
             (   mContents
             >>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec)
                             fileIndex
-                            filepath
+                            fileSource
             )
         )
     & (foldl'
@@ -125,6 +135,23 @@ readConfigFromFiles spec =
         (mempty, []) <$>
       )
 
+processFilesSpec :: Spec.ConfigSpec cmd -> IO (Config, [SomeException])
+processFilesSpec spec = case Spec.specConfigFilepaths spec of
+  Nothing -> readConfigFromFileSources spec []
+  Just (Spec.FilePathsSpec paths) ->
+    readConfigFromFileSources spec (map FilePathSource paths)
+  Just (Spec.FilesSpec fileEnvVar paths0) -> do
+    let getPaths = case fileEnvVar of
+          Nothing       -> return $ map FilePathSource paths0
+          Just filePath -> do
+            envFilePath <- lookupEnv (Text.unpack filePath)
+            let envPath =
+                  maybeToList ((EnvVarFileSource filePath . Text.pack) <$> envFilePath)
+            return $ map FilePathSource paths0 ++ envPath
+
+    paths <- getPaths
+    readConfigFromFileSources spec paths
+
 {-|
 
 Gathers configuration values from a list of files specified on the
@@ -137,5 +164,5 @@ resolveFiles
   :: Spec.ConfigSpec cmd -- ^ Config Spec
   -> IO (Config, Vector SomeException) -- ^ Configuration Map with all values from files filled in and a list of warnings
 resolveFiles spec = do
-  (config, exceptions) <- readConfigFromFiles spec
+  (config, exceptions) <- processFilesSpec spec
   return (config, Vector.fromList exceptions)
diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs
@@ -94,9 +94,14 @@ data CliProgramSpec
   }
   deriving (Show, Eq)
 
+data FilesSpec
+  = FilePathsSpec ![Text]
+  | FilesSpec { fileLocationEnvVar :: !(Maybe Text), fileLocationPaths :: ![Text] }
+  deriving (Show, Eq)
+
 data ConfigSpec cmd
   = ConfigSpec {
-    specConfigFilepaths :: ![Text]
+    specConfigFilepaths :: !(Maybe FilesSpec)
   , specCliProgramSpec  :: !(Maybe CliProgramSpec)
   , specConfigValues    :: !(HashMap Text (ConfigValue cmd))
   }
@@ -258,12 +263,37 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
           , 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  =
+  parseJSON json =
     case json of
       JSON.Object object ->
         ConfigSpec
-        <$> (fromMaybe [] <$> (object .:?  "etc/filepaths"))
+        <$> parseFileSpec json
         <*> (object .:? "etc/cli")
         <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))
       _ ->

diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
@@ -53,10 +53,15 @@ instance IsString a => IsString (Value a) where
 boolToValue :: Bool -> (a -> Value a)
 boolToValue = bool Plain Sensitive
 
+data FileSource
+  = FilePathSource { fileSourcePath :: !Text }
+  | EnvVarFileSource { fileSourceEnvVar :: !Text,  fileSourcePath :: !Text }
+  deriving (Show, Eq)
+
 data ConfigSource
   = File {
       configIndex :: !Int
-    , filepath    :: !Text
+    , filepath    :: !FileSource
     , value       :: !(Value JSON.Value)
     }
   | Env {

diff --git a/etc/test/System/Etc/Resolver/FileTest.hs b/etc/test/System/Etc/Resolver/FileTest.hs
@@ -16,12 +16,30 @@ import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
 import qualified Data.Aeson as JSON
 import           Paths_etc  (getDataFileName)
 
-import System.Etc
+import System.Environment (setEnv)
 
+import System.Etc
+import System.Etc.Internal.Types (FileSource (..))
 
 tests :: TestTree
 tests = testGroup
-  "file"
+  "files"
+  [ testCase "fail if using both `etc/files` and `etc/filepaths`" $ do
+    let input = "{\"etc/files\": {}, \"etc/filepaths\": []}"
+
+    (espec :: Either ConfigurationError (ConfigSpec ())) <- try $ parseConfigSpec input
+    case espec of
+      Left (InvalidConfiguration _ _) -> return ()
+      _ ->
+        assertFailure ("Expecting InvalidConfigurationError; got instead " <> show espec)
+  , filePathsTests
+  , filesTest
+  ]
+
+
+filePathsTests :: TestTree
+filePathsTests = testGroup
+  "etc/filepaths"
   [ testCase "supports json, yaml and yml extensions" $ do
     jsonFilepath <- getDataFileName "test/fixtures/config.json"
 #ifdef WITH_YAML
@@ -47,14 +65,14 @@ tests = testGroup
         ("expecting to get entries for greeting (check fixtures)\n" <> show config)
       Just aSet -> assertBool
         ("expecting to see entry from json config file " <> show aSet)
-        (Set.member (File 1 (Text.pack jsonFilepath) "hello json") aSet)
+        (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
 
 #ifdef WITH_YAML
        >> assertBool ("expecting to see entry from yaml config file " <> show aSet)
-                     (Set.member (File 2 (Text.pack jsonFilepath) "hello yaml") aSet)
+                     (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello yaml") aSet)
 
        >> assertBool ("expecting to see entry from yml config file " <> show aSet)
-                     (Set.member (File 3 (Text.pack jsonFilepath) "hello yml") aSet)
+                     (Set.member (File 3 (FilePathSource $ Text.pack jsonFilepath) "hello yml") aSet)
 #endif
   , testCase "does not support any other file extension" $ do
     fooFilepath <- getDataFileName "test/fixtures/config.foo"
@@ -69,9 +87,11 @@ tests = testGroup
     if Vector.null errs
       then assertFailure "expecting one error, got none"
       else
-        let err = Vector.head errs
+        let err = do
+              e <- errs Vector.!? 0
+              fromException e
         in
-          case fromException err of
+          case err of
             Just (InvalidConfiguration _ _) -> return ()
             _                               -> assertFailure
               ("Expecting InvalidConfigurationError; got instead " <> show err)
@@ -92,14 +112,16 @@ tests = testGroup
         ("expecting to get entries for greeting (check fixtures)\n" <> show config)
       Just aSet -> assertBool
         ("expecting to see entry from json config file " <> show aSet)
-        (Set.member (File 1 (Text.pack jsonFilepath) "hello json") aSet)
+        (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
 
     if Vector.null errs
       then assertFailure "expecting one error, got none"
       else
-        let err = Vector.head errs
+        let err = do
+              e <- errs Vector.!? 0
+              fromException e
         in
-          case fromException err of
+          case err of
             Just (ConfigurationFileNotFound _) -> return ()
             _ -> assertFailure
               ("Expecting ConfigurationFileNotFound; got instead " <> show err)
@@ -138,3 +160,49 @@ tests = testGroup
                                    greeting
       Nothing -> assertFailure "Expecting config value, but got nothing"
   ]
+
+filesTest :: TestTree
+filesTest = testGroup
+  "etc/files"
+  [ testCase "at least the `env` or `paths` keys must be present" $ do
+    let input = "{\"etc/files\": {}}"
+
+    (espec :: Either ConfigurationError (ConfigSpec ())) <- try $ parseConfigSpec input
+    case espec of
+      Left (InvalidConfiguration _ _) -> return ()
+      _ ->
+        assertFailure ("Expecting InvalidConfigurationError; 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"
+    let input = mconcat
+          [ "{\"etc/files\": {"
+          , "  \"env\": \"ENV_FILE_TEST\","
+          , "  \"paths\": [\"" <> Text.pack jsonFilepath <> "\"]"
+          , "}}"
+          ]
+
+        envFileTest = "ENV_FILE_TEST"
+
+    setEnv (Text.unpack envFileTest) envFilePath
+
+    (spec :: ConfigSpec ()) <- parseConfigSpec input
+    (config, _)             <- resolveFiles spec
+
+    case getAllConfigSources ["greeting"] config of
+      Nothing -> assertFailure
+        ("expecting to get entries for greeting (check fixtures)\n" <> show config)
+      Just aSet -> do
+        assertBool
+          ("expecting to see entry from env config file " <> show aSet)
+          (Set.member
+            (File 1
+                  (EnvVarFileSource envFileTest $ Text.pack envFilePath)
+                  "hello environment"
+            )
+            aSet
+          )
+        assertBool
+          ("expecting to see entry from json config file " <> show aSet)
+          (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
+  ]