diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 60308d43..a95588f6 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -12,7 +12,6 @@ import Control.Exception (SomeException, fromException, import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (LogLevel, LogSource) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -30,12 +29,10 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H import Network.Wai import Prelude hiding (catch) import System.IO (hPutStrLn, stderr) -import System.Log.FastLogger (LogStr) import System.Log.FastLogger (Logger) import System.Random (newStdGen) import Web.Cookie (renderSetCookie) @@ -83,30 +80,20 @@ headerToPair (Header key value) = (CI.mk key, value) localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = - local (\hd -> hd { handlerRoute = Nothing }) + local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }}) local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub master a -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r -data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData - { rheRender :: !(Route master -> [(Text, Text)] -> Text) - , rheRoute :: !(Maybe (Route sub)) - , rheToMaster :: !(Route sub -> Route master) - , rheMaster :: !master - , rheSub :: !sub - , rheUpload :: !(RequestBodyLength -> FileUpload) - , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - } - -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. runHandler :: HasReps c => RunHandlerEnv sub master -> GHandler sub master c -> YesodApp -runHandler RunHandlerEnv {..} handler yreq = do +runHandler rhe@RunHandlerEnv {..} handler yreq = do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -120,14 +107,8 @@ runHandler RunHandlerEnv {..} handler yreq = do } let hd = HandlerData { handlerRequest = yreq - , handlerSub = rheSub - , handlerMaster = rheMaster - , handlerRoute = rheRoute - , handlerRender = rheRender - , handlerToMaster = rheToMaster - , handlerState = istate - , handlerUpload = rheUpload - , handlerLog = rheLog + , handlerEnv = rhe + , handlerState = istate } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -290,15 +271,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} -data YesodRunnerEnv sub master = YesodRunnerEnv - { yreLogger :: !Logger - , yreMaster :: !master - , yreSub :: !sub - , yreRoute :: !(Maybe (Route sub)) - , yreToMaster :: !(Route sub -> Route master) - , yreSessionBackend :: !(Maybe (SessionBackend master)) - } - defaultYesodRunner :: Yesod master => YesodRunnerEnv sub master -> GHandler sub master ChooseRep @@ -410,9 +382,11 @@ handlerSubDataMaybe :: (Route sub -> Route master) -> HandlerData oldSub master -> HandlerData sub master handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route + { handlerEnv = (handlerEnv hd) + { rheSub = ts $ rheMaster $ handlerEnv hd + , rheToMaster = tm + , rheRoute = route + } } resolveApproot :: Yesod master => master -> Request -> ResolvedApproot diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 4a7d077f..0ba8f6cb 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -44,7 +44,7 @@ import Network.Wai (FilePart, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP -import System.Log.FastLogger (LogStr, toLogStr) +import System.Log.FastLogger (LogStr, toLogStr, Logger) import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) @@ -114,8 +114,8 @@ data YesodRequest = YesodRequest -- | An augmented WAI 'W.Response'. This can either be a standard @Response@, -- or a higher-level data structure which Yesod will turn into a @Response@. data YesodResponse - = YRWai W.Response - | YRPlain H.Status [Header] ContentType Content SessionMap + = YRWai !W.Response + | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = @@ -124,15 +124,15 @@ type RequestBodyContents = ) data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileSource :: Source (ResourceT IO) ByteString - , fileMove :: FilePath -> IO () + { fileName :: !Text + , fileContentType :: !Text + , fileSource :: !(Source (ResourceT IO) ByteString) + , fileMove :: !(FilePath -> IO ()) } -data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) - | FileUploadDisk (NWP.BackEnd FilePath) - | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) +data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) + | FileUploadDisk !(NWP.BackEnd FilePath) + | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString)) -- | How to determine the root of the application for constructing URLs. -- @@ -140,9 +140,9 @@ data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) -- the major version number. As a result, you should /not/ pattern match on -- @Approot@ values. data Approot master = ApprootRelative -- ^ No application root. - | ApprootStatic Text - | ApprootMaster (master -> Text) - | ApprootRequest (master -> W.Request -> Text) + | ApprootStatic !Text + | ApprootMaster !(master -> Text) + | ApprootRequest !(master -> W.Request -> Text) type ResolvedApproot = Text @@ -169,16 +169,29 @@ type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } +data RunHandlerEnv sub master = RunHandlerEnv + { rheRender :: !(Route master -> [(Text, Text)] -> Text) + , rheRoute :: !(Maybe (Route sub)) + , rheToMaster :: !(Route sub -> Route master) + , rheMaster :: !master + , rheSub :: !sub + , rheUpload :: !(RequestBodyLength -> FileUpload) + , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + } + data HandlerData sub master = HandlerData - { handlerRequest :: YesodRequest - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: Route master -> [(Text, Text)] -> Text - , handlerToMaster :: Route sub -> Route master - , handlerState :: IORef GHState - , handlerUpload :: RequestBodyLength -> FileUpload - , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + { handlerRequest :: !YesodRequest + , handlerEnv :: !(RunHandlerEnv sub master) + , handlerState :: !(IORef GHState) + } + +data YesodRunnerEnv sub master = YesodRunnerEnv + { yreLogger :: !Logger + , yreMaster :: !master + , yreSub :: !sub + , yreRoute :: !(Maybe (Route sub)) + , yreToMaster :: !(Route sub -> Route master) + , yreSessionBackend :: !(Maybe (SessionBackend master)) } -- | A generic handler monad, which can have a different subsite and master @@ -407,7 +420,7 @@ instance MonadResource (GHandler sub master) where instance MonadLogger (GHandler sub master) where monadLoggerLog a b c d = GHandler $ \hd -> - liftIO $ handlerLog hd a b c (toLogStr d) + liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) instance Exception e => Failure e (GHandler sub master) where failure = liftIO . throwIO diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 5f260034..a2f1bcc3 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -199,7 +199,7 @@ hcError = liftIO . throwIO . HCError runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do hd <- ask - let getUpload = handlerUpload hd + let getUpload = rheUpload $ handlerEnv hd len = W.requestBodyLength $ reqWaiRequest $ handlerRequest hd @@ -241,32 +241,32 @@ rbHelper' backend mkFI req = -- | Get the sub application argument. getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub `liftM` ask +getYesodSub = (rheSub . handlerEnv) `liftM` ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master -getYesod = handlerMaster `liftM` ask +getYesod = (rheMaster . handlerEnv) `liftM` ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> Text) getUrlRender = do - x <- handlerRender `liftM` ask + x <- (rheRender . handlerEnv) `liftM` ask return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: GHandler sub master (Route master -> [(Text, Text)] -> Text) -getUrlRenderParams = handlerRender `liftM` ask +getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute `liftM` ask +getCurrentRoute = (rheRoute . handlerEnv) `liftM` ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster `liftM` ask +getRouteToMaster = (rheToMaster . handlerEnv) `liftM` ask -- | Returns a function that runs 'GHandler' actions inside @IO@.