{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Functionality for using YAML as configuration files
--
-- In particular, merging environment variables with yaml values
--
-- 'loadYamlSettings' is a high-level API for loading YAML and merging environment variables.
-- A yaml value of @_env:ENV_VAR:default@ will lookup the environment variable @ENV_VAR@.
--
-- On a historical note, this code was taken directly from the yesod web framework's configuration module.
module Data.Yaml.Config
    ( -- * High-level
      loadYamlSettings
    , loadYamlSettingsArgs
      -- ** EnvUsage
    , EnvUsage
    , ignoreEnv
    , useEnv
    , requireEnv
    , useCustomEnv
    , requireCustomEnv
      -- * Lower level
    , applyCurrentEnv
    , getCurrentEnv
    , applyEnvValue
    ) where


#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
import Data.Monoid
#endif
import Data.Semigroup
import Data.List.NonEmpty (nonEmpty)
import Data.Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as H
import Data.Aeson.KeyMap (KeyMap)
#else
import qualified Data.HashMap.Strict as H
#endif
import Data.Text (Text, pack)
import System.Environment (getArgs, getEnvironment)
import Control.Arrow ((***))
import Control.Monad (forM)
import Control.Exception (throwIO)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Yaml as Y
import qualified Data.Yaml.Include as YI
import Data.Maybe (fromMaybe)
import qualified Data.Text as T

#if MIN_VERSION_aeson(2,0,0)
fromText :: T.Text -> Key
fromText :: Text -> Key
fromText = Text -> Key
K.fromText
#else
fromText :: T.Text -> T.Text
fromText = id

type KeyMap a = H.HashMap T.Text a
#endif

newtype MergedValue = MergedValue { MergedValue -> Value
getMergedValue :: Value }

instance Semigroup MergedValue where
    MergedValue Value
x <> :: MergedValue -> MergedValue -> MergedValue
<> MergedValue Value
y = Value -> MergedValue
MergedValue forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeValues Value
x Value
y

-- | Left biased
mergeValues :: Value -> Value -> Value
mergeValues :: Value -> Value -> Value
mergeValues (Object Object
x) (Object Object
y) = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v
H.unionWith Value -> Value -> Value
mergeValues Object
x Object
y
mergeValues Value
x Value
_ = Value
x

-- | Override environment variable placeholders in the given @Value@ with
-- values from the environment.
--
-- If the first argument is @True@, then all placeholders _must_ be provided by
-- the actual environment. Otherwise, default values from the @Value@ will be
-- used.
--
-- @since 0.8.16
applyEnvValue :: Bool -- ^ require an environment variable to be present?
              -> KeyMap Text -> Value -> Value
applyEnvValue :: Bool -> KeyMap Text -> Value -> Value
applyEnvValue Bool
requireEnv' KeyMap Text
env =
    Value -> Value
goV
  where
    goV :: Value -> Value
goV (Object Object
o) = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ Value -> Value
goV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
    goV (Array Array
a) = Array -> Value
Array (Value -> Value
goV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
a)
    goV (String Text
t1) = forall a. a -> Maybe a -> a
fromMaybe (Text -> Value
String Text
t1) forall a b. (a -> b) -> a -> b
$ do
        Text
t2 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"_env:" Text
t1
        let (Text
name, Text
t3) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t2
            mdef :: Maybe Value
mdef = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
parseValue forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t3
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case forall v. Key -> KeyMap v -> Maybe v
H.lookup (Text -> Key
fromText Text
name) KeyMap Text
env of
            Just Text
val ->
                -- If the default value parses as a String, we treat the
                -- environment variable as a raw value and do not parse it.
                -- This means that things like numeric passwords just work.
                -- However, for originally numerical or boolean values (e.g.,
                -- port numbers), we still perform a normal YAML parse.
                --
                -- For details, see:
                -- https://github.com/yesodweb/yesod/issues/1061
                case Maybe Value
mdef of
                    Just (String Text
_) -> Text -> Value
String Text
val
                    Maybe Value
_ -> Text -> Value
parseValue Text
val
            Maybe Text
Nothing ->
                case Maybe Value
mdef of
                    Just Value
val | Bool -> Bool
not Bool
requireEnv' -> Value
val
                    Maybe Value
_ -> Value
Null
    goV Value
v = Value
v

    parseValue :: Text -> Value
parseValue Text
val = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (forall a b. a -> b -> a
const (Text -> Value
String Text
val))
      forall a. a -> a
id
      (forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Y.decodeThrow forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
val)

-- | Get the actual environment as a @HashMap@ from @Text@ to @Text@.
--
-- @since 0.8.16
getCurrentEnv :: IO (KeyMap Text)
getCurrentEnv :: IO (KeyMap Text)
getCurrentEnv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. [(Key, v)] -> KeyMap v
H.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> Key
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
pack)) IO [(String, String)]
getEnvironment

-- | A convenience wrapper around 'applyEnvValue' and 'getCurrentEnv'
--
-- @since 0.8.16
applyCurrentEnv :: Bool -- ^ require an environment variable to be present?
                -> Value -> IO Value
applyCurrentEnv :: Bool -> Value -> IO Value
applyCurrentEnv Bool
requireEnv' Value
orig = forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> KeyMap Text -> Value -> Value
applyEnvValue Bool
requireEnv') Value
orig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (KeyMap Text)
getCurrentEnv

