From 4dc7a1258c9e50833115b27d21555c9756b91f62 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 10 Apr 2014 20:21:49 +0300 Subject: [PATCH] Deeply evaluate session and headers #712 --- yesod-core/Yesod/Core/Internal/Run.hs | 32 ++++++++++++++++++++------- yesod-core/Yesod/Core/Types.hs | 6 +++++ yesod-core/yesod-core.cabal | 3 ++- 3 files changed, 32 insertions(+), 9 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 10871a27..d20fd7f4 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -48,6 +48,7 @@ import Yesod.Core.Types import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) +import Control.DeepSeq (($!!)) -- | Function used internally by Yesod in the process of converting a -- 'HandlerT' into an 'Application'. Should not be needed by users. @@ -78,23 +79,38 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id $ fromException e) state <- liftIO $ I.readIORef istate - let finalSession = ghsSession state - let headers = ghsHeaders state - let contents = either id (HCContent defaultStatus . toTypedContent) contents' + + (finalSession, mcontents1) <- (do + finalSession <- return $!! ghsSession state + return (finalSession, Nothing)) `E.catch` \e -> return + (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException)) + + (headers, mcontents2) <- (do + headers <- return $!! appEndo (ghsHeaders state) [] + return (headers, Nothing)) `E.catch` \e -> return + ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException)) + + let contents = + case mcontents1 of + Just x -> x + Nothing -> + case mcontents2 of + Just x -> x + Nothing -> either id (HCContent defaultStatus . toTypedContent) contents' let handleError e = flip runInternalState resState $ do yar <- rheOnError e yreq { reqSession = finalSession } case yar of YRPlain status' hs ct c sess -> - let hs' = appEndo headers hs + let hs' = headers ++ hs status | status' == defaultStatus = getStatus e | otherwise = status' in return $ YRPlain status hs' ct c sess YRWai _ -> return yar let sendFile' ct fp p = - return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession + return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession contents1 <- evaluate contents `E.catch` \e -> return (HCError $! InternalError $! T.pack $! show (e :: E.SomeException)) case contents1 of @@ -102,7 +118,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e - Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession + Right c' -> return $ YRPlain status headers ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let disable_caching x = @@ -110,7 +126,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" : x hs = (if status /= H.movedPermanently301 then disable_caching else id) - $ Header "Location" (encodeUtf8 loc) : appEndo headers [] + $ Header "Location" (encodeUtf8 loc) : headers return $ YRPlain status hs typePlain emptyContent finalSession @@ -118,7 +134,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do - let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] + let hs = Header "Location" (encodeUtf8 loc) : headers return $ YRPlain H.status201 hs diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 01f52798..c64f7708 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -64,6 +64,7 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..)) import Prelude hiding (catch) +import Control.DeepSeq (NFData (rnf)) -- Sessions type SessionMap = Map Text ByteString @@ -312,6 +313,11 @@ data Header = | Header ByteString ByteString deriving (Eq, Show) +instance NFData Header where + rnf (AddCookie x) = rnf x + rnf (DeleteCookie x y) = rnf x `seq` rnf y + rnf (Header x y) = rnf x `seq` rnf y + data Location url = Local url | Remote Text deriving (Show, Eq) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index a6b8d7e7..08cfb142 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -47,7 +47,7 @@ library , containers >= 0.2 , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4 - , cookie >= 0.4 && < 0.5 + , cookie >= 0.4.1 && < 0.5 , http-types >= 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 @@ -69,6 +69,7 @@ library , unix-compat , conduit-extra , exceptions + , deepseq exposed-modules: Yesod.Core Yesod.Core.Content