@@ -39,7 +39,7 @@ import Control.Distributed.Process.Internal.Types
3939import Control.Distributed.Process.Node
4040import Control.Distributed.Process.Serializable (Serializable)
4141
42−import Test.HUnit (Assertion, assertFailure)
42+import Test.HUnit (Assertion, assertBool, assertFailure)
4343import Test.Framework (Test, testGroup)
4444import Test.Framework.Providers.HUnit (testCase)
4545import Control.Rematch hiding (match)
@@ -75,12 +75,47 @@ ping = do
7575 send partner (Ping self)
7676 ping
7777
78+verifyClient :: String -> MVar Bool -> IO ()
79+verifyClient s b = takeMVar b >>= assertBool s
80+
81+expectPing :: MVar Bool -> Process ()
82+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
83+ where
84+ checkPing (Ping _) = True
85+ checkPing _ = False
86+
7887-- | Quick and dirty synchronous version of whereisRemoteAsync
7988whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
8089whereisRemote nid string = do
8190 whereisRemoteAsync nid string
82− WhereIsReply _ mPid <- expect
83− return mPid
91+ receiveWait [
92+ match (\(WhereIsReply _ mPid) -> return mPid)
93+ ]
94+
95+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
96+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
97+
98+waitForExit :: ProcessId -> Process DiedReason
99+waitForExit pid = monitor pid >>= waitForDown
100+
101+waitForDown :: MonitorRef -> Process DiedReason
102+waitForDown ref =
103+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
104+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
105+
106+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
107+syncBreakConnection breakConnection nid0 nid1 = do
108+ m <- newEmptyMVar
109+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
110+ runProcess nid0 $ do
111+ them <- liftIO $ takeMVar m
112+ pinger <- spawnLocal $ forever $ send them ()
113+ _ <- monitorNode (localNodeId nid1)
114+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
115+ (nodeAddress $ localNodeId nid1)
116+ NodeMonitorNotification _ _ _ <- expect
117+ kill pinger "finished"
118+ return ()
84119
85120data Add = Add ProcessId Double Double deriving (Typeable)
86121data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -155,12 +190,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
155190 unmonitor ref
156191 liftIO $ putMVar done ()
157192 (False, ref) -> do
158− ProcessMonitorNotification ref' pid reason' <- expect
159− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
160− liftIO $ putMVar done ()
193+ receiveWait [
194+ match (\(ProcessMonitorNotification ref' pid reason') -> do
195+ liftIO $ do
196+ assertBool "Bad Monitor Signal"
197+ (Just ref' == ref && pid == theirAddr &&
198+ mOrL && reason == reason')
199+ putMVar done ())
200+ ]
161201 )
162202 (\(ProcessLinkException pid reason') -> do
163− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
203+ (liftIO $ assertBool "link exception unmatched" $
204+ pid == theirAddr && not mOrL && not un && reason == reason')
164205 liftIO $ putMVar done ()
165206 )
166207
@@ -191,8 +232,10 @@ testPing TestTransport{..} = do
191232 pid <- getSelfPid
192233 replicateM_ numPings $ do
193234 send pingServer (Pong pid)
194− Ping _ <- expect
195− return ()
235+ p <- expect
236+ case p of
237+ Ping _ -> return ()
238+ _ -> die "Unexpected message"
196239
197240 putMVar clientDone ()
198241
@@ -279,7 +322,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
279322 runProcess localNode $ do
280323 monitor theirAddr
281324 -- wait for the process to die
282− ProcessMonitorNotification _ _ _ <- expect
325+ expect :: Process ProcessMonitorNotification
283326 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
284327
285328 takeMVar done
@@ -353,14 +396,17 @@ testMath TestTransport{..} = do
353396 runProcess localNode $ do
354397 pid <- getSelfPid
355398 send mathServer (Add pid 1 2)
356− 3 <- expect :: Process Double
399+ three <- expect :: Process Double
357400 send mathServer (Divide pid 8 2)
358− 4 <- expect :: Process Double
401+ four <- expect :: Process Double
359402 send mathServer (Divide pid 8 0)
360− DivByZero <- expect
361− liftIO $ putMVar clientDone ()
403+ divByZ <- expect
404+ liftIO $ putMVar clientDone (three, four, divByZ)
362405
363− takeMVar clientDone
406+ res <- takeMVar clientDone
407+ case res of
408+ (3, 4, DivByZero) -> return ()
409+ _ -> error $ "Something went horribly wrong"
364410
365411-- | Send first message (i.e. connect) to an already terminated process
366412-- (without monitoring); then send another message to a second process on
@@ -388,11 +434,9 @@ testSendToTerminated TestTransport{..} = do
388434 pid <- getSelfPid
389435 send server1 "Hi"
390436 send server2 (Pong pid)
391− Ping pid' <- expect
392− True <- return $ pid' == server2
393− liftIO $ putMVar clientDone ()
437+ expectPing clientDone
394438
395− takeMVar clientDone
439+ verifyClient "Expected Ping from server" clientDone
396440
397441-- | Test (non-zero) timeout
398442testTimeout :: TestTransport -> Assertion
@@ -401,10 +445,10 @@ testTimeout TestTransport{..} = do
401445 done <- newEmptyMVar
402446
403447 runProcess localNode $ do
404− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
405− liftIO $ putMVar done ()
448+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
449+ liftIO $ putMVar done $ res == Nothing
406450
407− takeMVar done
451+ verifyClient "Expected receiveTimeout to timeout..." done
408452
409453-- | Test zero timeout
410454testTimeout0 :: TestTransport -> Assertion
@@ -432,10 +476,9 @@ testTimeout0 TestTransport{..} = do
432476 -- is not interested in, and then a single message that it wants
433477 replicateM_ 10000 $ send server "Irrelevant message"
434478 send server (Pong pid)
435− Ping _ <- expect
436− liftIO $ putMVar clientDone ()
479+ expectPing clientDone
437480
438− takeMVar clientDone
481+ verifyClient "Expected Ping from server" clientDone
439482
440483-- | Test typed channels
441484testTypedChannels :: TestTransport -> Assertion
@@ -458,10 +501,10 @@ testTypedChannels TestTransport{..} = do
458501 runProcess localNode $ do
459502 (clientSendPort, rport) <- newChan
460503 sendChan serverSendPort (clientSendPort, 5)
461− False <- receiveChan rport
462− liftIO $ putMVar clientDone ()
504+ ch <- receiveChan rport
505+ liftIO $ putMVar clientDone $ ch == False
463506
464− takeMVar clientDone
507+ verifyClient "Expected channel to send 'False'" clientDone
465508
466509-- | Test merging receive ports
467510testMergeChannels :: TestTransport -> Assertion
@@ -484,9 +527,8 @@ testMergeChannels TestTransport{..} = do
484527 rs <- mapM charChannel "abc"
485528 m <- mergePorts biased rs
486529 xs <- replicateM 9 $ receiveChan m
487− True <- return $ xs == expected
488− liftIO $ putMVar done ()
489− takeMVar done
530+ liftIO $ putMVar done $ xs == expected
531+ verifyClient "Expected single layer merge to match expected ordering" done
490532
491533 -- Two layers of merging
492534 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -497,9 +539,8 @@ testMergeChannels TestTransport{..} = do
497539 ms <- mapM (mergePorts biasedInner) rss
498540 m <- mergePorts biasedOuter ms
499541 xs <- replicateM (9 * 3) $ receiveChan m
500− True <- return $ xs == expected
501− liftIO $ putMVar done ()
502− takeMVar done
542+ liftIO $ putMVar done $ xs == expected
543+ verifyClient "Expected nested channels to match expeted ordering" done
503544
504545 -- Test that if no messages are (immediately) available, the scheduler makes no difference
505546 testBlocked :: LocalNode -> Bool -> IO ()
@@ -508,43 +549,45 @@ testMergeChannels TestTransport{..} = do
508549 done <- newEmptyMVar
509550
510551 forkProcess localNode $ do
511− [sa, sb, sc] <- liftIO $ mapM readMVar vs
512− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
513− [ -- a, b, c
514− (sa, 'a')
515− , (sb, 'b')
516− , (sc, 'c')
517− -- a, c, b
518− , (sa, 'a')
519− , (sc, 'c')
520− , (sb, 'b')
521− -- b, a, c
522− , (sb, 'b')
523− , (sa, 'a')
524− , (sc, 'c')
525− -- b, c, a
526− , (sb, 'b')
527− , (sc, 'c')
528− , (sa, 'a')
529− -- c, a, b
530− , (sc, 'c')
531− , (sa, 'a')
532− , (sb, 'b')
533− -- c, b, a
534− , (sc, 'c')
535− , (sb, 'b')
536− , (sa, 'a')
537− ]
552+ ss <- liftIO $ mapM readMVar vs
553+ case ss of
554+ [sa, sb, sc] ->
555+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
556+ [ -- a, b, c
557+ (sa, 'a')
558+ , (sb, 'b')
559+ , (sc, 'c')
560+ -- a, c, b
561+ , (sa, 'a')
562+ , (sc, 'c')
563+ , (sb, 'b')
564+ -- b, a, c
565+ , (sb, 'b')
566+ , (sa, 'a')
567+ , (sc, 'c')
568+ -- b, c, a
569+ , (sb, 'b')
570+ , (sc, 'c')
571+ , (sa, 'a')
572+ -- c, a, b
573+ , (sc, 'c')
574+ , (sa, 'a')
575+ , (sb, 'b')
576+ -- c, b, a
577+ , (sc, 'c')
578+ , (sb, 'b')
579+ , (sa, 'a')
580+ ]
581+ _ -> die "Something went horribly wrong"
538582
539583 forkProcess localNode $ do
540584 (ss, rs) <- unzip <$> replicateM 3 newChan
541585 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
542586 m <- mergePorts biased rs
543587 xs <- replicateM (6 * 3) $ receiveChan m
544− True <- return $ xs == "abcacbbacbcacabcba"
545− liftIO $ putMVar done ()
588+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
546589
547− takeMVar done
590+ verifyClient "Expected merged ports to match expected ordering" done
548591
549592 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
550593 mergePorts True = mergePortsBiased
@@ -562,8 +605,9 @@ testTerminate TestTransport{..} = do
562605 localNode <- newLocalNode testTransport initRemoteTable
563606 runProcess localNode $ do
564607 e <- try terminate :: Process (Either ProcessTerminationException ())
565− True <- return $ either show show e == show ProcessTerminationException
566− return ()
608+ if either show show e == show ProcessTerminationException
609+ then return ()
610+ else die "Unexpected result from terminate"
567611
568612testMonitorNode :: TestTransport -> Assertion
569613testMonitorNode TestTransport{..} = do
@@ -574,11 +618,12 @@ testMonitorNode TestTransport{..} = do
574618
575619 runProcess node2 $ do
576620 ref <- monitorNode (localNodeId node1)
577− NodeMonitorNotification ref' nid DiedDisconnect <- expect
578− True <- return $ ref == ref' && nid == localNodeId node1
579− liftIO $ putMVar done ()
621+ receiveWait [
622+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
623+ return $ ref == ref' && nid == localNodeId node1)
624+ ] >>= liftIO . putMVar done
580625
581− takeMVar done
626+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
582627
583628testMonitorLiveNode :: TestTransport -> Assertion
584629testMonitorLiveNode TestTransport{..} = do
@@ -593,15 +638,16 @@ testMonitorLiveNode TestTransport{..} = do
593638 liftIO $ putMVar ready ()
594639 liftIO $ takeMVar readyr
595640 send p ()
596− NodeMonitorNotification ref' nid _ <- expect
597− True <- return $ ref == ref' && nid == localNodeId node1
598− liftIO $ putMVar done ()
641+ receiveWait [
642+ match (\(NodeMonitorNotification ref' nid _) ->
643+ (return $ ref == ref' && nid == localNodeId node1))
644+ ] >>= liftIO . putMVar done
599645
600646 takeMVar ready
601647 closeLocalNode node1
602648 putMVar readyr ()
603649
604− takeMVar done
650+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
605651
606652testMonitorChannel :: TestTransport -> Assertion
607653testMonitorChannel TestTransport{..} = do
@@ -611,18 +657,20 @@ testMonitorChannel TestTransport{..} = do
611657 pid <- forkProcess node1 $ do
612658 sport <- expect :: Process (SendPort ())
613659 ref <- monitorPort sport
614− PortMonitorNotification ref' port' reason <- expect
615− -- reason might be DiedUnknownId if the receive port is GCed before the
616− -- monitor is established (TODO: not sure that this is reasonable)
617− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
618− liftIO $ putMVar gotNotification ()
660+ receiveWait [
661+ -- reason might be DiedUnknownId if the receive port is GCed before the
662+ -- monitor is established (TODO: not sure that this is reasonable)
663+ match (\(PortMonitorNotification ref' port' reason) ->
664+ return $ ref' == ref && port' == sendPortId sport &&
665+ (reason == DiedNormal || reason == DiedUnknownId))
666+ ] >>= liftIO . putMVar gotNotification
619667
620668 runProcess node2 $ do
621669 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
622670 send pid sport
623671 liftIO $ threadDelay 100000
624672
625− takeMVar gotNotification
673+ verifyClient "Expected PortMonitorNotification" gotNotification
626674
627675testRegistry :: TestTransport -> Assertion
628676testRegistry TestTransport{..} = do
@@ -634,20 +682,28 @@ testRegistry TestTransport{..} = do
634682
635683 runProcess node $ do
636684 register "ping" pingServer
637− Just pid <- whereis "ping"
638− True <- return $ pingServer == pid
685+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
639686 us <- getSelfPid
640687 nsend "ping" (Pong us)
641− Ping pid' <- expect
642− True <- return $ pingServer == pid'
643− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
644− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
645− True <- return $ x == pingServer
646− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
688+ receiveWait [
689+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
690+ ]
691+ checkRegException "dead" Nothing deadProcess
692+ checkRegException "ping" (Just pingServer) deadProcess
693+ try (unregister "dead") >>= checkReg "dead" Nothing
647694 liftIO $ putMVar done ()
648695
649696 takeMVar done
650697
698+ where
699+ checkRegException name pid dead =
700+ try (register name dead) >>= checkReg name pid
701+
702+ checkReg name pid res =
703+ case res of
704+ Left (ProcessRegistrationException name pid) -> return ()
705+ _ -> die $ "Unexpected Registration" ++ show res
706+
651707testRegistryRemoteProcess :: TestTransport -> Assertion
652708testRegistryRemoteProcess TestTransport{..} = do
653709 node1 <- newLocalNode testTransport initRemoteTable
@@ -658,13 +714,13 @@ testRegistryRemoteProcess TestTransport{..} = do
658714
659715 runProcess node2 $ do
660716 register "ping" pingServer
661− Just pid <- whereis "ping"
662− True <- return $ pingServer == pid
717+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
663718 us <- getSelfPid
664719 nsend "ping" (Pong us)
665− Ping pid' <- expect
666− True <- return $ pingServer == pid'
667− liftIO $ putMVar done ()
720+ receiveWait [
721+ matchIf (\(Ping pid') -> pingServer == pid')
722+ (const $ liftIO $ putMVar done ())
723+ ]
668724
669725 takeMVar done
670726
@@ -685,12 +741,13 @@ testRemoteRegistry TestTransport{..} = do
685741 "ping" == label' && pid == pingServer)
686742 (\(RegisterReply _ _ _) -> return ()) ]
687743
688− Just pid <- whereisRemote nid1 "ping"
689− True <- return $ pingServer == pid
744+ pid <- verifyWhereIsRemote nid1 "ping"
745+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
690746 us <- getSelfPid
691747 nsendRemote nid1 "ping" (Pong us)
692− Ping pid' <- expect
693− True <- return $ pingServer == pid'
748+ receiveWait [
749+ match (\(Ping pid') -> return $ pingServer == pid')
750+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
694751
695752 -- test that if process was not registered Nothing is returned
696753 -- in owner field.
@@ -726,15 +783,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
726783 receiveWait [
727784 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
728785 (\(RegisterReply _ _ _) -> return ()) ]
729− Just pid <- whereisRemote nid1 "ping"
730− True <- return $ pingServer == pid
786+ pid <- verifyWhereIsRemote nid1 "ping"
787+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
731788 us <- getSelfPid
732789 nsendRemote nid1 "ping" (Pong us)
733− Ping pid' <- expect
734− True <- return $ pingServer == pid'
735− liftIO $ putMVar done ()
790+ receiveWait [
791+ match (\(Ping pid') -> return $ pingServer == pid')
792+ ] >>= liftIO . putMVar done
736793
737− takeMVar done
794+ verifyClient "Expected Ping with ping server's ProcessId" done
738795
739796testSpawnLocal :: TestTransport -> Assertion
740797testSpawnLocal TestTransport{..} = do
@@ -748,15 +805,14 @@ testSpawnLocal TestTransport{..} = do
748805 sport <- expect
749806 sendChan sport (1234 :: Int)
750807
751− sport <- spawnChannelLocal $ \rport -> do
752− (1234 :: Int) <- receiveChan rport
753− send us ()
808+ sport <- spawnChannelLocal $
809+ \rport -> (receiveChan rport :: Process Int) >>= send us
754810
755811 send pid sport
756− () <- expect
757− liftIO $ putMVar done ()
812+ expect >>= liftIO . putMVar done
758813
759− takeMVar done
814+ res <- takeMVar done
815+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
760816
761817testSpawnAsyncStrictness :: TestTransport -> Assertion
762818testSpawnAsyncStrictness TestTransport{..} = do
@@ -785,8 +841,9 @@ testReconnect TestTransport{..} = do
785841 liftIO $ putMVar processA us
786842 msg1 <- expect
787843 msg2 <- expect
788− True <- return $ msg1 == "message 1" && msg2 == "message 3"
789− liftIO $ putMVar sendTestOk ()
844+ liftIO $ do
845+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
846+ putMVar sendTestOk ()
790847
791848 forkProcess node2 $ do
792849 {-
@@ -819,7 +876,7 @@ testReconnect TestTransport{..} = do
819876 matchIf (\(RegisterReply label' _ _) -> "a" == label')
820877 (\(RegisterReply _ _ _) -> return ()) ]
821878
822− Just _ <- whereisRemote nid1 "a"
879+ _ <- whereisRemote nid1 "a"
823880
824881
825882 -- Simulate network failure
@@ -838,9 +895,10 @@ testReconnect TestTransport{..} = do
838895 (\(RegisterReply _ _ _) -> return ()) ]
839896
840897 -- Check
841− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
842− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
843− Just _ <- whereisRemote nid1 "c"
898+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
899+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
900+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
901+ verifyWhereIsRemote nid1 "c"
844902
845903 liftIO $ putMVar registerTestOk ()
846904
@@ -881,13 +939,14 @@ testUSend usendPrim TestTransport{..} numMessages = do
881939 isSorted _ = True
882940 -- The list can't be null since there are no failures after sending
883941 -- the last message.
884− True <- return $ isSorted msgs && not (null msgs)
885− liftIO $ putMVar usendTestOk ()
942+ liftIO $ do
943+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)
944+ putMVar usendTestOk ()
886945
887946 forkProcess node2 $ do
888947 them <- liftIO $ readMVar processA
889948 getSelfPid >>= send them
890− () <- expect
949+ expect :: Process ()
891950 forM_ [1..numMessages] $ \i -> do
892951 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
893952 usendPrim them i
@@ -919,14 +978,17 @@ testMatchAny TestTransport{..} = do
919978 runProcess localNode $ do
920979 pid <- getSelfPid
921980 send mathServer (Add pid 1 2)
922− 3 <- expect :: Process Double
981+ three <- expect :: Process Double
923982 send mathServer (Divide pid 8 2)
924− 4 <- expect :: Process Double
983+ four <- expect :: Process Double
925984 send mathServer (Divide pid 8 0)
926− DivByZero <- expect
927− liftIO $ putMVar clientDone ()
985+ divByZ <- expect
986+ liftIO $ putMVar clientDone (three, four, divByZ)
928987
929− takeMVar clientDone
988+ res <- takeMVar clientDone
989+ case res of
990+ (3, 4, DivByZero) -> return ()
991+ _ -> error "Unexpected result"
930992
931993-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
932994-- in between, however we block 'Divide' requests ....
@@ -953,12 +1015,13 @@ testMatchAnyHandle TestTransport{..} = do
9531015 runProcess localNode $ do
9541016 pid <- getSelfPid
9551017 send mathServer (Add pid 1 2)
956− 3 <- expect :: Process Double
1018+ three <- expect :: Process Double
9571019 send mathServer (Divide pid 8 2)
958− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
959− liftIO $ putMVar clientDone ()
1020+ res <- (expectTimeout 100000) :: Process (Maybe Double)
1021+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1022+
1023+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
9601024
961− takeMVar clientDone
9621025 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
9631026 maybeForward s msg =
9641027 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -986,8 +1049,10 @@ testMatchAnyNoHandle TestTransport{..} = do
9861049 Just _ -> die "NONSENSE")
9871050 ]
9881051 -- we *must* have removed the message from our mailbox though!!!
989− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
990− liftIO $ putMVar serverDone ()
1052+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1053+ liftIO $ do
1054+ assertBool "Expected timeout!" $ res == Nothing
1055+ putMVar serverDone ()
9911056 putMVar addr server
9921057
9931058 -- Client
@@ -1030,14 +1095,21 @@ testMatchAnyIf TestTransport{..} = do
10301095 runProcess localNode $ do
10311096 pid <- getSelfPid
10321097 send server (pid, "foo")
1033− "foo" <- expect
1034− send server (pid, "baz")
1035− "baz" <- expect
1098+ foo <- expect
1099+ -- provoking what would be the wrong ordering is informative here...
1100+
10361101 send server (pid, "bar")
1037− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1038− liftIO $ putMVar clientDone ()
1102+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1103+
1104+ send server (pid, "baz")
1105+ baz <- expect
1106+
1107+ liftIO $ putMVar clientDone (foo, bar, baz)
1108+
1109+ res <- takeMVar clientDone
1110+ let res' = res == ("foo", Nothing, "baz")
1111+ assertBool "Expected timeout due to type mismatch" res'
10391112
1040− takeMVar clientDone
10411113 where tryHandleMessage :: Message -> Process (Maybe ())
10421114 tryHandleMessage msg =
10431115 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1070,12 +1142,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do
10701142 runProcess localNode $ do
10711143 pid <- getSelfPid
10721144 send server (pid, wrapMessage ("foo" :: String))
1073− "foo" <- expect
1145+ foo <- expect
10741146 send server (pid, wrapMessage ("baz" :: String))
1075− "baz" <- expect
1076− liftIO $ putMVar clientDone ()
1147+ baz <- expect
1148+ liftIO $ putMVar clientDone (foo, baz)
10771149
1078− takeMVar clientDone
1150+ res <- takeMVar clientDone
1151+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
10791152
10801153-- Test 'receiveChanTimeout'
10811154testReceiveChanTimeout :: TestTransport -> Assertion
@@ -1093,18 +1166,19 @@ testReceiveChanTimeout TestTransport{..} = do
10931166
10941167 -- Wait for a message with a delay. No message arrives, we should get
10951168 -- Nothing after the delay.
1096− Nothing <- receiveChanTimeout 100000 rp
1169+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
10971170
10981171 -- Let the sender know that it can send a message.
10991172 liftIO $ putMVar mvSender ()
11001173
11011174 -- Wait for a message with a delay again. Now a message arrives after
11021175 -- 0.1 seconds
1103− Just True <- receiveChanTimeout 20000000 rp
1176+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1177+ liftIO $ assertBool "Expected result to be 'True'" res
11041178
11051179 -- Wait for a message with zero timeout: non-blocking check. No message is
11061180 -- available, we get Nothing
1107− Nothing <- receiveChanTimeout 0 rp
1181+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11081182
11091183 -- Let the sender know that it can send a message.
11101184 liftIO $ putMVar mvSender ()
@@ -1114,7 +1188,7 @@ testReceiveChanTimeout TestTransport{..} = do
11141188 liftIO $ threadDelay 100000
11151189 mb <- receiveChanTimeout 0 rp
11161190 case mb of
1117− Just b -> do False <- return b; return ()
1191+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
11181192 _ -> loop
11191193
11201194 liftIO $ putMVar done ()
@@ -1151,8 +1225,8 @@ testReceiveChanFeatures TestTransport{..} = do
11511225
11521226 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
11531227
1154− True <- receiveChan rp1
1155− False <- receiveChan rp1
1228+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1229+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
11561230
11571231 -- Test Applicative instance
11581232
@@ -1161,7 +1235,7 @@ testReceiveChanFeatures TestTransport{..} = do
11611235
11621236 let rp2 = pure (+) <*> rpInt <*> rpInt
11631237
1164− 7 <- receiveChan rp2
1238+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
11651239
11661240 -- Test Alternative instance
11671241
@@ -1170,8 +1244,8 @@ testReceiveChanFeatures TestTransport{..} = do
11701244
11711245 let rp3 = (even <$> rpInt) <|> rpBool
11721246
1173− False <- receiveChan rp3
1174− True <- receiveChan rp3
1247+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1248+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
11751249
11761250 -- Test Monad instance
11771251
@@ -1185,8 +1259,8 @@ testReceiveChanFeatures TestTransport{..} = do
11851259 then rpInt
11861260 else return 7
11871261
1188− 5 <- receiveChan rp4
1189− 7 <- receiveChan rp4
1262+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1263+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
11901264
11911265 liftIO $ putMVar done ()
11921266
@@ -1195,7 +1269,6 @@ testReceiveChanFeatures TestTransport{..} = do
11951269testKillLocal :: TestTransport -> Assertion
11961270testKillLocal TestTransport{..} = do
11971271 localNode <- newLocalNode testTransport initRemoteTable
1198− done <- newEmptyMVar
11991272
12001273 pid <- forkProcess localNode $ do
12011274 liftIO $ threadDelay 1000000
@@ -1204,17 +1277,18 @@ testKillLocal TestTransport{..} = do
12041277 ref <- monitor pid
12051278 us <- getSelfPid
12061279 kill pid "TestKill"
1207− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1208− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1209− liftIO $ putMVar done ()
1210−
1211− takeMVar done
1280+ mn <- expect
1281+ case mn of
1282+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1283+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1284+ True -> return ()
1285+ False -> die "Invalid ProcessMonitorNotification received"
1286+ _ -> die "Something went horribly wrong"
12121287
12131288testKillRemote :: TestTransport -> Assertion
12141289testKillRemote TestTransport{..} = do
12151290 node1 <- newLocalNode testTransport initRemoteTable
12161291 node2 <- newLocalNode testTransport initRemoteTable
1217− done <- newEmptyMVar
12181292
12191293 pid <- forkProcess node1 $ do
12201294 liftIO $ threadDelay 1000000
@@ -1223,11 +1297,17 @@ testKillRemote TestTransport{..} = do
12231297 ref <- monitor pid
12241298 us <- getSelfPid
12251299 kill pid "TestKill"
1226− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1227− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1228− liftIO $ putMVar done ()
1229−
1230− takeMVar done
1300+ mn <- expect
1301+ case mn of
1302+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1303+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1304+ (True, True, True) -> return ()
1305+ (a, b, c) -> do
1306+ let a' = if a then "" else "Invalid ref"
1307+ let b' = if b then "" else "Invalid pid"
1308+ let c' = if c then "" else "Invalid message"
1309+ die $ unwords [a', b', c']
1310+ _ -> die "Received unexpected message"
12311311
12321312testCatchesExit :: TestTransport -> Assertion
12331313testCatchesExit TestTransport{..} = do
@@ -1253,7 +1333,10 @@ testHandleMessageIf TestTransport{..} = do
12531333 self <- getSelfPid
12541334 send self (5 :: Integer, 10 :: Integer)
12551335 msg <- receiveWait [ matchMessage return ]
1256− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1336+ handleMessageIf msg
1337+ (\() -> True)
1338+ (\() -> die "whoops") >>= maybe (return ())
1339+ (const $ die "Expected Mismatch")
12571340 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
12581341 (\input -> liftIO $ putMVar done input)
12591342 return ()
@@ -1298,8 +1381,11 @@ testDie TestTransport{..} = do
12981381 (die ("foobar", 123 :: Int))
12991382 `catchExit` \_from reason -> do
13001383 -- TODO: should verify that 'from' has the right value
1301− True <- return $ reason == ("foobar", 123 :: Int)
1384+ let res = reason == ("foobar", 123 :: Int)
13021385 liftIO $ putMVar done ()
1386+ if res
1387+ then return ()
1388+ else die "Something went horribly wrong"
13031389
13041390 takeMVar done
13051391
@@ -1313,8 +1399,11 @@ testPrettyExit TestTransport{..} = do
13131399 `catch` \ex@(ProcessExitException from _) ->
13141400 let expected = "exit-from=" ++ (show from)
13151401 in do
1316− True <- return $ (show ex) == expected
1402+ let res = (show ex) == expected
13171403 liftIO $ putMVar done ()
1404+ if res
1405+ then return ()
1406+ else die "Something went horribly wrong"
13181407
13191408 takeMVar done
13201409
@@ -1330,17 +1419,26 @@ testExitLocal TestTransport{..} = do
13301419 pid <- forkProcess localNode $ do
13311420 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
13321421 -- TODO: should verify that 'from' has the right value
1333− True <- return $ reason == "TestExit"
1422+ res <- return $ reason == "TestExit"
13341423 liftIO $ putMVar supervisedDone ()
1424+ if res
1425+ then return ()
1426+ else die "Something went horribly wrong"
13351427
13361428 runProcess localNode $ do
13371429 liftIO $ takeMVar handlerSetUp
13381430 ref <- monitor pid
13391431 exit pid "TestExit"
13401432 -- This time the client catches the exception, so it dies normally
1341− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1342− True <- return $ ref == ref' && pid == pid'
1343− liftIO $ putMVar supervisorDone ()
1433+ mn <- expect
1434+ case mn of
1435+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1436+ let res = ref == ref' && pid == pid'
1437+ liftIO $ putMVar supervisorDone ()
1438+ if res
1439+ then return ()
1440+ else die "Something went horribly wrong"
1441+ _ -> die "Something went horribly wrong"
13441442
13451443 takeMVar supervisedDone
13461444 takeMVar supervisorDone
@@ -1356,15 +1454,24 @@ testExitRemote TestTransport{..} = do
13561454 (receiveWait [] :: Process ()) -- block forever
13571455 `catchExit` \_from reason -> do
13581456 -- TODO: should verify that 'from' has the right value
1359− True <- return $ reason == "TestExit"
1457+ res <- return $ reason == "TestExit"
13601458 liftIO $ putMVar supervisedDone ()
1459+ if res
1460+ then return ()
1461+ else die "Something went horribly wrong"
13611462
13621463 runProcess node2 $ do
13631464 ref <- monitor pid
13641465 exit pid "TestExit"
1365− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1366− True <- return $ ref == ref' && pid == pid'
1367− liftIO $ putMVar supervisorDone ()
1466+ mn <- expect
1467+ case mn of
1468+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1469+ res' <- return $ ref == ref' && pid == pid'
1470+ liftIO $ putMVar supervisorDone ()
1471+ if res'
1472+ then return ()
1473+ else die "Something went horribly wrong"
1474+ _ -> die "Something went horribly wrong"
13681475
13691476 takeMVar supervisedDone
13701477 takeMVar supervisorDone
@@ -1384,8 +1491,7 @@ testUnsafeSend TestTransport{..} = do
13841491 void $ forkProcess localNode $ do
13851492 serverPid <- liftIO $ takeMVar serverAddr
13861493 getSelfPid >>= unsafeSend serverPid
1387− () <- expect
1388− liftIO $ putMVar clientDone ()
1494+ expect >>= liftIO . putMVar clientDone
13891495
13901496 takeMVar clientDone
13911497
@@ -1404,8 +1510,7 @@ testUnsafeUSend TestTransport{..} = do
14041510 void $ forkProcess localNode $ do
14051511 serverPid <- liftIO $ takeMVar serverAddr
14061512 getSelfPid >>= unsafeUSend serverPid
1407− () <- expect
1408− liftIO $ putMVar clientDone ()
1513+ expect >>= liftIO . putMVar clientDone
14091514
14101515 takeMVar clientDone
14111516
@@ -1416,8 +1521,7 @@ testUnsafeNSend TestTransport{..} = do
14161521 localNode <- newLocalNode testTransport initRemoteTable
14171522
14181523 pid <- forkProcess localNode $ do
1419− () <- expect
1420− liftIO $ putMVar clientDone ()
1524+ expect >>= liftIO . putMVar clientDone
14211525
14221526 void $ runProcess localNode $ do
14231527 register "foobar" pid
@@ -1435,8 +1539,7 @@ testUnsafeNSendRemote TestTransport{..} = do
14351539 _ <- forkProcess localNode1 $ do
14361540 getSelfPid >>= register "foobar"
14371541 liftIO $ putMVar clientDone ()
1438− () <- expect
1439− liftIO $ putMVar clientDone ()
1542+ expect >>= liftIO . putMVar clientDone
14401543
14411544 takeMVar clientDone
14421545 void $ runProcess localNode2 $ do
@@ -1460,7 +1563,7 @@ testUnsafeSendChan TestTransport{..} = do
14601563 serverPid <- liftIO $ takeMVar serverAddr
14611564 (sp, rp) <- newChan
14621565 unsafeSend serverPid sp
1463− () <- receiveChan rp
1566+ receiveChan rp :: Process ()
14641567 liftIO $ putMVar clientDone ()
14651568
14661569 takeMVar clientDone
@@ -1474,8 +1577,8 @@ testCallLocal TestTransport{..} = do
14741577 runProcess node $ do
14751578 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
14761579 liftIO $ putMVar result r
1477− True <- takeMVar result
1478− return ()
1580+
1581+ takeMVar result >>= assertBool "Expected 'True'"
14791582
14801583 -- Testing that when callLocal is interrupted, the worker is interrupted.
14811584 ibox <- newIORef False
@@ -1492,10 +1595,9 @@ testCallLocal TestTransport{..} = do
14921595 (send keeper ())
14931596 caller <- expect
14941597 exit caller "test"
1495− () <- expect
1496− return ()
1497− True <- readIORef ibox
1498− return ()
1598+ expect :: Process ()
1599+
1600+ readIORef ibox >>= assertBool "Expected 'True'"
14991601
15001602 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
15011603 ibox2 <- newIORef False
@@ -1504,8 +1606,8 @@ testCallLocal TestTransport{..} = do
15041606 liftIO $ writeIORef ibox2 $ case r of
15051607 Left (ErrorCall "e") -> True
15061608 _ -> False
1507− True <- readIORef ibox
1508− return ()
1609+
1610+ readIORef ibox >>= assertBool "Expected 'True'"
15091611
15101612 -- Test that caller waits for the worker in correct situation
15111613 ibox3 <- newIORef False
@@ -1522,8 +1624,8 @@ testCallLocal TestTransport{..} = do
15221624 liftIO $ putMVar result3 =<< readIORef ibox3
15231625 worker <- expect
15241626 send worker ()
1525− True <- takeMVar result3
1526− return ()
1627+
1628+ takeMVar result3 >>= assertBool "Expected 'True'"
15271629
15281630 -- Test that caller waits for the worker in case when caller gets an exception
15291631 ibox4 <- newIORef False
@@ -1539,13 +1641,9 @@ testCallLocal TestTransport{..} = do
15391641 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
15401642 caller <- expect
15411643 exit caller "hi!"
1542− True <- takeMVar result4
1543− return ()
1544− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1545−
1546−
1547−
15481644
1645+ takeMVar result4 >>= assertBool "Expected 'True'"
1646+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
15491647
15501648tests :: TestTransport -> IO [Test]
15511649tests testtrans = return [
@@ -1631,17 +1729,3 @@ tests testtrans = return [
16311729 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
16321730 ]
16331731 ]
1634−
1635−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1636−syncBreakConnection breakConnection nid0 nid1 = do
1637− m <- newEmptyMVar
1638− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1639− runProcess nid0 $ do
1640− them <- liftIO $ takeMVar m
1641− pinger <- spawnLocal $ forever $ send them ()
1642− _ <- monitorNode (localNodeId nid1)
1643− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1644− (nodeAddress $ localNodeId nid1)
1645− NodeMonitorNotification _ _ _ <- expect
1646− kill pinger "finished"
1647− return ()