DontFullyEvaluate (Felipe's code)

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

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
+    ya = runHandler h render murl toMasterRoute y s upload log'
-    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval
+    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
+    go c
-        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
   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

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' toMasterRoute
-    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

@@ -25,9 +25,7 @@ mkYesod "App" [parseRoutes|
 /error-in-body-noeval ErrorInBodyNoEvalR GET
 |]
 
-instance Yesod App where
+instance Yesod App
-    fullyEvaluateBody _ ErrorInBodyNoEvalR = False
-    fullyEvaluateBody _ _ = True
 
 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"