diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 618665f2..c1ffe100 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/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) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 4605fd40..b35c93d2 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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|
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