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 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 => Maybe (Spec.ConfigValue cmd) -> Int -> Text -> JSON.Value -> m ConfigValue
parseConfigValue mSpec fileIndex filepath json = case json of
JSON.Object object -> SubConfig <$> foldM
(\acc (key, subConfigValue) -> do
let msubConfigSpec = do
spec <- mSpec
case spec of
Spec.SubConfig hsh -> HashMap.lookup key hsh
_ ->
fail "configuration spec and configuration value are different"
value1 <- parseConfigValue msubConfigSpec fileIndex filepath subConfigValue
return $ HashMap.insert key value1 acc
)
HashMap.empty
(HashMap.toList object)
_ ->
let mToValue = do
spec <- mSpec
case spec of
Spec.ConfigValue{} -> return $ boolToValue (Spec.isSensitive spec)
_ -> fail "configuration spec and configuration value are different"
toValue = fromMaybe Plain mToValue
in return $ ConfigValue (Set.singleton $ File fileIndex filepath (toValue json))
eitherDecode :: ConfigFile -> Either String JSON.Value
#ifdef WITH_YAML
eitherDecode contents0 =
case contents0 of
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 -> 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)
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
readConfigFromFiles :: Spec.ConfigSpec cmd -> IO (Config, [SomeException])
readConfigFromFiles spec =
Spec.specConfigFilepaths spec
& zip [1 ..]
& mapM
(\(fileIndex, filepath) -> do
mContents <- readConfigFile filepath
return
( mContents
>>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec)
fileIndex
filepath
)
)
& (foldl'
(\(result, errs) eCurrent -> case eCurrent of
Left err -> (result, err : errs)
Right current -> (result `mappend` current, errs)
)
(mempty, []) <$>
)
resolveFiles
:: Spec.ConfigSpec cmd
-> IO (Config, Vector SomeException)
resolveFiles spec = do
(config, exceptions) <- readConfigFromFiles spec
return (config, Vector.fromList exceptions)