{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Yesod.Default.Config
    ( DefaultEnv (..)
    , fromArgs
    , fromArgsSettings
    , loadDevelopmentConfig

    -- reexport
    , AppConfig (..)
    , ConfigSettings (..)
    , configSettings
    , loadConfig
    , withYamlEnvironment
    ) where

import Data.Char (toUpper)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml
import Data.Maybe (fromMaybe)
import System.Environment (getArgs, getProgName, getEnvironment)
import System.Exit (exitFailure)
import Data.Streaming.Network (HostPreference)
import Data.String (fromString)

#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as M
#else
import qualified Data.HashMap.Strict as M
#endif

-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
--   Production environments
data DefaultEnv = Development
                | Testing
                | Staging
                | Production deriving (ReadPrec [DefaultEnv]
ReadPrec DefaultEnv
Int -> ReadS DefaultEnv
ReadS [DefaultEnv]
(Int -> ReadS DefaultEnv)
-> ReadS [DefaultEnv]
-> ReadPrec DefaultEnv
-> ReadPrec [DefaultEnv]
-> Read DefaultEnv
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DefaultEnv]
$creadListPrec :: ReadPrec [DefaultEnv]
readPrec :: ReadPrec DefaultEnv
$creadPrec :: ReadPrec DefaultEnv
readList :: ReadS [DefaultEnv]
$creadList :: ReadS [DefaultEnv]
readsPrec :: Int -> ReadS DefaultEnv
$creadsPrec :: Int -> ReadS DefaultEnv
Read, Int -> DefaultEnv -> ShowS
[DefaultEnv] -> ShowS
DefaultEnv -> String
(Int -> DefaultEnv -> ShowS)
-> (DefaultEnv -> String)
-> ([DefaultEnv] -> ShowS)
-> Show DefaultEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultEnv] -> ShowS
$cshowList :: [DefaultEnv] -> ShowS
show :: DefaultEnv -> String
$cshow :: DefaultEnv -> String
showsPrec :: Int -> DefaultEnv -> ShowS
$cshowsPrec :: Int -> DefaultEnv -> ShowS
Show, Int -> DefaultEnv
DefaultEnv -> Int
DefaultEnv -> [DefaultEnv]
DefaultEnv -> DefaultEnv
DefaultEnv -> DefaultEnv -> [DefaultEnv]
DefaultEnv -> DefaultEnv -> DefaultEnv -> [DefaultEnv]
(DefaultEnv -> DefaultEnv)
-> (DefaultEnv -> DefaultEnv)
-> (Int -> DefaultEnv)
-> (DefaultEnv -> Int)
-> (DefaultEnv -> [DefaultEnv])
-> (DefaultEnv -> DefaultEnv -> [DefaultEnv])
-> (DefaultEnv -> DefaultEnv -> [DefaultEnv])
-> (DefaultEnv -> DefaultEnv -> DefaultEnv -> [DefaultEnv])
-> Enum DefaultEnv
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DefaultEnv -> DefaultEnv -> DefaultEnv -> [DefaultEnv]
$cenumFromThenTo :: DefaultEnv -> DefaultEnv -> DefaultEnv -> [DefaultEnv]
enumFromTo :: DefaultEnv -> DefaultEnv -> [DefaultEnv]
$cenumFromTo :: DefaultEnv -> DefaultEnv -> [DefaultEnv]
enumFromThen :: DefaultEnv -> DefaultEnv -> [DefaultEnv]
$cenumFromThen :: DefaultEnv -> DefaultEnv -> [DefaultEnv]
enumFrom :: DefaultEnv -> [DefaultEnv]
$cenumFrom :: DefaultEnv -> [DefaultEnv]
fromEnum :: DefaultEnv -> Int
$cfromEnum :: DefaultEnv -> Int
toEnum :: Int -> DefaultEnv
$ctoEnum :: Int -> DefaultEnv
pred :: DefaultEnv -> DefaultEnv
$cpred :: DefaultEnv -> DefaultEnv
succ :: DefaultEnv -> DefaultEnv
$csucc :: DefaultEnv -> DefaultEnv
Enum, DefaultEnv
DefaultEnv -> DefaultEnv -> Bounded DefaultEnv
forall a. a -> a -> Bounded a
maxBound :: DefaultEnv
$cmaxBound :: DefaultEnv
minBound :: DefaultEnv
$cminBound :: DefaultEnv
Bounded)

