diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 5e6538b6..dd79ae20 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# 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'. diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 15f660c1..27853b38 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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.