change catchbehavior to get app be in io, make it abstract type

yesod-core/src/Yesod/Core/CatchBehavior.hs

@@ -0,0 +1,23 @@
+{-# 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

@@ -55,8 +55,9 @@ import Data.CaseInsensitive (CI)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Request
 import Data.IORef
-import UnliftIO (SomeException, fromException)
+import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap)
 import Data.Proxy(Proxy)
+import Yesod.Core.CatchBehavior
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -81,8 +82,8 @@ class RenderRoute site => Yesod site where
     --   the default 'defaultCatchBehavior' is to catch everything
     --   (even async), except for the
     --   'Warp.ConnectionClosedByPeer' constructor.
-    catchBehavior :: Proxy site -> SomeException -> CatchBehavior
-    catchBehavior _ = defaultCatchBehavior
+    catchBehavior :: site -> SomeException -> IO CatchBehavior
+    catchBehavior _ = pure . defaultCatchBehavior
 
     -- | Output error response pages.
     --
@@ -648,10 +649,14 @@ 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
+
 defaultCatchBehavior :: SomeException -> CatchBehavior
-defaultCatchBehavior exception = case fromException exception of
-  Just Warp.ConnectionClosedByPeer -> Rethrow
-  _                                -> Catch
+defaultCatchBehavior exception = case fromExceptionUnwrap exception of
+  Just Warp.ConnectionClosedByPeer -> rethrow
+  _                                -> catch
 
 
 -- | The default error handler for 'errorHandler'.

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

@@ -56,6 +56,7 @@ 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.
@@ -67,14 +68,15 @@ import           Data.Proxy(Proxy(..))
 --   see async section: https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/
 unsafeAsyncCatch
   :: (MonadUnliftIO m)
-  => (SomeException -> CatchBehavior)
+  => (SomeException -> IO CatchBehavior)
   -> m a -- ^ action
   -> (SomeException -> m a) -- ^ handler
   -> m a
 unsafeAsyncCatch catchBehavior f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do
-    case catchBehavior e of
-      Catch -> run (g e)
-      Rethrow -> liftIO $ throwIO e
+    caught <- liftIO $ catchBehavior e
+    if   isCatch caught
+    then run (g e)
+    else liftIO $ EUnsafe.throwIO e
 
 -- | Convert a synchronous exception into an ErrorResponse
 toErrorHandler :: SomeException -> IO ErrorResponse
@@ -211,7 +213,7 @@ handleContents handleError' finalSession headers contents =
 --
 -- Note that this also catches async exceptions.
 evalFallback :: (Monoid w, NFData w)
-             => (SomeException -> CatchBehavior)
+             => (SomeException -> IO CatchBehavior)
              -> HandlerContents
              -> w
              -> IO (w, HandlerContents)
@@ -296,7 +298,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
             , rheMaxExpires = maxExpires
-            , rheShouldCatch = catchBehavior (Proxy :: Proxy site)
+            , rheShouldCatch = catchBehavior site
             }
         handler'
       errHandler err req = do
@@ -373,7 +375,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
               , rheLog = log'
               , rheOnError = safeEh log'
               , rheMaxExpires = maxExpires
-              , rheShouldCatch = catchBehavior (Proxy :: Proxy site)
+              , rheShouldCatch = catchBehavior yreSite
               }
           rhe = rheSafe
               { rheOnError = runHandler rheSafe . errorHandler

yesod-core/src/Yesod/Core/Types.hs

@@ -56,6 +56,7 @@ 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
@@ -169,13 +170,6 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 -- @since 1.4.34
 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
 
--- | @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
-
-
--- defaultShouldCatch = pure ()
-
 data RunHandlerEnv child site = RunHandlerEnv
     { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
     , rheRoute    :: !(Maybe (Route child))
@@ -192,7 +186,7 @@ data RunHandlerEnv child site = RunHandlerEnv
 
       -- | @since 1.6.24.0
       --   should we catch an exception, or rethrow it.
-    , rheShouldCatch :: !(SomeException -> CatchBehavior)
+    , rheShouldCatch :: !(SomeException -> IO CatchBehavior)
     }
 
 data HandlerData child site = HandlerData

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -133,8 +133,10 @@ getThreadKilledR = do
 
 
 getConnectionClosedPeerR :: Handler Html
-getConnectionClosedPeerR =
-  liftIO $ E.throwIO Warp.ConnectionClosedByPeer
+getConnectionClosedPeerR = do
+  x <- liftIO Conc.myThreadId
+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+  pure "unreachablle"
 
 
 getAsyncSessionR :: Handler Html
@@ -339,8 +341,9 @@ caseThreadKilled500 = runner $ do
 
 caseDefaultConnectionCloseRethrows :: IO ()
 caseDefaultConnectionCloseRethrows =
-  shouldThrow testcode $ \case Warp.ConnectionClosedByPeer -> True
-                               _ -> False
+  shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of
+                                  Just Warp.ConnectionClosedByPeer -> True
+                                  _ -> False
 
   where
 

yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs

@@ -15,6 +15,7 @@ module YesodCoreTest.ErrorHandling.CustomApp
     ) where
 
 
+import Yesod.Core.CatchBehavior
 import Yesod.Core.Types
 import Yesod.Core
 import qualified UnliftIO.Exception as E
@@ -33,7 +34,7 @@ data MyException = MkMyException
  deriving (Show, E.Exception)
 
 instance Yesod CustomApp where
-  catchBehavior _ exception =
+  catchBehavior _ exception = pure $
     case E.fromException exception of
-      Just MkMyException -> Rethrow
-      Nothing -> Catch
+      Just MkMyException -> rethrow
+      Nothing -> catch

yesod-core/yesod-core.cabal

@@ -75,6 +75,7 @@ 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