From 1487b121be0efc2ef34e4500ee1187eabc66972b Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 6 Jul 2022 21:55:49 +0200
Subject: [PATCH 01/13] 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      | 20 ++++++++
 yesod-core/src/Yesod/Core/Internal/Run.hs     | 50 ++++++++++---------
 yesod-core/src/Yesod/Core/Types.hs            | 13 ++++-
 .../test/YesodCoreTest/ErrorHandling.hs       | 34 +++++++++++++
 .../YesodCoreTest/ErrorHandling/CustomApp.hs  | 39 +++++++++++++++
 yesod-core/yesod-core.cabal                   |  2 +-
 6 files changed, 132 insertions(+), 26 deletions(-)
 create mode 100644 yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs

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

From 827d9269b04fced5c5e552b261e97ab935929f9f Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 6 Jul 2022 22:41:52 +0200
Subject: [PATCH 02/13] update changelog

---
 yesod-core/ChangeLog.md | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 2c899b82..917fa5a0 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 1.6.23.2
+
+* Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772).
+
 ## 1.6.23.1
 
 * Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)

From 9648ccf79f13e381a7cc371719b177b771074ed3 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 6 Jul 2022 22:43:19 +0200
Subject: [PATCH 03/13] add customapp to core.cabal

---
 yesod-core/yesod-core.cabal | 1 +
 1 file changed, 1 insertion(+)

diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index 756d71ec..d7b4b929 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -146,6 +146,7 @@ test-suite tests
                    YesodCoreTest.Header
                    YesodCoreTest.Csrf
                    YesodCoreTest.ErrorHandling
+                   YesodCoreTest.ErrorHandling.CustomApp
                    YesodCoreTest.Exceptions
                    YesodCoreTest.InternalRequest
                    YesodCoreTest.JsLoader

From 710adc7329ec99de854be5d4db3b1064e0bfa856 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Thu, 7 Jul 2022 11:15:40 +0200
Subject: [PATCH 04/13] don't patch but minor version bump isntead

---
 yesod-core/ChangeLog.md                  | 2 +-
 yesod-core/src/Yesod/Core/Class/Yesod.hs | 2 +-
 yesod-core/src/Yesod/Core/Types.hs       | 4 ++--
 yesod-core/yesod-core.cabal              | 2 +-
 4 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 917fa5a0..197dd2c0 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,6 +1,6 @@
 # ChangeLog for yesod-core
 
-## 1.6.23.2
+## 1.6.24.0
 
 * Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772).
 
diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 78419f82..e205ba7a 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -73,7 +73,7 @@ class RenderRoute site => Yesod site where
     approot :: Approot site
     approot = guessApproot
 
-    -- | @since 1.6.23.2
+    -- | @since 1.6.24.0
     --   Should we catch an exception, or rethrow it.
     --   Rethrowing an exception lets the webserver deal with it
     --   (usually warp).
diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs
index bcf3b96e..c93dc2d6 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -169,7 +169,7 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 -- @since 1.4.34
 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
 
--- | @since 1.6.23.2
+-- | @since 1.6.24.0
 data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp)
                    | Catch -- ^ catch an exception and render in yesod
 
@@ -190,7 +190,7 @@ data RunHandlerEnv child site = RunHandlerEnv
       -- Since 1.2.0
     , rheMaxExpires :: !Text
 
-      -- | @since 1.6.23.2
+      -- | @since 1.6.24.0
       --   should we catch an exception, or rethrow it.
     , rheShouldCatch :: !(SomeException -> CatchBehavior)
     }
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index d7b4b929..e99d0337 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.23.2
+version:         1.6.24.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

From 27042c93ce532cad9b8b699d2778dc828091f78e Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Thu, 7 Jul 2022 12:06:56 +0200
Subject: [PATCH 05/13] change catchbehavior to get app be in io, make it
 abstract type

---
 yesod-core/src/Yesod/Core/CatchBehavior.hs    | 23 +++++++++++++++++++
 yesod-core/src/Yesod/Core/Class/Yesod.hs      | 17 +++++++++-----
 yesod-core/src/Yesod/Core/Internal/Run.hs     | 16 +++++++------
 yesod-core/src/Yesod/Core/Types.hs            | 10 ++------
 .../test/YesodCoreTest/ErrorHandling.hs       | 11 +++++----
 .../YesodCoreTest/ErrorHandling/CustomApp.hs  |  7 +++---
 yesod-core/yesod-core.cabal                   |  1 +
 7 files changed, 57 insertions(+), 28 deletions(-)
 create mode 100644 yesod-core/src/Yesod/Core/CatchBehavior.hs

diff --git a/yesod-core/src/Yesod/Core/CatchBehavior.hs b/yesod-core/src/Yesod/Core/CatchBehavior.hs
new file mode 100644
index 00000000..6965239c
--- /dev/null
+++ b/yesod-core/src/Yesod/Core/CatchBehavior.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- | module providing an abstract type around 'CatchBehavior'
+--   through smart constructors.
+--   providing future additional extensibility.
+--
+--   @since 1.6.24.0
+module Yesod.Core.CatchBehavior(CatchBehavior, rethrow, catch, isCatch) where
+
+-- | @since 1.6.24.0
+data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp)
+                   | Catch -- ^ catch an exception and render in yesod
+
+rethrow :: CatchBehavior
+rethrow = Rethrow
+
+catch :: CatchBehavior
+catch = Catch
+
+isCatch :: CatchBehavior -> Bool
+isCatch = \case
+  Catch   -> True
+  Rethrow -> False
diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index e205ba7a..5e6538b6 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -55,8 +55,9 @@ 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 UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap)
 import Data.Proxy(Proxy)
+import Yesod.Core.CatchBehavior
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -81,8 +82,8 @@ class RenderRoute site => Yesod site where
     --   the default 'defaultCatchBehavior' is to catch everything
     --   (even async), except for the
     --   'Warp.ConnectionClosedByPeer' constructor.
-    catchBehavior :: Proxy site -> SomeException -> CatchBehavior
-    catchBehavior _ = defaultCatchBehavior
+    catchBehavior :: site -> SomeException -> IO CatchBehavior
+    catchBehavior _ = pure . defaultCatchBehavior
 
     -- | Output error response pages.
     --
@@ -648,10 +649,14 @@ widgetToPageContent w = do
     runUniqueList :: Eq x => UniqueList x -> [x]
     runUniqueList (UniqueList x) = nub $ x []
 
+rethrowAsync :: SomeException -> CatchBehavior
+rethrowAsync exception =
+  if isSyncException exception then catch else rethrow
+
 defaultCatchBehavior :: SomeException -> CatchBehavior
-defaultCatchBehavior exception = case fromException exception of
-  Just Warp.ConnectionClosedByPeer -> Rethrow
-  _                                -> Catch
+defaultCatchBehavior exception = case fromExceptionUnwrap exception of
+  Just Warp.ConnectionClosedByPeer -> rethrow
+  _                                -> catch
 
 
 -- | The default error handler for 'errorHandler'.
diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs
index a86c1894..0f444155 100644
--- a/yesod-core/src/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/src/Yesod/Core/Internal/Run.hs
@@ -56,6 +56,7 @@ import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
 import           UnliftIO(MonadUnliftIO, withRunInIO)
 import           Data.Proxy(Proxy(..))
+import           Yesod.Core.CatchBehavior
 
 -- | like `catch` but doesn't check for async exceptions,
 --   thereby catching them too.
@@ -67,14 +68,15 @@ import           Data.Proxy(Proxy(..))
 --   see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/
 unsafeAsyncCatch
   :: (MonadUnliftIO m)
-  => (SomeException -> CatchBehavior)
+  => (SomeException -> IO CatchBehavior)
   -> m a -- ^ action
   -> (SomeException -> m a) -- ^ handler
   -> m a
 unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
-    case catchBehavior e of
-      Catch -> run (g e)
-      Rethrow -> liftIO $ throwIO e
+    caught <- liftIO $ catchBehavior e
+    if   isCatch caught
+    then run (g e)
+    else liftIO $ EUnsafe.throwIO e
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -211,7 +213,7 @@ handleContents handleError' finalSession headers contents =
 --
 -- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => (SomeException -> CatchBehavior)
+             => (SomeException -> IO CatchBehavior)
              -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
@@ -296,7 +298,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheShouldCatch = catchBehavior (Proxy :: Proxy site)
+            , rheShouldCatch = catchBehavior site
             }
         handler'
       errHandler err req = do
@@ -373,7 +375,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
-              , rheShouldCatch = catchBehavior (Proxy :: Proxy site)
+              , rheShouldCatch = catchBehavior yreSite
               }
           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 c93dc2d6..84925767 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -56,6 +56,7 @@ import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
 import UnliftIO (MonadUnliftIO (..), SomeException)
+import Yesod.Core.CatchBehavior
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -169,13 +170,6 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 -- @since 1.4.34
 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
 
--- | @since 1.6.24.0
-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))
@@ -192,7 +186,7 @@ data RunHandlerEnv child site = RunHandlerEnv
 
       -- | @since 1.6.24.0
       --   should we catch an exception, or rethrow it.
-    , rheShouldCatch :: !(SomeException -> CatchBehavior)
+    , rheShouldCatch :: !(SomeException -> IO CatchBehavior)
     }
 
 data HandlerData child site = HandlerData
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
index 68680ffe..15f660c1 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
@@ -133,8 +133,10 @@ getThreadKilledR = do
 
 
 getConnectionClosedPeerR :: Handler Html
-getConnectionClosedPeerR =
-  liftIO $ E.throwIO Warp.ConnectionClosedByPeer
+getConnectionClosedPeerR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+  pure "unreachablle"
 
 
 getAsyncSessionR :: Handler Html
@@ -339,8 +341,9 @@ caseThreadKilled500 = runner $ do
 
 caseDefaultConnectionCloseRethrows :: IO ()
 caseDefaultConnectionCloseRethrows =
-  shouldThrow testcode $ \case Warp.ConnectionClosedByPeer -> True
-                               _ -> False
+  shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
 
   where
 
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
index ed0ce972..d55df593 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
@@ -15,6 +15,7 @@ module YesodCoreTest.ErrorHandling.CustomApp
     ) where
 
 
+import Yesod.Core.CatchBehavior
 import Yesod.Core.Types
 import Yesod.Core
 import qualified UnliftIO.Exception as E
@@ -33,7 +34,7 @@ data MyException = MkMyException
  deriving (Show, E.Exception)
 
 instance Yesod CustomApp where
-  catchBehavior _ exception =
+  catchBehavior _ exception = pure $
     case E.fromException exception of
-      Just MkMyException -> Rethrow
-      Nothing -> Catch
+      Just MkMyException -> rethrow
+      Nothing -> catch
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index e99d0337..d1a20b25 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -75,6 +75,7 @@ library
                      Yesod.Core.Types
                      Yesod.Core.Unsafe
                      Yesod.Routes.TH.Types
+                     Yesod.Core.CatchBehavior
     other-modules:   Yesod.Core.Internal.Session
                      Yesod.Core.Internal.Request
                      Yesod.Core.Class.Handler

From 964fa0db5521f946da68c46225d74e4e2aa93a12 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Thu, 14 Jul 2022 21:52:06 +0200
Subject: [PATCH 06/13] Fix dealing with timeout and add appropriate test

add comments for this nonobvious test
---
 yesod-core/src/Yesod/Core/Class/Yesod.hs       | 15 ++++++++++-----
 yesod-core/test/YesodCoreTest/ErrorHandling.hs | 15 +++++++++++++++
 2 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 5e6538b6..dd79ae20 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -58,6 +60,7 @@ import Data.IORef
 import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap)
 import Data.Proxy(Proxy)
 import Yesod.Core.CatchBehavior
+import System.Timeout(Timeout)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -656,7 +659,9 @@ rethrowAsync exception =
 defaultCatchBehavior :: SomeException -> CatchBehavior
 defaultCatchBehavior exception = case fromExceptionUnwrap exception of
   Just Warp.ConnectionClosedByPeer -> rethrow
-  _                                -> catch
+  _                                -> case fromExceptionUnwrap exception of
+    Just (_ :: Timeout) -> rethrow
+    _ -> catch
 
 
 -- | The default error handler for 'errorHandler'.
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
index 15f660c1..27853b38 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
@@ -30,6 +30,7 @@ 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
+import System.Timeout(timeout)
 
 data App = App
 
@@ -58,6 +59,7 @@ mkYesod "App" [parseRoutes|
 /thread-killed ThreadKilledR GET
 /connection-closed-by-peer ConnectionClosedPeerR GET
 /async-session AsyncSessionR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -131,6 +133,10 @@ getThreadKilledR = do
   liftIO $ Async.withAsync (Conc.killThread x) Async.wait
   pure "unreachablle"
 
+getSleepASecR :: Handler Html
+getSleepASecR = do
+  liftIO $ Conc.threadDelay 1000000
+  pure "slept a second"
 
 getConnectionClosedPeerR :: Handler Html
 getConnectionClosedPeerR = do
@@ -195,6 +201,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
       it "custom config rethrows an exception" caseCustomExceptionRethrows
       it "async session exception = 500" asyncSessionKilled500
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -366,3 +373,11 @@ asyncSessionKilled500 = runner $ do
   res <- request defaultRequest { pathInfo = ["async-session"] }
   assertStatus 500 res
   assertBodyContains "Internal Server Error" res
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.

From d04c22e3d6d7bdc1933904a30a6c7d095b5ffe98 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 11:55:44 +0200
Subject: [PATCH 07/13] Rewrite default behavior into rethrow async exceptions

---
 yesod-core/src/Yesod/Core/Class/Yesod.hs      | 15 ++-----
 .../test/YesodCoreTest/ErrorHandling.hs       | 39 ++++++-------------
 2 files changed, 15 insertions(+), 39 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index dd79ae20..62d182ca 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -82,11 +82,10 @@ class RenderRoute site => Yesod site where
     --   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.
+    --   the default 'rethrowAsync' is to rethrow async
+    --   exceptions.
     catchBehavior :: site -> SomeException -> IO CatchBehavior
-    catchBehavior _ = pure . defaultCatchBehavior
+    catchBehavior _ = pure . rethrowAsync
 
     -- | Output error response pages.
     --
@@ -656,14 +655,6 @@ rethrowAsync :: SomeException -> CatchBehavior
 rethrowAsync exception =
   if isSyncException exception then catch else rethrow
 
-defaultCatchBehavior :: SomeException -> CatchBehavior
-defaultCatchBehavior exception = case fromExceptionUnwrap exception of
-  Just Warp.ConnectionClosedByPeer -> rethrow
-  _                                -> case fromExceptionUnwrap exception of
-    Just (_ :: Timeout) -> rethrow
-    _ -> catch
-
-
 -- | The default error handler for 'errorHandler'.
 defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
 defaultErrorHandler NotFound = selectRep $ do
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
index 27853b38..30b22e89 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
@@ -18,7 +18,7 @@ import Network.Wai
 import Network.Wai.Test
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, try, AsyncException(..))
 import           UnliftIO.Exception(finally)
 import Network.HTTP.Types (Status, mkStatus)
 import Data.ByteString.Builder (Builder, toLazyByteString)
@@ -58,7 +58,6 @@ mkYesod "App" [parseRoutes|
 
 /thread-killed ThreadKilledR GET
 /connection-closed-by-peer ConnectionClosedPeerR GET
-/async-session AsyncSessionR GET
 /sleep-sec SleepASecR GET
 |]
 
@@ -132,7 +131,6 @@ getThreadKilledR = do
   x <- liftIO Conc.myThreadId
   liftIO $ Async.withAsync (Conc.killThread x) Async.wait
   pure "unreachablle"
-
 getSleepASecR :: Handler Html
 getSleepASecR = do
   liftIO $ Conc.threadDelay 1000000
@@ -144,16 +142,6 @@ getConnectionClosedPeerR = do
   liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
   pure "unreachablle"
 
-
-getAsyncSessionR :: Handler Html
-getAsyncSessionR = do
-  setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out
-  x <- liftIO Conc.myThreadId
-  liftIO $ forkIO $ do
-     liftIO $ Conc.threadDelay 100000
-     Conc.killThread x
-  pure "reachable"
-
 getErrorR :: Int -> Handler ()
 getErrorR 1 = setSession undefined "foo"
 getErrorR 2 = setSession "foo" undefined
@@ -197,10 +185,9 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "accept CSS, permission denied -> 403" caseCssPermissionDenied
       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
+      it "thread killed rethrow" caseThreadKilledRethrow
       it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
@@ -340,11 +327,16 @@ caseVideoBadMethod = runner $ do
             }
     assertStatus 405 res
 
-caseThreadKilled500 :: IO ()
-caseThreadKilled500 = runner $ do
-  res <- request defaultRequest { pathInfo = ["thread-killed"] }
-  assertStatus 500 res
-  assertBodyContains "Internal Server Error" res
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+  shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of
+                                (Just ThreadKilled) -> True
+                                _ -> False
+  where
+  testcode = runner $ do
+                res <- request defaultRequest { pathInfo = ["thread-killed"] }
+                assertStatus 500 res
+                assertBodyContains "Internal Server Error" res
 
 caseDefaultConnectionCloseRethrows :: IO ()
 caseDefaultConnectionCloseRethrows =
@@ -353,7 +345,6 @@ caseDefaultConnectionCloseRethrows =
                                   _ -> False
 
   where
-
   testcode = runner $ do
       _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
       pure ()
@@ -368,12 +359,6 @@ caseCustomExceptionRethrows =
     customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
 
 
-asyncSessionKilled500 :: IO ()
-asyncSessionKilled500 = runner $ do
-  res <- request defaultRequest { pathInfo = ["async-session"] }
-  assertStatus 500 res
-  assertBodyContains "Internal Server Error" res
-
 canTimeoutARunner :: IO ()
 canTimeoutARunner = do
   res <- timeout 1000 $ runner $ do

From 5ac65db1bf034e145a8530a6b67014ffae546baf Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 12:32:48 +0200
Subject: [PATCH 08/13] Delete catchbevior and allow a user to provide a catch.

By default the one from unliftIO is used.
---
 yesod-core/src/Yesod/Core/CatchBehavior.hs    | 23 -------------------
 yesod-core/src/Yesod/Core/Class/Yesod.hs      | 13 +++--------
 yesod-core/src/Yesod/Core/Internal/Run.hs     | 22 +++++-------------
 yesod-core/src/Yesod/Core/Types.hs            |  4 ++--
 .../YesodCoreTest/ErrorHandling/CustomApp.hs  | 11 +++++----
 yesod-core/yesod-core.cabal                   |  1 -
 6 files changed, 17 insertions(+), 57 deletions(-)
 delete mode 100644 yesod-core/src/Yesod/Core/CatchBehavior.hs

diff --git a/yesod-core/src/Yesod/Core/CatchBehavior.hs b/yesod-core/src/Yesod/Core/CatchBehavior.hs
deleted file mode 100644
index 6965239c..00000000
--- a/yesod-core/src/Yesod/Core/CatchBehavior.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
--- | module providing an abstract type around 'CatchBehavior'
---   through smart constructors.
---   providing future additional extensibility.
---
---   @since 1.6.24.0
-module Yesod.Core.CatchBehavior(CatchBehavior, rethrow, catch, isCatch) where
-
--- | @since 1.6.24.0
-data CatchBehavior = Rethrow -- ^ Rethrow an exception and let the webserver deal with it (usually warp)
-                   | Catch -- ^ catch an exception and render in yesod
-
-rethrow :: CatchBehavior
-rethrow = Rethrow
-
-catch :: CatchBehavior
-catch = Catch
-
-isCatch :: CatchBehavior -> Bool
-isCatch = \case
-  Catch   -> True
-  Rethrow -> False
diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 62d182ca..553b11cf 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -57,10 +57,7 @@ import Data.CaseInsensitive (CI)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Request
 import Data.IORef
-import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap)
-import Data.Proxy(Proxy)
-import Yesod.Core.CatchBehavior
-import System.Timeout(Timeout)
+import UnliftIO (SomeException, catch)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -84,8 +81,8 @@ class RenderRoute site => Yesod site where
     --   catching allows yesod to render the error page.
     --   the default 'rethrowAsync' is to rethrow async
     --   exceptions.
-    catchBehavior :: site -> SomeException -> IO CatchBehavior
-    catchBehavior _ = pure . rethrowAsync
+    catchBehavior :: site -> IO a -> (SomeException -> IO a) -> IO a
+    catchBehavior _ = catch
 
     -- | Output error response pages.
     --
@@ -651,10 +648,6 @@ widgetToPageContent w = do
     runUniqueList :: Eq x => UniqueList x -> [x]
     runUniqueList (UniqueList x) = nub $ x []
 
-rethrowAsync :: SomeException -> CatchBehavior
-rethrowAsync exception =
-  if isSyncException exception then catch else rethrow
-
 -- | 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 0f444155..e8c361d2 100644
--- a/yesod-core/src/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/src/Yesod/Core/Internal/Run.hs
@@ -56,27 +56,17 @@ import           Control.DeepSeq              (($!!), NFData)
 import           UnliftIO.Exception
 import           UnliftIO(MonadUnliftIO, withRunInIO)
 import           Data.Proxy(Proxy(..))
-import           Yesod.Core.CatchBehavior
 
--- | like `catch` but doesn't check for async exceptions,
---   thereby catching them too.
---   This is desirable for letting yesod generate a 500 error page
---   rather then warp.
---
---   Normally this is VERY dubious. you need to rethrow.
---   recovrery from async isn't allowed.
---   see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/
+-- | wraps the provided catch fun in a unliftIO
 unsafeAsyncCatch
   :: (MonadUnliftIO m)
-  => (SomeException -> IO CatchBehavior)
+  => (IO a -> (SomeException -> IO a) -> IO a)
   -> m a -- ^ action
   -> (SomeException -> m a) -- ^ handler
   -> m a
-unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
-    caught <- liftIO $ catchBehavior e
-    if   isCatch caught
-    then run (g e)
-    else liftIO $ EUnsafe.throwIO e
+unsafeAsyncCatch catchFun f g = withRunInIO $ \run ->
+    run f `catchFun` \e -> run (g e)
+
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -213,7 +203,7 @@ handleContents handleError' finalSession headers contents =
 --
 -- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => (SomeException -> IO CatchBehavior)
+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)
              -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs
index 84925767..eb07be47 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Types where
 
 import Data.Aeson (ToJSON)
@@ -56,7 +57,6 @@ import Control.DeepSeq (NFData (rnf))
 import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 import Control.Monad.Logger (MonadLoggerIO (..))
 import UnliftIO (MonadUnliftIO (..), SomeException)
-import Yesod.Core.CatchBehavior
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -186,7 +186,7 @@ data RunHandlerEnv child site = RunHandlerEnv
 
       -- | @since 1.6.24.0
       --   should we catch an exception, or rethrow it.
-    , rheShouldCatch :: !(SomeException -> IO CatchBehavior)
+    , rheShouldCatch :: !(forall a. IO a -> (SomeException -> IO a) -> IO a)
     }
 
 data HandlerData child site = HandlerData
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
index d55df593..092ee32e 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
@@ -15,7 +15,6 @@ module YesodCoreTest.ErrorHandling.CustomApp
     ) where
 
 
-import Yesod.Core.CatchBehavior
 import Yesod.Core.Types
 import Yesod.Core
 import qualified UnliftIO.Exception as E
@@ -34,7 +33,9 @@ data MyException = MkMyException
  deriving (Show, E.Exception)
 
 instance Yesod CustomApp where
-  catchBehavior _ exception = pure $
-    case E.fromException exception of
-      Just MkMyException -> rethrow
-      Nothing -> catch
+  -- something we couldn't do before, rethrow custom exceptions
+  catchBehavior _ action handler =
+    action `E.catch` \exception -> do
+      case E.fromException exception of
+        Just MkMyException -> E.throwIO MkMyException
+        Nothing -> handler exception
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index d1a20b25..e99d0337 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -75,7 +75,6 @@ library
                      Yesod.Core.Types
                      Yesod.Core.Unsafe
                      Yesod.Routes.TH.Types
-                     Yesod.Core.CatchBehavior
     other-modules:   Yesod.Core.Internal.Session
                      Yesod.Core.Internal.Request
                      Yesod.Core.Class.Handler

From 01ccea46cc88421a1b9c0f3bcd44be6205a1ee86 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 12:40:00 +0200
Subject: [PATCH 09/13] update docs, better names

rename catchBehvaior -> catchHandlerExceptions
rename shouldCatch -> catchHanlderExceptions
---
 yesod-core/src/Yesod/Core/Class/Yesod.hs         | 16 ++++++++--------
 yesod-core/src/Yesod/Core/Internal/Run.hs        | 10 +++++-----
 yesod-core/src/Yesod/Core/Types.hs               |  5 +++--
 .../YesodCoreTest/ErrorHandling/CustomApp.hs     |  2 +-
 4 files changed, 17 insertions(+), 16 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 553b11cf..21914468 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -75,14 +75,14 @@ class RenderRoute site => Yesod site where
     approot = guessApproot
 
     -- | @since 1.6.24.0
-    --   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 'rethrowAsync' is to rethrow async
-    --   exceptions.
-    catchBehavior :: site -> IO a -> (SomeException -> IO a) -> IO a
-    catchBehavior _ = catch
+    --  allows the user to specify how exceptions are cought.
+    --  by default all async exceptions are thrown and synchronous
+    --  exceptions render a 500 page.
+    --  One could override this for example to catch all exceptions
+    --  aside connection closed by peer to let yesod do more 500 page
+    --  rendering (instead of warp).
+    catchHandlerExceptions :: site -> IO a -> (SomeException -> IO a) -> IO a
+    catchHandlerExceptions _ = catch
 
     -- | Output error response pages.
     --
diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs
index e8c361d2..c090ba4c 100644
--- a/yesod-core/src/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/src/Yesod/Core/Internal/Run.hs
@@ -99,7 +99,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- unsafeAsyncCatch (rheShouldCatch rhe)
+    contents' <- unsafeAsyncCatch (rheCatchHandlerExceptions rhe)
         (do
             res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
@@ -223,8 +223,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
 
     -- Evaluate the unfortunately-lazy session and headers,
     -- propagating exceptions into the contents
-    (finalSession, contents1) <- evalFallback rheShouldCatch contents0 (ghsSession state)
-    (headers, contents2) <- evalFallback rheShouldCatch contents1 (appEndo (ghsHeaders state) [])
+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
 
     -- Convert the HandlerContents into the final YesodResponse
@@ -288,7 +288,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheShouldCatch = catchBehavior site
+            , rheCatchHandlerExceptions = catchHandlerExceptions site
             }
         handler'
       errHandler err req = do
@@ -365,7 +365,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
-              , rheShouldCatch = catchBehavior yreSite
+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
               }
           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 eb07be47..508f4ad5 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -185,8 +185,9 @@ data RunHandlerEnv child site = RunHandlerEnv
     , rheMaxExpires :: !Text
 
       -- | @since 1.6.24.0
-      --   should we catch an exception, or rethrow it.
-    , rheShouldCatch :: !(forall a. IO a -> (SomeException -> IO a) -> IO a)
+      --   catch function for rendering 500 pages on exceptions.
+      --   by default this is catch from unliftio (rethrows all async exceptions).
+    , rheCatchHandlerExceptions :: !(forall a. IO a -> (SomeException -> IO a) -> IO a)
     }
 
 data HandlerData child site = HandlerData
diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
index 092ee32e..e7e5bde2 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs
@@ -34,7 +34,7 @@ data MyException = MkMyException
 
 instance Yesod CustomApp where
   -- something we couldn't do before, rethrow custom exceptions
-  catchBehavior _ action handler =
+  catchHandlerExceptions _ action handler =
     action `E.catch` \exception -> do
       case E.fromException exception of
         Just MkMyException -> E.throwIO MkMyException

From dc4ee0f92cfa48a5055142ef45f997dbcb08aead Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 14:07:30 +0200
Subject: [PATCH 10/13] remove unsafeAsyncCatch

---
 yesod-core/src/Yesod/Core/Class/Yesod.hs  |  4 ++--
 yesod-core/src/Yesod/Core/Internal/Run.hs | 15 ++-------------
 yesod-core/src/Yesod/Core/Types.hs        |  2 +-
 3 files changed, 5 insertions(+), 16 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 21914468..18ab351c 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -57,7 +57,7 @@ import Data.CaseInsensitive (CI)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Request
 import Data.IORef
-import UnliftIO (SomeException, catch)
+import UnliftIO (SomeException, catch, MonadUnliftIO)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -81,7 +81,7 @@ class RenderRoute site => Yesod site where
     --  One could override this for example to catch all exceptions
     --  aside connection closed by peer to let yesod do more 500 page
     --  rendering (instead of warp).
-    catchHandlerExceptions :: site -> IO a -> (SomeException -> IO a) -> IO a
+    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
     catchHandlerExceptions _ = catch
 
     -- | Output error response pages.
diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs
index c090ba4c..897966f0 100644
--- a/yesod-core/src/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/src/Yesod/Core/Internal/Run.hs
@@ -57,17 +57,6 @@ import           UnliftIO.Exception
 import           UnliftIO(MonadUnliftIO, withRunInIO)
 import           Data.Proxy(Proxy(..))
 
--- | wraps the provided catch fun in a unliftIO
-unsafeAsyncCatch
-  :: (MonadUnliftIO m)
-  => (IO a -> (SomeException -> IO a) -> IO a)
-  -> m a -- ^ action
-  -> (SomeException -> m a) -- ^ handler
-  -> m a
-unsafeAsyncCatch catchFun f g = withRunInIO $ \run ->
-    run f `catchFun` \e -> run (g e)
-
-
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
 toErrorHandler e0 = handleAny errFromShow $
@@ -99,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do
 
     -- Run the handler itself, capturing any runtime exceptions and
     -- converting them into a @HandlerContents@
-    contents' <- unsafeAsyncCatch (rheCatchHandlerExceptions rhe)
+    contents' <- rheCatchHandlerExceptions rhe
         (do
             res <- unHandlerFor handler (hd istate)
             tc <- evaluate (toTypedContent res)
@@ -207,7 +196,7 @@ evalFallback :: (Monoid w, NFData w)
              -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback shouldCatch contents val = unsafeAsyncCatch shouldCatch
+evalFallback catcher contents val = catcher
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 
diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs
index 508f4ad5..88f01e35 100644
--- a/yesod-core/src/Yesod/Core/Types.hs
+++ b/yesod-core/src/Yesod/Core/Types.hs
@@ -187,7 +187,7 @@ data RunHandlerEnv child site = RunHandlerEnv
       -- | @since 1.6.24.0
       --   catch function for rendering 500 pages on exceptions.
       --   by default this is catch from unliftio (rethrows all async exceptions).
-    , rheCatchHandlerExceptions :: !(forall a. IO a -> (SomeException -> IO a) -> IO a)
+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)
     }
 
 data HandlerData child site = HandlerData

From 13db3db1187738caa2d800fd6f430d0646acec77 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 14:14:14 +0200
Subject: [PATCH 11/13] Add backwards compatibility for old unliftio

---
 yesod-core/test/YesodCoreTest/ErrorHandling.hs | 12 ++++++++++--
 1 file changed, 10 insertions(+), 2 deletions(-)

diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
index 30b22e89..0892faf1 100644
--- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs
+++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs
@@ -9,6 +9,7 @@ module YesodCoreTest.ErrorHandling
     , resourcesApp
     ) where
 
+import  Data.Typeable(cast)
 import qualified System.Mem as Mem
 import qualified Control.Concurrent.Async as Async
 import Control.Concurrent as Conc
@@ -327,9 +328,16 @@ caseVideoBadMethod = runner $ do
             }
     assertStatus 405 res
 
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+  | otherwise = E.fromException se
+
+
 caseThreadKilledRethrow :: IO ()
 caseThreadKilledRethrow =
-  shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
                                 (Just ThreadKilled) -> True
                                 _ -> False
   where
@@ -340,7 +348,7 @@ caseThreadKilledRethrow =
 
 caseDefaultConnectionCloseRethrows :: IO ()
 caseDefaultConnectionCloseRethrows =
-  shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of
+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
                                   Just Warp.ConnectionClosedByPeer -> True
                                   _ -> False
 

From dd2ba40873f894176b5ef58d3ddf86f618bb53a2 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 14:30:34 +0200
Subject: [PATCH 12/13] be more explicit in changelog

---
 yesod-core/ChangeLog.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 197dd2c0..ae2c2295 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -2,7 +2,7 @@
 
 ## 1.6.24.0
 
-* Make catching exceptions configurable [#1772](https://github.com/yesodweb/yesod/pull/1772).
+* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
 
 ## 1.6.23.1
 

From 69df01668ac9acdc329e66e68436d50cda4c7e74 Mon Sep 17 00:00:00 2001
From: Jappie Klooster <jappieklooster@hotmail.com>
Date: Wed, 20 Jul 2022 15:23:29 +0200
Subject: [PATCH 13/13] Update yesod-core/src/Yesod/Core/Class/Yesod.hs

Co-authored-by: patrick brisbin <pbrisbin@gmail.com>
---
 yesod-core/src/Yesod/Core/Class/Yesod.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs
index 18ab351c..a5845126 100644
--- a/yesod-core/src/Yesod/Core/Class/Yesod.hs
+++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs
@@ -78,9 +78,9 @@ class RenderRoute site => Yesod site where
     --  allows the user to specify how exceptions are cought.
     --  by default all async exceptions are thrown and synchronous
     --  exceptions render a 500 page.
-    --  One could override this for example to catch all exceptions
-    --  aside connection closed by peer to let yesod do more 500 page
-    --  rendering (instead of warp).
+    -- To catch all exceptions (even async) to render a 500 page, 
+    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
+    -- this may have negative effects with functions like 'timeout'.
     catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
     catchHandlerExceptions _ = catch