-- | Setup commandline arguments for environment and port
data ArgConfig env = ArgConfig
    { ArgConfig env -> env
environment :: env
    , ArgConfig env -> Int
port        :: Int
    } deriving Int -> ArgConfig env -> ShowS
[ArgConfig env] -> ShowS
ArgConfig env -> String
(Int -> ArgConfig env -> ShowS)
-> (ArgConfig env -> String)
-> ([ArgConfig env] -> ShowS)
-> Show (ArgConfig env)
forall env. Show env => Int -> ArgConfig env -> ShowS
forall env. Show env => [ArgConfig env] -> ShowS
forall env. Show env => ArgConfig env -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgConfig env] -> ShowS
$cshowList :: forall env. Show env => [ArgConfig env] -> ShowS
show :: ArgConfig env -> String
$cshow :: forall env. Show env => ArgConfig env -> String
showsPrec :: Int -> ArgConfig env -> ShowS
$cshowsPrec :: forall env. Show env => Int -> ArgConfig env -> ShowS
Show

parseArgConfig :: (Show env, Read env, Enum env, Bounded env) => IO (ArgConfig env)
parseArgConfig :: IO (ArgConfig env)
parseArgConfig = do
    let envs :: [env]
envs = [env
forall a. Bounded a => a
minBound..env
forall a. Bounded a => a
maxBound]
    [String]
args <- IO [String]
getArgs
    (String
portS, [String]
args') <- ([String] -> [String]) -> [String] -> IO (String, [String])
forall c. ([String] -> c) -> [String] -> IO (String, c)
getPort [String] -> [String]
forall a. a -> a
id [String]
args
    Int
portI <-
        case ReadS Int
forall a. Read a => ReadS a
reads String
portS of
            (Int
i, String
_):[(Int, String)]
_ -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
            [] -> String -> IO Int
forall a. HasCallStack => String -> a
error (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String
"Invalid port value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
portS
    case [String]
args' of
        [String
e] -> do
            case ReadS env
forall a. Read a => ReadS a
reads ReadS env -> ReadS env
forall a b. (a -> b) -> a -> b
$ ShowS
capitalize String
e of
                (env
e', String
_):[(env, String)]
_ -> ArgConfig env -> IO (ArgConfig env)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgConfig env -> IO (ArgConfig env))
-> ArgConfig env -> IO (ArgConfig env)
forall a b. (a -> b) -> a -> b
$ env -> Int -> ArgConfig env
forall env. env -> Int -> ArgConfig env
ArgConfig env
e' Int
portI
                [] -> do
                    () <- String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid environment, valid entries are: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [env] -> String
forall a. Show a => a -> String
show [env]
envs
                    -- next line just provided to force the type of envs
                    ArgConfig env -> IO (ArgConfig env)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgConfig env -> IO (ArgConfig env))
-> ArgConfig env -> IO (ArgConfig env)
forall a b. (a -> b) -> a -> b
$ env -> Int -> ArgConfig env
forall env. env -> Int -> ArgConfig env
ArgConfig ([env] -> env
forall a. [a] -> a
head [env]
envs) Int
0
        [String]
_ -> do
            String
pn <- IO String
getProgName
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Usage: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <environment> [--port <port>]"
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Valid environments: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [env] -> String
forall a. Show a => a -> String
show [env]
envs
            IO (ArgConfig env)
forall a. IO a
exitFailure
  where
    getPort :: ([String] -> c) -> [String] -> IO (String, c)
getPort [String] -> c
front [] = do
        [(String, String)]
env <- IO [(String, String)]
getEnvironment
        (String, c) -> IO (String, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"0" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"PORT" [(String, String)]
env, [String] -> c
front [])
    getPort [String] -> c
front (String
"--port":String
p:[String]
rest) = (String, c) -> IO (String, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
p, [String] -> c
front [String]
rest)
    getPort [String] -> c
front (String
"-p":String
p:[String]
rest) = (String, c) -> IO (String, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
p, [String] -> c
front [String]
rest)
    getPort [String] -> c
front (String
arg:[String]
rest) = ([String] -> c) -> [String] -> IO (String, c)
getPort ([String] -> c
front ([String] -> c) -> ([String] -> [String]) -> [String] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) [String]
rest

    capitalize :: ShowS
