@@ -5,6 +5,7 @@ module Control.Distributed.Process.Tests.Mx (tests) where
55
66import Control.Distributed.Process.Tests.Internal.Utils
77import Network.Transport.Test (TestTransport(..))
8+import Control.Exception (SomeException)
89import Control.Distributed.Process hiding (bracket, finally, try)
910import Control.Distributed.Process.Internal.Types
1011 ( ProcessExitException(..)
@@ -38,7 +39,7 @@ import Control.Monad.Catch(finally, bracket, try)
3839import Control.Rematch (equalTo)
3940import Data.Binary
4041import Data.List (find, sort, intercalate)
41−import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)
42+import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
4243import Data.Typeable
4344import GHC.Generics hiding (from)
4445#if ! MIN_VERSION_base(4,6,0)
@@ -49,6 +50,7 @@ import Test.Framework
4950 ( Test
5051 , testGroup
5152 )
53+import Test.HUnit (Assertion)
5254import Test.Framework.Providers.HUnit (testCase)
5355
5456data Publish = Publish
@@ -66,7 +68,7 @@ awaitExit pid =
6668 where
6769 withMonitorRef p = bracket (monitor p) unmonitor
6870
69−testAgentBroadcast :: TestResult (Maybe ()) -> Process ()
71+testAgentBroadcast :: TestResult () -> Process ()
7072testAgentBroadcast result = do
7173 (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())
7274
@@ -81,10 +83,10 @@ testAgentBroadcast result = do
8183 mxNotify ()
8284 -- Once the publisher has seen our message, it will broadcast the Publish
8385 -- and the consumer will see that and send the result to our typed channel.
84− stash result =<< receiveChanTimeout 10000000 resultRP
86+ stash result =<< receiveChan resultRP
8587
86− kill publisher "finished"
87− kill consumer "finished"
88+ kill publisher "finished" >> awaitExit publisher
89+ kill consumer "finished" >> awaitExit consumer
8890
8991testAgentDualInput :: TestResult (Maybe Int) -> Process ()
9092testAgentDualInput result = do
@@ -99,8 +101,6 @@ testAgentDualInput result = do
99101 else mxReady)
100102 ]
101103
102− mRef <- monitor s
103−
104104 mxNotify (1 :: Int)
105105 nsend "sum-agent" (3 :: Int)
106106 mxNotify (2 :: Int)
@@ -108,10 +108,7 @@ testAgentDualInput result = do
108108 mxNotify (5 :: Int)
109109
110110 stash result =<< receiveChanTimeout 10000000 rp
111− died <- receiveTimeout 10000000 [
112− matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) (const $ return True)
113− ]
114− died `shouldBe` equalTo (Just True)
111+ awaitExit s
115112
116113testAgentPrioritisation :: TestResult [String] -> Process ()
117114testAgentPrioritisation result = do
@@ -125,10 +122,10 @@ testAgentPrioritisation result = do
125122 (sp, rp) <- newChan
126123 s <- mxAgent (MxAgentId name) ["first"] [
127124 mxSink (\(s :: String) -> do
128− mxUpdateLocal (s:)
125+ mxUpdateLocal ((s:))
129126 st <- mxGetLocal
130127 case length st of
131− n | n == 5 -> do liftMX $ sendChan sp (sort st)
128+ n | n == 5 -> do liftMX $ sendChan sp st
132129 mxDeactivate "finished"
133130 _ -> mxReceive -- go to the mailbox
134131 )
@@ -139,7 +136,7 @@ testAgentPrioritisation result = do
139136 mxNotify "fourth"
140137 nsend name "fifth"
141138
142− stash result . fromMaybe [] =<< receiveChanTimeout 10000000 rp
139+ stash result . sort =<< receiveChan rp
143140 awaitExit s
144141
145142testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()
@@ -152,19 +149,12 @@ testAgentMailboxHandling result = do
152149 nsend "mailbox-agent" ()
153150
154151 stash result =<< receiveChanTimeout 1000000 rp
155− kill agent "finished"
152+ kill agent "finished" >> awaitExit agent
156153
157154testAgentEventHandling :: TestResult Bool -> Process ()
158155testAgentEventHandling result = do
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"
166−
167156 let initState = [] :: [MxEvent]
157+
168158 (rc, rs) <- newChan
169159 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [
170160 (mxSink $ \ev -> do
@@ -197,7 +187,8 @@ testAgentEventHandling result = do
197187 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
198188 faff 2000000 rs
199189
200− (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())
190+ _ <- monitor agentPid
191+ (sp, rp) <- newChan
201192
202193 pid <- spawnLocal $ expect >>= sendChan sp
203194
@@ -206,11 +197,9 @@ testAgentEventHandling result = do
206197 monitor pid
207198
208199 send pid ()
209− rct <- receiveChanTimeout 10000000 rp
210− unless (isJust rct) $ die "No response on channel"
200+ () <- receiveChan rp
211201
212− pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]
213− unless (isJust pmn) $ die "No monitor notification arrived"
202+ receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]
214203
215204 -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
216205 faff 2000000 rs
@@ -219,16 +208,17 @@ testAgentEventHandling result = do
219208 mxNotify (MxSpawned pid, replyTo)
220209 mxNotify (MxProcessDied pid DiedNormal, replyTo)
221210
222− seenAlive <- receiveChanTimeout 10000000 reply
223− seenDead <- receiveChanTimeout 10000000 reply
211+ seenAlive <- receiveChan reply
212+ seenDead <- receiveChan reply
224213
225− stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]
226− kill timer "test-complete"
227− kill agentPid "test-complete"
214+ stash result $ seenAlive && seenDead
215+ kill agentPid "test-complete" >> awaitExit agentPid
228216 where
229217 faff delay port = do
230218 res <- receiveChanTimeout delay port
231− unless (isNothing res) $ pause delay
219+ unless (isNothing res) $ do
220+ pause delay
221+ faff delay port
232222
233223testMxRegEvents :: TestResult () -> Process ()
234224testMxRegEvents result = do
@@ -275,6 +265,7 @@ testMxRegEvents result = do
275265 reg3 `shouldBe` equalTo (Just (label, p1))
276266
277267 mapM_ (flip kill $ "test-complete") [agent, p1, p2]
268+ awaitExit agent
278269
279270testMxRegMon :: LocalNode -> TestResult () -> Process ()
280271testMxRegMon remoteNode result = do
@@ -332,7 +323,7 @@ testMxRegMon remoteNode result = do
332323 evts `shouldContain` (Just (label1, p1))
333324 evts `shouldContain` (Just (label2, p1))
334325
335− kill agent "test-complete"
326+ kill agent "test-complete" >> awaitExit agent
336327
337328ensure :: Process () -> Process () -> Process ()
338329ensure = flip finally
@@ -340,62 +331,59 @@ ensure = flip finally
340331testNSend :: (String -> () -> Process ())
341332 -> Maybe LocalNode
342333 -> Process ()
343−testNSend op n = do
344− us <- getSelfPid
334+testNSend op n = testMxSend n $ \p1 sink -> do
345335 let delay = 5000000
346− let label = "testMxSend" ++ (show us)
336+ let label = "testMxSend"
347337 let isValid = isValidLabel n label
348338
349− testMxSend n label $ \p1 sink -> do
350− register label p1
351− reg1 <- receiveChanTimeout delay sink
352− case reg1 of
353− Just (MxRegistered pd lb)
354− | pd == p1 && isValid lb -> return ()
355− _ -> die $ "Reg-Failed: " ++ show reg1
339+ register label p1
340+ reg1 <- receiveChanTimeout delay sink
341+ case reg1 of
342+ Just (MxRegistered pd lb)
343+ | pd == p1 && isValid lb -> return ()
344+ _ -> die $ "Reg-Failed: " ++ show reg1
356345
357− op label ()
346+ op label ()
358347
359− sent <- receiveChanTimeout delay sink
360− case sent of
361− Just (MxSentToName lb by _)
362− | by == us && isValid lb -> return True
363− _ -> die $ "Send-Failed: " ++ show sent
348+ us <- getSelfPid
349+ sent <- receiveChanTimeout delay sink
350+ case sent of
351+ Just (MxSentToName lb by _)
352+ | by == us && isValid lb -> return True
353+ _ -> die $ "Send-Failed: " ++ show sent
364354
365355 where
366− isValidLabel nd l1 l2
356+ isValidLabel n l1 l2
367357 | l2 == l2 = True
368− | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)
358+ | isJust n = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust n)
369359 | otherwise = False
370360
371361testSend :: (ProcessId -> () -> Process ())
372362 -> Maybe LocalNode
373363 -> Process ()
374−testSend op n = do
364+testSend op n = testMxSend n $ \p1 sink -> do
365+ -- initiate a send
366+ op p1 ()
367+
368+ -- verify the management event
375369 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
382− sent <- receiveChanTimeout 5000000 sink
383− case sent of
384− Just (MxSent pidTo pidFrom _)
385− | pidTo == p1 && pidFrom == us -> return True
386− _ -> return False
370+ sent <- receiveChanTimeout 5000000 sink
371+ case sent of
372+ Just (MxSent pidTo pidFrom _)
373+ | pidTo == p1 && pidFrom == us -> return True
374+ _ -> return False
387375
388376testChan :: (SendPort () -> () -> Process ())
389377 -> Maybe LocalNode
390378 -> Process ()
391−testChan op n = testMxSend n "" $ \p1 sink -> do
379+testChan op n = testMxSend n $ \p1 sink -> do
392380
393381 us <- getSelfPid
394382 send p1 us
395383
396− cleared <- receiveChanTimeout 2000000 sink
384+ cleared <- receiveChan sink
397385 case cleared of
398− Just (MxSent pidTo pidFrom _)
386+ (MxSent pidTo pidFrom _)
399387 | pidTo == p1 && pidFrom == us -> return ()
400388 _ -> die "Received uncleared Mx Event"
401389
@@ -414,8 +402,8 @@ testChan op n = testMxSend n "" $ \p1 sink -> do
414402
415403type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
416404
417−testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()
418−testMxSend mNode label test = do
405+testMxSend :: Maybe LocalNode -> SendTest -> Process ()
406+testMxSend mNode test = do
419407 us <- getSelfPid
420408 (sp, rp) <- newChan
421409 (chan, sink) <- newChan
@@ -439,12 +427,11 @@ testMxSend mNode label test = do
439427 Nothing -> void $ spawnLocal (proc sp)
440428 Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp
441429
442− p1 <- receiveChanTimeout 2000000 rp
443− unless (isJust p1) $ die "Timed out waiting for ProcessId"
444− res <- try $ test (fromJust p1) sink
430+ p1 <- receiveChan rp
431+ res <- try (test p1 sink)
445432
446433 kill agent "bye"
447− kill (fromJust p1) "bye"
434+ kill p1 "bye"
448435
449436 case res of
450437 Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m
@@ -452,6 +439,7 @@ testMxSend mNode label test = do
452439
453440
454441 where
442+ label = "testMxSend"
455443 agentLabel s = "mx-unsafe-check-agent-" ++ show s
456444 proc sp' = getSelfPid >>= sendChan sp' >> go Nothing
457445
@@ -465,7 +453,7 @@ testMxSend mNode label test = do
465453 return r
466454
467455tests :: TestTransport -> IO [Test]
468−tests TestTransport{..} = do
456+tests tt@TestTransport{..} = do
469457 node1 <- newLocalNode testTransport initRemoteTable
470458 node2 <- newLocalNode testTransport initRemoteTable
471459 return [
@@ -477,7 +465,7 @@ tests TestTransport{..} = do
477465 , testCase "InterAgentBroadcast"
478466 (delayedAssertion
479467 "expected (), but no broadcast was received"
480− node1 (Just ()) testAgentBroadcast)
468+ node1 () testAgentBroadcast)
481469 , testCase "AgentMailboxHandling"
482470 (delayedAssertion
483471 "expected (Just ()), but no regular (mailbox) input was handled"
@@ -502,11 +490,11 @@ tests TestTransport{..} = do
502490 (delayedAssertion
503491 "expected process deaths to result in unregistration events"
504492 node1 () (testMxRegMon node2))
505− , testGroup "SendEvents" $ buildTestCases node1 node2
493+ , testGroup "SendEvents" $ buildTestCases tt node2
506494 ]
507495 ]
508496 where
509− buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [
497+ buildTestCases tt' n2 = let nid = localNodeId n2 in build tt' n2 [
510498 ("NSend", [
511499 ("nsend", testNSend nsend)
512500 , ("Unsafe.nsend", testNSend Unsafe.nsend)
@@ -527,14 +515,15 @@ tests TestTransport{..} = do
527515 ])
528516 ]
529517
530− build :: LocalNode
518+ build :: TestTransport
531519 -> LocalNode
532520 -> [(String, [(String, (Maybe LocalNode -> Process ()))])]
533521 -> [Test]
534− build n ln specs =
522+ build TestTransport{..} ln specs =
535523 [ testGroup (intercalate "-" [groupName, caseSuffix]) [
536524 testCase (intercalate "-" [caseName, caseSuffix])
537− (runProcess n (caseImpl caseNode))
525+ (newLocalNode testTransport initRemoteTable >>= \n ->
526+ tryRunProcess n (caseImpl caseNode))
538527 | (caseName, caseImpl) <- groupCases
539528 ]
540529 | (groupName, groupCases) <- specs