@@ -42,7 +42,7 @@ import Control.Distributed.Process.Management.Internal.Types
4242import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)
4343import Control.Distributed.Process.Serializable (Serializable)
4444
45−import Test.HUnit (Assertion, assertFailure, assertBool)
45+import Test.HUnit (Assertion, assertBool, assertFailure)
4646import Test.Framework (Test, testGroup)
4747import Test.Framework.Providers.HUnit (testCase)
4848import Control.Rematch hiding (match)
@@ -78,12 +78,47 @@ ping = do
7878 send partner (Ping self)
7979 ping
8080
81+verifyClient :: String -> MVar Bool -> IO ()
82+verifyClient s b = takeMVar b >>= assertBool s
83+
84+expectPing :: MVar Bool -> Process ()
85+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
86+ where
87+ checkPing (Ping _) = True
88+ checkPing _ = False
89+
8190-- | Quick and dirty synchronous version of whereisRemoteAsync
8291whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
8392whereisRemote nid string = do
8493 whereisRemoteAsync nid string
85− WhereIsReply _ mPid <- expect
86− return mPid
94+ receiveWait [
95+ match (\(WhereIsReply _ mPid) -> return mPid)
96+ ]
97+
98+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
99+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
100+
101+waitForExit :: ProcessId -> Process DiedReason
102+waitForExit pid = monitor pid >>= waitForDown
103+
104+waitForDown :: MonitorRef -> Process DiedReason
105+waitForDown ref =
106+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
107+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
108+
109+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
110+syncBreakConnection breakConnection nid0 nid1 = do
111+ m <- newEmptyMVar
112+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
113+ runProcess nid0 $ do
114+ them <- liftIO $ takeMVar m
115+ pinger <- spawnLocal $ forever $ send them ()
116+ _ <- monitorNode (localNodeId nid1)
117+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
118+ (nodeAddress $ localNodeId nid1)
119+ NodeMonitorNotification _ _ _ <- expect
120+ kill pinger "finished"
121+ return ()
87122
88123data Add = Add ProcessId Double Double deriving (Typeable)
89124data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -158,12 +193,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
158193 unmonitor ref
159194 liftIO $ putMVar done ()
160195 (False, ref) -> do
161− ProcessMonitorNotification ref' pid reason' <- expect
162− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
163− liftIO $ putMVar done ()
196+ receiveWait [
197+ match (\(ProcessMonitorNotification ref' pid reason') -> do
198+ liftIO $ do
199+ assertBool "Bad Monitor Signal"
200+ (Just ref' == ref && pid == theirAddr &&
201+ mOrL && reason == reason')
202+ putMVar done ())
203+ ]
164204 )
165205 (\(ProcessLinkException pid reason') -> do
166− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
206+ (liftIO $ assertBool "link exception unmatched" $
207+ pid == theirAddr && not mOrL && not un && reason == reason')
167208 liftIO $ putMVar done ()
168209 )
169210
@@ -194,8 +235,10 @@ testPing TestTransport{..} = do
194235 pid <- getSelfPid
195236 replicateM_ numPings $ do
196237 send pingServer (Pong pid)
197− Ping _ <- expect
198− return ()
238+ p <- expect
239+ case p of
240+ Ping _ -> return ()
241+ _ -> die "Unexpected message"
199242
200243 putMVar clientDone ()
201244
@@ -282,7 +325,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
282325 runProcess localNode $ do
283326 monitor theirAddr
284327 -- wait for the process to die
285− ProcessMonitorNotification _ _ _ <- expect
328+ expect :: Process ProcessMonitorNotification
286329 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
287330
288331 takeMVar done
@@ -356,14 +399,17 @@ testMath TestTransport{..} = do
356399 runProcess localNode $ do
357400 pid <- getSelfPid
358401 send mathServer (Add pid 1 2)
359− 3 <- expect :: Process Double
402+ three <- expect :: Process Double
360403 send mathServer (Divide pid 8 2)
361− 4 <- expect :: Process Double
404+ four <- expect :: Process Double
362405 send mathServer (Divide pid 8 0)
363− DivByZero <- expect
364− liftIO $ putMVar clientDone ()
406+ divByZ <- expect
407+ liftIO $ putMVar clientDone (three, four, divByZ)
365408
366− takeMVar clientDone
409+ res <- takeMVar clientDone
410+ case res of
411+ (3, 4, DivByZero) -> return ()
412+ _ -> error $ "Something went horribly wrong"
367413
368414-- | Send first message (i.e. connect) to an already terminated process
369415-- (without monitoring); then send another message to a second process on
@@ -391,11 +437,9 @@ testSendToTerminated TestTransport{..} = do
391437 pid <- getSelfPid
392438 send server1 "Hi"
393439 send server2 (Pong pid)
394− Ping pid' <- expect
395− True <- return $ pid' == server2
396− liftIO $ putMVar clientDone ()
440+ expectPing clientDone
397441
398− takeMVar clientDone
442+ verifyClient "Expected Ping from server" clientDone
399443
400444-- | Test (non-zero) timeout
401445testTimeout :: TestTransport -> Assertion
@@ -404,10 +448,10 @@ testTimeout TestTransport{..} = do
404448 done <- newEmptyMVar
405449
406450 runProcess localNode $ do
407− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
408− liftIO $ putMVar done ()
451+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
452+ liftIO $ putMVar done $ res == Nothing
409453
410− takeMVar done
454+ verifyClient "Expected receiveTimeout to timeout..." done
411455
412456-- | Test zero timeout
413457testTimeout0 :: TestTransport -> Assertion
@@ -435,10 +479,9 @@ testTimeout0 TestTransport{..} = do
435479 -- is not interested in, and then a single message that it wants
436480 replicateM_ 10000 $ send server "Irrelevant message"
437481 send server (Pong pid)
438− Ping _ <- expect
439− liftIO $ putMVar clientDone ()
482+ expectPing clientDone
440483
441− takeMVar clientDone
484+ verifyClient "Expected Ping from server" clientDone
442485
443486-- | Test typed channels
444487testTypedChannels :: TestTransport -> Assertion
@@ -461,10 +504,10 @@ testTypedChannels TestTransport{..} = do
461504 runProcess localNode $ do
462505 (clientSendPort, rport) <- newChan
463506 sendChan serverSendPort (clientSendPort, 5)
464− False <- receiveChan rport
465− liftIO $ putMVar clientDone ()
507+ ch <- receiveChan rport
508+ liftIO $ putMVar clientDone $ ch == False
466509
467− takeMVar clientDone
510+ verifyClient "Expected channel to send 'False'" clientDone
468511
469512-- | Test merging receive ports
470513testMergeChannels :: TestTransport -> Assertion
@@ -487,9 +530,8 @@ testMergeChannels TestTransport{..} = do
487530 rs <- mapM charChannel "abc"
488531 m <- mergePorts biased rs
489532 xs <- replicateM 9 $ receiveChan m
490− True <- return $ xs == expected
491− liftIO $ putMVar done ()
492− takeMVar done
533+ liftIO $ putMVar done $ xs == expected
534+ verifyClient "Expected single layer merge to match expected ordering" done
493535
494536 -- Two layers of merging
495537 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -500,9 +542,8 @@ testMergeChannels TestTransport{..} = do
500542 ms <- mapM (mergePorts biasedInner) rss
501543 m <- mergePorts biasedOuter ms
502544 xs <- replicateM (9 * 3) $ receiveChan m
503− True <- return $ xs == expected
504− liftIO $ putMVar done ()
505− takeMVar done
545+ liftIO $ putMVar done $ xs == expected
546+ verifyClient "Expected nested channels to match expeted ordering" done
506547
507548 -- Test that if no messages are (immediately) available, the scheduler makes no difference
508549 testBlocked :: LocalNode -> Bool -> IO ()
@@ -511,43 +552,45 @@ testMergeChannels TestTransport{..} = do
511552 done <- newEmptyMVar
512553
513554 forkProcess localNode $ do
514− [sa, sb, sc] <- liftIO $ mapM readMVar vs
515− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
516− [ -- a, b, c
517− (sa, 'a')
518− , (sb, 'b')
519− , (sc, 'c')
520− -- a, c, b
521− , (sa, 'a')
522− , (sc, 'c')
523− , (sb, 'b')
524− -- b, a, c
525− , (sb, 'b')
526− , (sa, 'a')
527− , (sc, 'c')
528− -- b, c, a
529− , (sb, 'b')
530− , (sc, 'c')
531− , (sa, 'a')
532− -- c, a, b
533− , (sc, 'c')
534− , (sa, 'a')
535− , (sb, 'b')
536− -- c, b, a
537− , (sc, 'c')
538− , (sb, 'b')
539− , (sa, 'a')
540− ]
555+ ss <- liftIO $ mapM readMVar vs
556+ case ss of
557+ [sa, sb, sc] ->
558+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
559+ [ -- a, b, c
560+ (sa, 'a')
561+ , (sb, 'b')
562+ , (sc, 'c')
563+ -- a, c, b
564+ , (sa, 'a')
565+ , (sc, 'c')
566+ , (sb, 'b')
567+ -- b, a, c
568+ , (sb, 'b')
569+ , (sa, 'a')
570+ , (sc, 'c')
571+ -- b, c, a
572+ , (sb, 'b')
573+ , (sc, 'c')
574+ , (sa, 'a')
575+ -- c, a, b
576+ , (sc, 'c')
577+ , (sa, 'a')
578+ , (sb, 'b')
579+ -- c, b, a
580+ , (sc, 'c')
581+ , (sb, 'b')
582+ , (sa, 'a')
583+ ]
584+ _ -> die "Something went horribly wrong"
541585
542586 forkProcess localNode $ do
543587 (ss, rs) <- unzip <$> replicateM 3 newChan
544588 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
545589 m <- mergePorts biased rs
546590 xs <- replicateM (6 * 3) $ receiveChan m
547− True <- return $ xs == "abcacbbacbcacabcba"
548− liftIO $ putMVar done ()
591+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
549592
550− takeMVar done
593+ verifyClient "Expected merged ports to match expected ordering" done
551594
552595 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
553596 mergePorts True = mergePortsBiased
@@ -565,8 +608,9 @@ testTerminate TestTransport{..} = do
565608 localNode <- newLocalNode testTransport initRemoteTable
566609 runProcess localNode $ do
567610 e <- try terminate :: Process (Either ProcessTerminationException ())
568− True <- return $ either show show e == show ProcessTerminationException
569− return ()
611+ if either show show e == show ProcessTerminationException
612+ then return ()
613+ else die "Unexpected result from terminate"
570614
571615testMonitorNode :: TestTransport -> Assertion
572616testMonitorNode TestTransport{..} = do
@@ -577,11 +621,12 @@ testMonitorNode TestTransport{..} = do
577621
578622 runProcess node2 $ do
579623 ref <- monitorNode (localNodeId node1)
580− NodeMonitorNotification ref' nid DiedDisconnect <- expect
581− True <- return $ ref == ref' && nid == localNodeId node1
582− liftIO $ putMVar done ()
624+ receiveWait [
625+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
626+ return $ ref == ref' && nid == localNodeId node1)
627+ ] >>= liftIO . putMVar done
583628
584− takeMVar done
629+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
585630
586631testMonitorLiveNode :: TestTransport -> Assertion
587632testMonitorLiveNode TestTransport{..} = do
@@ -596,15 +641,16 @@ testMonitorLiveNode TestTransport{..} = do
596641 liftIO $ putMVar ready ()
597642 liftIO $ takeMVar readyr
598643 send p ()
599− NodeMonitorNotification ref' nid _ <- expect
600− True <- return $ ref == ref' && nid == localNodeId node1
601− liftIO $ putMVar done ()
644+ receiveWait [
645+ match (\(NodeMonitorNotification ref' nid _) ->
646+ (return $ ref == ref' && nid == localNodeId node1))
647+ ] >>= liftIO . putMVar done
602648
603649 takeMVar ready
604650 closeLocalNode node1
605651 putMVar readyr ()
606652
607− takeMVar done
653+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
608654
609655testMonitorChannel :: TestTransport -> Assertion
610656testMonitorChannel TestTransport{..} = do
@@ -614,18 +660,20 @@ testMonitorChannel TestTransport{..} = do
614660 pid <- forkProcess node1 $ do
615661 sport <- expect :: Process (SendPort ())
616662 ref <- monitorPort sport
617− PortMonitorNotification ref' port' reason <- expect
618− -- reason might be DiedUnknownId if the receive port is GCed before the
619− -- monitor is established (TODO: not sure that this is reasonable)
620− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
621− liftIO $ putMVar gotNotification ()
663+ receiveWait [
664+ -- reason might be DiedUnknownId if the receive port is GCed before the
665+ -- monitor is established (TODO: not sure that this is reasonable)
666+ match (\(PortMonitorNotification ref' port' reason) ->
667+ return $ ref' == ref && port' == sendPortId sport &&
668+ (reason == DiedNormal || reason == DiedUnknownId))
669+ ] >>= liftIO . putMVar gotNotification
622670
623671 runProcess node2 $ do
624672 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
625673 send pid sport
626674 liftIO $ threadDelay 100000
627675
628− takeMVar gotNotification
676+ verifyClient "Expected PortMonitorNotification" gotNotification
629677
630678testRegistry :: TestTransport -> Assertion
631679testRegistry TestTransport{..} = do
@@ -637,20 +685,28 @@ testRegistry TestTransport{..} = do
637685
638686 runProcess node $ do
639687 register "ping" pingServer
640− Just pid <- whereis "ping"
641− True <- return $ pingServer == pid
688+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
642689 us <- getSelfPid
643690 nsend "ping" (Pong us)
644− Ping pid' <- expect
645− True <- return $ pingServer == pid'
646− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
647− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
648− True <- return $ x == pingServer
649− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
691+ receiveWait [
692+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
693+ ]
694+ checkRegException "dead" Nothing deadProcess
695+ checkRegException "ping" (Just pingServer) deadProcess
696+ try (unregister "dead") >>= checkReg "dead" Nothing
650697 liftIO $ putMVar done ()
651698
652699 takeMVar done
653700
701+ where
702+ checkRegException name pid dead =
703+ try (register name dead) >>= checkReg name pid
704+
705+ checkReg name pid res =
706+ case res of
707+ Left (ProcessRegistrationException name pid) -> return ()
708+ _ -> die $ "Unexpected Registration" ++ show res
709+
654710testRegistryRemoteProcess :: TestTransport -> Assertion
655711testRegistryRemoteProcess TestTransport{..} = do
656712 node1 <- newLocalNode testTransport initRemoteTable
@@ -661,13 +717,13 @@ testRegistryRemoteProcess TestTransport{..} = do
661717
662718 runProcess node2 $ do
663719 register "ping" pingServer
664− Just pid <- whereis "ping"
665− True <- return $ pingServer == pid
720+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
666721 us <- getSelfPid
667722 nsend "ping" (Pong us)
668− Ping pid' <- expect
669− True <- return $ pingServer == pid'
670− liftIO $ putMVar done ()
723+ receiveWait [
724+ matchIf (\(Ping pid') -> pingServer == pid')
725+ (const $ liftIO $ putMVar done ())
726+ ]
671727
672728 takeMVar done
673729
@@ -688,12 +744,13 @@ testRemoteRegistry TestTransport{..} = do
688744 "ping" == label' && pid == pingServer)
689745 (\(RegisterReply _ _ _) -> return ()) ]
690746
691− Just pid <- whereisRemote nid1 "ping"
692− True <- return $ pingServer == pid
747+ pid <- verifyWhereIsRemote nid1 "ping"
748+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
693749 us <- getSelfPid
694750 nsendRemote nid1 "ping" (Pong us)
695− Ping pid' <- expect
696− True <- return $ pingServer == pid'
751+ receiveWait [
752+ match (\(Ping pid') -> return $ pingServer == pid')
753+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
697754
698755 -- test that if process was not registered Nothing is returned
699756 -- in owner field.
@@ -729,15 +786,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
729786 receiveWait [
730787 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
731788 (\(RegisterReply _ _ _) -> return ()) ]
732− Just pid <- whereisRemote nid1 "ping"
733− True <- return $ pingServer == pid
789+ pid <- verifyWhereIsRemote nid1 "ping"
790+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
734791 us <- getSelfPid
735792 nsendRemote nid1 "ping" (Pong us)
736− Ping pid' <- expect
737− True <- return $ pingServer == pid'
738− liftIO $ putMVar done ()
793+ receiveWait [
794+ match (\(Ping pid') -> return $ pingServer == pid')
795+ ] >>= liftIO . putMVar done
739796
740− takeMVar done
797+ verifyClient "Expected Ping with ping server's ProcessId" done
741798
742799testSpawnLocal :: TestTransport -> Assertion
743800testSpawnLocal TestTransport{..} = do
@@ -751,15 +808,14 @@ testSpawnLocal TestTransport{..} = do
751808 sport <- expect
752809 sendChan sport (1234 :: Int)
753810
754− sport <- spawnChannelLocal $ \rport -> do
755− (1234 :: Int) <- receiveChan rport
756− send us ()
811+ sport <- spawnChannelLocal $
812+ \rport -> (receiveChan rport :: Process Int) >>= send us
757813
758814 send pid sport
759− () <- expect
760− liftIO $ putMVar done ()
815+ expect >>= liftIO . putMVar done
761816
762− takeMVar done
817+ res <- takeMVar done
818+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
763819
764820testSpawnAsyncStrictness :: TestTransport -> Assertion
765821testSpawnAsyncStrictness TestTransport{..} = do
@@ -788,8 +844,9 @@ testReconnect TestTransport{..} = do
788844 liftIO $ putMVar processA us
789845 msg1 <- expect
790846 msg2 <- expect
791− True <- return $ msg1 == "message 1" && msg2 == "message 3"
792− liftIO $ putMVar sendTestOk ()
847+ liftIO $ do
848+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
849+ putMVar sendTestOk ()
793850
794851 forkProcess node2 $ do
795852 {-
@@ -822,7 +879,7 @@ testReconnect TestTransport{..} = do
822879 matchIf (\(RegisterReply label' _ _) -> "a" == label')
823880 (\(RegisterReply _ _ _) -> return ()) ]
824881
825− Just _ <- whereisRemote nid1 "a"
882+ _ <- whereisRemote nid1 "a"
826883
827884
828885 -- Simulate network failure
@@ -841,9 +898,10 @@ testReconnect TestTransport{..} = do
841898 (\(RegisterReply _ _ _) -> return ()) ]
842899
843900 -- Check
844− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
845− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
846− Just _ <- whereisRemote nid1 "c"
901+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
902+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
903+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
904+ verifyWhereIsRemote nid1 "c"
847905
848906 liftIO $ putMVar registerTestOk ()
849907
@@ -884,13 +942,14 @@ testUSend usendPrim TestTransport{..} numMessages = do
884942 isSorted _ = True
885943 -- The list can't be null since there are no failures after sending
886944 -- the last message.
887− True <- return $ isSorted msgs && not (null msgs)
888− liftIO $ putMVar usendTestOk ()
945+ liftIO $ do
946+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)
947+ putMVar usendTestOk ()
889948
890949 forkProcess node2 $ do
891950 them <- liftIO $ readMVar processA
892951 getSelfPid >>= send them
893− () <- expect
952+ expect :: Process ()
894953 forM_ [1..numMessages] $ \i -> do
895954 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
896955 usendPrim them i
@@ -922,14 +981,17 @@ testMatchAny TestTransport{..} = do
922981 runProcess localNode $ do
923982 pid <- getSelfPid
924983 send mathServer (Add pid 1 2)
925− 3 <- expect :: Process Double
984+ three <- expect :: Process Double
926985 send mathServer (Divide pid 8 2)
927− 4 <- expect :: Process Double
986+ four <- expect :: Process Double
928987 send mathServer (Divide pid 8 0)
929− DivByZero <- expect
930− liftIO $ putMVar clientDone ()
988+ divByZ <- expect
989+ liftIO $ putMVar clientDone (three, four, divByZ)
931990
932− takeMVar clientDone
991+ res <- takeMVar clientDone
992+ case res of
993+ (3, 4, DivByZero) -> return ()
994+ _ -> error "Unexpected result"
933995
934996-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
935997-- in between, however we block 'Divide' requests ....
@@ -956,12 +1018,13 @@ testMatchAnyHandle TestTransport{..} = do
9561018 runProcess localNode $ do
9571019 pid <- getSelfPid
9581020 send mathServer (Add pid 1 2)
959− 3 <- expect :: Process Double
1021+ three <- expect :: Process Double
9601022 send mathServer (Divide pid 8 2)
961− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
962− liftIO $ putMVar clientDone ()
1023+ res <- (expectTimeout 100000) :: Process (Maybe Double)
1024+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1025+
1026+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
9631027
964− takeMVar clientDone
9651028 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
9661029 maybeForward s msg =
9671030 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -989,8 +1052,10 @@ testMatchAnyNoHandle TestTransport{..} = do
9891052 Just _ -> die "NONSENSE")
9901053 ]
9911054 -- we *must* have removed the message from our mailbox though!!!
992− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
993− liftIO $ putMVar serverDone ()
1055+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1056+ liftIO $ do
1057+ assertBool "Expected timeout!" $ res == Nothing
1058+ putMVar serverDone ()
9941059 putMVar addr server
9951060
9961061 -- Client
@@ -1033,14 +1098,21 @@ testMatchAnyIf TestTransport{..} = do
10331098 runProcess localNode $ do
10341099 pid <- getSelfPid
10351100 send server (pid, "foo")
1036− "foo" <- expect
1037− send server (pid, "baz")
1038− "baz" <- expect
1101+ foo <- expect
1102+ -- provoking what would be the wrong ordering is informative here...
1103+
10391104 send server (pid, "bar")
1040− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1041− liftIO $ putMVar clientDone ()
1105+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1106+
1107+ send server (pid, "baz")
1108+ baz <- expect
1109+
1110+ liftIO $ putMVar clientDone (foo, bar, baz)
1111+
1112+ res <- takeMVar clientDone
1113+ let res' = res == ("foo", Nothing, "baz")
1114+ assertBool "Expected timeout due to type mismatch" res'
10421115
1043− takeMVar clientDone
10441116 where tryHandleMessage :: Message -> Process (Maybe ())
10451117 tryHandleMessage msg =
10461118 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1073,12 +1145,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do
10731145 runProcess localNode $ do
10741146 pid <- getSelfPid
10751147 send server (pid, wrapMessage ("foo" :: String))
1076− "foo" <- expect
1148+ foo <- expect
10771149 send server (pid, wrapMessage ("baz" :: String))
1078− "baz" <- expect
1079− liftIO $ putMVar clientDone ()
1150+ baz <- expect
1151+ liftIO $ putMVar clientDone (foo, baz)
10801152
1081− takeMVar clientDone
1153+ res <- takeMVar clientDone
1154+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
10821155
10831156-- Test 'receiveChanTimeout'
10841157testReceiveChanTimeout :: TestTransport -> Assertion
@@ -1096,18 +1169,19 @@ testReceiveChanTimeout TestTransport{..} = do
10961169
10971170 -- Wait for a message with a delay. No message arrives, we should get
10981171 -- Nothing after the delay.
1099− Nothing <- receiveChanTimeout 100000 rp
1172+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11001173
11011174 -- Let the sender know that it can send a message.
11021175 liftIO $ putMVar mvSender ()
11031176
11041177 -- Wait for a message with a delay again. Now a message arrives after
11051178 -- 0.1 seconds
1106− Just True <- receiveChanTimeout 20000000 rp
1179+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1180+ liftIO $ assertBool "Expected result to be 'True'" res
11071181
11081182 -- Wait for a message with zero timeout: non-blocking check. No message is
11091183 -- available, we get Nothing
1110− Nothing <- receiveChanTimeout 0 rp
1184+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11111185
11121186 -- Let the sender know that it can send a message.
11131187 liftIO $ putMVar mvSender ()
@@ -1117,7 +1191,7 @@ testReceiveChanTimeout TestTransport{..} = do
11171191 liftIO $ threadDelay 100000
11181192 mb <- receiveChanTimeout 0 rp
11191193 case mb of
1120− Just b -> do False <- return b; return ()
1194+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
11211195 _ -> loop
11221196
11231197 liftIO $ putMVar done ()
@@ -1154,8 +1228,8 @@ testReceiveChanFeatures TestTransport{..} = do
11541228
11551229 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
11561230
1157− True <- receiveChan rp1
1158− False <- receiveChan rp1
1231+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1232+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
11591233
11601234 -- Test Applicative instance
11611235
@@ -1164,7 +1238,7 @@ testReceiveChanFeatures TestTransport{..} = do
11641238
11651239 let rp2 = pure (+) <*> rpInt <*> rpInt
11661240
1167− 7 <- receiveChan rp2
1241+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
11681242
11691243 -- Test Alternative instance
11701244
@@ -1173,8 +1247,8 @@ testReceiveChanFeatures TestTransport{..} = do
11731247
11741248 let rp3 = (even <$> rpInt) <|> rpBool
11751249
1176− False <- receiveChan rp3
1177− True <- receiveChan rp3
1250+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1251+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
11781252
11791253 -- Test Monad instance
11801254
@@ -1188,8 +1262,8 @@ testReceiveChanFeatures TestTransport{..} = do
11881262 then rpInt
11891263 else return 7
11901264
1191− 5 <- receiveChan rp4
1192− 7 <- receiveChan rp4
1265+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1266+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
11931267
11941268 liftIO $ putMVar done ()
11951269
@@ -1198,7 +1272,6 @@ testReceiveChanFeatures TestTransport{..} = do
11981272testKillLocal :: TestTransport -> Assertion
11991273testKillLocal TestTransport{..} = do
12001274 localNode <- newLocalNode testTransport initRemoteTable
1201− done <- newEmptyMVar
12021275
12031276 pid <- forkProcess localNode $ do
12041277 liftIO $ threadDelay 1000000
@@ -1207,17 +1280,18 @@ testKillLocal TestTransport{..} = do
12071280 ref <- monitor pid
12081281 us <- getSelfPid
12091282 kill pid "TestKill"
1210− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1211− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1212− liftIO $ putMVar done ()
1213−
1214− takeMVar done
1283+ mn <- expect
1284+ case mn of
1285+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1286+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1287+ True -> return ()
1288+ False -> die "Invalid ProcessMonitorNotification received"
1289+ _ -> die "Something went horribly wrong"
12151290
12161291testKillRemote :: TestTransport -> Assertion
12171292testKillRemote TestTransport{..} = do
12181293 node1 <- newLocalNode testTransport initRemoteTable
12191294 node2 <- newLocalNode testTransport initRemoteTable
1220− done <- newEmptyMVar
12211295
12221296 pid <- forkProcess node1 $ do
12231297 liftIO $ threadDelay 1000000
@@ -1226,11 +1300,17 @@ testKillRemote TestTransport{..} = do
12261300 ref <- monitor pid
12271301 us <- getSelfPid
12281302 kill pid "TestKill"
1229− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1230− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1231− liftIO $ putMVar done ()
1232−
1233− takeMVar done
1303+ mn <- expect
1304+ case mn of
1305+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1306+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1307+ (True, True, True) -> return ()
1308+ (a, b, c) -> do
1309+ let a' = if a then "" else "Invalid ref"
1310+ let b' = if b then "" else "Invalid pid"
1311+ let c' = if c then "" else "Invalid message"
1312+ die $ unwords [a', b', c']
1313+ _ -> die "Received unexpected message"
12341314
12351315testCatchesExit :: TestTransport -> Assertion
12361316testCatchesExit TestTransport{..} = do
@@ -1256,7 +1336,10 @@ testHandleMessageIf TestTransport{..} = do
12561336 self <- getSelfPid
12571337 send self (5 :: Integer, 10 :: Integer)
12581338 msg <- receiveWait [ matchMessage return ]
1259− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1339+ handleMessageIf msg
1340+ (\() -> True)
1341+ (\() -> die "whoops") >>= maybe (return ())
1342+ (const $ die "Expected Mismatch")
12601343 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
12611344 (\input -> liftIO $ putMVar done input)
12621345 return ()
@@ -1301,8 +1384,11 @@ testDie TestTransport{..} = do
13011384 (die ("foobar", 123 :: Int))
13021385 `catchExit` \_from reason -> do
13031386 -- TODO: should verify that 'from' has the right value
1304− True <- return $ reason == ("foobar", 123 :: Int)
1387+ let res = reason == ("foobar", 123 :: Int)
13051388 liftIO $ putMVar done ()
1389+ if res
1390+ then return ()
1391+ else die "Something went horribly wrong"
13061392
13071393 takeMVar done
13081394
@@ -1316,8 +1402,11 @@ testPrettyExit TestTransport{..} = do
13161402 `catch` \ex@(ProcessExitException from _) ->
13171403 let expected = "exit-from=" ++ (show from)
13181404 in do
1319− True <- return $ (show ex) == expected
1405+ let res = (show ex) == expected
13201406 liftIO $ putMVar done ()
1407+ if res
1408+ then return ()
1409+ else die "Something went horribly wrong"
13211410
13221411 takeMVar done
13231412
@@ -1333,17 +1422,26 @@ testExitLocal TestTransport{..} = do
13331422 pid <- forkProcess localNode $ do
13341423 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
13351424 -- TODO: should verify that 'from' has the right value
1336− True <- return $ reason == "TestExit"
1425+ res <- return $ reason == "TestExit"
13371426 liftIO $ putMVar supervisedDone ()
1427+ if res
1428+ then return ()
1429+ else die "Something went horribly wrong"
13381430
13391431 runProcess localNode $ do
13401432 liftIO $ takeMVar handlerSetUp
13411433 ref <- monitor pid
13421434 exit pid "TestExit"
13431435 -- This time the client catches the exception, so it dies normally
1344− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1345− True <- return $ ref == ref' && pid == pid'
1346− liftIO $ putMVar supervisorDone ()
1436+ mn <- expect
1437+ case mn of
1438+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1439+ let res = ref == ref' && pid == pid'
1440+ liftIO $ putMVar supervisorDone ()
1441+ if res
1442+ then return ()
1443+ else die "Something went horribly wrong"
1444+ _ -> die "Something went horribly wrong"
13471445
13481446 takeMVar supervisedDone
13491447 takeMVar supervisorDone
@@ -1359,15 +1457,24 @@ testExitRemote TestTransport{..} = do
13591457 (receiveWait [] :: Process ()) -- block forever
13601458 `catchExit` \_from reason -> do
13611459 -- TODO: should verify that 'from' has the right value
1362− True <- return $ reason == "TestExit"
1460+ res <- return $ reason == "TestExit"
13631461 liftIO $ putMVar supervisedDone ()
1462+ if res
1463+ then return ()
1464+ else die "Something went horribly wrong"
13641465
13651466 runProcess node2 $ do
13661467 ref <- monitor pid
13671468 exit pid "TestExit"
1368− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1369− True <- return $ ref == ref' && pid == pid'
1370− liftIO $ putMVar supervisorDone ()
1469+ mn <- expect
1470+ case mn of
1471+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1472+ res' <- return $ ref == ref' && pid == pid'
1473+ liftIO $ putMVar supervisorDone ()
1474+ if res'
1475+ then return ()
1476+ else die "Something went horribly wrong"
1477+ _ -> die "Something went horribly wrong"
13711478
13721479 takeMVar supervisedDone
13731480 takeMVar supervisorDone
@@ -1497,8 +1604,7 @@ testUnsafeSend TestTransport{..} = do
14971604 void $ forkProcess localNode $ do
14981605 serverPid <- liftIO $ takeMVar serverAddr
14991606 getSelfPid >>= unsafeSend serverPid
1500− () <- expect
1501− liftIO $ putMVar clientDone ()
1607+ expect >>= liftIO . putMVar clientDone
15021608
15031609 takeMVar clientDone
15041610
@@ -1517,8 +1623,7 @@ testUnsafeUSend TestTransport{..} = do
15171623 void $ forkProcess localNode $ do
15181624 serverPid <- liftIO $ takeMVar serverAddr
15191625 getSelfPid >>= unsafeUSend serverPid
1520− () <- expect
1521− liftIO $ putMVar clientDone ()
1626+ expect >>= liftIO . putMVar clientDone
15221627
15231628 takeMVar clientDone
15241629
@@ -1529,8 +1634,7 @@ testUnsafeNSend TestTransport{..} = do
15291634 localNode <- newLocalNode testTransport initRemoteTable
15301635
15311636 pid <- forkProcess localNode $ do
1532− () <- expect
1533− liftIO $ putMVar clientDone ()
1637+ expect >>= liftIO . putMVar clientDone
15341638
15351639 void $ runProcess localNode $ do
15361640 register "foobar" pid
@@ -1548,8 +1652,7 @@ testUnsafeNSendRemote TestTransport{..} = do
15481652 _ <- forkProcess localNode1 $ do
15491653 getSelfPid >>= register "foobar"
15501654 liftIO $ putMVar clientDone ()
1551− () <- expect
1552− liftIO $ putMVar clientDone ()
1655+ expect >>= liftIO . putMVar clientDone
15531656
15541657 takeMVar clientDone
15551658 void $ runProcess localNode2 $ do
@@ -1573,7 +1676,7 @@ testUnsafeSendChan TestTransport{..} = do
15731676 serverPid <- liftIO $ takeMVar serverAddr
15741677 (sp, rp) <- newChan
15751678 unsafeSend serverPid sp
1576− () <- receiveChan rp
1679+ receiveChan rp :: Process ()
15771680 liftIO $ putMVar clientDone ()
15781681
15791682 takeMVar clientDone
@@ -1587,8 +1690,8 @@ testCallLocal TestTransport{..} = do
15871690 runProcess node $ do
15881691 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
15891692 liftIO $ putMVar result r
1590− True <- takeMVar result
1591− return ()
1693+
1694+ takeMVar result >>= assertBool "Expected 'True'"
15921695
15931696 -- Testing that when callLocal is interrupted, the worker is interrupted.
15941697 ibox <- newIORef False
@@ -1605,10 +1708,9 @@ testCallLocal TestTransport{..} = do
16051708 (send keeper ())
16061709 caller <- expect
16071710 exit caller "test"
1608− () <- expect
1609− return ()
1610− True <- readIORef ibox
1611− return ()
1711+ expect :: Process ()
1712+
1713+ readIORef ibox >>= assertBool "Expected 'True'"
16121714
16131715 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
16141716 ibox2 <- newIORef False
@@ -1617,8 +1719,8 @@ testCallLocal TestTransport{..} = do
16171719 liftIO $ writeIORef ibox2 $ case r of
16181720 Left (ErrorCall "e") -> True
16191721 _ -> False
1620− True <- readIORef ibox
1621− return ()
1722+
1723+ readIORef ibox >>= assertBool "Expected 'True'"
16221724
16231725 -- Test that caller waits for the worker in correct situation
16241726 ibox3 <- newIORef False
@@ -1635,8 +1737,8 @@ testCallLocal TestTransport{..} = do
16351737 liftIO $ putMVar result3 =<< readIORef ibox3
16361738 worker <- expect
16371739 send worker ()
1638− True <- takeMVar result3
1639− return ()
1740+
1741+ takeMVar result3 >>= assertBool "Expected 'True'"
16401742
16411743 -- Test that caller waits for the worker in case when caller gets an exception
16421744 ibox4 <- newIORef False
@@ -1652,13 +1754,9 @@ testCallLocal TestTransport{..} = do
16521754 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
16531755 caller <- expect
16541756 exit caller "hi!"
1655− True <- takeMVar result4
1656− return ()
1657− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1658−
1659−
1660−
16611757
1758+ takeMVar result4 >>= assertBool "Expected 'True'"
1759+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
16621760
16631761tests :: TestTransport -> IO [Test]
16641762tests testtrans = return [
@@ -1745,17 +1843,3 @@ tests testtrans = return [
17451843 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
17461844 ]
17471845 ]
1748−
1749−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1750−syncBreakConnection breakConnection nid0 nid1 = do
1751− m <- newEmptyMVar
1752− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1753− runProcess nid0 $ do
1754− them <- liftIO $ takeMVar m
1755− pinger <- spawnLocal $ forever $ send them ()
1756− _ <- monitorNode (localNodeId nid1)
1757− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1758− (nodeAddress $ localNodeId nid1)
1759− NodeMonitorNotification _ _ _ <- expect
1760− kill pinger "finished"
1761− return ()