{-# 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 (Value -> MergedValue) -> Value -> 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 (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
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 (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
goV (Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
    goV (Array Array
a) = Array -> Value
Array (Value -> Value
goV (Value -> Value) -> Array -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
a)
    goV (String Text
t1) = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Text -> Value
String Text
t1) (Maybe Value -> Value) -> Maybe Value -> Value
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
t2
            mdef :: Maybe Value
mdef = (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
parseValue (Maybe Text -> Maybe Value) -> Maybe Text -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t3
        Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ case Key -> KeyMap Text -> Maybe Text
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 = (SomeException -> Value)
-> (Value -> Value) -> Either SomeException Value -> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (Value -> SomeException -> Value
forall a b. a -> b -> a
const (Text -> Value
String Text
val))
      Value -> Value
forall a. a -> a
id
      (ByteString -> Either SomeException Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Y.decodeThrow (ByteString -> Either SomeException Value)
-> ByteString -> Either SomeException Value
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 = ([(String, String)] -> KeyMap Text)
-> IO [(String, String)] -> IO (KeyMap Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Key, Text)] -> KeyMap Text
forall v. [(Key, v)] -> KeyMap v
H.fromList ([(Key, Text)] -> KeyMap Text)
-> ([(String, String)] -> [(Key, Text)])
-> [(String, String)]
-> KeyMap Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (Key, Text))
-> [(String, String)] -> [(Key, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Key
fromText (Text -> Key) -> (String -> Text) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Key)
-> (String -> Text) -> (String, String) -> (Key, Text)
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 = (KeyMap Text -> Value -> Value) -> Value -> KeyMap Text -> Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> KeyMap Text -> Value -> Value
applyEnvValue Bool
requireEnv') Value
orig (KeyMap Text -> Value) -> IO (KeyMap Text) -> IO Value
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 :: [String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [String]
runTimeFiles [Value]
compileValues EnvUsage
envUsage = do
    [Value]
runValues <- [String] -> (String -> IO Value) -> IO [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
runTimeFiles ((String -> IO Value) -> IO [Value])
-> (String -> IO Value) -> IO [Value]
forall a b. (a -> b) -> a -> b
$ \String
fp -> do
        Either ParseException Value
eres <- String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
YI.decodeFileEither String
fp
        case Either ParseException Value
eres of
            Left ParseException
e -> ParseException -> IO Value
forall e a. Exception e => e -> IO a
throwIO (String -> ParseException -> ParseException
Y.LoadSettingsException String
fp ParseException
e)
            Right Value
value -> Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value

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

    case (Value -> Parser settings) -> Value -> Either String settings
forall a b. (a -> Parser b) -> a -> Either String b
Y.parseEither Value -> Parser settings
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value of
        Left String
s -> String -> IO settings
forall a. HasCallStack => String -> a
error (String -> IO settings) -> String -> IO settings
forall a b. (a -> b) -> a -> b
$ String
"Could not convert to expected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        Right settings
settings -> settings -> IO 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 :: [Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs [Value]
values EnvUsage
env = do
    [String]
args <- IO [String]
getArgs
    [String] -> [Value] -> EnvUsage -> IO settings
forall settings.
FromJSON settings =>
[String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [String]
args [Value]
values EnvUsage
env