capitalize [] = []
    capitalize (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs

-- | Load the app config from command line parameters, using the given
-- @ConfigSettings.
--
-- Since 1.2.2
fromArgsSettings :: (Read env, Show env, Enum env, Bounded env)
                 => (env -> IO (ConfigSettings env extra))
                 -> IO (AppConfig env extra)
fromArgsSettings :: (env -> IO (ConfigSettings env extra)) -> IO (AppConfig env extra)
fromArgsSettings env -> IO (ConfigSettings env extra)
cs = do
    ArgConfig env
args <- IO (ArgConfig env)
forall env.
(Show env, Read env, Enum env, Bounded env) =>
IO (ArgConfig env)
parseArgConfig

    let env :: env
env = ArgConfig env -> env
forall env. ArgConfig env -> env
environment ArgConfig env
args

    AppConfig env extra
config <- env -> IO (ConfigSettings env extra)
cs env
env IO (ConfigSettings env extra)
-> (ConfigSettings env extra -> IO (AppConfig env extra))
-> IO (AppConfig env extra)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConfigSettings env extra -> IO (AppConfig env extra)
forall environment extra.
ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig

    [(String, String)]
env' <- IO [(String, String)]
getEnvironment
    let config' :: AppConfig env extra
config' =
            case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"APPROOT" [(String, String)]
env' of
                Maybe String
Nothing -> AppConfig env extra
config
                Just String
ar -> AppConfig env extra
config { appRoot :: Text
appRoot = String -> Text
T.pack String
ar }

    AppConfig env extra -> IO (AppConfig env extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppConfig env extra -> IO (AppConfig env extra))
-> AppConfig env extra -> IO (AppConfig env extra)
forall a b. (a -> b) -> a -> b
$ if ArgConfig env -> Int
forall env. ArgConfig env -> Int
port ArgConfig env
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                then AppConfig env extra
config' { appPort :: Int
appPort = ArgConfig env -> Int
forall env. ArgConfig env -> Int
port ArgConfig env
args }
                else AppConfig env extra
config'

-- | Load the app config from command line parameters
fromArgs :: (Read env, Show env, Enum env, Bounded env)
         => (env -> Object -> Parser extra)
         -> IO (AppConfig env extra)
fromArgs :: (env -> Object -> Parser extra) -> IO (AppConfig env extra)
fromArgs env -> Object -> Parser extra
getExtra = (env -> IO (ConfigSettings env extra)) -> IO (AppConfig env extra)
forall env extra.
(Read env, Show env, Enum env, Bounded env) =>
(env -> IO (ConfigSettings env extra)) -> IO (AppConfig env extra)
fromArgsSettings ((env -> IO (ConfigSettings env extra))
 -> IO (AppConfig env extra))
-> (env -> IO (ConfigSettings env extra))
-> IO (AppConfig env extra)
forall a b. (a -> b) -> a -> b
$ \env
env -> ConfigSettings env extra -> IO (ConfigSettings env extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (env -> ConfigSettings env ()
forall env. Show env => env -> ConfigSettings env ()
configSettings env
env)
    { csParseExtra :: env -> Object -> Parser extra
csParseExtra = env -> Object -> Parser extra
getExtra
    }

-- | Load your development config (when using @'DefaultEnv'@)
loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())
loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())
loadDevelopmentConfig = ConfigSettings DefaultEnv () -> IO (AppConfig DefaultEnv ())
forall environment extra.
ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig (ConfigSettings DefaultEnv () -> IO (AppConfig DefaultEnv ()))
-> ConfigSettings DefaultEnv () -> IO (AppConfig DefaultEnv ())
forall a b. (a -> b) -> a -> b
$ DefaultEnv -> ConfigSettings DefaultEnv ()
forall env. Show env => env -> ConfigSettings env ()
configSettings DefaultEnv
Development

