yesod-default 0.4.1 → 0.5.0
raw patch · 4 files changed
+210/−56 lines, 4 filesdep +data-objectdep +data-object-yamldep ~shakespeare-cssdep ~shakespeare-jsdep ~yesod-core
Dependencies added: data-object, data-object-yaml
Dependency ranges changed: shakespeare-css, shakespeare-js, yesod-core
Files
- Yesod/Default/Config.hs +172/−21
- Yesod/Default/Main.hs +20/−19
- Yesod/Default/Util.hs +12/−12
- yesod-default.cabal +6/−4
Yesod/Default/Config.hs view
@@ -1,19 +1,27 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Default.Config- ( DefaultEnv(..)- , ArgConfig(..)- , defaultArgConfig+ ( DefaultEnv (..) , fromArgs- , fromArgsWith+ , fromArgsExtra , loadDevelopmentConfig -- reexport- , module Yesod.Config+ , AppConfig (..)+ , ConfigSettings (..)+ , configSettings+ , loadConfig+ , withYamlEnvironment ) where -import Yesod.Config 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) -- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and -- Production environments@@ -32,27 +40,30 @@ defaultArgConfig :: ArgConfig defaultArgConfig = ArgConfig- { environment = "development"- &= help ("application environment, one of: " ++ environments)+ { environment = def+ &= argPos 0 &= 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+fromArgs :: IO (AppConfig DefaultEnv ())+fromArgs = fromArgsExtra (const $ const $ return ()) -fromArgsWith :: (Read e, Show e) => ArgConfig -> IO (AppConfig e)-fromArgsWith argConfig = do+-- | Same as 'fromArgs', but allows you to specify how to parse the 'appExtra'+-- record.+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 <-@@ -60,7 +71,10 @@ (e, _):_ -> return e [] -> error $ "Invalid environment: " ++ environment args - config <- loadConfig env+ let cs = (configSettings env)+ { csLoadExtra = getExtra+ }+ config <- loadConfig cs return $ if port args /= 0 then config { appPort = port args }@@ -71,5 +85,142 @@ capitalize (x:xs) = toUpper x : map toLower xs -- | Load your development config (when using @'DefaultEnv'@)-loadDevelopmentConfig :: IO (AppConfig DefaultEnv)-loadDevelopmentConfig = loadConfig Development+loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())+loadDevelopmentConfig = loadConfig $ configSettings Development++-- | Dynamic per-environment configuration which can be loaded at+-- run-time negating the need to recompile between environments.+data AppConfig environment extra = AppConfig+ { appEnv :: environment+ , appPort :: Int+ , appRoot :: Text+ , appExtra :: extra+ } deriving (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.+ csEnv :: environment+ -- | Load any extra data, to be used by the application.+ , csLoadExtra :: environment -> TextObject -> IO extra+ -- | Return the path to the YAML config file.+ , csFile :: environment -> IO FilePath+ -- | Get the sub-object (if relevant) from the given YAML source which+ -- contains the specific settings for the current environment.+ , csGetObject :: environment -> TextObject -> IO TextObject+ }++-- | Default config settings.+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)+ }++-- | Load an @'AppConfig'@.+--+-- Some examples:+--+-- > -- typical local development+-- > Development:+-- > host: localhost+-- > port: 3000+-- >+-- > -- ssl: will default false+-- > -- approot: will default to "http://localhost:3000"+--+-- > -- typical outward-facing production box+-- > Production:+-- > host: www.example.com+-- >+-- > -- ssl: will default false+-- > -- port: will default 80+-- > -- 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"+-- >+-- > -- approot is specified so that the non-80 port is not appended+-- > -- automatically.+--+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++ -- set some default arguments+ 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++-- | Returns 'fail' if read fails+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++-- | Loads the configuration block in the passed file named by the+-- passed environment, yeilds 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+ -> (TextObject -> IO a) -- ^ what to do with the mapping+ -> 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
Yesod/Default/Main.hs view
@@ -7,12 +7,12 @@ , defaultDevelAppWith ) where -import Yesod.Core+import Yesod.Core hiding (AppConfig (..)) import Yesod.Default.Config-import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)+import Yesod.Logger (Logger, makeDefaultLogger, logString, flushLogger) import Network.Wai (Application)-import Network.Wai.Handler.Warp (run)-import Network.Wai.Middleware.Debug (debugHandle)+import Network.Wai.Handler.Warp+ (runSettings, defaultSettings, settingsPort, settingsHost) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import Network.Wai.Middleware.Gzip (gzip', GzipFiles (GzipCacheFolder), gzipFiles, def) import Network.Wai.Middleware.Autohead (autohead)@@ -39,11 +39,17 @@ -- > main :: IO () -- > main = defaultMain (fromArgsWith customArgConfig) withMySite ---defaultMain :: (Show e, Read e) => IO (AppConfig e) -> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -> IO ()+defaultMain :: (Show env, Read env)+ => IO (AppConfig env extra)+ -> (AppConfig env extra -> Logger -> (Application -> IO ()) -> IO ())+ -> IO () defaultMain load withSite = do config <- load- logger <- makeLogger- withSite config logger $ run (appPort config)+ logger <- makeDefaultLogger+ withSite config logger $ runSettings defaultSettings+ { settingsHost = "0.0.0.0"+ , settingsPort = appPort config+ } -- | Run your application continously, listening for SIGINT and exiting -- when recieved@@ -53,9 +59,6 @@ -- > Settings.withConnectionPool conf $ \p -> do -- > runConnectionPool (runMigration yourMigration) p -- > defaultRunner f $ YourSite conf logger p------ TODO: ifdef WINDOWS--- defaultRunner :: (YesodDispatch y y, Yesod y) => (Application -> IO a) -> y -- ^ your foundation type@@ -77,6 +80,7 @@ #endif where middlewares = gzip' gset . jsonp . autohead+ gset = def { gzipFiles = GzipCacheFolder staticCache } staticCache = ".static-cache" @@ -85,7 +89,7 @@ -- > withDevelAppPort :: Dynamic -- > withDevelAppPort = toDyn $ defaultDevelApp withMySite ---defaultDevelApp :: (AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO ())+defaultDevelApp :: (AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO ()) -> ((Int, Application) -> IO ()) -> IO () defaultDevelApp = defaultDevelAppWith loadDevelopmentConfig@@ -96,17 +100,14 @@ -- > withDevelAppPort :: Dynamic -- > withDevelAppPort = toDyn $ (defaultDevelAppWith customLoadAppConfig) withMySite ---defaultDevelAppWith :: (Show e, Read e)- => IO (AppConfig e) -- ^ A means to load your development @'AppConfig'@- -> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -- ^ Your @withMySite@ function+defaultDevelAppWith :: (Show env, Read env)+ => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@+ -> (AppConfig env extra -> Logger -> (Application -> IO ()) -> IO ()) -- ^ Your @withMySite@ function -> ((Int, Application) -> IO ()) -> IO () defaultDevelAppWith load withSite f = do conf <- load- logger <- makeLogger+ logger <- makeDefaultLogger let p = appPort conf logString logger $ "Devel application launched, listening on port " ++ show p- withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)+ withSite conf logger $ \app -> f (p, app) flushLogger logger-- where- logHandle logger msg = logLazyText logger msg >> flushLogger logger
Yesod/Default/Util.hs view
@@ -5,8 +5,8 @@ module Yesod.Default.Util ( addStaticContentExternal , globFile- , widgetFileProduction- , widgetFileDebug+ , widgetFileNoReload+ , widgetFileReload ) where import Control.Monad.IO.Class (liftIO)@@ -16,9 +16,9 @@ import Control.Monad (unless) import System.Directory (doesFileExist, createDirectoryIfMissing) import Language.Haskell.TH.Syntax-import Text.Lucius (luciusFile, luciusFileDebug)-import Text.Julius (juliusFile, juliusFileDebug)-import Text.Cassius (cassiusFile, cassiusFileDebug)+import Text.Lucius (luciusFile, luciusFileReload)+import Text.Julius (juliusFile, juliusFileReload)+import Text.Cassius (cassiusFile, cassiusFileReload) import Data.Monoid (mempty) -- | An implementation of 'addStaticContent' which stores the contents in an@@ -56,20 +56,20 @@ globFile :: String -> String -> FilePath globFile kind x = "templates/" ++ x ++ "." ++ kind -widgetFileProduction :: FilePath -> Q Exp-widgetFileProduction x = do+widgetFileNoReload :: FilePath -> Q Exp+widgetFileNoReload x = do let h = whenExists x "hamlet" whamletFile let c = whenExists x "cassius" cassiusFile let j = whenExists x "julius" juliusFile let l = whenExists x "lucius" luciusFile [|$h >> addCassius $c >> addJulius $j >> addLucius $l|] -widgetFileDebug :: FilePath -> Q Exp-widgetFileDebug x = do+widgetFileReload :: FilePath -> Q Exp+widgetFileReload x = do let h = whenExists x "hamlet" whamletFile- let c = whenExists x "cassius" cassiusFileDebug- let j = whenExists x "julius" juliusFileDebug- let l = whenExists x "lucius" luciusFileDebug+ let c = whenExists x "cassius" cassiusFileReload+ let j = whenExists x "julius" juliusFileReload+ let l = whenExists x "lucius" luciusFileReload [|$h >> addCassius $c >> addJulius $j >> addLucius $l|] whenExists :: String -> String -> (FilePath -> Q Exp) -> Q Exp
yesod-default.cabal view
@@ -1,5 +1,5 @@ name: yesod-default-version: 0.4.1+version: 0.5.0 license: BSD3 license-file: LICENSE author: Patrick Brisbin@@ -18,7 +18,7 @@ cpp-options: -DWINDOWS build-depends: base >= 4 && < 5- , yesod-core >= 0.9 && < 0.10+ , yesod-core >= 0.9.4 && < 0.10 , cmdargs >= 0.8 , warp >= 0.4 && < 0.5 , wai >= 0.4 && < 0.5@@ -27,9 +27,11 @@ , transformers >= 0.2.2 && < 0.3 , text >= 0.9 , directory >= 1.0- , shakespeare-css >= 0.10 && < 0.11- , shakespeare-js >= 0.10 && < 0.11+ , shakespeare-css >= 0.10.5 && < 0.11+ , shakespeare-js >= 0.10.4 && < 0.11 , template-haskell+ , data-object >= 0.3 && < 0.4+ , data-object-yaml >= 0.3 && < 0.4 if !os(windows) build-depends: unix