-- | Defines how we want to use the environment variables when loading a config
-- file. Use the smart constructors provided by this module.
--
-- @since 0.8.16
data EnvUsage = IgnoreEnv
              | UseEnv
              | RequireEnv
              | UseCustomEnv (KeyMap Text)
              | RequireCustomEnv (KeyMap Text)

-- | Do not use any environment variables, instead relying on defaults values
-- in the config file.
--
-- @since 0.8.16
ignoreEnv :: EnvUsage
ignoreEnv :: EnvUsage
ignoreEnv = EnvUsage
IgnoreEnv

-- | Use environment variables when available, otherwise use defaults.
--
-- @since 0.8.16
useEnv :: EnvUsage
useEnv :: EnvUsage
useEnv = EnvUsage
UseEnv

-- | Do not use default values from the config file, but instead take all
-- overrides from the environment. If a value is missing, loading the file will
-- throw an exception.
--
-- @since 0.8.16
requireEnv :: EnvUsage
requireEnv :: EnvUsage
requireEnv = EnvUsage
RequireEnv

-- | Same as 'useEnv', but instead of the actual environment, use the provided
-- @HashMap@ as the environment.
--
-- @since 0.8.16
useCustomEnv :: KeyMap Text -> EnvUsage
useCustomEnv :: KeyMap Text -> EnvUsage
useCustomEnv = KeyMap Text -> EnvUsage
UseCustomEnv

-- | Same as 'requireEnv', but instead of the actual environment, use the
-- provided @HashMap@ as the environment.
--
-- @since 0.8.16
requireCustomEnv :: KeyMap Text -> EnvUsage
requireCustomEnv :: KeyMap Text -> EnvUsage
requireCustomEnv = KeyMap Text -> EnvUsage
RequireCustomEnv

-- | Load the settings from the following three sources:
--
-- * Run time config files
--
-- * Run time environment variables
--
-- * The default compile time config file
--
-- For example, to load up settings from @config/foo.yaml@ and allow overriding
-- from the actual environment, you can use:
--
-- > loadYamlSettings ["config/foo.yaml"] [] useEnv
--
-- @since 0.8.16
loadYamlSettings
    :: FromJSON settings
    => [FilePath] -- ^ run time config files to use, earlier files have precedence
    -> [Value] -- ^ any other values to use, usually from compile time config. overridden by files
    -> EnvUsage
    -> IO settings
loadYamlSettings :: forall settings.
FromJSON settings =>
[String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [String]
runTimeFiles [Value]
compileValues EnvUsage
envUsage = do
    [Value]
runValues <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
runTimeFiles forall a b. (a -> b) -> a -> b
$ \String
fp -> do
        Either ParseException Value
eres <- forall a. FromJSON a => String -> IO (Either ParseException a)
YI.decodeFileEither String
fp
        case Either ParseException Value
eres of
            Left ParseException
e -> forall e a. Exception e => e -> IO a
throwIO (String -> ParseException -> ParseException
Y.LoadSettingsException String
fp ParseException
e)
            Right Value
value -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
value

    Value
value' <-
        case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> MergedValue
MergedValue forall a b. (a -> b) -> a -> b
$ [Value]
runValues forall a. [a] -> [a] -> [a]
++ [Value]
compileValues of
            Maybe (NonEmpty MergedValue)
Nothing -> forall a. HasCallStack => String -> a
error String
"loadYamlSettings: No configuration provided"
            Just NonEmpty MergedValue
ne -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MergedValue -> Value
getMergedValue forall a b. (a -> b) -> a -> b
$ forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty MergedValue
ne
    Value
value <-
        case EnvUsage
envUsage of
            EnvUsage
IgnoreEnv            -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> KeyMap Text -> Value -> Value
applyEnvValue   Bool
False forall a. Monoid a => a
mempty Value
value'
            EnvUsage
UseEnv               ->          Bool -> Value -> IO Value
applyCurrentEnv Bool
False        Value
value'
            EnvUsage
RequireEnv           ->          Bool -> Value -> IO Value
applyCurrentEnv Bool
True         Value
value'
            UseCustomEnv KeyMap Text
env     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> KeyMap Text -> Value -> Value
applyEnvValue   Bool
False KeyMap Text
env    Value
value'
            RequireCustomEnv KeyMap Text
env -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> KeyMap Text -> Value -> Value
applyEnvValue   Bool
True  KeyMap Text
env    Value
value'

    case forall a b. (a -> Parser b) -> a -> Either String b
Y.parseEither forall a. FromJSON a => Value -> Parser a
parseJSON Value
value of
        Left String
s -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not convert to expected type: " forall a. [a] -> [a] -> [a]
++ String
s
        Right settings
settings -> forall (m :: * -> *) a. Monad m => a -> m a
return settings
settings

-- | Same as @loadYamlSettings@, but get the list of runtime config files from
-- the command line arguments.
--
-- @since 0.8.17
loadYamlSettingsArgs
    :: FromJSON settings
    => [Value] -- ^ any other values to use, usually from compile time config. overridden by files
    -> EnvUsage -- ^ use environment variables
    -> IO settings
loadYamlSettingsArgs :: forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs [Value]
values EnvUsage
env = do
    [String]
args <- IO [String]
getArgs
    forall settings.
FromJSON settings =>
[String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [String]
args [Value]
values EnvUsage
env