fullyEvaluateBody

yesod-core/Yesod/Handler.hs

@@ -146,6 +146,7 @@ import qualified Data.Text.Lazy as TL
 
 import qualified Data.Map as Map
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
 import Network.Wai.Parse (parseHttpAccept)
 
 import Yesod.Content
@@ -158,7 +159,7 @@ import qualified Data.ByteString.Char8 as S8
 import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import Blaze.ByteString.Builder (toByteString)
+import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)
 import Data.Text (Text)
 import Yesod.Message (RenderMessage (..))
 
@@ -394,8 +395,9 @@ runHandler :: HasReps c
            -> sub
            -> (Word64 -> FileUpload)
            -> (Loc -> LogLevel -> LogStr -> IO ())
+           -> Bool -- ^ to eval body?
            -> YesodApp
-runHandler handler mrender sroute tomr master sub upload log' =
+runHandler handler mrender sroute tomr master sub upload log' toEval =
   YesodApp $ \eh rr cts initSession -> do
     let toErrorHandler e =
             case fromException e of
@@ -438,7 +440,10 @@ runHandler handler mrender sroute tomr master sub upload log' =
     case contents of
         HCContent status a -> do
             (ct, c) <- liftIO $ a cts
-            return $ YARPlain status (appEndo headers []) ct c finalSession
+            ec' <- if toEval then liftIO $ evaluateContent c else return (Right c)
+            case ec' of
+                Left e -> handleError e
+                Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession
         HCError e -> handleError e
         HCRedirect status loc -> do
             let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
@@ -458,6 +463,15 @@ runHandler handler mrender sroute tomr master sub upload log' =
                 finalSession
         HCWai r -> return $ YARWai r
 
+evaluateContent :: Content -> IO (Either ErrorResponse Content)
+evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
+    let lbs = toLazyByteString b
+    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
+  where
+    f :: SomeException -> IO (Either ErrorResponse Content)
+    f = return . Left . InternalError . T.pack . show
+evaluateContent c = return (Right c)
+
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ session -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
@@ -792,6 +806,7 @@ 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)
@@ -800,11 +815,11 @@ handlerToYAR :: (HasReps a, HasReps b)
              -> SessionMap
              -> GHandler sub master b
              -> ResourceT IO YesodAppResult
-handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
+handlerToYAR y s upload log' toEval toMasterRoute render errorHandler rr murl sessionMap h =
     unYesodApp ya eh' rr types sessionMap
   where
-    ya = runHandler h render murl toMasterRoute y s upload log'
-    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
+    ya = runHandler h render murl toMasterRoute y s upload log' toEval
+    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval
     types = httpAccept $ reqWaiRequest rr
     errorHandler' = localNoCurrent . errorHandler
 

yesod-core/Yesod/Internal/Core.hs

@@ -343,6 +343,23 @@ $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
@@ -415,7 +432,8 @@ 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
-    yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
+        toEval = maybe True (fullyEvaluateBody master) (fmap toMasterRoute murl)
+    yar <- handlerToYAR master sub (fileUpload master) log' toEval toMasterRoute
         (yesodRender master ra) errorHandler rr murl sessionMap h
     extraHeaders <- case yar of
         (YARPlain _ _ ct _ newSess) -> do

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
@@ -11,6 +12,7 @@ import Network.Wai.Test
 import Text.Hamlet (hamlet)
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
+import Control.Exception (SomeException, try)
 
 data App = App
 
@@ -19,9 +21,13 @@ mkYesod "App" [parseRoutes|
 /not_found      NotFoundR POST
 /first_thing    FirstThingR POST
 /after_runRequestBody AfterRunRequestBodyR POST
+/error-in-body ErrorInBodyR GET
+/error-in-body-noeval ErrorInBodyNoEvalR GET
 |]
 
-instance Yesod App
+instance Yesod App where
+    fullyEvaluateBody _ ErrorInBodyNoEvalR = False
+    fullyEvaluateBody _ _ = True
 
 getHomeR :: Handler RepHtml
 getHomeR = do
@@ -54,11 +60,19 @@ postAfterRunRequestBodyR = do
    _ <- error $ show $ fst x
    getHomeR
 
+getErrorInBodyR = do
+    let foo = error "error in body 19328" :: String
+    defaultLayout [whamlet|#{foo}|]
+
+getErrorInBodyNoEvalR = getErrorInBodyR
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling"
     [ it "says not found" caseNotFound
     , it "says 'There was an error' before runRequestBody" caseBefore
     , it "says 'There was an error' after runRequestBody" caseAfter
+    , it "error in body == 500" caseErrorInBody
+    , it "error in body, no eval == 200" caseErrorInBodyNoEval
     ]
 
 runner :: Session () -> IO ()
@@ -98,3 +112,18 @@ caseAfter = runner $ do
         }
     assertStatus 500 res
     assertBodyContains "bin12345" res
+
+caseErrorInBody :: IO ()
+caseErrorInBody = runner $ do
+    res <- request defaultRequest { pathInfo = ["error-in-body"] }
+    assertStatus 500 res
+    assertBodyContains "error in body 19328" res
+
+caseErrorInBodyNoEval :: IO ()
+caseErrorInBodyNoEval = do
+    eres <- try $ runner $ do
+        _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }
+        return ()
+    case eres of
+        Left (_ :: SomeException) -> return ()
+        Right _ -> error "Expected an exception"