-- | Dynamic per-environment configuration which can be loaded at
--   run-time negating the need to recompile between environments.
data AppConfig environment extra = AppConfig
    { AppConfig environment extra -> environment
appEnv   :: environment
    , AppConfig environment extra -> Int
appPort  :: Int
    , AppConfig environment extra -> Text
appRoot  :: Text
    , AppConfig environment extra -> HostPreference
appHost  :: HostPreference
    , AppConfig environment extra -> extra
appExtra :: extra
    } deriving (Int -> AppConfig environment extra -> ShowS
[AppConfig environment extra] -> ShowS
AppConfig environment extra -> String
(Int -> AppConfig environment extra -> ShowS)
-> (AppConfig environment extra -> String)
-> ([AppConfig environment extra] -> ShowS)
-> Show (AppConfig environment extra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall environment extra.
(Show environment, Show extra) =>
Int -> AppConfig environment extra -> ShowS
forall environment extra.
(Show environment, Show extra) =>
[AppConfig environment extra] -> ShowS
forall environment extra.
(Show environment, Show extra) =>
AppConfig environment extra -> String
showList :: [AppConfig environment extra] -> ShowS
$cshowList :: forall environment extra.
(Show environment, Show extra) =>
[AppConfig environment extra] -> ShowS
show :: AppConfig environment extra -> String
$cshow :: forall environment extra.
(Show environment, Show extra) =>
AppConfig environment extra -> String
showsPrec :: Int -> AppConfig environment extra -> ShowS
$cshowsPrec :: forall environment extra.
(Show environment, Show extra) =>
Int -> AppConfig environment extra -> ShowS
Show)

data ConfigSettings environment extra = ConfigSettings
    {
    -- | An arbitrary value, used below, to indicate the current running
    -- environment. Usually, you will use 'DefaultEnv' for this type.
       ConfigSettings environment extra -> environment
csEnv :: environment
    -- | Load any extra data, to be used by the application.
    , ConfigSettings environment extra
-> environment -> Object -> Parser extra
csParseExtra :: environment -> Object -> Parser extra
    -- | Return the path to the YAML config file.
    , ConfigSettings environment extra -> environment -> IO String
csFile :: environment -> IO FilePath
    -- | Get the sub-object (if relevant) from the given YAML source which
    -- contains the specific settings for the current environment.
    , ConfigSettings environment extra
-> environment -> Value -> IO Value
csGetObject :: environment -> Value -> IO Value
    }

-- | Default config settings.
configSettings :: Show env => env -> ConfigSettings env ()
configSettings :: env -> ConfigSettings env ()
configSettings env
env0 = ConfigSettings :: forall environment extra.
environment
-> (environment -> Object -> Parser extra)
-> (environment -> IO String)
-> (environment -> Value -> IO Value)
-> ConfigSettings environment extra
ConfigSettings
    { csEnv :: env
csEnv = env
env0
    , csParseExtra :: env -> Object -> Parser ()
csParseExtra = \env
_ Object
_ -> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , csFile :: env -> IO String
csFile = \env
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"config/settings.yml"
    , csGetObject :: env -> Value -> IO Value
csGetObject = \env
env Value
v -> do
        Object
envs <-
            case Value
v of
                Object Object
obj -> Object -> IO Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
obj
                Value
_ -> String -> IO Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected Object"
        let senv :: String
senv = env -> String
forall a. Show a => a -> String
show env
env
            tenv :: Key
tenv = String -> Key
forall a. IsString a => String -> a
fromString String
senv
        IO Value -> (Value -> IO Value) -> Maybe Value -> IO Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> IO Value
forall a. HasCallStack => String -> a
error (String -> IO Value) -> String -> IO Value
forall a b. (a -> b) -> a -> b
$ String
"Could not find environment: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
senv)
            Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
tenv Object
envs)
    }

-- | Load an @'AppConfig'@.
--
--   Some examples:
--
--   > -- typical local development
--   > Development:
--   >   host: localhost
--   >   port: 3000
--   >
--   >   -- approot: will default to ""
--
--   > -- typical outward-facing production box
--   > Production:
--   >   host: www.example.com
--   >
--   >   -- port: will default 80
--   >   -- host: will default to "*"
--   >   -- approot: will default "http://www.example.com"
--
--   > -- maybe you're reverse proxying connections to the running app
--   > -- on some other port
--   > Production:
--   >   port: 8080
--   >   approot: "http://example.com"
--   >   host: "localhost"
loadConfig :: ConfigSettings environment extra
           -> IO (AppConfig environment extra)
loadConfig :: ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig (ConfigSettings environment
env environment -> Object -> Parser extra
parseExtra environment -> IO String
getFile environment -> Value -> IO Value
getObject) = do
    String
