Add backwards compatibility for old unliftio
This commit is contained in:
parent
dc4ee0f92c
commit
13db3db118
@ -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
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user