From f91ff4fde2ee1dcfb8e8ebc48ce75477936c34bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 24 Jul 2012 17:49:17 +0300 Subject: [PATCH] fullyEvaluateBody --- yesod-core/Yesod/Handler.hs | 27 ++++++++++++---- yesod-core/Yesod/Internal/Core.hs | 20 +++++++++++- .../test/YesodCoreTest/ErrorHandling.hs | 31 ++++++++++++++++++- 3 files changed, 70 insertions(+), 8 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 4640fba8..b0a357fd 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/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 diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 0eb78497..0cd42b9c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 66362c57..ae00b4c1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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"