Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-yesod-core for openSUSE:Factory checked in at 2022-10-13 15:44:21 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-yesod-core (Old) and /work/SRC/openSUSE:Factory/.ghc-yesod-core.new.2275 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-yesod-core" Thu Oct 13 15:44:21 2022 rev:13 rq:1009721 version:1.6.24.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-yesod-core/ghc-yesod-core.changes 2022-08-10 17:14:45.813937198 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-yesod-core.new.2275/ghc-yesod-core.changes 2022-10-13 15:44:58.887070130 +0200 @@ -1,0 +2,8 @@ +Wed Jul 20 15:05:36 UTC 2022 - Peter Simons <[email protected]> + +- Update yesod-core to version 1.6.24.0. + ## 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). + +------------------------------------------------------------------- Old: ---- yesod-core-1.6.23.1.tar.gz New: ---- yesod-core-1.6.24.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-yesod-core.spec ++++++ --- /var/tmp/diff_new_pack.g5opSZ/_old 2022-10-13 15:44:59.491071309 +0200 +++ /var/tmp/diff_new_pack.g5opSZ/_new 2022-10-13 15:44:59.491071309 +0200 @@ -19,7 +19,7 @@ %global pkg_name yesod-core %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.6.23.1 +Version: 1.6.24.0 Release: 0 Summary: Creation of type-safe, RESTful web applications License: MIT ++++++ yesod-core-1.6.23.1.tar.gz -> yesod-core-1.6.24.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/ChangeLog.md new/yesod-core-1.6.24.0/ChangeLog.md --- old/yesod-core-1.6.23.1/ChangeLog.md 2022-04-25 11:55:17.000000000 +0200 +++ new/yesod-core-1.6.24.0/ChangeLog.md 2022-07-20 17:04:47.000000000 +0200 @@ -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 `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs new/yesod-core-1.6.24.0/src/Yesod/Core/Class/Yesod.hs --- old/yesod-core-1.6.23.1/src/Yesod/Core/Class/Yesod.hs 2022-04-25 11:55:17.000000000 +0200 +++ new/yesod-core-1.6.24.0/src/Yesod/Core/Class/Yesod.hs 2022-07-20 17:04:47.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs new/yesod-core-1.6.24.0/src/Yesod/Core/Internal/Run.hs --- old/yesod-core-1.6.23.1/src/Yesod/Core/Internal/Run.hs 2022-03-24 04:23:58.000000000 +0100 +++ new/yesod-core-1.6.24.0/src/Yesod/Core/Internal/Run.hs 2022-07-20 17:04:47.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/src/Yesod/Core/Types.hs new/yesod-core-1.6.24.0/src/Yesod/Core/Types.hs --- old/yesod-core-1.6.23.1/src/Yesod/Core/Types.hs 2022-04-21 04:35:57.000000000 +0200 +++ new/yesod-core-1.6.24.0/src/Yesod/Core/Types.hs 2022-07-20 17:04:47.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling/CustomApp.hs new/yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling/CustomApp.hs --- old/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling/CustomApp.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling/CustomApp.hs 2022-07-20 17:04:47.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs new/yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling.hs --- old/yesod-core-1.6.23.1/test/YesodCoreTest/ErrorHandling.hs 2022-04-14 04:53:35.000000000 +0200 +++ new/yesod-core-1.6.24.0/test/YesodCoreTest/ErrorHandling.hs 2022-07-20 17:04:47.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.6.23.1/yesod-core.cabal new/yesod-core-1.6.24.0/yesod-core.cabal --- old/yesod-core-1.6.23.1/yesod-core.cabal 2022-04-25 11:55:17.000000000 +0200 +++ new/yesod-core-1.6.24.0/yesod-core.cabal 2022-07-20 17:04:47.000000000 +0200 @@ -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 <[email protected]> @@ -146,6 +146,7 @@ YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling + YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions YesodCoreTest.InternalRequest YesodCoreTest.JsLoader
