24240ac · distributed-process

git.iko.soy/distributed-process

on master help sign in

Try to remove any racy expressions from the test suite

24240acTim Watson8 years ago

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+81−70

compare with master

unifiedsplit

@@ -5,7 +5,6 @@ module Control.Distributed.Process.Tests.Mx (tests) where

6import Control.Distributed.Process.Tests.Internal.Utils

7import Network.Transport.Test (TestTransport(..))

8−import Control.Exception (SomeException)

9import Control.Distributed.Process hiding (bracket, finally, try)

8import Control.Distributed.Process hiding (bracket, finally, try)

10import Control.Distributed.Process.Internal.Types

9import Control.Distributed.Process.Internal.Types

11 ( ProcessExitException(..)

10 ( ProcessExitException(..)

@@ -39,7 +38,7 @@ import Control.Monad.Catch(finally, bracket, try)

39import Control.Rematch (equalTo)

38import Control.Rematch (equalTo)

40import Data.Binary

39import Data.Binary

41import Data.List (find, sort, intercalate)

40import Data.List (find, sort, intercalate)

42−import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)

41+import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)

43import Data.Typeable

42import Data.Typeable

44import GHC.Generics hiding (from)

43import GHC.Generics hiding (from)

45#if ! MIN_VERSION_base(4,6,0)

44#if ! MIN_VERSION_base(4,6,0)

@@ -50,7 +49,6 @@ import Test.Framework

50 ( Test

49 ( Test

51 , testGroup

50 , testGroup

52 )

51 )

53−import Test.HUnit (Assertion)

54import Test.Framework.Providers.HUnit (testCase)

52import Test.Framework.Providers.HUnit (testCase)

56data Publish = Publish

54data Publish = Publish

@@ -68,7 +66,7 @@ awaitExit pid =

68 where

66 where

69 withMonitorRef p = bracket (monitor p) unmonitor

67 withMonitorRef p = bracket (monitor p) unmonitor

71−testAgentBroadcast :: TestResult () -> Process ()

69+testAgentBroadcast :: TestResult (Maybe ()) -> Process ()

72testAgentBroadcast result = do

70testAgentBroadcast result = do

73 (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())

71 (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())

@@ -83,10 +81,10 @@ testAgentBroadcast result = do

83 mxNotify ()

81 mxNotify ()

84 -- Once the publisher has seen our message, it will broadcast the Publish

82 -- Once the publisher has seen our message, it will broadcast the Publish

85 -- and the consumer will see that and send the result to our typed channel.

83 -- and the consumer will see that and send the result to our typed channel.

86− stash result =<< receiveChan resultRP

84+ stash result =<< receiveChanTimeout 10000000 resultRP

88− kill publisher "finished" >> awaitExit publisher

86+ kill publisher "finished"

89− kill consumer "finished" >> awaitExit consumer

87+ kill consumer "finished"

91testAgentDualInput :: TestResult (Maybe Int) -> Process ()

89testAgentDualInput :: TestResult (Maybe Int) -> Process ()

92testAgentDualInput result = do

90testAgentDualInput result = do

@@ -101,6 +99,8 @@ testAgentDualInput result = do

101 else mxReady)

99 else mxReady)

102 ]

100 ]

103

101

102+ mRef <- monitor s

103+

104 mxNotify (1 :: Int)

105 nsend "sum-agent" (3 :: Int)

106 mxNotify (2 :: Int)

@@ -108,7 +108,10 @@ testAgentDualInput result = do

108 mxNotify (5 :: Int)

109

110 stash result =<< receiveChanTimeout 10000000 rp

111− awaitExit s

111+ died <- receiveTimeout 10000000 [

112+ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) (const $ return True)

113+ ]

114+ died `shouldBe` equalTo (Just True)

112

115

113testAgentPrioritisation :: TestResult [String] -> Process ()

116testAgentPrioritisation :: TestResult [String] -> Process ()

114testAgentPrioritisation result = do

117testAgentPrioritisation result = do

@@ -122,10 +125,10 @@ testAgentPrioritisation result = do

122 (sp, rp) <- newChan

125 (sp, rp) <- newChan

