{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Etc.Internal.Resolver.File (resolveFiles) where
import RIO
import RIO.Directory (doesFileExist)
import qualified RIO.HashMap as HashMap
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import qualified RIO.Vector as Vector
#ifdef WITH_YAML
import qualified Data.Yaml as YAML
#endif
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Internal as JSON (IResult (..), iparse)
import qualified 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)
data ConfigFile
= JsonFile Text LB8.ByteString
| YamlFile Text LB8.ByteString
deriving (Show, Eq)
parseConfigValue
:: Monad m
=> [Text]
-> Maybe (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
_ ->
fail "configuration spec and configuration value are different"
value1 <- parseConfigValue (key : keys)
msubConfigSpec
fileIndex
fileSource
subConfigValue
return $ HashMap.insert key value1 acc
)
HashMap.empty
(HashMap.toList object)
_ -> case mSpec of
Just Spec.ConfigValue { Spec.isSensitive, Spec.configValueType } -> do
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
#ifdef WITH_YAML
eitherDecode contents0 =
case contents0 of
JsonFile _ contents ->
JSON.eitherDecode contents
YamlFile _ contents ->
YAML.decodeEither (LB8.toStrict contents)
#else
eitherDecode contents0 = case contents0 of
JsonFile _ contents -> JSON.eitherDecode contents
YamlFile filepath _ -> Left ("Unsupported yaml file: " <> Text.unpack filepath)
#endif
parseConfig
:: MonadThrow m => 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)
readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile)
readConfigFile filepath =
let filepathStr = Text.unpack filepath
in
do
fileExists <- doesFileExist filepathStr
if fileExists
then do
contents <- LB8.readFile filepathStr
if ".json" `Text.isSuffixOf` filepath
then
return $ return (JsonFile filepath contents)
else
if (".yaml" `Text.isSuffixOf` filepath) || (".yml" `Text.isSuffixOf` filepath)
then return $ return (YamlFile filepath contents)
else return
(throwM $ InvalidConfiguration Nothing "Unsupported file extension")
else return $ throwM $ ConfigurationFileNotFound filepath
readConfigFromFileSources
:: Spec.ConfigSpec cmd -> [FileSource] -> IO (Config, [SomeException])
readConfigFromFileSources spec fileSources =
fileSources
& zip [1 ..]
& mapM
(\(fileIndex, fileSource) -> do
mContents <- readConfigFile (fileSourcePath fileSource)
return
( mContents
>>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec)
fileIndex
fileSource
)
)
& (foldl'
(\(result, errs) eCurrent -> case eCurrent of
Left err -> (result, err : errs)
Right current -> (result `mappend` current, errs)
)
(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
resolveFiles
:: Spec.ConfigSpec cmd
-> IO (Config, Vector SomeException)
resolveFiles spec = do
(config, exceptions) <- processFilesSpec spec
return (config, Vector.fromList exceptions)