module Yesod.Default.Config
( DefaultEnv (..)
, fromArgs
, loadDevelopmentConfig
, AppConfig (..)
, ConfigSettings (..)
, configSettings
, loadConfig
, withYamlEnvironment
) where
import Data.Char (toUpper, toLower)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml
import Data.Maybe (fromMaybe)
import qualified Data.HashMap.Strict as M
import System.Environment (getArgs, getProgName, getEnvironment)
import System.Exit (exitFailure)
data DefaultEnv = Development
| Testing
| Staging
| Production deriving (Read, Show, Enum, Bounded)
data ArgConfig env = ArgConfig
{ environment :: env
, port :: Int
} deriving Show
parseArgConfig :: (Show env, Read env, Enum env, Bounded env) => IO (ArgConfig env)
parseArgConfig = do
let envs = [minBound..maxBound]
args <- getArgs
(portS, args') <- getPort id args
portI <-
case reads portS of
(i, _):_ -> return i
[] -> error $ "Invalid port value: " ++ show portS
case args' of
[e] -> do
case reads $ capitalize e of
(e', _):_ -> return $ ArgConfig e' portI
[] -> do
() <- error $ "Invalid environment, valid entries are: " ++ show envs
return $ ArgConfig (head envs) 0
_ -> do
pn <- getProgName
putStrLn $ "Usage: " ++ pn ++ " <environment> [--port <port>]"
putStrLn $ "Valid environments: " ++ show envs
exitFailure
where
getPort front [] = do
env <- getEnvironment
return (fromMaybe "0" $ lookup "PORT" env, front [])
getPort front ("--port":p:rest) = return (p, front rest)
getPort front ("-p":p:rest) = return (p, front rest)
getPort front (arg:rest) = getPort (front . (arg:)) rest
capitalize [] = []
capitalize (x:xs) = toUpper x : map toLower xs
fromArgs :: (Read env, Show env, Enum env, Bounded env)
=> (env -> Object -> Parser extra)
-> IO (AppConfig env extra)
fromArgs getExtra = do
args <- parseArgConfig
let env = environment args
let cs = (configSettings env)
{ csParseExtra = getExtra
}
config <- loadConfig cs
return $ if port args /= 0
then config { appPort = port args }
else config
loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())
loadDevelopmentConfig = loadConfig $ configSettings Development
data AppConfig environment extra = AppConfig
{ appEnv :: environment
, appPort :: Int
, appRoot :: Text
, appExtra :: extra
} deriving (Show)
data ConfigSettings environment extra = ConfigSettings
{
csEnv :: environment
, csParseExtra :: environment -> Object -> Parser extra
, csFile :: environment -> IO FilePath
, csGetObject :: environment -> Value -> IO Value
}
configSettings :: Show env => env -> ConfigSettings env ()
configSettings env0 = ConfigSettings
{ csEnv = env0
, csParseExtra = \_ _ -> return ()
, csFile = \_ -> return "config/settings.yml"
, csGetObject = \env v -> do
envs <-
case v of
Object obj -> return obj
_ -> fail "Expected Object"
let senv = show env
tenv = T.pack senv
maybe
(error $ "Could not find environment: " ++ senv)
return
(M.lookup tenv envs)
}
loadConfig :: ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig (ConfigSettings env parseExtra getFile getObject) = do
fp <- getFile env
mtopObj <- decodeFile fp
topObj <- maybe (fail "Invalid YAML file") return mtopObj
obj <- getObject env topObj
m <-
case obj of
Object m -> return m
_ -> fail "Expected map"
let mssl = lookupScalar "ssl" m
let mhost = lookupScalar "host" m
mport <- parseMonad (\x -> x .: "port") m
let mapproot = lookupScalar "approot" m
extra <- parseMonad (parseExtra env) m
let ssl = maybe False toBool mssl
let port' = fromMaybe (if ssl then 443 else 80) mport
approot <- case (mhost, mapproot) of
(_ , Just ar) -> return ar
(Just host, _ ) -> return $ T.concat
[ if ssl then "https://" else "http://"
, host
, addPort ssl port'
]
_ -> fail "You must supply either a host or approot"
return $ AppConfig
{ appEnv = env
, appPort = port'
, appRoot = approot
, appExtra = extra
}
where
lookupScalar k m =
case M.lookup k m of
Just (String t) -> return t
Just _ -> fail $ "Invalid value for: " ++ show k
Nothing -> fail $ "Not found: " ++ show k
toBool :: Text -> Bool
toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
addPort :: Bool -> Int -> Text
addPort True 443 = ""
addPort False 80 = ""
addPort _ p = T.pack $ ':' : show p
withYamlEnvironment :: Show e
=> FilePath
-> e
-> (Value -> Parser a)
-> IO a
withYamlEnvironment fp env f = do
mval <- decodeFile fp
case mval of
Nothing -> fail $ "Invalid YAML file: " ++ show fp
Just (Object obj)
| Just v <- M.lookup (T.pack $ show env) obj -> parseMonad f v
_ -> fail $ "Could not find environment: " ++ show env