From eb7405765d6d5ebd22e25c6cd8e46c1a64d3f13c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:47:27 -0400 Subject: [PATCH] Add async exception handling for basic runner. --- yesod-core/src/Yesod/Core/Internal/Run.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 89530400..6ad7cd3f 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -21,6 +21,8 @@ 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) import qualified Data.ByteString.Lazy as BL @@ -52,6 +54,24 @@ import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception +import UnliftIO(MonadUnliftIO, withRunInIO) + +-- | 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/ +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 + liftIO Sync.disableAllocationLimit -- otherwise it can throw again on rendering the 500 page + run (g e) -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -84,7 +104,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- catchAny + contents' <- unsafeAsyncCatch (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res)