@@ -42,9 +42,12 @@ import Control.Distributed.Process.Internal.Types
4242 , createUnencodedMessage
4343 )
4444import Control.Distributed.Process.Node
45+import Control.Distributed.Process.Debug
46+import Control.Distributed.Process.Management.Internal.Types
47+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)
4548import Control.Distributed.Process.Serializable (Serializable)
4649
47−import Test.HUnit (Assertion, assertFailure)
50+import Test.HUnit (Assertion, assertBool, assertFailure)
4851import Test.Framework (Test, testGroup)
4952import Test.Framework.Providers.HUnit (testCase)
5053import Control.Rematch hiding (match)
@@ -80,12 +83,47 @@ ping = do
8083 send partner (Ping self)
8184 ping
8285
86+verifyClient :: String -> MVar Bool -> IO ()
87+verifyClient s b = takeMVar b >>= assertBool s
88+
89+expectPing :: MVar Bool -> Process ()
90+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
91+ where
92+ checkPing (Ping _) = True
93+ checkPing _ = False
94+
8395-- | Quick and dirty synchronous version of whereisRemoteAsync
8496whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
8597whereisRemote nid string = do
8698 whereisRemoteAsync nid string
87− WhereIsReply _ mPid <- expect
88− return mPid
99+ receiveWait [
100+ match (\(WhereIsReply _ mPid) -> return mPid)
101+ ]
102+
103+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
104+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
105+
106+waitForExit :: ProcessId -> Process DiedReason
107+waitForExit pid = monitor pid >>= waitForDown
108+
109+waitForDown :: MonitorRef -> Process DiedReason
110+waitForDown ref =
111+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
112+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
113+
114+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
115+syncBreakConnection breakConnection nid0 nid1 = do
116+ m <- newEmptyMVar
117+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
118+ runProcess nid0 $ do
119+ them <- liftIO $ takeMVar m
120+ pinger <- spawnLocal $ forever $ send them ()
121+ _ <- monitorNode (localNodeId nid1)
122+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
123+ (nodeAddress $ localNodeId nid1)
124+ NodeMonitorNotification _ _ _ <- expect
125+ kill pinger "finished"
126+ return ()
89127
90128data Add = Add ProcessId Double Double deriving (Typeable)
91129data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -160,12 +198,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
160198 unmonitor ref
161199 liftIO $ putMVar done ()
162200 (False, ref) -> do
163− ProcessMonitorNotification ref' pid reason' <- expect
164− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
165− liftIO $ putMVar done ()
201+ receiveWait [
202+ match (\(ProcessMonitorNotification ref' pid reason') -> do
203+ liftIO $ do
204+ assertBool "Bad Monitor Signal"
205+ (Just ref' == ref && pid == theirAddr &&
206+ mOrL && reason == reason')
207+ putMVar done ())
208+ ]
166209 )
167210 (\(ProcessLinkException pid reason') -> do
168− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
211+ (liftIO $ assertBool "link exception unmatched" $
212+ pid == theirAddr && not mOrL && not un && reason == reason')
169213 liftIO $ putMVar done ()
170214 )
171215
@@ -196,8 +240,10 @@ testPing TestTransport{..} = do
196240 pid <- getSelfPid
197241 replicateM_ numPings $ do
198242 send pingServer (Pong pid)
199− Ping _ <- expect
200− return ()
243+ p <- expect
244+ case p of
245+ Ping _ -> return ()
246+ _ -> die "Unexpected message"
201247
202248 putMVar clientDone ()
203249
@@ -284,7 +330,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
284330 runProcess localNode $ do
285331 monitor theirAddr
286332 -- wait for the process to die
287− ProcessMonitorNotification _ _ _ <- expect
333+ expect :: Process ProcessMonitorNotification
288334 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
289335
290336 takeMVar done
@@ -358,14 +404,17 @@ testMath TestTransport{..} = do
358404 runProcess localNode $ do
359405 pid <- getSelfPid
360406 send mathServer (Add pid 1 2)
361− 3 <- expect :: Process Double
407+ three <- expect :: Process Double
362408 send mathServer (Divide pid 8 2)
363− 4 <- expect :: Process Double
409+ four <- expect :: Process Double
364410 send mathServer (Divide pid 8 0)
365− DivByZero <- expect
366− liftIO $ putMVar clientDone ()
411+ divByZ <- expect
412+ liftIO $ putMVar clientDone (three, four, divByZ)
367413
368− takeMVar clientDone
414+ res <- takeMVar clientDone
415+ case res of
416+ (3, 4, DivByZero) -> return ()
417+ _ -> error $ "Something went horribly wrong"
369418
370419-- | Send first message (i.e. connect) to an already terminated process
371420-- (without monitoring); then send another message to a second process on
@@ -393,11 +442,9 @@ testSendToTerminated TestTransport{..} = do
393442 pid <- getSelfPid
394443 send server1 "Hi"
395444 send server2 (Pong pid)
396− Ping pid' <- expect
397− True <- return $ pid' == server2
398− liftIO $ putMVar clientDone ()
445+ expectPing clientDone
399446
400− takeMVar clientDone
447+ verifyClient "Expected Ping from server" clientDone
401448
402449-- | Test (non-zero) timeout
403450testTimeout :: TestTransport -> Assertion
@@ -406,10 +453,10 @@ testTimeout TestTransport{..} = do
406453 done <- newEmptyMVar
407454
408455 runProcess localNode $ do
409− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
410− liftIO $ putMVar done ()
456+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
457+ liftIO $ putMVar done $ res == Nothing
411458
412− takeMVar done
459+ verifyClient "Expected receiveTimeout to timeout..." done
413460
414461-- | Test zero timeout
415462testTimeout0 :: TestTransport -> Assertion
@@ -437,10 +484,9 @@ testTimeout0 TestTransport{..} = do
437484 -- is not interested in, and then a single message that it wants
438485 replicateM_ 10000 $ send server "Irrelevant message"
439486 send server (Pong pid)
440− Ping _ <- expect
441− liftIO $ putMVar clientDone ()
487+ expectPing clientDone
442488
443− takeMVar clientDone
489+ verifyClient "Expected Ping from server" clientDone
444490
445491-- | Test typed channels
446492testTypedChannels :: TestTransport -> Assertion
@@ -463,10 +509,10 @@ testTypedChannels TestTransport{..} = do
463509 runProcess localNode $ do
464510 (clientSendPort, rport) <- newChan
465511 sendChan serverSendPort (clientSendPort, 5)
466− False <- receiveChan rport
467− liftIO $ putMVar clientDone ()
512+ ch <- receiveChan rport
513+ liftIO $ putMVar clientDone $ ch == False
468514
469− takeMVar clientDone
515+ verifyClient "Expected channel to send 'False'" clientDone
470516
471517-- | Test merging receive ports
472518testMergeChannels :: TestTransport -> Assertion
@@ -489,9 +535,8 @@ testMergeChannels TestTransport{..} = do
489535 rs <- mapM charChannel "abc"
490536 m <- mergePorts biased rs
491537 xs <- replicateM 9 $ receiveChan m
492− True <- return $ xs == expected
493− liftIO $ putMVar done ()
494− takeMVar done
538+ liftIO $ putMVar done $ xs == expected
539+ verifyClient "Expected single layer merge to match expected ordering" done
495540
496541 -- Two layers of merging
497542 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -502,9 +547,8 @@ testMergeChannels TestTransport{..} = do
502547 ms <- mapM (mergePorts biasedInner) rss
503548 m <- mergePorts biasedOuter ms
504549 xs <- replicateM (9 * 3) $ receiveChan m
505− True <- return $ xs == expected
506− liftIO $ putMVar done ()
507− takeMVar done
550+ liftIO $ putMVar done $ xs == expected
551+ verifyClient "Expected nested channels to match expeted ordering" done
508552
509553 -- Test that if no messages are (immediately) available, the scheduler makes no difference
510554 testBlocked :: LocalNode -> Bool -> IO ()
@@ -513,43 +557,45 @@ testMergeChannels TestTransport{..} = do
513557 done <- newEmptyMVar
514558
515559 forkProcess localNode $ do
516− [sa, sb, sc] <- liftIO $ mapM readMVar vs
517− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
518− [ -- a, b, c
519− (sa, 'a')
520− , (sb, 'b')
521− , (sc, 'c')
522− -- a, c, b
523− , (sa, 'a')
524− , (sc, 'c')
525− , (sb, 'b')
526− -- b, a, c
527− , (sb, 'b')
528− , (sa, 'a')
529− , (sc, 'c')
530− -- b, c, a
531− , (sb, 'b')
532− , (sc, 'c')
533− , (sa, 'a')
534− -- c, a, b
535− , (sc, 'c')
536− , (sa, 'a')
537− , (sb, 'b')
538− -- c, b, a
539− , (sc, 'c')
540− , (sb, 'b')
541− , (sa, 'a')
542− ]
560+ ss <- liftIO $ mapM readMVar vs
561+ case ss of
562+ [sa, sb, sc] ->
563+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
564+ [ -- a, b, c
565+ (sa, 'a')
566+ , (sb, 'b')
567+ , (sc, 'c')
568+ -- a, c, b
569+ , (sa, 'a')
570+ , (sc, 'c')
571+ , (sb, 'b')
572+ -- b, a, c
573+ , (sb, 'b')
574+ , (sa, 'a')
575+ , (sc, 'c')
576+ -- b, c, a
577+ , (sb, 'b')
578+ , (sc, 'c')
579+ , (sa, 'a')
580+ -- c, a, b
581+ , (sc, 'c')
582+ , (sa, 'a')
583+ , (sb, 'b')
584+ -- c, b, a
585+ , (sc, 'c')
586+ , (sb, 'b')
587+ , (sa, 'a')
588+ ]
589+ _ -> die "Something went horribly wrong"
543590
544591 forkProcess localNode $ do
545592 (ss, rs) <- unzip <$> replicateM 3 newChan
546593 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
547594 m <- mergePorts biased rs
548595 xs <- replicateM (6 * 3) $ receiveChan m
549− True <- return $ xs == "abcacbbacbcacabcba"
550− liftIO $ putMVar done ()
596+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
551597
552− takeMVar done
598+ verifyClient "Expected merged ports to match expected ordering" done
553599
554600 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
555601 mergePorts True = mergePortsBiased
@@ -567,8 +613,9 @@ testTerminate TestTransport{..} = do
567613 localNode <- newLocalNode testTransport initRemoteTable
568614 runProcess localNode $ do
569615 e <- try terminate :: Process (Either ProcessTerminationException ())
570− True <- return $ either show show e == show ProcessTerminationException
571− return ()
616+ if either show show e == show ProcessTerminationException
617+ then return ()
618+ else die "Unexpected result from terminate"
572619
573620testMonitorNode :: TestTransport -> Assertion
574621testMonitorNode TestTransport{..} = do
@@ -579,11 +626,12 @@ testMonitorNode TestTransport{..} = do
579626
580627 runProcess node2 $ do
581628 ref <- monitorNode (localNodeId node1)
582− NodeMonitorNotification ref' nid DiedDisconnect <- expect
583− True <- return $ ref == ref' && nid == localNodeId node1
584− liftIO $ putMVar done ()
629+ receiveWait [
630+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
631+ return $ ref == ref' && nid == localNodeId node1)
632+ ] >>= liftIO . putMVar done
585633
586− takeMVar done
634+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
587635
588636testMonitorLiveNode :: TestTransport -> Assertion
589637testMonitorLiveNode TestTransport{..} = do
@@ -598,15 +646,16 @@ testMonitorLiveNode TestTransport{..} = do
598646 liftIO $ putMVar ready ()
599647 liftIO $ takeMVar readyr
600648 send p ()
601− NodeMonitorNotification ref' nid _ <- expect
602− True <- return $ ref == ref' && nid == localNodeId node1
603− liftIO $ putMVar done ()
649+ receiveWait [
650+ match (\(NodeMonitorNotification ref' nid _) ->
651+ (return $ ref == ref' && nid == localNodeId node1))
652+ ] >>= liftIO . putMVar done
604653
605654 takeMVar ready
606655 closeLocalNode node1
607656 putMVar readyr ()
608657
609− takeMVar done
658+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
610659
611660testMonitorChannel :: TestTransport -> Assertion
612661testMonitorChannel TestTransport{..} = do
@@ -616,18 +665,20 @@ testMonitorChannel TestTransport{..} = do
616665 pid <- forkProcess node1 $ do
617666 sport <- expect :: Process (SendPort ())
618667 ref <- monitorPort sport
619− PortMonitorNotification ref' port' reason <- expect
620− -- reason might be DiedUnknownId if the receive port is GCed before the
621− -- monitor is established (TODO: not sure that this is reasonable)
622− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
623− liftIO $ putMVar gotNotification ()
668+ receiveWait [
669+ -- reason might be DiedUnknownId if the receive port is GCed before the
670+ -- monitor is established (TODO: not sure that this is reasonable)
671+ match (\(PortMonitorNotification ref' port' reason) ->
672+ return $ ref' == ref && port' == sendPortId sport &&
673+ (reason == DiedNormal || reason == DiedUnknownId))
674+ ] >>= liftIO . putMVar gotNotification
624675
625676 runProcess node2 $ do
626677 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
627678 send pid sport
628679 liftIO $ threadDelay 100000
629680
630− takeMVar gotNotification
681+ verifyClient "Expected PortMonitorNotification" gotNotification
631682
632683testRegistry :: TestTransport -> Assertion
633684testRegistry TestTransport{..} = do
@@ -639,20 +690,28 @@ testRegistry TestTransport{..} = do
639690
640691 runProcess node $ do
641692 register "ping" pingServer
642− Just pid <- whereis "ping"
643− True <- return $ pingServer == pid
693+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
644694 us <- getSelfPid
645695 nsend "ping" (Pong us)
646− Ping pid' <- expect
647− True <- return $ pingServer == pid'
648− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
649− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
650− True <- return $ x == pingServer
651− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
696+ receiveWait [
697+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
698+ ]
699+ checkRegException "dead" Nothing deadProcess
700+ checkRegException "ping" (Just pingServer) deadProcess
701+ try (unregister "dead") >>= checkReg "dead" Nothing
652702 liftIO $ putMVar done ()
653703
654704 takeMVar done
655705
706+ where
707+ checkRegException name pid dead =
708+ try (register name dead) >>= checkReg name pid
709+
710+ checkReg name pid res =
711+ case res of
712+ Left (ProcessRegistrationException name pid) -> return ()
713+ _ -> die $ "Unexpected Registration" ++ show res
714+
656715testRegistryRemoteProcess :: TestTransport -> Assertion
657716testRegistryRemoteProcess TestTransport{..} = do
658717 node1 <- newLocalNode testTransport initRemoteTable
@@ -663,13 +722,13 @@ testRegistryRemoteProcess TestTransport{..} = do
663722
664723 runProcess node2 $ do
665724 register "ping" pingServer
666− Just pid <- whereis "ping"
667− True <- return $ pingServer == pid
725+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
668726 us <- getSelfPid
669727 nsend "ping" (Pong us)
670− Ping pid' <- expect
671− True <- return $ pingServer == pid'
672− liftIO $ putMVar done ()
728+ receiveWait [
729+ matchIf (\(Ping pid') -> pingServer == pid')
730+ (const $ liftIO $ putMVar done ())
731+ ]
673732
674733 takeMVar done
675734
@@ -690,12 +749,13 @@ testRemoteRegistry TestTransport{..} = do
690749 "ping" == label' && pid == pingServer)
691750 (\(RegisterReply _ _ _) -> return ()) ]
692751
693− Just pid <- whereisRemote nid1 "ping"
694− True <- return $ pingServer == pid
752+ pid <- verifyWhereIsRemote nid1 "ping"
753+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
695754 us <- getSelfPid
696755 nsendRemote nid1 "ping" (Pong us)
697− Ping pid' <- expect
698− True <- return $ pingServer == pid'
756+ receiveWait [
757+ match (\(Ping pid') -> return $ pingServer == pid')
758+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
699759
700760 -- test that if process was not registered Nothing is returned
701761 -- in owner field.
@@ -731,15 +791,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
731791 receiveWait [
732792 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
733793 (\(RegisterReply _ _ _) -> return ()) ]
734− Just pid <- whereisRemote nid1 "ping"
735− True <- return $ pingServer == pid
794+ pid <- verifyWhereIsRemote nid1 "ping"
795+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
736796 us <- getSelfPid
737797 nsendRemote nid1 "ping" (Pong us)
738− Ping pid' <- expect
739− True <- return $ pingServer == pid'
740− liftIO $ putMVar done ()
798+ receiveWait [
799+ match (\(Ping pid') -> return $ pingServer == pid')
800+ ] >>= liftIO . putMVar done
741801
742− takeMVar done
802+ verifyClient "Expected Ping with ping server's ProcessId" done
743803
744804testSpawnLocal :: TestTransport -> Assertion
745805testSpawnLocal TestTransport{..} = do
@@ -753,15 +813,14 @@ testSpawnLocal TestTransport{..} = do
753813 sport <- expect
754814 sendChan sport (1234 :: Int)
755815
756− sport <- spawnChannelLocal $ \rport -> do
757− (1234 :: Int) <- receiveChan rport
758− send us ()
816+ sport <- spawnChannelLocal $
817+ \rport -> (receiveChan rport :: Process Int) >>= send us
759818
760819 send pid sport
761− () <- expect
762− liftIO $ putMVar done ()
820+ expect >>= liftIO . putMVar done
763821
764− takeMVar done
822+ res <- takeMVar done
823+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
765824
766825testSpawnAsyncStrictness :: TestTransport -> Assertion
767826testSpawnAsyncStrictness TestTransport{..} = do
@@ -790,8 +849,9 @@ testReconnect TestTransport{..} = do
790849 liftIO $ putMVar processA us
791850 msg1 <- expect
792851 msg2 <- expect
793− True <- return $ msg1 == "message 1" && msg2 == "message 3"
794− liftIO $ putMVar sendTestOk ()
852+ liftIO $ do
853+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
854+ putMVar sendTestOk ()
795855
796856 forkProcess node2 $ do
797857 {-
@@ -824,7 +884,7 @@ testReconnect TestTransport{..} = do
824884 matchIf (\(RegisterReply label' _ _) -> "a" == label')
825885 (\(RegisterReply _ _ _) -> return ()) ]
826886
827− Just _ <- whereisRemote nid1 "a"
887+ _ <- whereisRemote nid1 "a"
828888
829889
830890 -- Simulate network failure
@@ -843,9 +903,10 @@ testReconnect TestTransport{..} = do
843903 (\(RegisterReply _ _ _) -> return ()) ]
844904
845905 -- Check
846− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
847− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
848− Just _ <- whereisRemote nid1 "c"
906+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
907+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
908+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
909+ verifyWhereIsRemote nid1 "c"
849910
850911 liftIO $ putMVar registerTestOk ()
851912
@@ -886,13 +947,14 @@ testUSend usendPrim TestTransport{..} numMessages = do
886947 isSorted _ = True
887948 -- The list can't be null since there are no failures after sending
888949 -- the last message.
889− True <- return $ isSorted msgs && not (null msgs)
890− liftIO $ putMVar usendTestOk ()
950+ liftIO $ do
951+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)
952+ putMVar usendTestOk ()
891953
892954 forkProcess node2 $ do
893955 them <- liftIO $ readMVar processA
894956 getSelfPid >>= send them
895− () <- expect
957+ expect :: Process ()
896958 forM_ [1..numMessages] $ \i -> do
897959 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
898960 usendPrim them i
@@ -924,14 +986,17 @@ testMatchAny TestTransport{..} = do
924986 runProcess localNode $ do
925987 pid <- getSelfPid
926988 send mathServer (Add pid 1 2)
927− 3 <- expect :: Process Double
989+ three <- expect :: Process Double
928990 send mathServer (Divide pid 8 2)
929− 4 <- expect :: Process Double
991+ four <- expect :: Process Double
930992 send mathServer (Divide pid 8 0)
931− DivByZero <- expect
932− liftIO $ putMVar clientDone ()
993+ divByZ <- expect
994+ liftIO $ putMVar clientDone (three, four, divByZ)
933995
934− takeMVar clientDone
996+ res <- takeMVar clientDone
997+ case res of
998+ (3, 4, DivByZero) -> return ()
999+ _ -> error "Unexpected result"
9351000
9361001-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
9371002-- in between, however we block 'Divide' requests ....
@@ -958,12 +1023,13 @@ testMatchAnyHandle TestTransport{..} = do
9581023 runProcess localNode $ do
9591024 pid <- getSelfPid
9601025 send mathServer (Add pid 1 2)
961− 3 <- expect :: Process Double
1026+ three <- expect :: Process Double
9621027 send mathServer (Divide pid 8 2)
963− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
964− liftIO $ putMVar clientDone ()
1028+ res <- (expectTimeout 100000) :: Process (Maybe Double)
1029+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1030+
1031+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
9651032
966− takeMVar clientDone
9671033 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
9681034 maybeForward s msg =
9691035 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -991,8 +1057,10 @@ testMatchAnyNoHandle TestTransport{..} = do
9911057 Just _ -> die "NONSENSE")
9921058 ]
9931059 -- we *must* have removed the message from our mailbox though!!!
994− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
995− liftIO $ putMVar serverDone ()
1060+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1061+ liftIO $ do
1062+ assertBool "Expected timeout!" $ res == Nothing
1063+ putMVar serverDone ()
9961064 putMVar addr server
9971065
9981066 -- Client
@@ -1035,14 +1103,21 @@ testMatchAnyIf TestTransport{..} = do
10351103 runProcess localNode $ do
10361104 pid <- getSelfPid
10371105 send server (pid, "foo")
1038− "foo" <- expect
1039− send server (pid, "baz")
1040− "baz" <- expect
1106+ foo <- expect
1107+ -- provoking what would be the wrong ordering is informative here...
1108+
10411109 send server (pid, "bar")
1042− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1043− liftIO $ putMVar clientDone ()
1110+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1111+
1112+ send server (pid, "baz")
1113+ baz <- expect
1114+
1115+ liftIO $ putMVar clientDone (foo, bar, baz)
1116+
1117+ res <- takeMVar clientDone
1118+ let res' = res == ("foo", Nothing, "baz")
1119+ assertBool "Expected timeout due to type mismatch" res'
10441120
1045− takeMVar clientDone
10461121 where tryHandleMessage :: Message -> Process (Maybe ())
10471122 tryHandleMessage msg =
10481123 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1075,12 +1150,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do
10751150 runProcess localNode $ do
10761151 pid <- getSelfPid
10771152 send server (pid, wrapMessage ("foo" :: String))
1078− "foo" <- expect
1153+ foo <- expect
10791154 send server (pid, wrapMessage ("baz" :: String))
1080− "baz" <- expect
1081− liftIO $ putMVar clientDone ()
1155+ baz <- expect
1156+ liftIO $ putMVar clientDone (foo, baz)
10821157
1083− takeMVar clientDone
1158+ res <- takeMVar clientDone
1159+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
10841160
10851161-- Test 'receiveChanTimeout'
10861162testReceiveChanTimeout :: TestTransport -> Assertion
@@ -1098,18 +1174,19 @@ testReceiveChanTimeout TestTransport{..} = do
10981174
10991175 -- Wait for a message with a delay. No message arrives, we should get
11001176 -- Nothing after the delay.
1101− Nothing <- receiveChanTimeout 100000 rp
1177+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11021178
11031179 -- Let the sender know that it can send a message.
11041180 liftIO $ putMVar mvSender ()
11051181
11061182 -- Wait for a message with a delay again. Now a message arrives after
11071183 -- 0.1 seconds
1108− Just True <- receiveChanTimeout 20000000 rp
1184+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1185+ liftIO $ assertBool "Expected result to be 'True'" res
11091186
11101187 -- Wait for a message with zero timeout: non-blocking check. No message is
11111188 -- available, we get Nothing
1112− Nothing <- receiveChanTimeout 0 rp
1189+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11131190
11141191 -- Let the sender know that it can send a message.
11151192 liftIO $ putMVar mvSender ()
@@ -1119,7 +1196,7 @@ testReceiveChanTimeout TestTransport{..} = do
11191196 liftIO $ threadDelay 100000
11201197 mb <- receiveChanTimeout 0 rp
11211198 case mb of
1122− Just b -> do False <- return b; return ()
1199+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
11231200 _ -> loop
11241201
11251202 liftIO $ putMVar done ()
@@ -1156,8 +1233,8 @@ testReceiveChanFeatures TestTransport{..} = do
11561233
11571234 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
11581235
1159− True <- receiveChan rp1
1160− False <- receiveChan rp1
1236+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1237+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
11611238
11621239 -- Test Applicative instance
11631240
@@ -1166,7 +1243,7 @@ testReceiveChanFeatures TestTransport{..} = do
11661243
11671244 let rp2 = pure (+) <*> rpInt <*> rpInt
11681245
1169− 7 <- receiveChan rp2
1246+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
11701247
11711248 -- Test Alternative instance
11721249
@@ -1175,8 +1252,8 @@ testReceiveChanFeatures TestTransport{..} = do
11751252
11761253 let rp3 = (even <$> rpInt) <|> rpBool
11771254
1178− False <- receiveChan rp3
1179− True <- receiveChan rp3
1255+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1256+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
11801257
11811258 -- Test Monad instance
11821259
@@ -1190,8 +1267,8 @@ testReceiveChanFeatures TestTransport{..} = do
11901267 then rpInt
11911268 else return 7
11921269
1193− 5 <- receiveChan rp4
1194− 7 <- receiveChan rp4
1270+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1271+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
11951272
11961273 liftIO $ putMVar done ()
11971274
@@ -1200,7 +1277,6 @@ testReceiveChanFeatures TestTransport{..} = do
12001277testKillLocal :: TestTransport -> Assertion
12011278testKillLocal TestTransport{..} = do
12021279 localNode <- newLocalNode testTransport initRemoteTable
1203− done <- newEmptyMVar
12041280
12051281 pid <- forkProcess localNode $ do
12061282 liftIO $ threadDelay 1000000
@@ -1209,17 +1285,18 @@ testKillLocal TestTransport{..} = do
12091285 ref <- monitor pid
12101286 us <- getSelfPid
12111287 kill pid "TestKill"
1212− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1213− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1214− liftIO $ putMVar done ()
1215−
1216− takeMVar done
1288+ mn <- expect
1289+ case mn of
1290+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1291+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1292+ True -> return ()
1293+ False -> die "Invalid ProcessMonitorNotification received"
1294+ _ -> die "Something went horribly wrong"
12171295
12181296testKillRemote :: TestTransport -> Assertion
12191297testKillRemote TestTransport{..} = do
12201298 node1 <- newLocalNode testTransport initRemoteTable
12211299 node2 <- newLocalNode testTransport initRemoteTable
1222− done <- newEmptyMVar
12231300
12241301 pid <- forkProcess node1 $ do
12251302 liftIO $ threadDelay 1000000
@@ -1228,11 +1305,17 @@ testKillRemote TestTransport{..} = do
12281305 ref <- monitor pid
12291306 us <- getSelfPid
12301307 kill pid "TestKill"
1231− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1232− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1233− liftIO $ putMVar done ()
1234−
1235− takeMVar done
1308+ mn <- expect
1309+ case mn of
1310+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1311+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1312+ (True, True, True) -> return ()
1313+ (a, b, c) -> do
1314+ let a' = if a then "" else "Invalid ref"
1315+ let b' = if b then "" else "Invalid pid"
1316+ let c' = if c then "" else "Invalid message"
1317+ die $ unwords [a', b', c']
1318+ _ -> die "Received unexpected message"
12361319
12371320testCatchesExit :: TestTransport -> Assertion
12381321testCatchesExit TestTransport{..} = do
@@ -1258,7 +1341,10 @@ testHandleMessageIf TestTransport{..} = do
12581341 self <- getSelfPid
12591342 send self (5 :: Integer, 10 :: Integer)
12601343 msg <- receiveWait [ matchMessage return ]
1261− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1344+ handleMessageIf msg
1345+ (\() -> True)
1346+ (\() -> die "whoops") >>= maybe (return ())
1347+ (const $ die "Expected Mismatch")
12621348 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
12631349 (\input -> liftIO $ putMVar done input)
12641350 return ()
@@ -1303,8 +1389,11 @@ testDie TestTransport{..} = do
13031389 (die ("foobar", 123 :: Int))
13041390 `catchExit` \_from reason -> do
13051391 -- TODO: should verify that 'from' has the right value
1306− True <- return $ reason == ("foobar", 123 :: Int)
1392+ let res = reason == ("foobar", 123 :: Int)
13071393 liftIO $ putMVar done ()
1394+ if res
1395+ then return ()
1396+ else die "Something went horribly wrong"
13081397
13091398 takeMVar done
13101399
@@ -1318,8 +1407,11 @@ testPrettyExit TestTransport{..} = do
13181407 `catch` \ex@(ProcessExitException from _) ->
13191408 let expected = "exit-from=" ++ (show from)
13201409 in do
1321− True <- return $ (show ex) == expected
1410+ let res = (show ex) == expected
13221411 liftIO $ putMVar done ()
1412+ if res
1413+ then return ()
1414+ else die "Something went horribly wrong"
13231415
13241416 takeMVar done
13251417
@@ -1335,17 +1427,26 @@ testExitLocal TestTransport{..} = do
13351427 pid <- forkProcess localNode $ do
13361428 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
13371429 -- TODO: should verify that 'from' has the right value
1338− True <- return $ reason == "TestExit"
1430+ res <- return $ reason == "TestExit"
13391431 liftIO $ putMVar supervisedDone ()
1432+ if res
1433+ then return ()
1434+ else die "Something went horribly wrong"
13401435
13411436 runProcess localNode $ do
13421437 liftIO $ takeMVar handlerSetUp
13431438 ref <- monitor pid
13441439 exit pid "TestExit"
13451440 -- This time the client catches the exception, so it dies normally
1346− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1347− True <- return $ ref == ref' && pid == pid'
1348− liftIO $ putMVar supervisorDone ()
1441+ mn <- expect
1442+ case mn of
1443+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1444+ let res = ref == ref' && pid == pid'
1445+ liftIO $ putMVar supervisorDone ()
1446+ if res
1447+ then return ()
1448+ else die "Something went horribly wrong"
1449+ _ -> die "Something went horribly wrong"
13491450
13501451 takeMVar supervisedDone
13511452 takeMVar supervisorDone
@@ -1361,19 +1462,90 @@ testExitRemote TestTransport{..} = do
13611462 (receiveWait [] :: Process ()) -- block forever
13621463 `catchExit` \_from reason -> do
13631464 -- TODO: should verify that 'from' has the right value
1364− True <- return $ reason == "TestExit"
1465+ res <- return $ reason == "TestExit"
13651466 liftIO $ putMVar supervisedDone ()
1467+ if res
1468+ then return ()
1469+ else die "Something went horribly wrong"
13661470
13671471 runProcess node2 $ do
13681472 ref <- monitor pid
13691473 exit pid "TestExit"
1370− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1371− True <- return $ ref == ref' && pid == pid'
1372− liftIO $ putMVar supervisorDone ()
1474+ mn <- expect
1475+ case mn of
1476+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1477+ res' <- return $ ref == ref' && pid == pid'
1478+ liftIO $ putMVar supervisorDone ()
1479+ if res'
1480+ then return ()
1481+ else die "Something went horribly wrong"
1482+ _ -> die "Something went horribly wrong"
13731483
13741484 takeMVar supervisedDone
13751485 takeMVar supervisorDone
13761486
1487+testRegistryMonitoring :: TestTransport -> Assertion
1488+testRegistryMonitoring TestTransport{..} = do
1489+ node1 <- newLocalNode testTransport initRemoteTable
1490+ node2 <- newLocalNode testTransport initRemoteTable
1491+ waitH <- newEmptyMVar
1492+
1493+ let nid = localNodeId node2
1494+ pid <- forkProcess node1 $ do
1495+ getSelfPid >>= runUntilRegistered nid
1496+ liftIO $ takeMVar waitH
1497+
1498+ runProcess node2 $ do
1499+ register regName pid
1500+ res <- whereis regName
1501+ us <- getSelfPid
1502+ liftIO $ do
1503+ putMVar waitH ()
1504+ assertBool "expected (Just pid)" $ res == (Just pid)
1505+
1506+ -- This delay isn't essential!
1507+ -- The test case passes perfectly fine without it (feel free to comment out
1508+ -- and see), however waiting a few seconds here, makes it much more likely
1509+ -- that in delayUntilMaybeUnregistered we will hit the match case right
1510+ -- away, and thus not be subjected to a 20 second delay. The value of 4
1511+ -- seconds appears to work optimally on osx and across several linux distros
1512+ -- running in virtual machines (which is essentially what we do in CI)
1513+ void $ receiveTimeout 4000000 [ matchAny return ]
1514+
1515+ -- This delay doesn't serve much purpose in the happy path, however if some
1516+ -- future patch breaks the cooperative behaviour of node controllers viz
1517+ -- remote process registration and notification taking place via ncEffectDied,
1518+ -- there would be the possibility of a race in the test case should we attempt
1519+ -- to evaluate `whereis regName` on node2 right away. In case the name is still
1520+ -- erroneously registered, observing the 20 second delay (or lack of), could at
1521+ -- least give a hint that something is wrong, and we give up our time slice
1522+ -- so that there's a higher change the registrations have been cleaned up
1523+ -- in either case.
1524+ runProcess node2 $ delayUntilMaybeUnregistered nid pid
1525+
1526+ regHere <- newEmptyMVar
1527+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1528+ res <- takeMVar regHere
1529+ assertBool "expected Nothing, but process still registered" (res == Nothing)
1530+
1531+ where
1532+ runUntilRegistered nid us = do
1533+ whereisRemoteAsync nid regName
1534+ receiveWait [
1535+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1536+ (const $ return ())
1537+ ]
1538+
1539+ delayUntilMaybeUnregistered nid p = do
1540+ whereisRemoteAsync nid regName
1541+ receiveTimeout 20000000 {- 20 sec delay -} [
1542+ matchIf (\(WhereIsReply n p) -> n == regName && p == Nothing)
1543+ (const $ return ())
1544+ ]
1545+ return ()
1546+
1547+ regName = "testRegisterRemote"
1548+
13771549testUnsafeSend :: TestTransport -> Assertion
13781550testUnsafeSend TestTransport{..} = do
13791551 serverAddr <- newEmptyMVar
@@ -1389,8 +1561,7 @@ testUnsafeSend TestTransport{..} = do
13891561 void $ forkProcess localNode $ do
13901562 serverPid <- liftIO $ takeMVar serverAddr
13911563 getSelfPid >>= unsafeSend serverPid
1392− () <- expect
1393− liftIO $ putMVar clientDone ()
1564+ expect >>= liftIO . putMVar clientDone
13941565
13951566 takeMVar clientDone
13961567
@@ -1409,8 +1580,7 @@ testUnsafeUSend TestTransport{..} = do
14091580 void $ forkProcess localNode $ do
14101581 serverPid <- liftIO $ takeMVar serverAddr
14111582 getSelfPid >>= unsafeUSend serverPid
1412− () <- expect
1413− liftIO $ putMVar clientDone ()
1583+ expect >>= liftIO . putMVar clientDone
14141584
14151585 takeMVar clientDone
14161586
@@ -1421,8 +1591,7 @@ testUnsafeNSend TestTransport{..} = do
14211591 localNode <- newLocalNode testTransport initRemoteTable
14221592
14231593 pid <- forkProcess localNode $ do
1424− () <- expect
1425− liftIO $ putMVar clientDone ()
1594+ expect >>= liftIO . putMVar clientDone
14261595
14271596 void $ runProcess localNode $ do
14281597 register "foobar" pid
@@ -1440,8 +1609,7 @@ testUnsafeNSendRemote TestTransport{..} = do
14401609 _ <- forkProcess localNode1 $ do
14411610 getSelfPid >>= register "foobar"
14421611 liftIO $ putMVar clientDone ()
1443− () <- expect
1444− liftIO $ putMVar clientDone ()
1612+ expect >>= liftIO . putMVar clientDone
14451613
14461614 takeMVar clientDone
14471615 void $ runProcess localNode2 $ do
@@ -1465,7 +1633,7 @@ testUnsafeSendChan TestTransport{..} = do
14651633 serverPid <- liftIO $ takeMVar serverAddr
14661634 (sp, rp) <- newChan
14671635 unsafeSend serverPid sp
1468− () <- receiveChan rp
1636+ receiveChan rp :: Process ()
14691637 liftIO $ putMVar clientDone ()
14701638
14711639 takeMVar clientDone
@@ -1479,8 +1647,8 @@ testCallLocal TestTransport{..} = do
14791647 runProcess node $ do
14801648 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
14811649 liftIO $ putMVar result r
1482− True <- takeMVar result
1483− return ()
1650+
1651+ takeMVar result >>= assertBool "Expected 'True'"
14841652
14851653 -- Testing that when callLocal is interrupted, the worker is interrupted.
14861654 ibox <- newIORef False
@@ -1497,10 +1665,9 @@ testCallLocal TestTransport{..} = do
14971665 (send keeper ())
14981666 caller <- expect
14991667 exit caller "test"
1500− () <- expect
1501− return ()
1502− True <- readIORef ibox
1503− return ()
1668+ expect :: Process ()
1669+
1670+ readIORef ibox >>= assertBool "Expected 'True'"
15041671
15051672 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
15061673 ibox2 <- newIORef False
@@ -1509,8 +1676,8 @@ testCallLocal TestTransport{..} = do
15091676 liftIO $ writeIORef ibox2 $ case r of
15101677 Left (ErrorCall "e") -> True
15111678 _ -> False
1512− True <- readIORef ibox
1513− return ()
1679+
1680+ readIORef ibox >>= assertBool "Expected 'True'"
15141681
15151682 -- Test that caller waits for the worker in correct situation
15161683 ibox3 <- newIORef False
@@ -1527,8 +1694,8 @@ testCallLocal TestTransport{..} = do
15271694 liftIO $ putMVar result3 =<< readIORef ibox3
15281695 worker <- expect
15291696 send worker ()
1530− True <- takeMVar result3
1531− return ()
1697+
1698+ takeMVar result3 >>= assertBool "Expected 'True'"
15321699
15331700 -- Test that caller waits for the worker in case when caller gets an exception
15341701 ibox4 <- newIORef False
@@ -1544,13 +1711,9 @@ testCallLocal TestTransport{..} = do
15441711 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
15451712 caller <- expect
15461713 exit caller "hi!"
1547− True <- takeMVar result4
1548− return ()
1549− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1550−
1551−
1552−
15531714
1715+ takeMVar result4 >>= assertBool "Expected 'True'"
1716+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
15541717
15551718tests :: TestTransport -> IO [Test]
15561719tests testtrans = return [
@@ -1584,6 +1747,7 @@ tests testtrans = return [
15841747 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
15851748 , testCase "ExitLocal" (testExitLocal testtrans)
15861749 , testCase "ExitRemote" (testExitRemote testtrans)
1750+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
15871751 , testCase "TextCallLocal" (testCallLocal testtrans)
15881752 -- Unsafe Primitives
15891753 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
@@ -1636,17 +1800,3 @@ tests testtrans = return [
16361800 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
16371801 ]
16381802 ]
1639−
1640−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1641−syncBreakConnection breakConnection nid0 nid1 = do
1642− m <- newEmptyMVar
1643− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1644− runProcess nid0 $ do
1645− them <- liftIO $ takeMVar m
1646− pinger <- spawnLocal $ forever $ send them ()
1647− _ <- monitorNode (localNodeId nid1)
1648− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1649− (nodeAddress $ localNodeId nid1)
1650− NodeMonitorNotification _ _ _ <- expect
1651− kill pinger "finished"
1652− return ()