1{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-}
2module Main where
3
4import Test.Framework (defaultMain, testGroup)
5import Test.Framework.Providers.HUnit
6
7import Test.HUnit
8
9import Control.Concurrent.STM
10import Control.Concurrent.Async
11import Control.Exception
12import Data.IORef
13import Data.Typeable
14import Control.Concurrent
15import Control.Monad
16import Data.List (sort)
17import Data.Maybe
18
19import Prelude hiding (catch)
20
21main = defaultMain tests
22
23tests = [
24    testCase "async_wait"        async_wait
25  , testCase "async_waitCatch"   async_waitCatch
26  , testCase "async_exwait"      async_exwait
27  , testCase "async_exwaitCatch" async_exwaitCatch
28  , testCase "withasync_waitCatch" withasync_waitCatch
29  , testCase "withasync_wait2"   withasync_wait2
30  , testGroup "async_cancel_rep" $
31      replicate 1000 $
32         testCase "async_cancel"       async_cancel
33  , testCase "async_cancelmany" async_cancelmany
34  , testCase "async_poll"        async_poll
35  , testCase "async_poll2"       async_poll2
36  , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked
37  , testCase "withasync_wait_blocked" withasync_wait_blocked
38  , testGroup "children surviving too long"
39      [ testCase "concurrently+success" concurrently_success
40      , testCase "concurrently+failure" concurrently_failure
41      , testCase "race+success" race_success
42      , testCase "race+failure" race_failure
43      , testCase "cancel" cancel_survive
44      , testCase "withAsync" withasync_survive
45      ]
46  , testCase "concurrently_" case_concurrently_
47  , testCase "replicateConcurrently_" case_replicateConcurrently
48  , testCase "replicateConcurrently" case_replicateConcurrently_
49  , testCase "link1" case_link1
50  , testCase "link2" case_link2
51  , testCase "link1_cancel" case_link1cancel
52  , testCase "concurrently_deadlock" case_concurrently_deadlock
53 ]
54
55value = 42 :: Int
56
57data TestException = TestException deriving (Eq,Show,Typeable)
58instance Exception TestException
59
60async_waitCatch :: Assertion
61async_waitCatch = do
62  a <- async (return value)
63  r <- waitCatch a
64  case r of
65    Left _  -> assertFailure ""
66    Right e -> e @?= value
67
68async_wait :: Assertion
69async_wait = do
70  a <- async (return value)
71  r <- wait a
72  assertEqual "async_wait" r value
73
74async_exwaitCatch :: Assertion
75async_exwaitCatch = do
76  a <- async (throwIO TestException)
77  r <- waitCatch a
78  case r of
79    Left e  -> fromException e @?= Just TestException
80    Right _ -> assertFailure ""
81
82async_exwait :: Assertion
83async_exwait = do
84  a <- async (throwIO TestException)
85  (wait a >> assertFailure "") `catch` \e -> e @?= TestException
86
87withasync_waitCatch :: Assertion
88withasync_waitCatch = do
89  withAsync (return value) $ \a -> do
90    r <- waitCatch a
91    case r of
92      Left _  -> assertFailure ""
93      Right e -> e @?= value
94
95withasync_wait2 :: Assertion
96withasync_wait2 = do
97  a <- withAsync (threadDelay 1000000) $ return
98  r <- waitCatch a
99  case r of
100    Left e  -> fromException e @?= Just AsyncCancelled
101    Right _ -> assertFailure ""
102
103async_cancel :: Assertion
104async_cancel = do
105  a <- async (return value)
106  cancelWith a TestException
107  r <- waitCatch a
108  case r of
109    Left e -> fromException e @?= Just TestException
110    Right r -> r @?= value
111
112async_cancelmany :: Assertion -- issue 59
113async_cancelmany = do
114  r <- newIORef []
115  a <- async $ forConcurrently_ ['a'..'z'] $ \c ->
116    delay 2 `finally` atomicModifyIORef r (\i -> (c:i,()))
117  delay 1
118  cancel a
119  v <- readIORef r
120  assertEqual "cancelmany" 26 (length v)
121  where
122    delay sec = threadDelay (sec * 1000000)
123
124async_poll :: Assertion
125async_poll = do
126  a <- async (threadDelay 1000000)
127  r <- poll a
128  when (isJust r) $ assertFailure ""
129  r <- poll a   -- poll twice, just to check we don't deadlock
130  when (isJust r) $ assertFailure ""
131
132async_poll2 :: Assertion
133async_poll2 = do
134  a <- async (return value)
135  wait a
136  r <- poll a
137  when (isNothing r) $ assertFailure ""
138  r <- poll a   -- poll twice, just to check we don't deadlock
139  when (isNothing r) $ assertFailure ""
140
141withasync_waitCatch_blocked :: Assertion
142withasync_waitCatch_blocked = do
143  r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch
144  case r of
145    Left e ->
146        case fromException e of
147            Just BlockedIndefinitelyOnMVar -> return ()
148            Nothing -> assertFailure $ show e
149    Right () -> assertFailure ""
150
151withasync_wait_blocked :: Assertion
152withasync_wait_blocked = do
153  r <- try $ withAsync (newEmptyMVar >>= takeMVar) wait
154  case r of
155    Left e ->
156        case fromException e of
157            Just BlockedIndefinitelyOnMVar -> return ()
158            Nothing -> assertFailure $ show e
159    Right () -> assertFailure ""
160
161concurrently_success :: Assertion
162concurrently_success = do
163  finalRes <- newIORef "never filled"
164  baton <- newEmptyMVar
165  let quick = return ()
166      slow = threadDelay 10000 `finally` do
167        threadDelay 10000
168        writeIORef finalRes "slow"
169        putMVar baton ()
170  _ <- concurrently quick slow
171  writeIORef finalRes "parent"
172  takeMVar baton
173  res <- readIORef finalRes
174  res @?= "parent"
175
176concurrently_failure :: Assertion
177concurrently_failure = do
178  finalRes <- newIORef "never filled"
179  let quick = error "a quick death"
180      slow = threadDelay 10000 `finally` do
181        threadDelay 10000
182        writeIORef finalRes "slow"
183  _ :: Either SomeException ((), ()) <- try (concurrently quick slow)
184  writeIORef finalRes "parent"
185  threadDelay 1000000 -- not using the baton, can lead to deadlock detection
186  res <- readIORef finalRes
187  res @?= "parent"
188
189race_success :: Assertion
190race_success = do
191  finalRes <- newIORef "never filled"
192  let quick = return ()
193      slow = threadDelay 10000 `finally` do
194        threadDelay 10000
195        writeIORef finalRes "slow"
196  race_ quick slow
197  writeIORef finalRes "parent"
198  threadDelay 1000000 -- not using the baton, can lead to deadlock detection
199  res <- readIORef finalRes
200  res @?= "parent"
201
202race_failure :: Assertion
203race_failure = do
204  finalRes <- newIORef "never filled"
205  baton <- newEmptyMVar
206  let quick = error "a quick death"
207      slow restore = restore (threadDelay 10000) `finally` do
208        threadDelay 10000
209        writeIORef finalRes "slow"
210        putMVar baton ()
211  _ :: Either SomeException () <-
212    try $ mask $ \restore ->
213       race_ quick (slow restore)
214  writeIORef finalRes "parent"
215  takeMVar baton
216  res <- readIORef finalRes
217  res @?= "parent"
218
219cancel_survive :: Assertion
220cancel_survive = do
221  finalRes <- newIORef "never filled"
222  a <- async $ threadDelay 10000 `finally` do
223        threadDelay 10000
224        writeIORef finalRes "child"
225  cancel a
226  writeIORef finalRes "parent"
227  threadDelay 1000000 -- not using the baton, can lead to deadlock detection
228  res <- readIORef finalRes
229  res @?= "parent"
230
231withasync_survive :: Assertion
232withasync_survive = do
233  finalRes <- newIORef "never filled"
234  let child = threadDelay 10000 `finally` do
235        threadDelay 10000
236        writeIORef finalRes "child"
237  withAsync child (\_ -> return ())
238  writeIORef finalRes "parent"
239  threadDelay 1000000 -- not using the baton, can lead to deadlock detection
240  res <- readIORef finalRes
241  res @?= "parent"
242
243case_concurrently_ :: Assertion
244case_concurrently_ = do
245  ref <- newIORef 0
246  () <- concurrently_
247    (atomicModifyIORef ref (\x -> (x + 1, True)))
248    (atomicModifyIORef ref (\x -> (x + 2, 'x')))
249  res <- readIORef ref
250  res @?= 3
251
252case_replicateConcurrently :: Assertion
253case_replicateConcurrently = do
254  ref <- newIORef 0
255  let action = atomicModifyIORef ref (\x -> (x + 1, x + 1))
256  resList <- replicateConcurrently 100 action
257  resVal <- readIORef ref
258  resVal @?= 100
259  sort resList @?= [1..100]
260
261case_replicateConcurrently_ :: Assertion
262case_replicateConcurrently_ = do
263  ref <- newIORef 0
264  let action = atomicModifyIORef ref (\x -> (x + 1, x + 1))
265  () <- replicateConcurrently_ 100 action
266  resVal <- readIORef ref
267  resVal @?= 100
268
269case_link1 :: Assertion
270case_link1 = do
271  m1 <- newEmptyMVar
272  m2 <- newEmptyMVar
273  let ex = ErrorCall "oops"
274  a <- async $ do takeMVar m1; throwIO ex; putMVar m2 ()
275  link a
276  e <- try $ (do
277    putMVar m1 ()
278    takeMVar m2)
279  assertBool "link1" $
280    case e of
281      Left (ExceptionInLinkedThread a' e') ->
282        compareAsyncs a' a == EQ &&
283          case fromException e' of
284            Just (ErrorCall s) -> s == "oops"
285            _otherwise -> False
286      _other -> False
287
288case_link2 :: Assertion
289case_link2 = do
290  let
291    setup = do
292      m1 <- newEmptyMVar
293      m2 <- newEmptyMVar
294      let ex1 = ErrorCall "oops1"; ex2 = ErrorCall "oops2"
295      a <- async $ do takeMVar m1; throwIO ex1
296      b <- async $ do takeMVar m2; throwIO ex2
297      link2 a b
298      return (m1,m2,a,b)
299
300  (m1,m2,a,b) <- setup
301  e <- try $ do
302    putMVar m1 ()
303    wait b
304  putMVar m2 ()  -- ensure the other thread is not deadlocked
305  assertBool "link2a" $
306    case e of
307      Left (ExceptionInLinkedThread a' e') ->
308        compareAsyncs a' a == EQ &&
309          case fromException e' of
310            Just (ErrorCall s) -> s == "oops1"
311            _otherwise -> False
312      _other -> False
313
314  (m1,m2,a,b) <- setup
315  e <- try $ do
316    putMVar m2 ()
317    wait a
318  putMVar m1 ()  -- ensure the other thread is not deadlocked
319  assertBool "link2b" $
320    case e of
321      Left (ExceptionInLinkedThread a' e') ->
322        compareAsyncs a' b == EQ &&
323          case fromException e' of
324            Just (ErrorCall s) -> s == "oops2"
325            _otherwise -> False
326      _other -> False
327
328case_link1cancel :: Assertion
329case_link1cancel = do
330  m1 <- newEmptyMVar
331  let ex = ErrorCall "oops"
332  a <- async $ do takeMVar m1
333  link a
334  e <- try $ do cancel a; wait a
335  putMVar m1 ()
336  assertBool "link1cancel" $
337    case e of
338      Left AsyncCancelled -> True  -- should not be ExceptionInLinkedThread
339      _other -> False
340
341-- See Issue #62
342case_concurrently_deadlock :: Assertion
343case_concurrently_deadlock = do
344  tvar <- newTVarIO False :: IO (TVar Bool)
345  e <- try $ void $ join (concurrently) (atomically $ readTVar tvar >>= check)
346    -- should throw BlockedIndefinitelyOnSTM not BlockedIndefinitelyOnMVar
347  assertBool "concurrently_deadlock" $
348    case e of
349      Left BlockedIndefinitelyOnSTM{} -> True
350      _other -> False
351