Add backwards compatibility for old unliftio

This commit is contained in:
Jappie Klooster 2022-07-20 14:14:14 +02:00
parent dc4ee0f92c
commit 13db3db118

View File

@ -9,6 +9,7 @@ module YesodCoreTest.ErrorHandling
, resourcesApp , resourcesApp
) where ) where
import Data.Typeable(cast)
import qualified System.Mem as Mem import qualified System.Mem as Mem
import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Async as Async
import Control.Concurrent as Conc import Control.Concurrent as Conc
@ -327,9 +328,16 @@ caseVideoBadMethod = runner $ do
} }
assertStatus 405 res 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 :: IO ()
caseThreadKilledRethrow = caseThreadKilledRethrow =
shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
(Just ThreadKilled) -> True (Just ThreadKilled) -> True
_ -> False _ -> False
where where
@ -340,7 +348,7 @@ caseThreadKilledRethrow =
caseDefaultConnectionCloseRethrows :: IO () caseDefaultConnectionCloseRethrows :: IO ()
caseDefaultConnectionCloseRethrows = caseDefaultConnectionCloseRethrows =
shouldThrow testcode $ \e -> case E.fromExceptionUnwrap e of shouldThrow testcode $ \e -> case fromExceptionUnwrap e of
Just Warp.ConnectionClosedByPeer -> True Just Warp.ConnectionClosedByPeer -> True
_ -> False _ -> False