diff --git a/Yesod/Default/Config.hs b/Yesod/Default/Config.hs --- a/Yesod/Default/Config.hs +++ b/Yesod/Default/Config.hs @@ -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 diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs --- a/Yesod/Default/Main.hs +++ b/Yesod/Default/Main.hs @@ -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 diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs --- a/Yesod/Default/Util.hs +++ b/Yesod/Default/Util.hs @@ -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 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.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