diff --git a/Yesod/Default/Config.hs b/Yesod/Default/Config.hs --- a/Yesod/Default/Config.hs +++ b/Yesod/Default/Config.hs @@ -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 ++ " [--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 diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs --- a/Yesod/Default/Main.hs +++ b/Yesod/Default/Main.hs @@ -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) diff --git a/yesod-default.cabal b/yesod-default.cabal --- a/yesod-default.cabal +++ b/yesod-default.cabal @@ -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