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