Fix it for async exceptions in the sessions as well

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

@@ -21,7 +21,6 @@ module Yesod.Core.Internal.Run
   )
   where
 
-import qualified GHC.Conc.Sync as Sync
 import qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
@@ -72,6 +71,12 @@ unsafeAsyncCatch
 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
+
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
 toErrorHandler e0 = handleAny errFromShow $
@@ -204,11 +209,13 @@ handleContents handleError' finalSession headers contents =
 -- | Evaluate the given value. If an exception is thrown, use it to
 -- replace the provided contents and then return @mempty@ in place of the
 -- evaluated value.
+--
+-- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
              => HandlerContents
              -> w
              -> IO (w, HandlerContents)
-evalFallback contents val = catchAny
+evalFallback contents val = unsafeAsyncCatchAny
     (fmap (, contents) (evaluate $!! val))
     (fmap ((mempty, ) . HCError) . toErrorHandler)
 

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE ViewPatterns #-}
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
@@ -53,6 +54,7 @@ mkYesod "App" [parseRoutes|
 
 /allocation-limit AlocationLimitR GET
 /thread-killed ThreadKilledR GET
+/async-session AsyncSessionR GET
 |]
 
 overrideStatus :: Status
@@ -128,7 +130,7 @@ getAlocationLimitR =
   defaultLayout $ [whamlet|
         <p> this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded
             which we need to catch
-  |]) `finally` (liftIO $ Mem.disableAllocationLimit)
+  |]) `finally` liftIO Mem.disableAllocationLimit
 
 -- this handler kills it's own thread
 getThreadKilledR :: Handler Html
@@ -137,6 +139,14 @@ getThreadKilledR = do
   liftIO $ Async.withAsync (Conc.killThread x) 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 100_000
+     Conc.killThread x
+  pure "reachable"
 
 getErrorR :: Int -> Handler ()
 getErrorR 1 = setSession undefined "foo"
@@ -183,11 +193,11 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "accept video, bad method -> 405" caseVideoBadMethod
       it "thread killed = 500" caseThreadKilled500
       it "allocation limit = 500" caseAllocationLimit500
+      it "async session exception = 500" asyncSessionKilled500
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
 
-
 caseNotFound :: IO ()
 caseNotFound = runner $ do
     res <- request defaultRequest
@@ -333,3 +343,9 @@ caseThreadKilled500 = runner $ do
   res <- request defaultRequest { pathInfo = ["thread-killed"] }
   assertStatus 500 res
   assertBodyContains "Internal Server Error" res
+
+asyncSessionKilled500 :: IO ()
+asyncSessionKilled500 = runner $ do
+  res <- request defaultRequest { pathInfo = ["async-session"] }
+  assertStatus 500 res
+  assertBodyContains "Internal Server Error" res