From 5ac65db1bf034e145a8530a6b67014ffae546baf Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 12:32:48 +0200 Subject: [PATCH] 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