Merge branch 'fix-catch-async-exception-on-requst-threads' of https://github.com/SupercedeTech/yesod

yesod-core/ChangeLog.md

@@ -1,11 +1,10 @@
 # ChangeLog for yesod-core
 
-## Unreleased
-
 ## 1.6.22.0
 
 * Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)
 * Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)
+* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)
 
 ## 1.6.21.0
 

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

@@ -5,9 +5,23 @@
 {-# 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 qualified Control.Exception as EUnsafe
 import Yesod.Core.Internal.Response
 import           Data.ByteString.Builder      (toLazyByteString)
 import qualified Data.ByteString.Lazy         as BL
@@ -39,6 +53,29 @@ 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
+    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
@@ -71,7 +108,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)
@@ -172,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)
 

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE ViewPatterns #-}
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , 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
@@ -13,6 +18,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)
@@ -45,6 +51,10 @@ 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
+/async-session AsyncSessionR GET
 |]
 
 overrideStatus :: Status
@@ -111,6 +121,33 @@ 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|
+        <p> 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
+getThreadKilledR = do
+  x <- liftIO Conc.myThreadId
+  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"
 getErrorR 2 = setSession "foo" undefined
@@ -154,6 +191,9 @@ 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
+      it "async session exception = 500" asyncSessionKilled500
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -291,3 +331,21 @@ 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
+
+asyncSessionKilled500 :: IO ()
+asyncSessionKilled500 = runner $ do
+  res <- request defaultRequest { pathInfo = ["async-session"] }
+  assertStatus 500 res
+  assertBodyContains "Internal Server Error" res