diff -Nru haskell-yesod-core-1.6.23.1/ChangeLog.md haskell-yesod-core-1.6.24.0/ChangeLog.md
--- haskell-yesod-core-1.6.23.1/ChangeLog.md 2022-04-25 09:55:17.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/ChangeLog.md 2022-07-20 15:04:47.000000000 +0000
@@ -1,5 +1,9 @@
# ChangeLog for yesod-core
+## 1.6.24.0
+
+* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).
+
## 1.6.23.1
* Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)
diff -Nru haskell-yesod-core-1.6.23.1/debian/changelog haskell-yesod-core-1.6.24.0/debian/changelog
--- haskell-yesod-core-1.6.23.1/debian/changelog 2022-08-01 13:53:01.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/debian/changelog 2022-12-12 15:55:31.000000000 +0000
@@ -1,3 +1,15 @@
+haskell-yesod-core (1.6.24.0-1build1) lunar; urgency=medium
+
+ * Rebuild against new GHC ABI.
+
+ -- Gianfranco Costamagna Mon, 12 Dec 2022 16:55:31 +0100
+
+haskell-yesod-core (1.6.24.0-1) unstable; urgency=medium
+
+ * New upstream release
+
+ -- Ilias Tsitsimpis Wed, 26 Oct 2022 12:11:53 +0300
+
haskell-yesod-core (1.6.23.1-1) unstable; urgency=medium
[ Ilias Tsitsimpis ]
diff -Nru haskell-yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs haskell-yesod-core-1.6.24.0/src/Yesod/Core/Class/Yesod.hs
--- haskell-yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs 2022-04-25 09:55:17.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/src/Yesod/Core/Class/Yesod.hs 2022-07-20 15:04:47.000000000 +0000
@@ -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
@@ -52,8 +54,10 @@
import Yesod.Core.Internal.Session
import Yesod.Core.Widget
import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Request
import Data.IORef
+import UnliftIO (SomeException, catch, MonadUnliftIO)
-- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required.
@@ -70,6 +74,16 @@
approot :: Approot site
approot = guessApproot
+ -- | @since 1.6.24.0
+ -- allows the user to specify how exceptions are cought.
+ -- by default all async exceptions are thrown and synchronous
+ -- exceptions render a 500 page.
+ -- To catch all exceptions (even async) to render a 500 page,
+ -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
+ -- this may have negative effects with functions like 'timeout'.
+ catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
+ catchHandlerExceptions _ = catch
+
-- | Output error response pages.
--
-- Default value: 'defaultErrorHandler'.
diff -Nru haskell-yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs haskell-yesod-core-1.6.24.0/src/Yesod/Core/Internal/Run.hs
--- haskell-yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs 2022-03-24 03:23:58.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/src/Yesod/Core/Internal/Run.hs 2022-07-20 15:04:47.000000000 +0000
@@ -1,10 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Core.Internal.Run
( toErrorHandler
, errFromShow
@@ -54,28 +55,7 @@
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
+import Data.Proxy(Proxy(..))
-- | Convert a synchronous exception into an ErrorResponse
toErrorHandler :: SomeException -> IO ErrorResponse
@@ -108,7 +88,7 @@
-- Run the handler itself, capturing any runtime exceptions and
-- converting them into a @HandlerContents@
- contents' <- unsafeAsyncCatch
+ contents' <- rheCatchHandlerExceptions rhe
(do
res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res)
@@ -212,10 +192,11 @@
--
-- Note that this also catches async exceptions.
evalFallback :: (Monoid w, NFData w)
- => HandlerContents
+ => (forall a. IO a -> (SomeException -> IO a) -> IO a)
+ -> HandlerContents
-> w
-> IO (w, HandlerContents)
-evalFallback contents val = unsafeAsyncCatchAny
+evalFallback catcher contents val = catcher
(fmap (, contents) (evaluate $!! val))
(fmap ((mempty, ) . HCError) . toErrorHandler)
@@ -231,8 +212,8 @@
-- Evaluate the unfortunately-lazy session and headers,
-- propagating exceptions into the contents
- (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
- (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
+ (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)
+ (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
-- Convert the HandlerContents into the final YesodResponse
@@ -275,7 +256,7 @@
-- @HandlerFor@ is completely ignored, including changes to the
-- session, cookies or headers. We only return you the
-- @HandlerFor@'s return value.
-runFakeHandler :: (Yesod site, MonadIO m) =>
+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
@@ -296,6 +277,7 @@
, rheLog = messageLoggerSource site $ logger site
, rheOnError = errHandler
, rheMaxExpires = maxExpires
+ , rheCatchHandlerExceptions = catchHandlerExceptions site
}
handler'
errHandler err req = do
@@ -337,7 +319,7 @@
_ <- runResourceT $ yapp fakeRequest
I.readIORef ret
-yesodRunner :: (ToTypedContent res, Yesod site)
+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)
=> HandlerFor site res
-> YesodRunnerEnv site
-> Maybe (Route site)
@@ -372,6 +354,7 @@
, rheLog = log'
, rheOnError = safeEh log'
, rheMaxExpires = maxExpires
+ , rheCatchHandlerExceptions = catchHandlerExceptions yreSite
}
rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
diff -Nru haskell-yesod-core-1.6.23.1/src/Yesod/Core/Types.hs haskell-yesod-core-1.6.24.0/src/Yesod/Core/Types.hs
--- haskell-yesod-core-1.6.23.1/src/Yesod/Core/Types.hs 2022-04-21 02:35:57.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/src/Yesod/Core/Types.hs 2022-07-20 15:04:47.000000000 +0000
@@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
module Yesod.Core.Types where
import Data.Aeson (ToJSON)
@@ -55,7 +56,7 @@
import Control.DeepSeq (NFData (rnf))
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..))
-import UnliftIO (MonadUnliftIO (..))
+import UnliftIO (MonadUnliftIO (..), SomeException)
-- Sessions
type SessionMap = Map Text ByteString
@@ -182,6 +183,11 @@
--
-- Since 1.2.0
, rheMaxExpires :: !Text
+
+ -- | @since 1.6.24.0
+ -- catch function for rendering 500 pages on exceptions.
+ -- by default this is catch from unliftio (rethrows all async exceptions).
+ , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a)
}
data HandlerData child site = HandlerData
diff -Nru haskell-yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling/CustomApp.hs haskell-yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling/CustomApp.hs
--- haskell-yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling/CustomApp.hs 1970-01-01 00:00:00.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling/CustomApp.hs 2022-07-20 15:04:47.000000000 +0000
@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+-- | a custom app that throws an exception
+module YesodCoreTest.ErrorHandling.CustomApp
+ (CustomApp(..)
+ , MyException(..)
+
+ -- * unused
+ , Widget
+ , resourcesCustomApp
+ ) where
+
+
+import Yesod.Core.Types
+import Yesod.Core
+import qualified UnliftIO.Exception as E
+
+data CustomApp = CustomApp
+
+mkYesod "CustomApp" [parseRoutes|
+/throw-custom-exception CustomHomeR GET
+|]
+
+getCustomHomeR :: Handler Html
+getCustomHomeR =
+ E.throwIO MkMyException
+
+data MyException = MkMyException
+ deriving (Show, E.Exception)
+
+instance Yesod CustomApp where
+ -- something we couldn't do before, rethrow custom exceptions
+ catchHandlerExceptions _ action handler =
+ action `E.catch` \exception -> do
+ case E.fromException exception of
+ Just MkMyException -> E.throwIO MkMyException
+ Nothing -> handler exception
diff -Nru haskell-yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs haskell-yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling.hs
--- haskell-yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs 2022-04-14 02:53:35.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling.hs 2022-07-20 15:04:47.000000000 +0000
@@ -1,12 +1,15 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
module YesodCoreTest.ErrorHandling
( errorHandlingTest
, Widget
, resourcesApp
) where
+import Data.Typeable(cast)
import qualified System.Mem as Mem
import qualified Control.Concurrent.Async as Async
import Control.Concurrent as Conc
@@ -16,16 +19,19 @@
import Network.Wai.Test
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8
-import Control.Exception (SomeException, try)
+import Control.Exception (SomeException, try, AsyncException(..))
import UnliftIO.Exception(finally)
import Network.HTTP.Types (Status, mkStatus)
import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Monoid (mconcat)
import Data.Text (Text, pack)
import Control.Monad (forM_)
+import qualified Network.Wai.Handler.Warp as Warp
+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
@@ -52,7 +58,8 @@
/only-plain-text OnlyPlainTextR GET
/thread-killed ThreadKilledR GET
-/async-session AsyncSessionR GET
+/connection-closed-by-peer ConnectionClosedPeerR GET
+/sleep-sec SleepASecR GET
|]
overrideStatus :: Status
@@ -125,15 +132,16 @@
x <- liftIO Conc.myThreadId
liftIO $ Async.withAsync (Conc.killThread x) Async.wait
pure "unreachablle"
+getSleepASecR :: Handler Html
+getSleepASecR = do
+ liftIO $ Conc.threadDelay 1000000
+ pure "slept a second"
-getAsyncSessionR :: Handler Html
-getAsyncSessionR = do
- setSession "jap" $ foldMap (pack . show) [0..999999999999999999999999] -- it's going to take a while to figure this one out
+getConnectionClosedPeerR :: Handler Html
+getConnectionClosedPeerR = do
x <- liftIO Conc.myThreadId
- liftIO $ forkIO $ do
- liftIO $ Conc.threadDelay 100000
- Conc.killThread x
- pure "reachable"
+ liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait
+ pure "unreachablle"
getErrorR :: Int -> Handler ()
getErrorR 1 = setSession undefined "foo"
@@ -178,8 +186,10 @@
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 "async session exception = 500" asyncSessionKilled500
+ it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows
+ it "custom config rethrows an exception" caseCustomExceptionRethrows
+ it "thread killed rethrow" caseThreadKilledRethrow
+ it "can timeout a runner" canTimeoutARunner
runner :: Session a -> IO a
runner f = toWaiApp App >>= runSession f
@@ -318,14 +328,49 @@
}
assertStatus 405 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
+fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e
+fromExceptionUnwrap se
+ | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e
+ | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e
+ | otherwise = E.fromException se
+
+
+caseThreadKilledRethrow :: IO ()
+caseThreadKilledRethrow =
+ shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+ (Just ThreadKilled) -> True
+ _ -> False
+ where
+ testcode = runner $ do
+ res <- request defaultRequest { pathInfo = ["thread-killed"] }
+ assertStatus 500 res
+ assertBodyContains "Internal Server Error" res
+
+caseDefaultConnectionCloseRethrows :: IO ()
+caseDefaultConnectionCloseRethrows =
+ shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
+ Just Warp.ConnectionClosedByPeer -> True
+ _ -> False
+
+ where
+ testcode = runner $ do
+ _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }
+ pure ()
+
+caseCustomExceptionRethrows :: IO ()
+caseCustomExceptionRethrows =
+ shouldThrow testcode $ \case Custom.MkMyException -> True
+ where
+ testcode = customAppRunner $ do
+ _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }
+ pure ()
+ customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f
+
+
+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.
diff -Nru haskell-yesod-core-1.6.23.1/yesod-core.cabal haskell-yesod-core-1.6.24.0/yesod-core.cabal
--- haskell-yesod-core-1.6.23.1/yesod-core.cabal 2022-04-25 09:55:17.000000000 +0000
+++ haskell-yesod-core-1.6.24.0/yesod-core.cabal 2022-07-20 15:04:47.000000000 +0000
@@ -1,5 +1,5 @@
name: yesod-core
-version: 1.6.23.1
+version: 1.6.24.0
license: MIT
license-file: LICENSE
author: Michael Snoyman
@@ -146,6 +146,7 @@
YesodCoreTest.Header
YesodCoreTest.Csrf
YesodCoreTest.ErrorHandling
+ YesodCoreTest.ErrorHandling.CustomApp
YesodCoreTest.Exceptions
YesodCoreTest.InternalRequest
YesodCoreTest.JsLoader