module Yesod.Config
( AppConfig(..)
, loadConfig
, withYamlEnvironment
) where
import Control.Monad (join)
import Data.Maybe (fromMaybe)
import Data.Object
import Data.Object.Yaml
import Data.Text (Text)
import qualified Data.Text as T
data AppConfig e = AppConfig
{ appEnv :: e
, appPort :: Int
, appRoot :: Text
} deriving (Show)
loadConfig :: Show e => e -> IO (AppConfig e)
loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do
e <- maybe (fail "Expected map") return $ fromMapping e'
let mssl = lookupScalar "ssl" e
let mhost = lookupScalar "host" e
let mport = lookupScalar "port" e
let mapproot = lookupScalar "approot" e
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
}
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
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
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