diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index b8ff28e0..d5827ea3 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -28,6 +28,8 @@ module Yesod.Content , typeOctet -- * Utilities , simpleContentType + -- * Evaluation strategy + , DontFullyEvaluate (..) -- * Representations , ChooseRep , HasReps (..) @@ -68,6 +70,7 @@ import Data.Conduit (Source, ResourceT, Flush) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentSource (Source (ResourceT IO) (Flush Builder)) | ContentFile FilePath (Maybe FilePart) + | ContentDontEvaluate Content -- | Zero-length enumerator. emptyContent :: Content @@ -235,3 +238,15 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" -- | Format as per RFC 822. formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" + +-- | Prevents a response body from being fully evaluated before sending the +-- request. +-- +-- Since 1.1.0 +newtype DontFullyEvaluate a = DontFullyEvaluate a + +instance HasReps a => HasReps (DontFullyEvaluate a) where + chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a + +instance ToContent a => ToContent (DontFullyEvaluate a) where + toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index b0a357fd..21bb25e5 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -395,9 +395,8 @@ runHandler :: HasReps c -> sub -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) - -> Bool -- ^ to eval body? -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' toEval = +runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of @@ -440,7 +439,7 @@ runHandler handler mrender sroute tomr master sub upload log' toEval = case contents of HCContent status a -> do (ct, c) <- liftIO $ a cts - ec' <- if toEval then liftIO $ evaluateContent c else return (Right c) + ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession @@ -806,7 +805,6 @@ handlerToYAR :: (HasReps a, HasReps b) -> sub -- ^ sub site foundation -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) - -> Bool -- ^ to eval body? -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a) @@ -815,28 +813,31 @@ handlerToYAR :: (HasReps a, HasReps b) -> SessionMap -> GHandler sub master b -> ResourceT IO YesodAppResult -handlerToYAR y s upload log' toEval toMasterRoute render errorHandler rr murl sessionMap h = +handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where - ya = runHandler h render murl toMasterRoute y s upload log' toEval - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval + ya = runHandler h render murl toMasterRoute y s upload log' + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response yarToResponse (YARWai a) _ = a yarToResponse (YARPlain s hs _ c _) extraHeaders = - case c of - ContentBuilder b mlen -> - let hs' = maybe finalHeaders finalHeaders' mlen - in W.ResponseBuilder s hs' b - ContentFile fp p -> W.ResponseFile s finalHeaders fp p - ContentSource body -> W.ResponseSource s finalHeaders body + go c where finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders + go (ContentBuilder b mlen) = + W.ResponseBuilder s hs' b + where + hs' = maybe finalHeaders finalHeaders' mlen + go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p + go (ContentSource body) = W.ResponseSource s finalHeaders body + go (ContentDontEvaluate c') = go c' + httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept . fromMaybe mempty diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 0cd42b9c..0eb78497 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -343,23 +343,6 @@ $doctype 5 | size > 50000 = FileUploadDisk tempFileBackEnd | otherwise = FileUploadMemory lbsBackEnd - -- | Whether or not to fully evaluate response bodies before sending. - -- - -- By fully evaluating, you will be forcing the contents into memory, which - -- will negatively impact performance. However, it means that if any - -- exceptions are thrown from pure code, they will be caught before sending - -- the response to the client, resulting in a proper 500 error page instead - -- of just getting an empty response. - -- - -- In general, it's recommend to leave the default value in place. However, - -- if you have a route that generates large responses, and you are - -- confident that no exceptions are thrown from pure code, you can safely - -- turn this off for that route. - -- - -- Default: On for all routes. - fullyEvaluateBody :: a -> Route a -> Bool - fullyEvaluateBody _ _ = True - formatLogMessage :: IO ZonedDate -> Loc -> LogLevel @@ -432,8 +415,7 @@ defaultYesodRunner logger handler master sub murl toMasterRoute msb req let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req let log' = messageLogger master logger - toEval = maybe True (fullyEvaluateBody master) (fmap toMasterRoute murl) - yar <- handlerToYAR master sub (fileUpload master) log' toEval toMasterRoute + yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of (YARPlain _ _ ct _ newSess) -> do diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index ae00b4c1..92171c41 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -25,9 +25,7 @@ mkYesod "App" [parseRoutes| /error-in-body-noeval ErrorInBodyNoEvalR GET |] -instance Yesod App where - fullyEvaluateBody _ ErrorInBodyNoEvalR = False - fullyEvaluateBody _ _ = True +instance Yesod App getHomeR :: Handler RepHtml getHomeR = do @@ -60,11 +58,13 @@ postAfterRunRequestBodyR = do _ <- error $ show $ fst x getHomeR +getErrorInBodyR :: Handler RepHtml getErrorInBodyR = do let foo = error "error in body 19328" :: String defaultLayout [whamlet|#{foo}|] -getErrorInBodyNoEvalR = getErrorInBodyR +getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate RepHtml) +getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling"