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