From 08d37a1857381a19c8906f2c39ba3611a3b13574 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:02:25 -0400 Subject: [PATCH 1/8] Add test showing the failures --- .../test/YesodCoreTest/ErrorHandling.hs | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 048342ce..218d5634 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -6,6 +6,10 @@ module YesodCoreTest.ErrorHandling , Widget , resourcesApp ) where + +import qualified System.Mem as Mem +import qualified Control.Concurrent.Async as Async +import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai @@ -45,6 +49,9 @@ mkYesod "App" [parseRoutes| /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET + +/allocation-limit AlocationLimitR GET +/thread-killed ThreadKilledR GET |] overrideStatus :: Status @@ -111,6 +118,24 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +getAlocationLimitR :: Handler Html +getAlocationLimitR = do + liftIO $ do + Mem.setAllocationCounter 1 -- very low limit + Mem.enableAllocationLimit + defaultLayout $ [whamlet| +

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded + which we need to catch + |] + +-- this handler kills it's own thread +getThreadKilledR :: Handler Html +getThreadKilledR = do + x <- liftIO Conc.myThreadId + liftIO $ Async.withAsync (Conc.killThread x) Async.wait + pure "unreachablle" + + getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -154,10 +179,13 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept CSS, permission denied -> 403" caseCssPermissionDenied it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod + it "thread killed = 500" caseThreadKilled500 + it "allocation limit = 500" caseAllocationLimit500 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f + caseNotFound :: IO () caseNotFound = runner $ do res <- request defaultRequest @@ -291,3 +319,15 @@ caseVideoBadMethod = runner $ do ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 res + +caseAllocationLimit500 :: IO () +caseAllocationLimit500 = runner $ do + res <- request defaultRequest { pathInfo = ["allocation-limit"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res + +caseThreadKilled500 :: IO () +caseThreadKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["thread-killed"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res From 42abd9b666d77256ce534328aa752aeeda6dcc2a Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:20:46 -0400 Subject: [PATCH 2/8] add explicit exports --- yesod-core/src/Yesod/Core/Internal/Run.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 8f0afee9..89530400 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -5,8 +5,21 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -module Yesod.Core.Internal.Run where - +module Yesod.Core.Internal.Run + ( toErrorHandler + , errFromShow + , basicRunHandler + , handleError + , handleContents + , evalFallback + , runHandler + , safeEh + , runFakeHandler + , yesodRunner + , yesodRender + , resolveApproot + ) + where import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) From eb7405765d6d5ebd22e25c6cd8e46c1a64d3f13c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 14:47:27 -0400 Subject: [PATCH 3/8] 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) From 4c1719cb6e4b99233eb29b2dffdc2028c8d00d37 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:15:49 -0400 Subject: [PATCH 4/8] Disable the allocation limit within the test instead I don't think we should add that to the function seems odly specific --- yesod-core/src/Yesod/Core/Internal/Run.hs | 9 ++++----- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 6 ++++-- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 6ad7cd3f..a7530eb5 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -70,7 +70,6 @@ unsafeAsyncCatch -> (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 @@ -97,7 +96,7 @@ basicRunHandler :: ToTypedContent c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents) -basicRunHandler rhe handler yreq resState = do +basicRunHandler rhe handler yreq resState = mask $ \unmask -> do -- Create a mutable ref to hold the state. We use mutable refs so -- that the updates will survive runtime exceptions. istate <- I.newIORef defState @@ -105,7 +104,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ contents' <- unsafeAsyncCatch - (do + (unmask $ do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ @@ -219,9 +218,9 @@ runHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodApp -runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do +runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> mask $ \unmask -> do -- Get the raw state and original contents - (state, contents0) <- basicRunHandler rhe handler yreq resState + (state, contents0) <- unmask $ basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 218d5634..4605fd40 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -17,6 +17,7 @@ import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) +import UnliftIO.Exception(finally) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString) import Data.Monoid (mconcat) @@ -119,14 +120,15 @@ getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent getAlocationLimitR :: Handler Html -getAlocationLimitR = do +getAlocationLimitR = + (do liftIO $ do Mem.setAllocationCounter 1 -- very low limit Mem.enableAllocationLimit defaultLayout $ [whamlet|

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded which we need to catch - |] + |]) `finally` (liftIO $ Mem.disableAllocationLimit) -- this handler kills it's own thread getThreadKilledR :: Handler Html From e284a68a9fa14f3da9a1da04dee8b2bd8526e320 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:18:38 -0400 Subject: [PATCH 5/8] Remove the use of masks I don't think these are neccisary. If an exception get's delivered at these points, we couldn't do anything about it anyway --- yesod-core/src/Yesod/Core/Internal/Run.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index a7530eb5..618665f2 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -96,7 +96,7 @@ basicRunHandler :: ToTypedContent c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents) -basicRunHandler rhe handler yreq resState = mask $ \unmask -> do +basicRunHandler rhe handler yreq resState = do -- Create a mutable ref to hold the state. We use mutable refs so -- that the updates will survive runtime exceptions. istate <- I.newIORef defState @@ -104,7 +104,7 @@ basicRunHandler rhe handler yreq resState = mask $ \unmask -> do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ contents' <- unsafeAsyncCatch - (unmask $ do + (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ @@ -218,9 +218,9 @@ runHandler :: ToTypedContent c => RunHandlerEnv site site -> HandlerFor site c -> YesodApp -runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> mask $ \unmask -> do +runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do -- Get the raw state and original contents - (state, contents0) <- unmask $ basicRunHandler rhe handler yreq resState + (state, contents0) <- basicRunHandler rhe handler yreq resState -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents From 5b96d949155eb1b09bed1d033e1f220989fcf31d Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:45:20 -0400 Subject: [PATCH 6/8] Fix it for async exceptions in the sessions as well --- yesod-core/src/Yesod/Core/Internal/Run.hs | 11 ++++++++-- .../test/YesodCoreTest/ErrorHandling.hs | 20 +++++++++++++++++-- 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 618665f2..c1ffe100 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -21,7 +21,6 @@ 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) @@ -72,6 +71,12 @@ unsafeAsyncCatch unsafeAsyncCatch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> do run (g e) +unsafeAsyncCatchAny :: (MonadUnliftIO m) + => m a -- ^ action + -> (SomeException -> m a) -- ^ handler + -> m a +unsafeAsyncCatchAny = unsafeAsyncCatch + -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse toErrorHandler e0 = handleAny errFromShow $ @@ -204,11 +209,13 @@ handleContents handleError' finalSession headers contents = -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value. +-- +-- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) => HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = catchAny +evalFallback contents val = unsafeAsyncCatchAny (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 4605fd40..b35c93d2 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ViewPatterns #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest @@ -53,6 +54,7 @@ mkYesod "App" [parseRoutes| /allocation-limit AlocationLimitR GET /thread-killed ThreadKilledR GET +/async-session AsyncSessionR GET |] overrideStatus :: Status @@ -128,7 +130,7 @@ getAlocationLimitR = defaultLayout $ [whamlet|

this will trigger https://hackage.haskell.org/package/base-4.16.0.0/docs/Control-Exception.html#t:AllocationLimitExceeded which we need to catch - |]) `finally` (liftIO $ Mem.disableAllocationLimit) + |]) `finally` liftIO Mem.disableAllocationLimit -- this handler kills it's own thread getThreadKilledR :: Handler Html @@ -137,6 +139,14 @@ getThreadKilledR = do liftIO $ Async.withAsync (Conc.killThread x) Async.wait pure "unreachablle" +getAsyncSessionR :: Handler Html +getAsyncSessionR = do + setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out + x <- liftIO Conc.myThreadId + liftIO $ forkIO $ do + liftIO $ Conc.threadDelay 100_000 + Conc.killThread x + pure "reachable" getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" @@ -183,11 +193,11 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept video, bad method -> 405" caseVideoBadMethod it "thread killed = 500" caseThreadKilled500 it "allocation limit = 500" caseAllocationLimit500 + it "async session exception = 500" asyncSessionKilled500 runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f - caseNotFound :: IO () caseNotFound = runner $ do res <- request defaultRequest @@ -333,3 +343,9 @@ caseThreadKilled500 = runner $ do res <- request defaultRequest { pathInfo = ["thread-killed"] } assertStatus 500 res assertBodyContains "Internal Server Error" res + +asyncSessionKilled500 :: IO () +asyncSessionKilled500 = runner $ do + res <- request defaultRequest { pathInfo = ["async-session"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res From f48485e18154c04276bac822f74d14538e4dd3f0 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:46:47 -0400 Subject: [PATCH 7/8] Bump version number --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f01e5ff9..9bf163f1 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.21.0 +version: 1.6.22.0 license: MIT license-file: LICENSE author: Michael Snoyman From 764fd94bc62796642fccdf325338e8f35503a728 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 22 Mar 2022 15:51:10 -0400 Subject: [PATCH 8/8] add changelog entry --- yesod-core/ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 47d63ffb..85f87ef0 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -3,6 +3,7 @@ ## Unreleased * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) ## 1.6.21.0