123 s <- mxAgent (MxAgentId name) ["first"] [

126 s <- mxAgent (MxAgentId name) ["first"] [

124 mxSink (\(s :: String) -> do

127 mxSink (\(s :: String) -> do

125− mxUpdateLocal ((s:))

128+ mxUpdateLocal (s:)

126 st <- mxGetLocal

129 st <- mxGetLocal

127 case length st of

130 case length st of

128− n | n == 5 -> do liftMX $ sendChan sp st

131+ n | n == 5 -> do liftMX $ sendChan sp (sort st)

129 mxDeactivate "finished"

132 mxDeactivate "finished"

130 _ -> mxReceive -- go to the mailbox

133 _ -> mxReceive -- go to the mailbox

131 )

134 )

@@ -136,7 +139,7 @@ testAgentPrioritisation result = do

136 mxNotify "fourth"

139 mxNotify "fourth"

137 nsend name "fifth"

140 nsend name "fifth"

138

141

139− stash result . sort =<< receiveChan rp

142+ stash result . fromMaybe [] =<< receiveChanTimeout 10000000 rp

140 awaitExit s

143 awaitExit s

141

144

142testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()

145testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()

@@ -149,12 +152,19 @@ testAgentMailboxHandling result = do

149 nsend "mailbox-agent" ()

152 nsend "mailbox-agent" ()

150

153

151 stash result =<< receiveChanTimeout 1000000 rp

154 stash result =<< receiveChanTimeout 1000000 rp

152− kill agent "finished" >> awaitExit agent

155+ kill agent "finished"

153

156

154testAgentEventHandling :: TestResult Bool -> Process ()

157testAgentEventHandling :: TestResult Bool -> Process ()

155testAgentEventHandling result = do

158testAgentEventHandling result = do

156− let initState = [] :: [MxEvent]

159+ us <- getSelfPid

160+ -- because this test is a bit racy, let's ensure it can't run indefinitely

161+ timer <- spawnLocal $ do

162+ pause (1000000 * 60 * 5)

163+ -- okay we've waited 5 mins, let's kill the test off if it's stuck...

164+ stash result False

165+ kill us "Test Timed Out"

157

166

167+ let initState = [] :: [MxEvent]

158 (rc, rs) <- newChan

168 (rc, rs) <- newChan

159 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

169 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

160 (mxSink $ \ev -> do

170 (mxSink $ \ev -> do

@@ -187,8 +197,7 @@ testAgentEventHandling result = do

187 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

197 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

188 faff 2000000 rs

198 faff 2000000 rs

189

199

190− _ <- monitor agentPid

191− (sp, rp) <- newChan

200+ (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())

192

201

193 pid <- spawnLocal $ expect >>= sendChan sp

202 pid <- spawnLocal $ expect >>= sendChan sp

194

203

@@ -197,9 +206,11 @@ testAgentEventHandling result = do

197 monitor pid

206 monitor pid

198

207

199 send pid ()

208 send pid ()

200− () <- receiveChan rp

209+ rct <- receiveChanTimeout 10000000 rp

210+ unless (isJust rct) $ die "No response on channel"

201

211

202− receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]

212+ pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]

213+ unless (isJust pmn) $ die "No monitor notification arrived"

203

214

204 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

215 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

205 faff 2000000 rs

216 faff 2000000 rs

@@ -208,17 +219,16 @@ testAgentEventHandling result = do

208 mxNotify (MxSpawned pid, replyTo)

219 mxNotify (MxSpawned pid, replyTo)

209 mxNotify (MxProcessDied pid DiedNormal, replyTo)

220 mxNotify (MxProcessDied pid DiedNormal, replyTo)

210

221

211− seenAlive <- receiveChan reply

222+ seenAlive <- receiveChanTimeout 10000000 reply

212− seenDead <- receiveChan reply

223+ seenDead <- receiveChanTimeout 10000000 reply

213

224

214− stash result $ seenAlive && seenDead

225+ stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]

215− kill agentPid "test-complete" >> awaitExit agentPid

226+ kill timer "test-complete"

227+ kill agentPid "test-complete"

216 where

228 where

217 faff delay port = do

229 faff delay port = do

218 res <- receiveChanTimeout delay port

230 res <- receiveChanTimeout delay port

219− unless (isNothing res) $ do

231+ unless (isNothing res) $ pause delay

220− pause delay

221− faff delay port

222

232

223testMxRegEvents :: TestResult () -> Process ()

233testMxRegEvents :: TestResult () -> Process ()

224testMxRegEvents result = do

234testMxRegEvents result = do

@@ -265,7 +275,6 @@ testMxRegEvents result = do

265 reg3 `shouldBe` equalTo (Just (label, p1))

275 reg3 `shouldBe` equalTo (Just (label, p1))

266

276

267 mapM_ (flip kill $ "test-complete") [agent, p1, p2]

277 mapM_ (flip kill $ "test-complete") [agent, p1, p2]

268− awaitExit agent

269

278

270testMxRegMon :: LocalNode -> TestResult () -> Process ()

279testMxRegMon :: LocalNode -> TestResult () -> Process ()

271testMxRegMon remoteNode result = do

280testMxRegMon remoteNode result = do

@@ -323,7 +332,7 @@ testMxRegMon remoteNode result = do

323 evts `shouldContain` (Just (label1, p1))

332 evts `shouldContain` (Just (label1, p1))

324 evts `shouldContain` (Just (label2, p1))

333 evts `shouldContain` (Just (label2, p1))

325

334

326− kill agent "test-complete" >> awaitExit agent

335+ kill agent "test-complete"

327

336

328ensure :: Process () -> Process () -> Process ()

337ensure :: Process () -> Process () -> Process ()

329ensure = flip finally

338ensure = flip finally

@@ -331,59 +340,62 @@ ensure = flip finally

331testNSend :: (String -> () -> Process ())

340testNSend :: (String -> () -> Process ())

332 -> Maybe LocalNode

341 -> Maybe LocalNode

333 -> Process ()

342 -> Process ()

334−testNSend op n = testMxSend n $ \p1 sink -> do

343+testNSend op n = do

344+ us <- getSelfPid

335 let delay = 5000000

345 let delay = 5000000

336− let label = "testMxSend"

346+ let label = "testMxSend" ++ (show us)

337 let isValid = isValidLabel n label

347 let isValid = isValidLabel n label

338

348

349+ testMxSend n label $ \p1 sink -> do

339− register label p1

350+ register label p1

340− reg1 <- receiveChanTimeout delay sink

351+ reg1 <- receiveChanTimeout delay sink

341− case reg1 of

352+ case reg1 of

342− Just (MxRegistered pd lb)

353+ Just (MxRegistered pd lb)

343− | pd == p1 && isValid lb -> return ()

354+ | pd == p1 && isValid lb -> return ()

344− _ -> die $ "Reg-Failed: " ++ show reg1

355+ _ -> die $ "Reg-Failed: " ++ show reg1

345

356

346− op label ()

357+ op label ()

347

358

348− us <- getSelfPid

349− sent <- receiveChanTimeout delay sink

359+ sent <- receiveChanTimeout delay sink

350− case sent of

360+ case sent of

351− Just (MxSentToName lb by _)

361+ Just (MxSentToName lb by _)

352− | by == us && isValid lb -> return True

362+ | by == us && isValid lb -> return True

353− _ -> die $ "Send-Failed: " ++ show sent

363+ _ -> die $ "Send-Failed: " ++ show sent

354

364

355 where

365 where

356− isValidLabel n l1 l2

366+ isValidLabel nd l1 l2

357 | l2 == l2 = True

367 | l2 == l2 = True

358− | isJust n = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust n)

