{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Etc.Internal.Config where
import RIO
import qualified RIO.HashMap as HashMap
import qualified RIO.Set as Set
import qualified RIO.Text as Text
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse)
import qualified Data.Aeson.Types as JSON (Parser)
import System.Etc.Internal.Types
configValueToJsonObject :: ConfigValue -> JSON.Value
configValueToJsonObject configValue = case configValue of
ConfigValue sources -> case Set.maxView sources of
Nothing -> error "this should not happen"
Just (source, _) -> fromValue $ value source
SubConfig configm ->
configm
& HashMap.foldrWithKey
(\key innerConfigValue acc ->
HashMap.insert key (configValueToJsonObject innerConfigValue) acc
)
HashMap.empty
& JSON.Object
_getConfigValueWith
:: MonadThrow m => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result
_getConfigValueWith parser keys0 (Config configValue0) =
let
loop keys configValue = case (keys, configValue) of
([], ConfigValue sources) -> case Set.maxView sources of
Nothing -> throwM $ InvalidConfigKeyPath keys0
Just (None , _) -> throwM $ InvalidConfigKeyPath keys0
Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of
JSON.IError path err ->
let key = keys0 & reverse & Text.intercalate "."
in JSON.formatError path err
& Text.pack
& InvalidConfiguration (Just key)
& throwM
JSON.ISuccess result -> return result
([], innerConfigValue) ->
case JSON.iparse parser (configValueToJsonObject innerConfigValue) of
JSON.IError path err ->
let key = keys0 & reverse & Text.intercalate "."
in JSON.formatError path err
& Text.pack
& InvalidConfiguration (Just key)
& throwM
JSON.ISuccess result -> return result
(k : keys1, SubConfig configm) -> case HashMap.lookup k configm of
Nothing -> throwM $ InvalidConfigKeyPath keys0
Just configValue1 -> loop keys1 configValue1
_ -> throwM $ InvalidConfigKeyPath keys0
in loop keys0 configValue0
_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m ConfigSource
_getSelectedConfigSource keys0 (Config configValue0) =
let loop keys configValue = case (keys, configValue) of
([], ConfigValue sources) -> case Set.maxView sources of
Nothing -> throwM $ InvalidConfigKeyPath keys0
Just (source, _) -> return source
(k : keys1, SubConfig configm) -> case HashMap.lookup k configm of
Nothing -> throwM $ InvalidConfigKeyPath keys0
Just configValue1 -> loop keys1 configValue1
_ -> throwM $ InvalidConfigKeyPath keys0
in loop keys0 configValue0
_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set ConfigSource)
_getAllConfigSources keys0 (Config configValue0) =
let loop keys configValue = case (keys, configValue) of
([] , ConfigValue sources) -> return sources
(k : keys1, SubConfig configm ) -> case HashMap.lookup k configm of
Nothing -> throwM $ InvalidConfigKeyPath keys0
Just configValue1 -> loop keys1 configValue1
_ -> throwM $ InvalidConfigKeyPath keys0
in loop keys0 configValue0
_getConfigValue :: (MonadThrow m, JSON.FromJSON result) => [Text] -> Config -> m result
_getConfigValue = _getConfigValueWith JSON.parseJSON
instance IConfig Config where
getConfigValue = _getConfigValue
getConfigValueWith = _getConfigValueWith
getAllConfigSources = _getAllConfigSources
getSelectedConfigSource = _getSelectedConfigSource