Add yesod-default

Still needs the cabal, Setup, etc etc but at least it compiles and is
somewhat extensible.
This commit is contained in:
patrick brisbin 2011-09-19 15:15:04 -04:00
parent 4f52f22a2c
commit b031702a9b
2 changed files with 141 additions and 0 deletions

View File

@ -0,0 +1,76 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Default.Config
( DefaultEnv(..)
, ArgConfig(..)
, defaultArgConfig
, fromArgs
, fromArgsWith
, loadDevelopmentConfig
-- reexport
, module Yesod.Config
) where
import Yesod.Config
import Data.Char (toUpper, toLower)
import System.Console.CmdArgs hiding (args)
-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
-- Production environments
data DefaultEnv = Development
| Testing
| Production deriving (Read, Show, Enum, Bounded)
instance AppEnv DefaultEnv where
displayPort Production = False
displayPort _ = True
-- | Setup commandline arguments for environment and port
data ArgConfig = ArgConfig
{ environment :: String
, port :: Int
} deriving (Show, Data, Typeable)
-- | A default @'ArgConfig'@ if using the provided @'DefaultEnv'@ type.
defaultArgConfig :: ArgConfig
defaultArgConfig =
ArgConfig
{ environment = def
&= opt "development"
&= help ("application environment, one of: " ++ environments)
&= typ "ENVIRONMENT"
, port = def
&= help "the port to listen on"
&= typ "PORT"
}
where
environments :: String
environments = foldl1 (\a b -> a ++ ", " ++ b)
. map ((map toLower) . show)
$ ([minBound..maxBound] :: [DefaultEnv])
-- | Load an @'AppConfig'@ using the @'DefaultEnv'@ environments from
-- commandline arguments.
fromArgs :: IO (AppConfig DefaultEnv)
fromArgs = fromArgsWith defaultArgConfig
fromArgsWith :: AppEnv e => ArgConfig -> IO (AppConfig e)
fromArgsWith argConfig = do
args <- cmdArgs argConfig
let env = read $ capitalize $ environment args
config <- loadConfig env
return $ if port args /= 0
then config { appPort = port args }
else config
where
capitalize [] = []
capitalize (x:xs) = toUpper x : map toLower xs
-- | Load your development config (when using @'DefaultEnv'@)
loadDevelopmentConfig :: IO (AppConfig DefaultEnv)
loadDevelopmentConfig = loadConfig Development

View File

@ -0,0 +1,65 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Default.Main
( defaultMain
, defaultDevelApp
, defaultDevelAppWith
) where
import Yesod.Default.Config
import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Debug (debugHandle)
-- | Run your app, taking environment and port settings from the
-- commandline.
--
-- Use @'fromArgs'@ when using the provided @'DefaultEnv'@ type, or
-- @'fromArgsWith'@ when using a custom type
--
-- > main :: IO ()
-- > main = defaultMain fromArgs withMySite
--
-- or
--
-- > main :: IO ()
-- > main = defaultMain (fromArgsWith customArgConfig) withMySite
--
defaultMain :: AppEnv e => IO (AppConfig e) -> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -> IO ()
defaultMain load withSite = do
config <- load
logger <- makeLogger
withSite config logger $ run (appPort config)
-- | Run your development app using the provided @'DefaultEnv'@ type
--
-- > withDevelAppPort :: Dynamic
-- > withDevelAppPort = toDyn $ defaultDevelApp withMySite
--
defaultDevelApp :: (AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO ())
-> ((Int, Application) -> IO ())
-> IO ()
defaultDevelApp = defaultDevelAppWith loadDevelopmentConfig
-- | Run your development app using a custom environment type and loader
-- function
--
-- > withDevelAppPort :: Dynamic
-- > withDevelAppPort = toDyn $ (defaultDevelAppWith customLoadAppConfig) withMySite
--
defaultDevelAppWith :: AppEnv e
-- | A means to load your development @'AppConfig'@
=> IO (AppConfig e)
-- | Your @withMySite@ function
-> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ())
-> ((Int, Application) -> IO ()) -> IO ()
defaultDevelAppWith load withSite f = do
conf <- load
logger <- makeLogger
let p = appPort conf
logString logger $ "Devel application launched, listening on port " ++ show p
withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)
flushLogger logger
where
logHandle logger msg = logLazyText logger msg >> flushLogger logger