368+ | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)

359 | otherwise = False

369 | otherwise = False

360

370

361testSend :: (ProcessId -> () -> Process ())

371testSend :: (ProcessId -> () -> Process ())

362 -> Maybe LocalNode

372 -> Maybe LocalNode

363 -> Process ()

373 -> Process ()

364−testSend op n = testMxSend n $ \p1 sink -> do

374+testSend op n = do

365− -- initiate a send

366− op p1 ()

367−

368− -- verify the management event

369 us <- getSelfPid

375 us <- getSelfPid

376+ let label = "testMxSend" ++ (show us)

377+ testMxSend n label $ \p1 sink -> do

378+ -- initiate a send

379+ op p1 ()

380+

381+ -- verify the management event

370− sent <- receiveChanTimeout 5000000 sink

382+ sent <- receiveChanTimeout 5000000 sink

371− case sent of

383+ case sent of

372− Just (MxSent pidTo pidFrom _)

384+ Just (MxSent pidTo pidFrom _)

373− | pidTo == p1 && pidFrom == us -> return True

385+ | pidTo == p1 && pidFrom == us -> return True

374− _ -> return False

386+ _ -> return False

375

387

376testChan :: (SendPort () -> () -> Process ())

388testChan :: (SendPort () -> () -> Process ())

377 -> Maybe LocalNode

389 -> Maybe LocalNode

378 -> Process ()

390 -> Process ()

379−testChan op n = testMxSend n $ \p1 sink -> do

391+testChan op n = testMxSend n "" $ \p1 sink -> do

380

392

381 us <- getSelfPid

393 us <- getSelfPid

382 send p1 us

394 send p1 us

383

395

384− cleared <- receiveChan sink

396+ cleared <- receiveChanTimeout 2000000 sink

385 case cleared of

397 case cleared of

386− (MxSent pidTo pidFrom _)

398+ Just (MxSent pidTo pidFrom _)

387 | pidTo == p1 && pidFrom == us -> return ()

399 | pidTo == p1 && pidFrom == us -> return ()

388 _ -> die "Received uncleared Mx Event"

400 _ -> die "Received uncleared Mx Event"

389

401

@@ -402,8 +414,8 @@ testChan op n = testMxSend n $ \p1 sink -> do

402

414

