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

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

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

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)

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

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

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