diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 7a66aa81..78419f82 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -52,8 +52,11 @@ import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget import Data.CaseInsensitive (CI) +import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef +import UnliftIO (SomeException, fromException) +import Data.Proxy(Proxy) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -70,6 +73,17 @@ class RenderRoute site => Yesod site where approot :: Approot site approot = guessApproot + -- | @since 1.6.23.2 + -- Should we catch an exception, or rethrow it. + -- Rethrowing an exception lets the webserver deal with it + -- (usually warp). + -- catching allows yesod to render the error page. + -- the default 'defaultCatchBehavior' is to catch everything + -- (even async), except for the + -- 'Warp.ConnectionClosedByPeer' constructor. + catchBehavior :: Proxy site -> SomeException -> CatchBehavior + catchBehavior _ = defaultCatchBehavior + -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. @@ -634,6 +648,12 @@ widgetToPageContent w = do runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] +defaultCatchBehavior :: SomeException -> CatchBehavior +defaultCatchBehavior exception = case fromException exception of + Just Warp.ConnectionClosedByPeer -> Rethrow + _ -> Catch + + -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index c1ffe100..a86c1894 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.Core.Internal.Run ( toErrorHandler , errFromShow @@ -54,6 +55,7 @@ import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception import UnliftIO(MonadUnliftIO, withRunInIO) +import Data.Proxy(Proxy(..)) -- | like `catch` but doesn't check for async exceptions, -- thereby catching them too. @@ -64,18 +66,15 @@ import UnliftIO(MonadUnliftIO, withRunInIO) -- recovrery from async isn't allowed. -- see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/ unsafeAsyncCatch - :: (MonadUnliftIO m, Exception e) - => m a -- ^ action - -> (e -> m a) -- ^ handler - -> m a -unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do - run (g e) - -unsafeAsyncCatchAny :: (MonadUnliftIO m) - => m a -- ^ action + :: (MonadUnliftIO m) + => (SomeException -> CatchBehavior) + -> m a -- ^ action -> (SomeException -> m a) -- ^ handler -> m a -unsafeAsyncCatchAny = unsafeAsyncCatch +unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do + case catchBehavior e of + Catch -> run (g e) + Rethrow -> liftIO $ throwIO e -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -108,7 +107,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- unsafeAsyncCatch + contents' <- unsafeAsyncCatch (rheShouldCatch rhe) (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -212,10 +211,11 @@ handleContents handleError' finalSession headers contents = -- -- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) - => HandlerContents + => (SomeException -> CatchBehavior) + -> HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = unsafeAsyncCatchAny +evalFallback shouldCatch contents val = unsafeAsyncCatch shouldCatch (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) @@ -231,8 +231,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents - (finalSession, contents1) <- evalFallback contents0 (ghsSession state) - (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) + (finalSession, contents1) <- evalFallback rheShouldCatch contents0 (ghsSession state) + (headers, contents2) <- evalFallback rheShouldCatch contents1 (appEndo (ghsHeaders state) []) contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse @@ -275,7 +275,7 @@ safeEh log' er req = do -- @HandlerFor@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the -- @HandlerFor@'s return value. -runFakeHandler :: (Yesod site, MonadIO m) => +runFakeHandler :: forall site m a . (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site @@ -296,6 +296,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires + , rheShouldCatch = catchBehavior (Proxy :: Proxy site) } handler' errHandler err req = do @@ -337,7 +338,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do _ <- runResourceT $ yapp fakeRequest I.readIORef ret -yesodRunner :: (ToTypedContent res, Yesod site) +yesodRunner :: forall res site . (ToTypedContent res, Yesod site) => HandlerFor site res -> YesodRunnerEnv site -> Maybe (Route site) @@ -372,6 +373,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires + , rheShouldCatch = catchBehavior (Proxy :: Proxy site) } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index df95b2d9..bcf3b96e 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -55,7 +55,7 @@ import Control.Monad.Reader (MonadReader (..)) import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) -import UnliftIO (MonadUnliftIO (..)) +import UnliftIO (MonadUnliftIO (..), SomeException) -- Sessions type SessionMap = Map Text ByteString @@ -169,6 +169,13 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } +-- | @since 1.6.23.2 +data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp) + | Catch -- ^ catch an exception and render in yesod + + +-- defaultShouldCatch = pure () + data RunHandlerEnv child site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route child)) @@ -182,6 +189,10 @@ data RunHandlerEnv child site = RunHandlerEnv -- -- Since 1.2.0 , rheMaxExpires :: !Text + + -- | @since 1.6.23.2 + -- should we catch an exception, or rethrow it. + , rheShouldCatch :: !(SomeException -> CatchBehavior) } data HandlerData child site = HandlerData diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 0995cd62..68680ffe 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget @@ -23,6 +25,8 @@ import Data.ByteString.Builder (Builder, toLazyByteString) import Data.Monoid (mconcat) import Data.Text (Text, pack) import Control.Monad (forM_) +import qualified Network.Wai.Handler.Warp as Warp +import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom import Control.Monad.Trans.State (StateT (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import qualified UnliftIO.Exception as E @@ -52,6 +56,7 @@ mkYesod "App" [parseRoutes| /only-plain-text OnlyPlainTextR GET /thread-killed ThreadKilledR GET +/connection-closed-by-peer ConnectionClosedPeerR GET /async-session AsyncSessionR GET |] @@ -126,6 +131,12 @@ getThreadKilledR = do liftIO $ Async.withAsync (Conc.killThread x) Async.wait pure "unreachablle" + +getConnectionClosedPeerR :: Handler Html +getConnectionClosedPeerR = + liftIO $ E.throwIO Warp.ConnectionClosedByPeer + + getAsyncSessionR :: Handler Html getAsyncSessionR = do setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out @@ -179,6 +190,8 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod it "thread killed = 500" caseThreadKilled500 + it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows + it "custom config rethrows an exception" caseCustomExceptionRethrows it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a @@ -324,6 +337,27 @@ caseThreadKilled500 = runner $ do assertStatus 500 res assertBodyContains "Internal Server Error" res +caseDefaultConnectionCloseRethrows :: IO () +caseDefaultConnectionCloseRethrows = + shouldThrow testcode $ \case Warp.ConnectionClosedByPeer -> True + _ -> False + + where + + testcode = runner $ do + _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] } + pure () + +caseCustomExceptionRethrows :: IO () +caseCustomExceptionRethrows = + shouldThrow testcode $ \case Custom.MkMyException -> True + where + testcode = customAppRunner $ do + _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] } + pure () + customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f + + asyncSessionKilled500 :: IO () asyncSessionKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["async-session"] } diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs new file mode 100644 index 00000000..ed0ce972 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} + +-- | a custom app that throws an exception +module YesodCoreTest.ErrorHandling.CustomApp + (CustomApp(..) + , MyException(..) + + -- * unused + , Widget + , resourcesCustomApp + ) where + + +import Yesod.Core.Types +import Yesod.Core +import qualified UnliftIO.Exception as E + +data CustomApp = CustomApp + +mkYesod "CustomApp" [parseRoutes| +/throw-custom-exception CustomHomeR GET +|] + +getCustomHomeR :: Handler Html +getCustomHomeR = + E.throwIO MkMyException + +data MyException = MkMyException + deriving (Show, E.Exception) + +instance Yesod CustomApp where + catchBehavior _ exception = + case E.fromException exception of + Just MkMyException -> Rethrow + Nothing -> Catch diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4c0fb52f..756d71ec 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.23.1 +version: 1.6.23.2 license: MIT license-file: LICENSE author: Michael Snoyman