403type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

415type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

404

416

405−testMxSend :: Maybe LocalNode -> SendTest -> Process ()

417+testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()

406−testMxSend mNode test = do

418+testMxSend mNode label test = do

407 us <- getSelfPid

419 us <- getSelfPid

408 (sp, rp) <- newChan

420 (sp, rp) <- newChan

409 (chan, sink) <- newChan

421 (chan, sink) <- newChan

@@ -427,11 +439,12 @@ testMxSend mNode test = do

427 Nothing -> void $ spawnLocal (proc sp)

439 Nothing -> void $ spawnLocal (proc sp)

428 Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

440 Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

429

441

430− p1 <- receiveChan rp

442+ p1 <- receiveChanTimeout 2000000 rp

443+ unless (isJust p1) $ die "Timed out waiting for ProcessId"

431− res <- try (test p1 sink)

444+ res <- try $ test (fromJust p1) sink

432

445

433 kill agent "bye"

446 kill agent "bye"

434− kill p1 "bye"

447+ kill (fromJust p1) "bye"

435

448

436 case res of

449 case res of

437 Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

450 Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

@@ -439,7 +452,6 @@ testMxSend mNode test = do

439

452

440

453

441 where

454 where

442− label = "testMxSend"

443 agentLabel s = "mx-unsafe-check-agent-" ++ show s

455 agentLabel s = "mx-unsafe-check-agent-" ++ show s

444 proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

456 proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

445

457

@@ -453,7 +465,7 @@ testMxSend mNode test = do

453 return r

465 return r

454

466

455tests :: TestTransport -> IO [Test]

467tests :: TestTransport -> IO [Test]

456−tests tt@TestTransport{..} = do

468+tests TestTransport{..} = do

457 node1 <- newLocalNode testTransport initRemoteTable

469 node1 <- newLocalNode testTransport initRemoteTable

458 node2 <- newLocalNode testTransport initRemoteTable

470 node2 <- newLocalNode testTransport initRemoteTable

459 return [

471 return [

@@ -465,7 +477,7 @@ tests tt@TestTransport{..} = do

465 , testCase "InterAgentBroadcast"

477 , testCase "InterAgentBroadcast"

466 (delayedAssertion

478 (delayedAssertion

467 "expected (), but no broadcast was received"

479 "expected (), but no broadcast was received"

468− node1 () testAgentBroadcast)

480+ node1 (Just ()) testAgentBroadcast)

469 , testCase "AgentMailboxHandling"

481 , testCase "AgentMailboxHandling"

470 (delayedAssertion

482 (delayedAssertion

471 "expected (Just ()), but no regular (mailbox) input was handled"

483 "expected (Just ()), but no regular (mailbox) input was handled"

@@ -490,11 +502,11 @@ tests tt@TestTransport{..} = do

490 (delayedAssertion

502 (delayedAssertion

491 "expected process deaths to result in unregistration events"

503 "expected process deaths to result in unregistration events"

492 node1 () (testMxRegMon node2))

504 node1 () (testMxRegMon node2))

493− , testGroup "SendEvents" $ buildTestCases tt node2

505+ , testGroup "SendEvents" $ buildTestCases node1 node2

494 ]

506 ]

495 ]

507 ]

496 where

508 where

497− buildTestCases tt' n2 = let nid = localNodeId n2 in build tt' n2 [

509+ buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [

498 ("NSend", [

510 ("NSend", [

499 ("nsend", testNSend nsend)

511 ("nsend", testNSend nsend)

500 , ("Unsafe.nsend", testNSend Unsafe.nsend)

512 , ("Unsafe.nsend", testNSend Unsafe.nsend)

@@ -515,15 +527,14 @@ tests tt@TestTransport{..} = do

515 ])

527 ])

516 ]

528 ]

517

529

518− build :: TestTransport

530+ build :: LocalNode

519 -> LocalNode

531 -> LocalNode

520 -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

532 -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

521 -> [Test]

533 -> [Test]

522− build TestTransport{..} ln specs =

534+ build n ln specs =

523 [ testGroup (intercalate "-" [groupName, caseSuffix]) [

535 [ testGroup (intercalate "-" [groupName, caseSuffix]) [

524 testCase (intercalate "-" [caseName, caseSuffix])

536 testCase (intercalate "-" [caseName, caseSuffix])

525− (newLocalNode testTransport initRemoteTable >>= \n ->

526− tryRunProcess n (caseImpl caseNode))

537+ (runProcess n (caseImpl caseNode))

527 | (caseName, caseImpl) <- groupCases

538 | (caseName, caseImpl) <- groupCases

528 ]

539 ]

529 | (groupName, groupCases) <- specs

540 | (groupName, groupCases) <- specs