1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Control.Exception.SafeSpec (spec) where
5
6import Control.Concurrent (threadDelay, newEmptyMVar, forkIOWithUnmask, takeMVar, putMVar)
7import Control.Exception (ArithException (..), AsyncException (..), BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..))
8import qualified Control.Exception as E
9import Control.Exception.Safe
10import Control.Monad (forever)
11import Data.Typeable (Typeable)
12import Data.Void (Void, absurd)
13import System.IO.Unsafe (unsafePerformIO)
14import System.Timeout (timeout)
15import Test.Hspec
16#if !MIN_VERSION_base(4,9,0)
17import System.IO.Error (isUserError)
18#endif
19
20newtype ExceptionPred = ExceptionPred { getExceptionPred :: Maybe () } deriving (Show, Eq, Typeable)
21
22instance Exception ExceptionPred
23
24-- | Ugly hack needed because the underlying type is not exported
25timeoutException :: SomeException
26timeoutException =
27    case unsafePerformIO $ mask $ \restore -> timeout 1 $ tryAsync $ restore $ forever $ threadDelay maxBound of
28        Nothing -> error "timeoutException returned Nothing"
29        Just (Left e) -> e
30        Just (Right e) -> absurd e
31
32asyncE :: IO a
33asyncE = E.throwIO ThreadKilled
34
35syncE :: IO a
36syncE = E.throwIO Overflow
37
38-- | Maps each exception to whether it is synchronous
39exceptions :: [(SomeException, Bool)]
40exceptions =
41    [ go Overflow True
42    , go ThreadKilled False
43    , go timeoutException False
44    , go BlockedIndefinitelyOnMVar True -- see the README, this is weird
45    , go BlockedIndefinitelyOnSTM True -- see the README, this is weird
46    ]
47  where
48    go e b = (toException e, b)
49
50withAll :: (SomeException -> Bool -> IO ()) -> Spec
51withAll f = mapM_ (\(e, b) -> it (show e) (f e b)) exceptions
52
53spec :: Spec
54spec = do
55    describe "isSyncException" $ withAll
56        $ \e sync -> isSyncException e `shouldBe` sync
57    describe "isAsncException" $ withAll
58        $ \e sync -> isAsyncException e `shouldBe` not sync
59    describe "toSyncException" $ withAll
60        $ \e _ -> isSyncException (toSyncException e) `shouldBe` True
61    describe "toAsyncException" $ withAll
62        $ \e _ -> isAsyncException (toAsyncException e) `shouldBe` True
63
64    let shouldBeSync :: Either SomeException Void -> IO ()
65        shouldBeSync (Left e)
66            | isSyncException e = return ()
67            | otherwise = error $ "Unexpected async exception: " ++ show e
68        shouldBeSync (Right x) = absurd x
69
70        shouldBeAsync :: Either SomeException Void -> IO ()
71        shouldBeAsync (Left e)
72            | isAsyncException e = return ()
73            | otherwise = error $ "Unexpected sync exception: " ++ show e
74        shouldBeAsync (Right x) = absurd x
75
76        shouldThrowSync f = E.try f >>= shouldBeSync
77        shouldThrowAsync f = E.try f >>= shouldBeAsync
78
79    describe "throw" $ withAll $ \e _ -> shouldThrowSync (throw e)
80    describe "throwTo" $ withAll $ \e _ -> do
81        var <- newEmptyMVar
82        tid <- E.uninterruptibleMask_ $ forkIOWithUnmask $ \restore -> do
83            res <- E.try $ restore $ forever $ threadDelay maxBound
84            putMVar var res
85        throwTo tid e
86        res <- takeMVar var
87        shouldBeAsync res
88
89    describe "stays async" $ do
90        let withPairs f = do
91                it "sync/sync" $ shouldThrowSync $ f syncE syncE
92
93                -- removing this case from consideration, since cleanup handlers
94                -- cannot receive async exceptions. See
95                -- https://github.com/fpco/safe-exceptions/issues/2
96                --
97                -- it "sync/async" $ shouldThrowAsync $ f syncE asyncE
98
99                it "async/sync" $ shouldThrowAsync $ f asyncE syncE
100                it "async/async" $ shouldThrowAsync $ f asyncE asyncE
101        describe "onException" $ withPairs $ \e1 e2 -> e1 `onException` e2
102        describe "withException" $ withPairs $ \e1 e2 -> e1 `withException` (\(_ :: SomeException) -> e2)
103        describe "bracket_" $ withPairs $ \e1 e2 -> bracket_ (return ()) e2 e1
104        describe "finally" $ withPairs $ \e1 e2 -> e1 `finally` e2
105        describe "bracketOnError_" $ withPairs $ \e1 e2 -> bracketOnError_ (return ()) e2 e1
106
107    describe "deepseq" $ do
108        describe "catchAnyDeep" $ withAll $ \e _ -> do
109            res <- return (impureThrow e) `catchAnyDeep` \_ -> return ()
110            res `shouldBe` ()
111        describe "handleAnyDeep" $ withAll $ \e _ -> do
112            res <- handleAnyDeep (const $ return ()) (return (impureThrow e))
113            res `shouldBe` ()
114        describe "tryAnyDeep" $ withAll $ \e _ -> do
115            res <- tryAnyDeep (return (impureThrow e))
116            -- deal with a missing NFData instance
117            shouldBeSync $ either Left (\() -> Right undefined) res
118        describe "catchesDeep" $ withAll $ \e _ -> do
119            res <- return (impureThrow e) `catchesDeep` [Handler (\(_ :: SomeException) -> return ())]
120            res `shouldBe` ()
121
122    describe "catchJust" $ do
123      it "catches a selected exception" $ do
124        res <- catchJust getExceptionPred (throw (ExceptionPred (Just ()))) (return . Just)
125        res `shouldBe` Just ()
126
127      it "re-raises a selection that is passed on" $ do
128        let ex = ExceptionPred Nothing
129        res <- try (catchJust getExceptionPred (throw ex) (return . Just))
130        res `shouldBe` Left ex
131
132    describe "throwString" $ do
133      it "is a StringException" $
134        throwString "foo" `catch` \(StringException _ _) -> return () :: IO ()
135