From 13db3db1187738caa2d800fd6f430d0646acec77 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 20 Jul 2022 14:14:14 +0200 Subject: [PATCH] Add backwards compatibility for old unliftio --- yesod-core/test/YesodCoreTest/ErrorHandling.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 30b22e89..0892faf1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -9,6 +9,7 @@ module YesodCoreTest.ErrorHandling , resourcesApp ) where +import Data.Typeable(cast) import qualified System.Mem as Mem import qualified Control.Concurrent.Async as Async import Control.Concurrent as Conc @@ -327,9 +328,16 @@ caseVideoBadMethod = runner $ do } assertStatus 405 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 E.fromExceptionUnwrap e of + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of (Just ThreadKilled) -> True _ -> False where @@ -340,7 +348,7 @@ caseThreadKilledRethrow = caseDefaultConnectionCloseRethrows :: IO () caseDefaultConnectionCloseRethrows = - shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of Just Warp.ConnectionClosedByPeer -> True _ -> False