module Yesod.Default.Config
( DefaultEnv (..)
, fromArgs
, fromArgsExtra
, loadDevelopmentConfig
, AppConfig (..)
, ConfigSettings (..)
, configSettings
, loadConfig
, withYamlEnvironment
) where
import Data.Char (toUpper, toLower)
import System.Console.CmdArgs hiding (args)
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad (join)
import Data.Object
import Data.Object.Yaml
import Data.Maybe (fromMaybe)
data DefaultEnv = Development
| Testing
| Staging
| Production deriving (Read, Show, Enum, Bounded)
data ArgConfig = ArgConfig
{ environment :: String
, port :: Int
} deriving (Show, Data, Typeable)
defaultArgConfig :: ArgConfig
defaultArgConfig =
ArgConfig
{ environment = def
&= argPos 0
&= typ "ENVIRONMENT"
, port = def
&= help "the port to listen on"
&= typ "PORT"
}
fromArgs :: IO (AppConfig DefaultEnv ())
fromArgs = fromArgsExtra (const $ const $ return ())
fromArgsExtra :: (DefaultEnv -> TextObject -> IO extra)
-> IO (AppConfig DefaultEnv extra)
fromArgsExtra = fromArgsWith defaultArgConfig
fromArgsWith :: (Read env, Show env)
=> ArgConfig
-> (env -> TextObject -> IO extra)
-> IO (AppConfig env extra)
fromArgsWith argConfig getExtra = do
args <- cmdArgs argConfig
env <-
case reads $ capitalize $ environment args of
(e, _):_ -> return e
[] -> error $ "Invalid environment: " ++ environment args
let cs = (configSettings env)
{ csLoadExtra = getExtra
}
config <- loadConfig cs
return $ if port args /= 0
then config { appPort = port args }
else config
where
capitalize [] = []
capitalize (x:xs) = toUpper x : map toLower xs
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
, csLoadExtra :: environment -> TextObject -> IO extra
, csFile :: environment -> IO FilePath
, csGetObject :: environment -> TextObject -> IO TextObject
}
configSettings :: Show env => env -> ConfigSettings env ()
configSettings env0 = ConfigSettings
{ csEnv = env0
, csLoadExtra = \_ _ -> return ()
, csFile = \_ -> return "config/settings.yml"
, csGetObject = \env obj -> do
envs <- fromMapping obj
let senv = show env
tenv = T.pack senv
maybe
(error $ "Could not find environment: " ++ senv)
return
(lookup tenv envs)
}
loadConfig :: ConfigSettings environment extra
-> IO (AppConfig environment extra)
loadConfig (ConfigSettings env loadExtra getFile getObject) = do
fp <- getFile env
topObj <- join $ decodeFile fp
obj <- getObject env topObj
m <- maybe (fail "Expected map") return $ fromMapping obj
let mssl = lookupScalar "ssl" m
let mhost = lookupScalar "host" m
let mport = lookupScalar "port" m
let mapproot = lookupScalar "approot" m
extra <- loadExtra env obj
let ssl = maybe False toBool mssl
port' <- safeRead "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
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
safeRead :: Monad m => String -> Text -> m Int
safeRead name' t = case reads s of
(i, _):_ -> return i
[] -> fail $ concat ["Invalid value for ", name', ": ", s]
where
s = T.unpack t
withYamlEnvironment :: Show e
=> FilePath
-> e
-> (TextObject -> IO a)
-> IO a
withYamlEnvironment fp env f = do
obj <- join $ decodeFile fp
envs <- fromMapping obj
conf <- maybe (fail $ "Could not find environment: " ++ show env) return
$ lookup (T.pack $ show env) envs
f conf