yesod-default 0.5.0 → 0.6.1
raw patch · 3 files changed
+114/−125 lines, 3 filesdep +unordered-containersdep +yamldep −cmdargsdep −data-objectdep −data-object-yamldep ~shakespeare-jsdep ~waidep ~wai-extra
Dependencies added: unordered-containers, yaml
Dependencies removed: cmdargs, data-object, data-object-yaml
Dependency ranges changed: shakespeare-js, wai, wai-extra, warp, yesod-core
Files
- Yesod/Default/Config.hs +78/−70
- Yesod/Default/Main.hs +27/−45
- yesod-default.cabal +9/−10
Yesod/Default/Config.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} module Yesod.Default.Config ( DefaultEnv (..) , fromArgs- , fromArgsExtra , loadDevelopmentConfig -- reexport@@ -15,13 +15,13 @@ ) 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.Yaml import Data.Maybe (fromMaybe)+import qualified Data.HashMap.Strict as M+import System.Environment (getArgs, getProgName, getEnvironment)+import System.Exit (exitFailure) -- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and -- Production environments@@ -31,48 +31,55 @@ | Production deriving (Read, Show, Enum, Bounded) -- | Setup commandline arguments for environment and port-data ArgConfig = ArgConfig- { environment :: String+data ArgConfig env = ArgConfig+ { environment :: env , port :: Int- } deriving (Show, Data, Typeable)---- | A default @'ArgConfig'@ if using the provided @'DefaultEnv'@ type.-defaultArgConfig :: ArgConfig-defaultArgConfig =- ArgConfig- { environment = def- &= argPos 0- &= typ "ENVIRONMENT"- , port = def- &= help "the port to listen on"- &= typ "PORT"- }+ } deriving Show --- | Load an @'AppConfig'@ using the @'DefaultEnv'@ environments from--- commandline arguments.-fromArgs :: IO (AppConfig DefaultEnv ())-fromArgs = fromArgsExtra (const $ const $ return ())+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+ -- next line just provided to force the type of 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 --- | 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+ capitalize [] = []+ capitalize (x:xs) = toUpper x : map toLower xs -fromArgsWith :: (Read env, Show env)- => ArgConfig- -> (env -> TextObject -> IO extra)- -> IO (AppConfig env extra)-fromArgsWith argConfig getExtra = do- args <- cmdArgs argConfig+-- | Load the app config from command line parameters+fromArgs :: (Read env, Show env, Enum env, Bounded env)+ => (env -> Object -> Parser extra)+ -> IO (AppConfig env extra)+fromArgs getExtra = do+ args <- parseArgConfig - env <-- case reads $ capitalize $ environment args of- (e, _):_ -> return e- [] -> error $ "Invalid environment: " ++ environment args+ let env = environment args let cs = (configSettings env)- { csLoadExtra = getExtra+ { csParseExtra = getExtra } config <- loadConfig cs @@ -80,10 +87,6 @@ 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 $ configSettings Development@@ -103,28 +106,31 @@ -- 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+ , csParseExtra :: environment -> Object -> Parser 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+ , csGetObject :: environment -> Value -> IO Value } -- | Default config settings. configSettings :: Show env => env -> ConfigSettings env () configSettings env0 = ConfigSettings { csEnv = env0- , csLoadExtra = \_ _ -> return ()+ , csParseExtra = \_ _ -> return () , csFile = \_ -> return "config/settings.yml"- , csGetObject = \env obj -> do- envs <- fromMapping obj+ , 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- (lookup tenv envs)+ (M.lookup tenv envs) } -- | Load an @'AppConfig'@.@@ -158,22 +164,26 @@ -- loadConfig :: ConfigSettings environment extra -> IO (AppConfig environment extra)-loadConfig (ConfigSettings env loadExtra getFile getObject) = do+loadConfig (ConfigSettings env parseExtra getFile getObject) = do fp <- getFile env- topObj <- join $ decodeFile fp+ 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" - m <- maybe (fail "Expected map") return $ fromMapping obj let mssl = lookupScalar "ssl" m let mhost = lookupScalar "host" m- let mport = lookupScalar "port" m+ mport <- parseMonad (\x -> x .: "port") m let mapproot = lookupScalar "approot" m - extra <- loadExtra env obj+ extra <- parseMonad (parseExtra env) m -- set some default arguments let ssl = maybe False toBool mssl- port' <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport+ let port' = fromMaybe (if ssl then 443 else 80) mport approot <- case (mhost, mapproot) of (_ , Just ar) -> return ar@@ -192,6 +202,11 @@ } 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"]) @@ -200,14 +215,6 @@ 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. --@@ -216,11 +223,12 @@ withYamlEnvironment :: Show e => FilePath -- ^ the yaml file -> e -- ^ the environment you want to load- -> (TextObject -> IO a) -- ^ what to do with the mapping+ -> (Value -> Parser 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+ 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
Yesod/Default/Main.hs view
@@ -4,17 +4,15 @@ ( defaultMain , defaultRunner , defaultDevelApp- , defaultDevelAppWith ) where -import Yesod.Core hiding (AppConfig (..)) import Yesod.Default.Config-import Yesod.Logger (Logger, makeDefaultLogger, logString, flushLogger)+import Yesod.Logger (Logger, defaultDevelopmentLogger, logString) import Network.Wai (Application) import Network.Wai.Handler.Warp- (runSettings, defaultSettings, settingsPort, settingsHost)+ (runSettings, defaultSettings, settingsPort) import System.Directory (doesDirectoryExist, removeDirectoryRecursive)-import Network.Wai.Middleware.Gzip (gzip', GzipFiles (GzipCacheFolder), gzipFiles, def)+import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles, def) import Network.Wai.Middleware.Autohead (autohead) import Network.Wai.Middleware.Jsonp (jsonp) import Control.Monad (when)@@ -41,15 +39,15 @@ -- defaultMain :: (Show env, Read env) => IO (AppConfig env extra)- -> (AppConfig env extra -> Logger -> (Application -> IO ()) -> IO ())+ -> (AppConfig env extra -> Logger -> IO Application) -> IO ()-defaultMain load withSite = do+defaultMain load getApp = do config <- load- logger <- makeDefaultLogger- withSite config logger $ runSettings defaultSettings- { settingsHost = "0.0.0.0"- , settingsPort = appPort config- }+ logger <- defaultDevelopmentLogger+ app <- getApp config logger+ runSettings defaultSettings+ { settingsPort = appPort config+ } app -- | Run your application continously, listening for SIGINT and exiting -- when recieved@@ -59,18 +57,15 @@ -- > Settings.withConnectionPool conf $ \p -> do -- > runConnectionPool (runMigration yourMigration) p -- > defaultRunner f $ YourSite conf logger p-defaultRunner :: (YesodDispatch y y, Yesod y)- => (Application -> IO a)- -> y -- ^ your foundation type- -> IO ()-defaultRunner f h = do+defaultRunner :: (Application -> IO ()) -> Application -> IO ()+defaultRunner f app = do -- clear the .static-cache so we don't have stale content exists <- doesDirectoryExist staticCache when exists $ removeDirectoryRecursive staticCache #ifdef WINDOWS- toWaiAppPlain h >>= f . middlewares >> return ()+ f (middlewares app) #else- tid <- forkIO $ toWaiAppPlain h >>= f . middlewares >> return ()+ tid <- forkIO $ f (middlewares app) >> return () flag <- newEmptyMVar _ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do putStrLn "Caught an interrupt"@@ -79,35 +74,22 @@ takeMVar flag #endif where- middlewares = gzip' gset . jsonp . autohead+ middlewares = gzip gset . jsonp . autohead gset = def { gzipFiles = GzipCacheFolder staticCache } staticCache = ".static-cache" --- | 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 :: (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 <- makeDefaultLogger- let p = appPort conf- logString logger $ "Devel application launched, listening on port " ++ show p- withSite conf logger $ \app -> f (p, app)- flushLogger logger+defaultDevelApp+ :: (Show env, Read env)+ => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@+ -> (AppConfig env extra -> Logger -> IO Application) -- ^ Get your @Application@+ -> IO (Int, Application)+defaultDevelApp load getApp = do+ conf <- load+ logger <- defaultDevelopmentLogger+ let p = appPort conf+ logString logger $ "Devel application launched, listening on port " ++ show p+ app <- getApp conf logger+ return (p, app)
yesod-default.cabal view
@@ -1,5 +1,5 @@ name: yesod-default-version: 0.5.0+version: 0.6.1 license: BSD3 license-file: LICENSE author: Patrick Brisbin@@ -18,20 +18,19 @@ cpp-options: -DWINDOWS build-depends: base >= 4 && < 5- , yesod-core >= 0.9.4 && < 0.10- , cmdargs >= 0.8- , warp >= 0.4 && < 0.5- , wai >= 0.4 && < 0.5- , wai-extra >= 0.4.4 && < 0.5+ , yesod-core >= 0.10.1&& < 0.11+ , warp >= 1.1 && < 1.2+ , wai >= 1.1 && < 1.2+ , wai-extra >= 1.1 && < 1.2 , bytestring >= 0.9.1.4 , transformers >= 0.2.2 && < 0.3 , text >= 0.9 , directory >= 1.0 , shakespeare-css >= 0.10.5 && < 0.11- , shakespeare-js >= 0.10.4 && < 0.11+ , shakespeare-js >= 0.11 && < 0.12 , template-haskell- , data-object >= 0.3 && < 0.4- , data-object-yaml >= 0.3 && < 0.4+ , yaml >= 0.5.1.2 && < 0.6+ , unordered-containers if !os(windows) build-depends: unix@@ -45,4 +44,4 @@ source-repository head type: git- location: git://github.com/yesodweb/yesod.git+ location: https://github.com/yesodweb/yesod