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