Fix dealing with timeout and add appropriate test

add comments for this nonobvious test

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

@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -58,6 +60,7 @@ import Data.IORef
 import UnliftIO (SomeException, fromException, isSyncException, fromExceptionUnwrap)
 import Data.Proxy(Proxy)
 import Yesod.Core.CatchBehavior
+import System.Timeout(Timeout)
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -656,7 +659,9 @@ rethrowAsync exception =
 defaultCatchBehavior :: SomeException -> CatchBehavior
 defaultCatchBehavior exception = case fromExceptionUnwrap exception of
   Just Warp.ConnectionClosedByPeer -> rethrow
-  _                                -> catch
+  _                                -> case fromExceptionUnwrap exception of
+    Just (_ :: Timeout) -> rethrow
+    _ -> catch
 
 
 -- | The default error handler for 'errorHandler'.

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -30,6 +30,7 @@ import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom
 import Control.Monad.Trans.State (StateT (..))
 import Control.Monad.Trans.Reader (ReaderT (..))
 import qualified UnliftIO.Exception as E
+import System.Timeout(timeout)
 
 data App = App
 
@@ -58,6 +59,7 @@ mkYesod "App" [parseRoutes|
 /thread-killed ThreadKilledR GET
 /connection-closed-by-peer ConnectionClosedPeerR GET
 /async-session AsyncSessionR GET
+/sleep-sec SleepASecR GET
 |]
 
 overrideStatus :: Status
@@ -131,6 +133,10 @@ getThreadKilledR = do
   liftIO $ Async.withAsync (Conc.killThread x) Async.wait
   pure "unreachablle"
 
+getSleepASecR :: Handler Html
+getSleepASecR = do
+  liftIO $ Conc.threadDelay 1000000
+  pure "slept a second"
 
 getConnectionClosedPeerR :: Handler Html
 getConnectionClosedPeerR = do
@@ -195,6 +201,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
       it "custom config rethrows an exception" caseCustomExceptionRethrows
       it "async session exception = 500" asyncSessionKilled500
+      it "can timeout a runner" canTimeoutARunner
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -366,3 +373,11 @@ asyncSessionKilled500 = runner $ do
   res <- request defaultRequest { pathInfo = ["async-session"] }
   assertStatus 500 res
   assertBodyContains "Internal Server Error" res
+
+canTimeoutARunner :: IO ()
+canTimeoutARunner = do
+  res <- timeout 1000 $ runner $ do
+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }
+    assertStatus 200 res -- if 500, it's catching the timeout exception
+    pure () -- it should've timeout by now, either being 500 or Nothing
+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.