From 27042c93ce532cad9b8b699d2778dc828091f78e Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 7 Jul 2022 12:06:56 +0200 Subject: [PATCH] change catchbehavior to get app be in io, make it abstract type --- yesod-core/src/Yesod/Core/CatchBehavior.hs | 23 +++++++++++++++++++ yesod-core/src/Yesod/Core/Class/Yesod.hs | 17 +++++++++----- yesod-core/src/Yesod/Core/Internal/Run.hs | 16 +++++++------ yesod-core/src/Yesod/Core/Types.hs | 10 ++------ .../test/YesodCoreTest/ErrorHandling.hs | 11 +++++---- .../YesodCoreTest/ErrorHandling/CustomApp.hs | 7 +++--- yesod-core/yesod-core.cabal | 1 + 7 files changed, 57 insertions(+), 28 deletions(-) create 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 new file mode 100644 index 00000000..6965239c --- /dev/null +++ b/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 diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index e205ba7a..5e6538b6 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/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'. diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index a86c1894..0f444155 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/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 diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index c93dc2d6..84925767 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 68680ffe..15f660c1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs index ed0ce972..d55df593 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs +++ b/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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e99d0337..d1a20b25 100644 --- a/yesod-core/yesod-core.cabal +++ b/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