Make catching exceptions configurable.

Fixes https://github.com/yesodweb/yesod/issues/1771

This is done by adding a function to Yesod
typeclass which can match on any exception
and tell the framework if it should rethrow
or not.

I used an overridable function because it seemed
more flexible then a whitelist.
A user can now for example choose to throw
everything, or catch everything as easily.

add docs

bump

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

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE PatternGuards       #-}
-{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE FlexibleContexts  #-}
+{-# 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)
+  :: (MonadUnliftIO m)
-  => m a -- ^ action
+  => (SomeException -> CatchBehavior)
-  -> (e -> m a) -- ^ handler
+  -> m a -- ^ action
-  -> m a
-unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
-    run (g e)
-
-unsafeAsyncCatchAny :: (MonadUnliftIO m)
-  => 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)
+    (finalSession, contents1) <- evalFallback rheShouldCatch contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders 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

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

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"] }

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

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 <michael@snoyman.com>