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
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Concurrent
import Control.Exception (Exception, MaskingState (MaskedInterruptible),
getMaskingState, throwIO, try, fromException)
import Control.Exception (SomeException, handle)
import Control.Monad (unless, void)
import qualified Control.Monad.Catch
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import Data.IORef
import Data.Typeable (Typeable)
import Test.Hspec
import Data.Acquire
main :: IO ()
main = hspec $ do
describe "general" $ do
it "survives releasing bottom" $ do
x <- newIORef (0 :: Int)
handle (\(_ :: SomeException) -> return ()) $ runResourceT $ do
_ <- register $ writeIORef x 1
release undefined
x' <- readIORef x
x' `shouldBe` 1
describe "early release" $ do
it "works from a different context" $ do
x <- newIORef (0 :: Int)
runResourceT $ do
key <- register $ writeIORef x 1
runResourceT $ release key
y <- liftIO $ readIORef x
liftIO $ y `shouldBe` 1
describe "resourceForkIO" $ do
it "waits for all threads" $ do
x <- newEmptyMVar
y <- newIORef (0 :: Int)
z <- newEmptyMVar
w <- newEmptyMVar
_ <- runResourceT $ do
_ <- register $ do
writeIORef y 1
putMVar w ()
resourceForkIO $ do
() <- liftIO $ takeMVar x
y' <- liftIO $ readIORef y
_ <- register $ putMVar z y'
return ()
y1 <- readIORef y
y1 `shouldBe` 0
putMVar x ()
z' <- takeMVar z
z' `shouldBe` 0
takeMVar w
y2 <- readIORef y
Just y2 `shouldBe` Just 1
describe "unprotecting" $ do
it "unprotect keeps resource from being cleared" $ do
x <- newIORef (0 :: Int)
_ <- runResourceT $ do
key <- register $ writeIORef x 1
unprotect key
y <- readIORef x
y `shouldBe` 0
it "cleanup actions are masked #144" $ do
let checkMasked name = do
ms <- getMaskingState
unless (ms == MaskedInterruptible) $
error $ show (name, ms)
_ <- runResourceT $ do
register (checkMasked "release") >>= release
register (checkMasked "normal")
Left Dummy <- try $ runResourceT $ do
_ <- register (checkMasked "exception")
liftIO $ throwIO Dummy
return ()
describe "mkAcquireType" $ do
describe "ResourceT" $ do
it "early" $ do
ref <- newIORef Nothing
let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
runResourceT $ do
(releaseKey, ()) <- allocateAcquire acq
release releaseKey
readIORef ref >>= (`shouldSatisfy` just releaseEarly)
it "normal" $ do
ref <- newIORef Nothing
let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
runResourceT $ do
(_releaseKey, ()) <- allocateAcquire acq
return ()
readIORef ref >>= (`shouldSatisfy` just releaseNormal)
it "exception" $ do
ref <- newIORef Nothing
let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
Left Dummy <- try $ runResourceT $ do
(_releaseKey, ()) <- allocateAcquire acq
liftIO $ throwIO Dummy
readIORef ref >>= (`shouldSatisfy` just (releaseException dummy))
describe "with" $ do
it "normal" $ do
ref <- newIORef Nothing
let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
with acq $ const $ return ()
readIORef ref >>= (`shouldSatisfy` just releaseNormal)
it "exception" $ do
ref <- newIORef Nothing
let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just
Left Dummy <- try $ with acq $ const $ throwIO Dummy
readIORef ref >>= (`shouldSatisfy` just (releaseException dummy))
describe "runResourceTChecked" $ do
it "catches exceptions" $ do
eres <- try $ runResourceTChecked $ void $ register $ throwIO Dummy
case eres of
Right () -> error "Expected an exception"
Left (ResourceCleanupException Nothing ex []) ->
case fromException ex of
Just Dummy -> return ()
Nothing -> error "It wasn't Dummy"
Left (ResourceCleanupException (Just _) _ []) -> error "Got a ResourceT exception"
Left (ResourceCleanupException _ _ (_:_)) -> error "Got more than one"
it "no exception is fine" $ (runResourceTChecked $ void $ register $ return () :: IO ())
it "catches multiple exceptions" $ do
eres <- try $ runResourceTChecked $ do
void $ register $ throwIO Dummy
void $ register $ throwIO Dummy2
case eres of
Right () -> error "Expected an exception"
Left (ResourceCleanupException Nothing ex1 [ex2]) ->
case (fromException ex1, fromException ex2) of
(Just Dummy, Just Dummy2) -> return ()
_ -> error $ "It wasn't Dummy, Dummy2: " ++ show (ex1, ex2)
Left (ResourceCleanupException (Just _) _ [_]) -> error "Got a ResourceT exception"
Left (ResourceCleanupException _ _ []) -> error "Only got 1"
Left (ResourceCleanupException _ _ (_:_:_)) -> error "Got more than 2"
describe "MonadMask" $
it "works" (runResourceT $ Control.Monad.Catch.bracket (return ()) (const (return ())) (const (return ())) :: IO ())
data Dummy = Dummy
deriving (Show, Typeable)
instance Exception Dummy
data Dummy2 = Dummy2
deriving (Show, Typeable)
instance Exception Dummy2
-- Helpers needed due to lack of 'Eq' on 'ReleaseType'
releaseEarly :: ReleaseType -> Bool
releaseEarly ReleaseEarly = True
releaseEarly _ = False
releaseNormal :: ReleaseType -> Bool
releaseNormal ReleaseNormal = True
releaseNormal _ = False
releaseException :: (Exception e) => Selector e -> ReleaseType -> Bool
releaseException sel (ReleaseExceptionWith se) = case fromException se of
Just e -> sel e
Nothing -> False
releaseException _ _ = False
just :: (a -> Bool) -> Maybe a -> Bool
just sel (Just x) = sel x
just _ Nothing = False
dummy :: Selector Dummy
dummy Dummy = True
|