fp <- environment -> IO String
getFile environment
env
    Either ParseException Value
etopObj <- String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fp
    Value
topObj <- (ParseException -> IO Value)
-> (Value -> IO Value) -> Either ParseException Value -> IO Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO Value -> ParseException -> IO Value
forall a b. a -> b -> a
const (IO Value -> ParseException -> IO Value)
-> IO Value -> ParseException -> IO Value
forall a b. (a -> b) -> a -> b
$ String -> IO Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid YAML file") Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Either ParseException Value
etopObj
    Value
obj <- environment -> Value -> IO Value
getObject environment
env Value
topObj
    Object
m <-
        case Value
obj of
            Object Object
m -> Object -> IO Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
            Value
_ -> String -> IO Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected map"

    let host :: HostPreference
host    = String -> HostPreference
forall a. IsString a => String -> a
fromString (String -> HostPreference) -> String -> HostPreference
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"*" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Text
forall (m :: * -> *). MonadFail m => Key -> Object -> m Text
lookupScalar Key
"host"    Object
m
    Maybe Int
mport <- (Object -> Parser (Maybe Int)) -> Object -> IO (Maybe Int)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Parser b) -> a -> m b
parseMonad (\Object
x -> Object
x Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port") Object
m
    let approot' :: Text
approot' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Text
forall (m :: * -> *). MonadFail m => Key -> Object -> m Text
lookupScalar Key
"approot" Object
m

    -- Handle the DISPLAY_PORT environment variable for yesod devel
    Text
approot <-
        case Text -> Text -> Maybe Text
T.stripSuffix Text
":3000" Text
approot' of
            Maybe Text
Nothing -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
approot'
            Just Text
prefix -> do
                [(String, String)]
envVars <- IO [(String, String)]
getEnvironment
                case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"DISPLAY_PORT" [(String, String)]
envVars of
                    Maybe String
Nothing -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
approot'
                    Just String
p -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
`T.append` String -> Text
T.pack (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: String
p)

    extra
extra <- (Object -> Parser extra) -> Object -> IO extra
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Parser b) -> a -> m b
parseMonad (environment -> Object -> Parser extra
parseExtra environment
env) Object
m

    -- set some default arguments
    let port' :: Int
port' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
80 Maybe Int
mport

    AppConfig environment extra -> IO (AppConfig environment extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (AppConfig environment extra -> IO (AppConfig environment extra))
-> AppConfig environment extra -> IO (AppConfig environment extra)
forall a b. (a -> b) -> a -> b
$ AppConfig :: forall environment extra.
environment
-> Int
-> Text
-> HostPreference
-> extra
-> AppConfig environment extra
AppConfig
        { appEnv :: environment
appEnv   = environment
env
        , appPort :: Int
appPort  = Int
port'
        , appRoot :: Text
appRoot  = Text
approot
        , appHost :: HostPreference
appHost  = HostPreference
host
        , appExtra :: extra
appExtra = extra
extra
        }

    where
        lookupScalar :: Key -> Object -> m Text
lookupScalar Key
k Object
m =
            case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k Object
m of
                Just (String Text
t) -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
                Just Value
_ -> String -> m Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ String
"Invalid value for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
k
                Maybe Value
Nothing -> String -> m Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ String
"Not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
k

-- | Loads the configuration block in the passed file named by the
--   passed environment, yields to the passed function as a mapping.
--
--   Errors in the case of a bad load or if your function returns
--   @Nothing@.
withYamlEnvironment :: Show e
                    => FilePath -- ^ the yaml file
                    -> e        -- ^ the environment you want to load
                    -> (Value -> Parser a) -- ^ what to do with the mapping
                    -> IO a
withYamlEnvironment :: String -> e -> (Value -> Parser a) -> IO a
withYamlEnvironment String
fp e
env Value -> Parser a
f = do
    Either ParseException Value
mval <- String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fp
    case Either ParseException Value
mval of
        Left ParseException
err ->
          String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Invalid YAML file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseException -> String
prettyPrintParseException ParseException
err
        Right (Object Object
obj)
            | Just Value
v <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup (String -> Key
forall a. IsString a => String -> a
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
env) Object
obj -> (Value -> Parser a) -> Value -> IO a
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Parser b) -> a -> m b
parseMonad Value -> Parser a
f Value
v
        Either ParseException Value
_ -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Could not find environment: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
env