diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 8511163f..95e3b4f1 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -21,12 +21,18 @@ module Yesod.Core.Dispatch , Texts -- * Convert to WAI , toWaiApp + , toWaiAppPlain + , warp + , warpDebug + , warpEnv + , mkDefaultMiddlewares -- * WAI subsites , WaiSubsite (..) ) where import Prelude hiding (exp) import Yesod.Core.Internal.TH +import Language.Haskell.TH.Syntax (qLocation) import Web.PathPieces @@ -44,27 +50,41 @@ import Yesod.Core.Types import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run +import Safe (readMay) +import System.Environment (getEnvironment) + +import Network.Wai.Middleware.Autohead +import Network.Wai.Middleware.AcceptOverride +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.MethodOverride + +import qualified Network.Wai.Handler.Warp +import System.Log.FastLogger +import Control.Monad.Logger -- | Convert the given argument into a WAI application, executable with any WAI --- handler. Note that, in versions of Yesod prior to 1.2, this would include --- some default middlewares (GZIP and autohead). This is no longer the case; if --- you want these middlewares, you should provide them yourself. -toWaiApp :: YesodDispatch site => site -> IO W.Application -toWaiApp site = do +-- handler. This function will provide no middlewares; if you want commonly +-- used middlewares, please use 'toWaiApp'. +toWaiAppPlain :: YesodDispatch site => site -> IO W.Application +toWaiAppPlain site = do logger <- makeLogger site sb <- makeSessionBackend site - let yre = YesodRunnerEnv + return $ toWaiAppYre $ YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb } - return $ \req -> - case cleanPath site $ W.pathInfo req of - Left pieces -> sendRedirect site pieces req - Right pieces -> yesodDispatch yre req - { W.pathInfo = pieces - } + +toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application +toWaiAppYre yre req = + case cleanPath site $ W.pathInfo req of + Left pieces -> sendRedirect site pieces req + Right pieces -> yesodDispatch yre req + { W.pathInfo = pieces + } where + site = yreSite yre sendRedirect :: Yesod master => master -> [Text] -> W.Application sendRedirect y segments' env = return $ W.responseLBS status301 @@ -78,3 +98,83 @@ toWaiApp site = do then dest else (dest `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) + +-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This +-- set may change with future releases, but currently covers: +-- +-- * Logging +-- +-- * GZIP compression +-- +-- * Automatic HEAD method handling +-- +-- * Request method override with the _method query string parameter +-- +-- * Accept header override with the _accept query string parameter +toWaiApp :: YesodDispatch site => site -> IO W.Application +toWaiApp site = do + logger <- makeLogger site + sb <- makeSessionBackend site + let yre = YesodRunnerEnv + { yreLogger = logger + , yreSite = site + , yreSessionBackend = sb + } + messageLoggerSource + site + logger + $(qLocation >>= liftLoc) + "yesod-core" + LevelInfo + (toLogStr ("Application launched" :: S.ByteString)) + middleware <- mkDefaultMiddlewares logger + return $ middleware $ toWaiAppYre yre + +-- | A convenience method to run an application using the Warp webserver on the +-- specified port. Automatically calls 'toWaiApp'. Provides a default set of +-- middlewares. This set may change at any point without a breaking version +-- number. Currently, it includes: +-- +-- If you need more fine-grained control of middlewares, please use 'toWaiApp' +-- directly. +-- +-- Since 1.2.0 +warp :: YesodDispatch site => Int -> site -> IO () +warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.run port + +-- | A default set of middlewares. +-- +-- Since 1.2.0 +mkDefaultMiddlewares :: Logger -> IO W.Middleware +mkDefaultMiddlewares logger = do + logWare <- mkRequestLogger def + { destination = Logger logger + , outputFormat = Apache FromSocket + } + return $ logWare + . acceptOverride + . autohead + . gzip def + . methodOverride + +-- | Deprecated synonym for 'warp'. +warpDebug :: YesodDispatch site => Int -> site -> IO () +warpDebug = warp +{-# DEPRECATED warpDebug "Please use warp instead" #-} + +-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It +-- reads port information from the PORT environment variable, as used by tools +-- such as Keter and the FP Complete School of Haskell. +-- +-- Note that the exact behavior of this function may be modified slightly over +-- time to work correctly with external tools, without a change to the type +-- signature. +warpEnv :: YesodDispatch site => site -> IO () +warpEnv site = do + env <- getEnvironment + case lookup "PORT" env of + Nothing -> error $ "warpEnv: no PORT environment variable found" + Just portS -> + case readMay portS of + Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS + Just port -> warp port site diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 85d4f832..c23bf1e3 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -88,6 +88,8 @@ library , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , data-default + , safe + , warp exposed-modules: Yesod.Core Yesod.Core.Content diff --git a/yesod/Yesod.hs b/yesod/Yesod.hs index 37d40545..7210ac8d 100644 --- a/yesod/Yesod.hs +++ b/yesod/Yesod.hs @@ -6,11 +6,6 @@ module Yesod module Yesod.Core , module Yesod.Form , module Yesod.Persist - -- * Running your application - , warp - , warpDebug - , warpEnv - , develServer -- * Commonly referenced functions/datatypes , Application , liftIO @@ -64,54 +59,3 @@ readIntegral s = case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing - --- | A convenience method to run an application using the Warp webserver on the --- specified port. Automatically calls 'toWaiApp'. -warp :: YesodDispatch site => Int -> site -> IO () -warp port a = toWaiApp a >>= run port - --- | Same as 'warp', but also sends a message to stdout for each request, and --- an \"application launched\" message as well. Can be useful for development. -warpDebug :: YesodDispatch site => Int -> site -> IO () -warpDebug port app = do - hPutStrLn stderr $ "Application launched, listening on port " ++ show port - waiApp <- toWaiApp app - run port $ logStdout waiApp - --- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It --- reads port information from the PORT environment variable, as used by tools --- such as Keter. --- --- Note that the exact behavior of this function may be modified slightly over --- time to work correctly with external tools, without a change to the type --- signature. -warpEnv :: YesodDispatch site => site -> IO () -warpEnv master = do - port <- getEnv "PORT" >>= readIO - app <- toWaiApp master - run port app - --- | Run a development server, where your code changes are automatically --- reloaded. -develServer :: Int -- ^ port number - -> String -- ^ module name holding the code - -> String -- ^ name of function providing a with-application - -> IO () - -develServer port modu func = - mapM_ putStrLn - [ "Due to issues with GHC 7.0.2, you must now run the devel server" - , "separately. To do so, ensure you have installed the " - , "wai-handler-devel package >= 0.2.1 and run:" - , concat - [ " wai-handler-devel " - , show port - , " " - , modu - , " " - , func - , " --yesod" - ] - , "" - ] -