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

    capitalize :: ShowS
capitalize [] = []
    capitalize (Char
x:String
xs) = Char -> Char
toUpper Char
x 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 :: 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)
cs = do
    ArgConfig env
args <- forall env.
(Show env, Read env, Enum env, Bounded env) =>
IO (ArgConfig env)
parseArgConfig

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

    AppConfig env extra
config <- env -> IO (ConfigSettings env extra)
cs env
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 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 }

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall env. ArgConfig env -> Int
port ArgConfig env
args forall a. Eq a => a -> a -> Bool
/= Int
0
                then AppConfig env extra
config' { appPort :: Int
appPort = 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 :: forall env extra.
(Read env, Show env, Enum env, Bounded env) =>
(env -> Object -> Parser extra) -> IO (AppConfig env extra)
fromArgs env -> Object -> Parser extra
getExtra = forall env extra.
(Read env, Show env, Enum env, Bounded env) =>
(env -> IO (ConfigSettings env extra)) -> IO (AppConfig env extra)
fromArgsSettings forall a b. (a -> b) -> a -> b
$ \env
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall environment extra.
ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig forall a b. (a -> b) -> a -> b
$ 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
    { forall environment extra.
AppConfig environment extra -> environment
appEnv   :: environment
    , forall environment extra. AppConfig environment extra -> Int
appPort  :: Int
    , forall environment extra. AppConfig environment extra -> Text
appRoot  :: Text
    , forall environment extra.
AppConfig environment extra -> HostPreference
appHost  :: HostPreference
    , forall environment extra. AppConfig environment extra -> extra
appExtra :: extra
    } deriving (Int -> AppConfig environment extra -> ShowS
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.
       forall environment extra.
ConfigSettings environment extra -> environment
csEnv :: environment
    -- | Load any extra data, to be used by the application.
    , forall environment extra.
ConfigSettings environment extra
-> environment -> Object -> Parser extra
csParseExtra :: environment -> Object -> Parser extra
    -- | Return the path to the YAML config file.
    , forall environment extra.
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.
    , forall environment extra.
ConfigSettings environment extra
-> environment -> Value -> IO Value
csGetObject :: environment -> Value -> IO Value
    }

-- | Default config settings.
configSettings :: Show env => env -> ConfigSettings env ()
configSettings :: forall env. Show env => env -> ConfigSettings env ()
configSettings env
env0 = ConfigSettings
    { csEnv :: env
csEnv = env
env0
    , csParseExtra :: env -> Object -> Parser ()
csParseExtra = \env
_ Object
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , csFile :: env -> IO String
csFile = \env
_ -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Object
obj
                Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected Object"
        let senv :: String
senv = forall a. Show a => a -> String
show env
env
            tenv :: Key
tenv = forall a. IsString a => String -> a
fromString String
senv
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find environment: " forall a. [a] -> [a] -> [a]
++ String
senv)
            forall (m :: * -> *) a. Monad m => a -> m a
return
            (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 :: forall environment extra.
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 <- forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fp
    Value
topObj <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid YAML file") 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
            Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected map"

    let host :: HostPreference
host    = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"*" forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadFail m => Key -> Object -> m Text
lookupScalar Key
"host"    Object
m
    Maybe Int
mport <- forall (m :: * -> *) a b.
MonadFail m =>
(a -> Parser b) -> a -> m b
parseMonad (\Object
x -> Object
x forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port") Object
m
    let approot' :: Text
approot' = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
approot'
            Just Text
prefix -> do
                [(String, String)]
envVars <- IO [(String, String)]
getEnvironment
                case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"DISPLAY_PORT" [(String, String)]
envVars of
                    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
approot'
                    Just String
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
`T.append` String -> Text
T.pack (Char
':' forall a. a -> [a] -> [a]
: String
p)

    extra
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' = forall a. a -> Maybe a -> a
fromMaybe Int
80 Maybe Int
mport

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k Object
m of
                Just (String Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
                Just Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid value for: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key
k
                Maybe Value
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not found: " forall a. [a] -> [a] -> [a]
++ 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 :: forall e a. Show e => String -> e -> (Value -> Parser a) -> IO a
withYamlEnvironment String
fp e
env Value -> Parser a
f = do
    Either ParseException Value
mval <- forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fp
    case Either ParseException Value
mval of
        Left ParseException
err ->
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid YAML file: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
fp forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ ParseException -> String
prettyPrintParseException ParseException
err
        Right (Object Object
obj)
            | Just Value
v <- forall v. Key -> KeyMap v -> Maybe v
M.lookup (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show e
env) Object
obj -> forall (m :: * -> *) a b.
MonadFail m =>
(a -> Parser b) -> a -> m b
parseMonad Value -> Parser a
f Value
v
        Either ParseException Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not find environment: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
env