@@ -25,24 +25,32 @@ import Control.Concurrent.MVar
2525 )
2626import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
2727import Control.Exception (SomeException, throwIO, ErrorCall(..))
28−import qualified Control.Exception as Ex (catch)
29−import Control.Applicative ((<$>), (<*>), pure, (<|>))
28+import Control.Monad.Catch (try, catch, finally, mask, onException)
29+import Control.Applicative ((<|>))
3030import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31−import Control.Distributed.Process
31+import Control.Distributed.Process hiding
32+ ( try
33+ , catch
34+ , finally
35+ , mask
36+ , onException
37+ )
3238import Control.Distributed.Process.Internal.Types
33− ( NodeId(nodeAddress)
34− , LocalNode(localEndPoint)
39+ ( LocalNode(localEndPoint)
3540 , ProcessExitException(..)
3641 , nullProcessId
3742 , createUnencodedMessage
3843 )
3944import 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, pause)
4048import Control.Distributed.Process.Serializable (Serializable)
41−
42−import Test.HUnit (Assertion, assertFailure)
49+import Data.Maybe (isNothing, isJust)
50+import Test.HUnit (Assertion, assertBool, assertFailure)
4351import Test.Framework (Test, testGroup)
4452import Test.Framework.Providers.HUnit (testCase)
45−import Control.Rematch hiding (match)
53+import Control.Rematch hiding (match, isNothing, isJust)
4654import Control.Rematch.Run (Match(..))
4755
4856newtype Ping = Ping ProcessId
@@ -65,7 +73,7 @@ expectThat a matcher = case res of
6573forkTry :: IO () -> IO ThreadId
6674forkTry p = do
6775 tid <- myThreadId
68− forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
76+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
6977
7078-- | The ping server from the paper
7179ping :: Process ()
@@ -75,12 +83,46 @@ ping = do
7583 send partner (Ping self)
7684 ping
7785
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+
7894-- | Quick and dirty synchronous version of whereisRemoteAsync
7995whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
8096whereisRemote nid string = do
8197 whereisRemoteAsync nid string
82− WhereIsReply _ mPid <- expect
83− return mPid
98+ receiveWait [
99+ match (\(WhereIsReply _ mPid) -> return mPid)
100+ ]
101+
102+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
103+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
104+
105+waitForExit :: ProcessId -> Process DiedReason
106+waitForExit pid = monitor pid >>= waitForDown
107+
108+waitForDown :: MonitorRef -> Process DiedReason
109+waitForDown ref =
110+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
111+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
112+
113+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
114+syncBreakConnection breakConnection nid0 nid1 = do
115+ m <- newEmptyMVar
116+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
117+ runProcess nid0 $ do
118+ them <- liftIO $ takeMVar m
119+ pinger <- spawnLocal $ forever $ send them ()
120+ _ <- monitorNode (localNodeId nid1)
121+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
122+ (nodeAddress $ localNodeId nid1)
123+ NodeMonitorNotification _ _ _ <- expect
124+ kill pinger "finished"
125+ return ()
84126
85127data Add = Add ProcessId Double Double deriving (Typeable)
86128data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -155,12 +197,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
155197 unmonitor ref
156198 liftIO $ putMVar done ()
157199 (False, ref) -> do
158− ProcessMonitorNotification ref' pid reason' <- expect
159− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
160− liftIO $ putMVar done ()
200+ receiveWait [
201+ match (\(ProcessMonitorNotification ref' pid reason') -> do
202+ liftIO $ do
203+ assertBool "Bad Monitor Signal"
204+ (Just ref' == ref && pid == theirAddr &&
205+ mOrL && reason == reason')
206+ putMVar done ())
207+ ]
161208 )
162209 (\(ProcessLinkException pid reason') -> do
163− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
210+ (liftIO $ assertBool "link exception unmatched" $
211+ pid == theirAddr && not mOrL && not un && reason == reason')
164212 liftIO $ putMVar done ()
165213 )
166214
@@ -191,8 +239,10 @@ testPing TestTransport{..} = do
191239 pid <- getSelfPid
192240 replicateM_ numPings $ do
193241 send pingServer (Pong pid)
194− Ping _ <- expect
195− return ()
242+ p <- expectTimeout 3000000
243+ case p of
244+ Just (Ping _) -> return ()
245+ Nothing -> die "Failed to receive Ping"
196246
197247 putMVar clientDone ()
198248
@@ -279,7 +329,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
279329 runProcess localNode $ do
280330 monitor theirAddr
281331 -- wait for the process to die
282− ProcessMonitorNotification _ _ _ <- expect
332+ expect :: Process ProcessMonitorNotification
283333 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
284334
285335 takeMVar done
@@ -353,14 +403,17 @@ testMath TestTransport{..} = do
353403 runProcess localNode $ do
354404 pid <- getSelfPid
355405 send mathServer (Add pid 1 2)
356− 3 <- expect :: Process Double
406+ three <- expect :: Process Double
357407 send mathServer (Divide pid 8 2)
358− 4 <- expect :: Process Double
408+ four <- expect :: Process Double
359409 send mathServer (Divide pid 8 0)
360− DivByZero <- expect
361− liftIO $ putMVar clientDone ()
410+ divByZ <- expect
411+ liftIO $ putMVar clientDone (three, four, divByZ)
362412
363− takeMVar clientDone
413+ res <- takeMVar clientDone
414+ case res of
415+ (3, 4, DivByZero) -> return ()
416+ _ -> error $ "Something went horribly wrong"
364417
365418-- | Send first message (i.e. connect) to an already terminated process
366419-- (without monitoring); then send another message to a second process on
@@ -388,11 +441,9 @@ testSendToTerminated TestTransport{..} = do
388441 pid <- getSelfPid
389442 send server1 "Hi"
390443 send server2 (Pong pid)
391− Ping pid' <- expect
392− True <- return $ pid' == server2
393− liftIO $ putMVar clientDone ()
444+ expectPing clientDone
394445
395− takeMVar clientDone
446+ verifyClient "Expected Ping from server" clientDone
396447
397448-- | Test (non-zero) timeout
398449testTimeout :: TestTransport -> Assertion
@@ -401,10 +452,10 @@ testTimeout TestTransport{..} = do
401452 done <- newEmptyMVar
402453
403454 runProcess localNode $ do
404− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
405− liftIO $ putMVar done ()
455+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
456+ liftIO $ putMVar done $ res == Nothing
406457
407− takeMVar done
458+ verifyClient "Expected receiveTimeout to timeout..." done
408459
409460-- | Test zero timeout
410461testTimeout0 :: TestTransport -> Assertion
@@ -432,10 +483,9 @@ testTimeout0 TestTransport{..} = do
432483 -- is not interested in, and then a single message that it wants
433484 replicateM_ 10000 $ send server "Irrelevant message"
434485 send server (Pong pid)
435− Ping _ <- expect
436− liftIO $ putMVar clientDone ()
486+ expectPing clientDone
437487
438− takeMVar clientDone
488+ verifyClient "Expected Ping from server" clientDone
439489
440490-- | Test typed channels
441491testTypedChannels :: TestTransport -> Assertion
@@ -458,10 +508,10 @@ testTypedChannels TestTransport{..} = do
458508 runProcess localNode $ do
459509 (clientSendPort, rport) <- newChan
460510 sendChan serverSendPort (clientSendPort, 5)
461− False <- receiveChan rport
462− liftIO $ putMVar clientDone ()
511+ ch <- receiveChan rport
512+ liftIO $ putMVar clientDone $ ch == False
463513
464− takeMVar clientDone
514+ verifyClient "Expected channel to send 'False'" clientDone
465515
466516-- | Test merging receive ports
467517testMergeChannels :: TestTransport -> Assertion
@@ -484,9 +534,8 @@ testMergeChannels TestTransport{..} = do
484534 rs <- mapM charChannel "abc"
485535 m <- mergePorts biased rs
486536 xs <- replicateM 9 $ receiveChan m
487− True <- return $ xs == expected
488− liftIO $ putMVar done ()
489− takeMVar done
537+ liftIO $ putMVar done $ xs == expected
538+ verifyClient "Expected single layer merge to match expected ordering" done
490539
491540 -- Two layers of merging
492541 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -497,9 +546,8 @@ testMergeChannels TestTransport{..} = do
497546 ms <- mapM (mergePorts biasedInner) rss
498547 m <- mergePorts biasedOuter ms
499548 xs <- replicateM (9 * 3) $ receiveChan m
500− True <- return $ xs == expected
501− liftIO $ putMVar done ()
502− takeMVar done
549+ liftIO $ putMVar done $ xs == expected
550+ verifyClient "Expected nested channels to match expeted ordering" done
503551
504552 -- Test that if no messages are (immediately) available, the scheduler makes no difference
505553 testBlocked :: LocalNode -> Bool -> IO ()
@@ -508,43 +556,45 @@ testMergeChannels TestTransport{..} = do
508556 done <- newEmptyMVar
509557
510558 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− ]
559+ ss <- liftIO $ mapM readMVar vs
560+ case ss of
561+ [sa, sb, sc] ->
562+ mapM_ ((>> pause 10000) . uncurry sendChan)
563+ [ -- a, b, c
564+ (sa, 'a')
565+ , (sb, 'b')
566+ , (sc, 'c')
567+ -- a, c, b
568+ , (sa, 'a')
569+ , (sc, 'c')
570+ , (sb, 'b')
571+ -- b, a, c
572+ , (sb, 'b')
573+ , (sa, 'a')
574+ , (sc, 'c')
575+ -- b, c, a
576+ , (sb, 'b')
577+ , (sc, 'c')
578+ , (sa, 'a')
579+ -- c, a, b
580+ , (sc, 'c')
581+ , (sa, 'a')
582+ , (sb, 'b')
583+ -- c, b, a
584+ , (sc, 'c')
585+ , (sb, 'b')
586+ , (sa, 'a')
587+ ]
588+ _ -> die "Something went horribly wrong"
538589
539590 forkProcess localNode $ do
540591 (ss, rs) <- unzip <$> replicateM 3 newChan
541592 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
542593 m <- mergePorts biased rs
543594 xs <- replicateM (6 * 3) $ receiveChan m
544− True <- return $ xs == "abcacbbacbcacabcba"
545− liftIO $ putMVar done ()
595+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
546596
547− takeMVar done
597+ verifyClient "Expected merged ports to match expected ordering" done
548598
549599 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
550600 mergePorts True = mergePortsBiased
@@ -560,19 +610,11 @@ testMergeChannels TestTransport{..} = do
560610testTerminate :: TestTransport -> Assertion
561611testTerminate TestTransport{..} = do
562612 localNode <- newLocalNode testTransport initRemoteTable
563− done <- newEmptyMVar
564−
565− pid <- forkProcess localNode $ do
566− liftIO $ threadDelay 100000
567− terminate
568−
569613 runProcess localNode $ do
570− ref <- monitor pid
571− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
572− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
573− liftIO $ putMVar done ()
574−
575− takeMVar done
614+ e <- try terminate :: Process (Either ProcessTerminationException ())
615+ if either show show e == show ProcessTerminationException
616+ then return ()
617+ else die "Unexpected result from terminate"
576618
577619testMonitorNode :: TestTransport -> Assertion
578620testMonitorNode TestTransport{..} = do
@@ -583,11 +625,12 @@ testMonitorNode TestTransport{..} = do
583625
584626 runProcess node2 $ do
585627 ref <- monitorNode (localNodeId node1)
586− NodeMonitorNotification ref' nid DiedDisconnect <- expect
587− True <- return $ ref == ref' && nid == localNodeId node1
588− liftIO $ putMVar done ()
628+ receiveWait [
629+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
630+ return $ ref == ref' && nid == localNodeId node1)
631+ ] >>= liftIO . putMVar done
589632
590− takeMVar done
633+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
591634
592635testMonitorLiveNode :: TestTransport -> Assertion
593636testMonitorLiveNode TestTransport{..} = do
@@ -602,15 +645,16 @@ testMonitorLiveNode TestTransport{..} = do
602645 liftIO $ putMVar ready ()
603646 liftIO $ takeMVar readyr
604647 send p ()
605− NodeMonitorNotification ref' nid _ <- expect
606− True <- return $ ref == ref' && nid == localNodeId node1
607− liftIO $ putMVar done ()
648+ receiveWait [
649+ match (\(NodeMonitorNotification ref' nid _) ->
650+ (return $ ref == ref' && nid == localNodeId node1))
651+ ] >>= liftIO . putMVar done
608652
609653 takeMVar ready
610654 closeLocalNode node1
611655 putMVar readyr ()
612656
613− takeMVar done
657+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
614658
615659testMonitorChannel :: TestTransport -> Assertion
616660testMonitorChannel TestTransport{..} = do
@@ -620,18 +664,20 @@ testMonitorChannel TestTransport{..} = do
620664 pid <- forkProcess node1 $ do
621665 sport <- expect :: Process (SendPort ())
622666 ref <- monitorPort sport
623− PortMonitorNotification ref' port' reason <- expect
624− -- reason might be DiedUnknownId if the receive port is GCed before the
625− -- monitor is established (TODO: not sure that this is reasonable)
626− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
627− liftIO $ putMVar gotNotification ()
667+ receiveWait [
668+ -- reason might be DiedUnknownId if the receive port is GCed before the
669+ -- monitor is established (TODO: not sure that this is reasonable)
670+ match (\(PortMonitorNotification ref' port' reason) ->
671+ return $ ref' == ref && port' == sendPortId sport &&
672+ (reason == DiedNormal || reason == DiedUnknownId))
673+ ] >>= liftIO . putMVar gotNotification
628674
629675 runProcess node2 $ do
630676 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
631677 send pid sport
632678 liftIO $ threadDelay 100000
633679
634− takeMVar gotNotification
680+ verifyClient "Expected PortMonitorNotification" gotNotification
635681
636682testRegistry :: TestTransport -> Assertion
637683testRegistry TestTransport{..} = do
@@ -643,20 +689,28 @@ testRegistry TestTransport{..} = do
643689
644690 runProcess node $ do
645691 register "ping" pingServer
646− Just pid <- whereis "ping"
647− True <- return $ pingServer == pid
692+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
648693 us <- getSelfPid
649694 nsend "ping" (Pong us)
650− Ping pid' <- expect
651− True <- return $ pingServer == pid'
652− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
653− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
654− True <- return $ x == pingServer
655− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
695+ receiveWait [
696+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
697+ ]
698+ checkRegException "dead" Nothing deadProcess
699+ checkRegException "ping" (Just pingServer) deadProcess
700+ try (unregister "dead") >>= checkReg "dead" Nothing
656701 liftIO $ putMVar done ()
657702
658703 takeMVar done
659704
705+ where
706+ checkRegException name pid dead =
707+ try (register name dead) >>= checkReg name pid
708+
709+ checkReg name pid res =
710+ case res of
711+ Left (ProcessRegistrationException name pid) -> return ()
712+ _ -> die $ "Unexpected Registration" ++ show res
713+
660714testRegistryRemoteProcess :: TestTransport -> Assertion
661715testRegistryRemoteProcess TestTransport{..} = do
662716 node1 <- newLocalNode testTransport initRemoteTable
@@ -667,13 +721,13 @@ testRegistryRemoteProcess TestTransport{..} = do
667721
668722 runProcess node2 $ do
669723 register "ping" pingServer
670− Just pid <- whereis "ping"
671− True <- return $ pingServer == pid
724+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
672725 us <- getSelfPid
673726 nsend "ping" (Pong us)
674− Ping pid' <- expect
675− True <- return $ pingServer == pid'
676− liftIO $ putMVar done ()
727+ receiveWait [
728+ matchIf (\(Ping pid') -> pingServer == pid')
729+ (const $ liftIO $ putMVar done ())
730+ ]
677731
678732 takeMVar done
679733
@@ -681,7 +735,6 @@ testRemoteRegistry :: TestTransport -> Assertion
681735testRemoteRegistry TestTransport{..} = do
682736 node1 <- newLocalNode testTransport initRemoteTable
683737 node2 <- newLocalNode testTransport initRemoteTable
684− done <- newEmptyMVar
685738
686739 pingServer <- forkProcess node1 ping
687740 deadProcess <- forkProcess node1 (return ())
@@ -694,32 +747,34 @@ testRemoteRegistry TestTransport{..} = do
694747 "ping" == label' && pid == pingServer)
695748 (\(RegisterReply _ _ _) -> return ()) ]
696749
697− Just pid <- whereisRemote nid1 "ping"
698− True <- return $ pingServer == pid
750+ pid <- verifyWhereIsRemote nid1 "ping"
751+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
752+
699753 us <- getSelfPid
700754 nsendRemote nid1 "ping" (Pong us)
701− Ping pid' <- expect
702− True <- return $ pingServer == pid'
755+ receiveWait [
756+ match (\(Ping pid') -> return $ pingServer == pid')
757+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
703758
704759 -- test that if process was not registered Nothing is returned
705760 -- in owner field.
706761 registerRemoteAsync nid1 "dead" deadProcess
707− receiveWait [
708− matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
709− (\(RegisterReply _ _ _) -> return ()) ]
762+ receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
763+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764+ ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
765+
710766 registerRemoteAsync nid1 "ping" deadProcess
711767 receiveWait [
712− matchIf (\(RegisterReply label' False (Just pid)) ->
713− "ping" == label' && pid == pingServer)
714− (\(RegisterReply _ _ _) -> return ()) ]
768+ matchIf (\(RegisterReply label' False mPid) ->
769+ "ping" == label' && isJust mPid)
770+ (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771+ ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
772+
715773 unregisterRemoteAsync nid1 "dead"
716774 receiveWait [
717− matchIf (\(RegisterReply label' False Nothing) ->
718− "dead" == label' && pid == pingServer)
719− (\(RegisterReply _ _ _) -> return ()) ]
720− liftIO $ putMVar done ()
721−
722− takeMVar done
775+ matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777+ ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
723778
724779testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
725780testRemoteRegistryRemoteProcess TestTransport{..} = do
@@ -735,15 +790,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
735790 receiveWait [
736791 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
737792 (\(RegisterReply _ _ _) -> return ()) ]
738− Just pid <- whereisRemote nid1 "ping"
739− True <- return $ pingServer == pid
793+ pid <- verifyWhereIsRemote nid1 "ping"
794+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
740795 us <- getSelfPid
741796 nsendRemote nid1 "ping" (Pong us)
742− Ping pid' <- expect
743− True <- return $ pingServer == pid'
744− liftIO $ putMVar done ()
797+ receiveWait [
798+ match (\(Ping pid') -> return $ pingServer == pid')
799+ ] >>= liftIO . putMVar done
745800
746− takeMVar done
801+ verifyClient "Expected Ping with ping server's ProcessId" done
747802
748803testSpawnLocal :: TestTransport -> Assertion
749804testSpawnLocal TestTransport{..} = do
@@ -757,15 +812,14 @@ testSpawnLocal TestTransport{..} = do
757812 sport <- expect
758813 sendChan sport (1234 :: Int)
759814
760− sport <- spawnChannelLocal $ \rport -> do
761− (1234 :: Int) <- receiveChan rport
762− send us ()
815+ sport <- spawnChannelLocal $
816+ \rport -> (receiveChan rport :: Process Int) >>= send us
763817
764818 send pid sport
765− () <- expect
766− liftIO $ putMVar done ()
819+ expect >>= liftIO . putMVar done
767820
768− takeMVar done
821+ res <- takeMVar done
822+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
769823
770824testSpawnAsyncStrictness :: TestTransport -> Assertion
771825testSpawnAsyncStrictness TestTransport{..} = do
@@ -794,8 +848,9 @@ testReconnect TestTransport{..} = do
794848 liftIO $ putMVar processA us
795849 msg1 <- expect
796850 msg2 <- expect
797− True <- return $ msg1 == "message 1" && msg2 == "message 3"
798− liftIO $ putMVar sendTestOk ()
851+ liftIO $ do
852+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
853+ putMVar sendTestOk ()
799854
800855 forkProcess node2 $ do
801856 {-
@@ -828,7 +883,7 @@ testReconnect TestTransport{..} = do
828883 matchIf (\(RegisterReply label' _ _) -> "a" == label')
829884 (\(RegisterReply _ _ _) -> return ()) ]
830885
831− Just _ <- whereisRemote nid1 "a"
886+ _ <- whereisRemote nid1 "a"
832887
833888
834889 -- Simulate network failure
@@ -847,9 +902,10 @@ testReconnect TestTransport{..} = do
847902 (\(RegisterReply _ _ _) -> return ()) ]
848903
849904 -- Check
850− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
851− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
852− Just _ <- whereisRemote nid1 "c"
905+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
906+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
907+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
908+ verifyWhereIsRemote nid1 "c"
853909
854910 liftIO $ putMVar registerTestOk ()
855911
@@ -890,19 +946,19 @@ testUSend usendPrim TestTransport{..} numMessages = do
890946 isSorted _ = True
891947 -- The list can't be null since there are no failures after sending
892948 -- the last message.
893− True <- return $ isSorted msgs && not (null msgs)
894− liftIO $ putMVar usendTestOk ()
949+ liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
895950
896951 forkProcess node2 $ do
897952 them <- liftIO $ readMVar processA
898953 getSelfPid >>= send them
899− () <- expect
954+ expect :: Process ()
900955 forM_ [1..numMessages] $ \i -> do
901956 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
902957 usendPrim them i
903958 liftIO (threadDelay 30000)
904959
905− takeMVar usendTestOk
960+ res <- takeMVar usendTestOk
961+ assertBool "Unexpected failure after sending last msg" res
906962
907963-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
908964-- in between
@@ -928,14 +984,17 @@ testMatchAny TestTransport{..} = do
928984 runProcess localNode $ do
929985 pid <- getSelfPid
930986 send mathServer (Add pid 1 2)
931− 3 <- expect :: Process Double
987+ three <- expect :: Process Double
932988 send mathServer (Divide pid 8 2)
933− 4 <- expect :: Process Double
989+ four <- expect :: Process Double
934990 send mathServer (Divide pid 8 0)
935− DivByZero <- expect
936− liftIO $ putMVar clientDone ()
991+ divByZ <- expect
992+ liftIO $ putMVar clientDone (three, four, divByZ)
937993
938− takeMVar clientDone
994+ res <- takeMVar clientDone
995+ case res of
996+ (3, 4, DivByZero) -> return ()
997+ _ -> error "Unexpected result"
939998
940999-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
9411000-- in between, however we block 'Divide' requests ....
@@ -962,12 +1021,13 @@ testMatchAnyHandle TestTransport{..} = do
9621021 runProcess localNode $ do
9631022 pid <- getSelfPid
9641023 send mathServer (Add pid 1 2)
965− 3 <- expect :: Process Double
1024+ three <- expect :: Process Double
9661025 send mathServer (Divide pid 8 2)
967− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
968− liftIO $ putMVar clientDone ()
1026+ res <- (expectTimeout 100000) :: Process (Maybe Double)
1027+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1028+
1029+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
9691030
970− takeMVar clientDone
9711031 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
9721032 maybeForward s msg =
9731033 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -995,8 +1055,10 @@ testMatchAnyNoHandle TestTransport{..} = do
9951055 Just _ -> die "NONSENSE")
9961056 ]
9971057 -- we *must* have removed the message from our mailbox though!!!
998− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
999− liftIO $ putMVar serverDone ()
1058+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1059+ liftIO $ do
1060+ assertBool "Expected timeout!" $ res == Nothing
1061+ putMVar serverDone ()
10001062 putMVar addr server
10011063
10021064 -- Client
@@ -1039,14 +1101,21 @@ testMatchAnyIf TestTransport{..} = do
10391101 runProcess localNode $ do
10401102 pid <- getSelfPid
10411103 send server (pid, "foo")
1042− "foo" <- expect
1043− send server (pid, "baz")
1044− "baz" <- expect
1104+ foo <- expect
1105+ -- provoking what would be the wrong ordering is informative here...
1106+
10451107 send server (pid, "bar")
1046− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1047− liftIO $ putMVar clientDone ()
1108+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1109+
1110+ send server (pid, "baz")
1111+ baz <- expect
1112+
1113+ liftIO $ putMVar clientDone (foo, bar, baz)
1114+
1115+ res <- takeMVar clientDone
1116+ let res' = res == ("foo", Nothing, "baz")
1117+ assertBool "Expected timeout due to type mismatch" res'
10481118
1049− takeMVar clientDone
10501119 where tryHandleMessage :: Message -> Process (Maybe ())
10511120 tryHandleMessage msg =
10521121 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1079,17 +1148,19 @@ testMatchMessageWithUnwrap TestTransport{..} = do
10791148 runProcess localNode $ do
10801149 pid <- getSelfPid
10811150 send server (pid, wrapMessage ("foo" :: String))
1082− "foo" <- expect
1151+ foo <- expect
10831152 send server (pid, wrapMessage ("baz" :: String))
1084− "baz" <- expect
1085− liftIO $ putMVar clientDone ()
1153+ baz <- expect
1154+ liftIO $ putMVar clientDone (foo, baz)
10861155
1087− takeMVar clientDone
1156+ res <- takeMVar clientDone
1157+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
10881158
10891159-- Test 'receiveChanTimeout'
10901160testReceiveChanTimeout :: TestTransport -> Assertion
10911161testReceiveChanTimeout TestTransport{..} = do
10921162 done <- newEmptyMVar
1163+ mvSender <- newEmptyMVar
10931164 sendPort <- newEmptyMVar
10941165
10951166 forkTry $ do
@@ -1099,18 +1170,32 @@ testReceiveChanTimeout TestTransport{..} = do
10991170 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
11001171 liftIO $ putMVar sendPort sp
11011172
1102− -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
1103− Nothing <- receiveChanTimeout 1000000 rp
1173+ -- Wait for a message with a delay. No message arrives, we should get
1174+ -- Nothing after the delay.
1175+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1176+
1177+ -- Let the sender know that it can send a message.
1178+ liftIO $ putMVar mvSender ()
1179+
1180+ -- Wait for a message with a delay again. Now a message arrives after
1181+ -- 0.1 seconds
1182+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1183+ liftIO $ assertBool "Expected result to be 'True'" res
11041184
1105− -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
1106− Just True <- receiveChanTimeout 1000000 rp
1185+ -- Wait for a message with zero timeout: non-blocking check. No message is
1186+ -- available, we get Nothing
1187+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
11071188
1108− -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
1109− Nothing <- receiveChanTimeout 0 rp
1189+ -- Let the sender know that it can send a message.
1190+ liftIO $ putMVar mvSender ()
11101191
11111192 -- Again, but now there is a message available
1112− liftIO $ threadDelay 1000000
1113− Just False <- receiveChanTimeout 0 rp
1193+ fix $ \loop -> do
1194+ liftIO $ threadDelay 100000
1195+ mb <- receiveChanTimeout 0 rp
1196+ case mb of
1197+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1198+ _ -> loop
11141199
11151200 liftIO $ putMVar done ()
11161201
@@ -1119,10 +1204,11 @@ testReceiveChanTimeout TestTransport{..} = do
11191204 runProcess localNode $ do
11201205 sp <- liftIO $ readMVar sendPort
11211206
1122− liftIO $ threadDelay 1500000
1207+ liftIO $ takeMVar mvSender
1208+ liftIO $ threadDelay 100000
11231209 sendChan sp True
11241210
1125− liftIO $ threadDelay 500000
1211+ liftIO $ takeMVar mvSender
11261212 sendChan sp False
11271213
11281214 takeMVar done
@@ -1145,8 +1231,8 @@ testReceiveChanFeatures TestTransport{..} = do
11451231
11461232 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
11471233
1148− True <- receiveChan rp1
1149− False <- receiveChan rp1
1234+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1235+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
11501236
11511237 -- Test Applicative instance
11521238
@@ -1155,7 +1241,7 @@ testReceiveChanFeatures TestTransport{..} = do
11551241
11561242 let rp2 = pure (+) <*> rpInt <*> rpInt
11571243
1158− 7 <- receiveChan rp2
1244+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
11591245
11601246 -- Test Alternative instance
11611247
@@ -1164,8 +1250,8 @@ testReceiveChanFeatures TestTransport{..} = do
11641250
11651251 let rp3 = (even <$> rpInt) <|> rpBool
11661252
1167− False <- receiveChan rp3
1168− True <- receiveChan rp3
1253+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1254+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
11691255
11701256 -- Test Monad instance
11711257
@@ -1179,17 +1265,86 @@ testReceiveChanFeatures TestTransport{..} = do
11791265 then rpInt
11801266 else return 7
11811267
1182− 5 <- receiveChan rp4
1183− 7 <- receiveChan rp4
1268+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1269+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
11841270
11851271 liftIO $ putMVar done ()
11861272
11871273 takeMVar done
11881274
1275+testChanLifecycle :: TestTransport -> Assertion
1276+testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1277+ result <- newEmptyMVar
1278+ tchMV <- newEmptyMVar
1279+ localNode <- newLocalNode testTransport initRemoteTable
1280+ runProcess localNode $ do
1281+
1282+ pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283+ liftIO $ putMVar tchMV tCh
1284+ expect :: Process ()
1285+ let (sp, _) = tCh
1286+ sendChan sp ()
1287+ expect :: Process ()
1288+
1289+ mRefPid <- monitor pid
1290+
1291+ cPid <- spawnLocal $ do
1292+ (sp', rp) <- liftIO $ takeMVar tchMV
1293+ -- say "picked up our test channel"
1294+ send pid ()
1295+ -- say "told pid to continue"
1296+ res <- receiveChanTimeout delay rp
1297+ case res of
1298+ Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299+ Just () -> do mr <- monitor pid
1300+ pause 10000
1301+ -- say "sending pid a second () will cause it to exit"
1302+ send pid ()
1303+
1304+ -- say "make sure we see a DOWN notification for pid having stopped"
1305+ receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1306+
1307+ -- now that pid has died, the send port should be useless...
1308+ liftIO $ putMVar tchMV (sp', rp)
1309+
1310+ -- let's verify that we do not see the message from our
1311+ -- parent process on the channel, once pid has died...
1312+ recv <- receiveChanTimeout delay rp
1313+ -- say $ "finished waiting for second (), writing result" ++ (show recv)
1314+ liftIO $ putMVar result $ isNothing recv
1315+
1316+ mRefCPid <- monitor cPid
1317+
1318+ receiveWait
1319+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1320+ (\_ -> return ())
1321+ ]
1322+
1323+ -- say "seen first pid die..."
1324+
1325+ (sendPort, _) <- liftIO $ takeMVar tchMV
1326+ sendChan sendPort ()
1327+ -- say "sent () after owning pid died"
1328+
1329+ -- let cPid know we've written to the channel...
1330+ send cPid ()
1331+
1332+ receiveWait
1333+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1334+ (\_ -> return ())
1335+ ]
1336+
1337+ -- say "seen both pids die now..."
1338+
1339+ -- and wait on the result back in IO land...
1340+ testRes <- takeMVar result
1341+ -- runProcess localNode $ say "got result..."
1342+ assertBool "Expected sending on the channel to fail, but received data!" testRes
1343+
1344+
11891345testKillLocal :: TestTransport -> Assertion
11901346testKillLocal TestTransport{..} = do
11911347 localNode <- newLocalNode testTransport initRemoteTable
1192− done <- newEmptyMVar
11931348
11941349 pid <- forkProcess localNode $ do
11951350 liftIO $ threadDelay 1000000
@@ -1198,17 +1353,18 @@ testKillLocal TestTransport{..} = do
11981353 ref <- monitor pid
11991354 us <- getSelfPid
12001355 kill pid "TestKill"
1201− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1202− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1203− liftIO $ putMVar done ()
1204−
1205− takeMVar done
1356+ mn <- expect
1357+ case mn of
1358+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1359+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1360+ True -> return ()
1361+ False -> die "Invalid ProcessMonitorNotification received"
1362+ _ -> die "Something went horribly wrong"
12061363
12071364testKillRemote :: TestTransport -> Assertion
12081365testKillRemote TestTransport{..} = do
12091366 node1 <- newLocalNode testTransport initRemoteTable
12101367 node2 <- newLocalNode testTransport initRemoteTable
1211− done <- newEmptyMVar
12121368
12131369 pid <- forkProcess node1 $ do
12141370 liftIO $ threadDelay 1000000
@@ -1217,11 +1373,17 @@ testKillRemote TestTransport{..} = do
12171373 ref <- monitor pid
12181374 us <- getSelfPid
12191375 kill pid "TestKill"
1220− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1221− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1222− liftIO $ putMVar done ()
1223−
1224− takeMVar done
1376+ mn <- expect
1377+ case mn of
1378+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1379+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1380+ (True, True, True) -> return ()
1381+ (a, b, c) -> do
1382+ let a' = if a then "" else "Invalid ref"
1383+ let b' = if b then "" else "Invalid pid"
1384+ let c' = if c then "" else "Invalid message"
1385+ die $ unwords [a', b', c']
1386+ _ -> die "Received unexpected message"
12251387
12261388testCatchesExit :: TestTransport -> Assertion
12271389testCatchesExit TestTransport{..} = do
@@ -1247,7 +1409,10 @@ testHandleMessageIf TestTransport{..} = do
12471409 self <- getSelfPid
12481410 send self (5 :: Integer, 10 :: Integer)
12491411 msg <- receiveWait [ matchMessage return ]
1250− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1412+ handleMessageIf msg
1413+ (\() -> True)
1414+ (\() -> die "whoops") >>= maybe (return ())
1415+ (const $ die "Expected Mismatch")
12511416 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
12521417 (\input -> liftIO $ putMVar done input)
12531418 return ()
@@ -1292,8 +1457,11 @@ testDie TestTransport{..} = do
12921457 (die ("foobar", 123 :: Int))
12931458 `catchExit` \_from reason -> do
12941459 -- TODO: should verify that 'from' has the right value
1295− True <- return $ reason == ("foobar", 123 :: Int)
1460+ let res = reason == ("foobar", 123 :: Int)
12961461 liftIO $ putMVar done ()
1462+ if res
1463+ then return ()
1464+ else die "Something went horribly wrong"
12971465
12981466 takeMVar done
12991467
@@ -1307,8 +1475,11 @@ testPrettyExit TestTransport{..} = do
13071475 `catch` \ex@(ProcessExitException from _) ->
13081476 let expected = "exit-from=" ++ (show from)
13091477 in do
1310− True <- return $ (show ex) == expected
1478+ let res = (show ex) == expected
13111479 liftIO $ putMVar done ()
1480+ if res
1481+ then return ()
1482+ else die "Something went horribly wrong"
13121483
13131484 takeMVar done
13141485
@@ -1324,17 +1495,26 @@ testExitLocal TestTransport{..} = do
13241495 pid <- forkProcess localNode $ do
13251496 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
13261497 -- TODO: should verify that 'from' has the right value
1327− True <- return $ reason == "TestExit"
1498+ res <- return $ reason == "TestExit"
13281499 liftIO $ putMVar supervisedDone ()
1500+ if res
1501+ then return ()
1502+ else die "Something went horribly wrong"
13291503
13301504 runProcess localNode $ do
13311505 liftIO $ takeMVar handlerSetUp
13321506 ref <- monitor pid
13331507 exit pid "TestExit"
13341508 -- This time the client catches the exception, so it dies normally
1335− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1336− True <- return $ ref == ref' && pid == pid'
1337− liftIO $ putMVar supervisorDone ()
1509+ mn <- expect
1510+ case mn of
1511+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1512+ let res = ref == ref' && pid == pid'
1513+ liftIO $ putMVar supervisorDone ()
1514+ if res
1515+ then return ()
1516+ else die "Something went horribly wrong"
1517+ _ -> die "Something went horribly wrong"
13381518
13391519 takeMVar supervisedDone
13401520 takeMVar supervisorDone
@@ -1350,19 +1530,98 @@ testExitRemote TestTransport{..} = do
13501530 (receiveWait [] :: Process ()) -- block forever
13511531 `catchExit` \_from reason -> do
13521532 -- TODO: should verify that 'from' has the right value
1353− True <- return $ reason == "TestExit"
1533+ res <- return $ reason == "TestExit"
13541534 liftIO $ putMVar supervisedDone ()
1535+ if res
1536+ then return ()
1537+ else die "Something went horribly wrong"
13551538
13561539 runProcess node2 $ do
13571540 ref <- monitor pid
13581541 exit pid "TestExit"
1359− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1360− True <- return $ ref == ref' && pid == pid'
1361− liftIO $ putMVar supervisorDone ()
1542+ mn <- expect
1543+ case mn of
1544+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1545+ res' <- return $ ref == ref' && pid == pid'
1546+ liftIO $ putMVar supervisorDone ()
1547+ if res'
1548+ then return ()
1549+ else die "Something went horribly wrong"
1550+ _ -> die "Something went horribly wrong"
13621551
13631552 takeMVar supervisedDone
13641553 takeMVar supervisorDone
13651554
1555+testRegistryMonitoring :: TestTransport -> Assertion
1556+testRegistryMonitoring TestTransport{..} = do
1557+ node1 <- newLocalNode testTransport initRemoteTable
1558+ node2 <- newLocalNode testTransport initRemoteTable
1559+
1560+ let nid = localNodeId node2
1561+ pid <- forkProcess node1 $ do
1562+ self <- getSelfPid
1563+ runUntilRegistered nid self
1564+ say $ (show self) ++ " registered as " ++ regName
1565+ expect :: Process ()
1566+ say $ (show self) ++ " exiting normally"
1567+
1568+ runProcess node2 $ do
1569+ register regName pid
1570+ say $ regName ++ " registered to " ++ show pid
1571+ res <- whereis regName
1572+ send pid ()
1573+ say $ " sent finish signal to " ++ show pid
1574+ us <- getSelfPid
1575+ liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
1576+
1577+
1578+ -- This delay isn't essential!
1579+ -- The test case passes perfectly fine without it (feel free to comment out
1580+ -- and see), however waiting a few seconds here, makes it much more likely
1581+ -- that in delayUntilMaybeUnregistered we will hit the match case right
1582+ -- away, and thus not be subjected to a 20 second delay. The value of 4
1583+ -- seconds appears to work optimally on osx and across several linux distros
1584+ -- running in virtual machines (which is essentially what we do in CI)
1585+ void $ receiveTimeout 4000000 [ matchAny return ]
1586+
1587+ -- This delay doesn't serve much purpose in the happy path, however if some
1588+ -- future patch breaks the cooperative behaviour of node controllers viz
1589+ -- remote process registration and notification taking place via ncEffectDied,
1590+ -- there would be the possibility of a race in the test case should we attempt
1591+ -- to evaluate `whereis regName` on node2 right away. In case the name is still
1592+ -- erroneously registered, observing the 20 second delay (or lack of), could at
1593+ -- least give a hint that something is wrong, and we give up our time slice
1594+ -- so that there's a higher change the registrations have been cleaned up
1595+ -- in either case.
1596+ runProcess node2 $ delayUntilMaybeUnregistered nid pid
1597+
1598+ regHere <- newEmptyMVar
1599+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600+ res <- takeMVar regHere
1601+ case res of
1602+ Nothing -> return ()
1603+ Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1604+
1605+ where
1606+ runUntilRegistered nid us = do
1607+ whereisRemoteAsync nid regName
1608+ receiveWait [
1609+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610+ (const $ return ())
1611+ ]
1612+
1613+ delayUntilMaybeUnregistered nid p = do
1614+ whereisRemoteAsync nid regName
1615+ res <- receiveTimeout 20000000 {- 20 sec delay -} [
1616+ matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)
1617+ (const $ return ())
1618+ ]
1619+ case res of
1620+ Just () -> return ()
1621+ Nothing -> delayUntilMaybeUnregistered nid p
1622+
1623+ regName = "testRegisterRemote"
1624+
13661625testUnsafeSend :: TestTransport -> Assertion
13671626testUnsafeSend TestTransport{..} = do
13681627 serverAddr <- newEmptyMVar
@@ -1378,8 +1637,7 @@ testUnsafeSend TestTransport{..} = do
13781637 void $ forkProcess localNode $ do
13791638 serverPid <- liftIO $ takeMVar serverAddr
13801639 getSelfPid >>= unsafeSend serverPid
1381− () <- expect
1382− liftIO $ putMVar clientDone ()
1640+ expect >>= liftIO . putMVar clientDone
13831641
13841642 takeMVar clientDone
13851643
@@ -1398,8 +1656,7 @@ testUnsafeUSend TestTransport{..} = do
13981656 void $ forkProcess localNode $ do
13991657 serverPid <- liftIO $ takeMVar serverAddr
14001658 getSelfPid >>= unsafeUSend serverPid
1401− () <- expect
1402− liftIO $ putMVar clientDone ()
1659+ expect >>= liftIO . putMVar clientDone
14031660
14041661 takeMVar clientDone
14051662
@@ -1410,8 +1667,7 @@ testUnsafeNSend TestTransport{..} = do
14101667 localNode <- newLocalNode testTransport initRemoteTable
14111668
14121669 pid <- forkProcess localNode $ do
1413− () <- expect
1414− liftIO $ putMVar clientDone ()
1670+ expect >>= liftIO . putMVar clientDone
14151671
14161672 void $ runProcess localNode $ do
14171673 register "foobar" pid
@@ -1429,8 +1685,7 @@ testUnsafeNSendRemote TestTransport{..} = do
14291685 _ <- forkProcess localNode1 $ do
14301686 getSelfPid >>= register "foobar"
14311687 liftIO $ putMVar clientDone ()
1432− () <- expect
1433− liftIO $ putMVar clientDone ()
1688+ expect >>= liftIO . putMVar clientDone
14341689
14351690 takeMVar clientDone
14361691 void $ runProcess localNode2 $ do
@@ -1454,7 +1709,7 @@ testUnsafeSendChan TestTransport{..} = do
14541709 serverPid <- liftIO $ takeMVar serverAddr
14551710 (sp, rp) <- newChan
14561711 unsafeSend serverPid sp
1457− () <- receiveChan rp
1712+ receiveChan rp :: Process ()
14581713 liftIO $ putMVar clientDone ()
14591714
14601715 takeMVar clientDone
@@ -1468,8 +1723,8 @@ testCallLocal TestTransport{..} = do
14681723 runProcess node $ do
14691724 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
14701725 liftIO $ putMVar result r
1471− True <- takeMVar result
1472− return ()
1726+
1727+ takeMVar result >>= assertBool "Expected 'True'"
14731728
14741729 -- Testing that when callLocal is interrupted, the worker is interrupted.
14751730 ibox <- newIORef False
@@ -1486,10 +1741,9 @@ testCallLocal TestTransport{..} = do
14861741 (send keeper ())
14871742 caller <- expect
14881743 exit caller "test"
1489− () <- expect
1490− return ()
1491− True <- readIORef ibox
1492− return ()
1744+ expect :: Process ()
1745+
1746+ readIORef ibox >>= assertBool "Expected 'True'"
14931747
14941748 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
14951749 ibox2 <- newIORef False
@@ -1498,8 +1752,8 @@ testCallLocal TestTransport{..} = do
14981752 liftIO $ writeIORef ibox2 $ case r of
14991753 Left (ErrorCall "e") -> True
15001754 _ -> False
1501− True <- readIORef ibox
1502− return ()
1755+
1756+ readIORef ibox >>= assertBool "Expected 'True'"
15031757
15041758 -- Test that caller waits for the worker in correct situation
15051759 ibox3 <- newIORef False
@@ -1516,8 +1770,8 @@ testCallLocal TestTransport{..} = do
15161770 liftIO $ putMVar result3 =<< readIORef ibox3
15171771 worker <- expect
15181772 send worker ()
1519− True <- takeMVar result3
1520− return ()
1773+
1774+ takeMVar result3 >>= assertBool "Expected 'True'"
15211775
15221776 -- Test that caller waits for the worker in case when caller gets an exception
15231777 ibox4 <- newIORef False
@@ -1533,13 +1787,9 @@ testCallLocal TestTransport{..} = do
15331787 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
15341788 caller <- expect
15351789 exit caller "hi!"
1536− True <- takeMVar result4
1537− return ()
1538− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1539−
1540−
1541−
15421790
1791+ takeMVar result4 >>= assertBool "Expected 'True'"
1792+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
15431793
15441794tests :: TestTransport -> IO [Test]
15451795tests testtrans = return [
@@ -1564,6 +1814,7 @@ tests testtrans = return [
15641814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
15651815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
15661816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)
15671818 , testCase "KillLocal" (testKillLocal testtrans)
15681819 , testCase "KillRemote" (testKillRemote testtrans)
15691820 , testCase "Die" (testDie testtrans)
@@ -1573,6 +1824,7 @@ tests testtrans = return [
15731824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
15741825 , testCase "ExitLocal" (testExitLocal testtrans)
15751826 , testCase "ExitRemote" (testExitRemote testtrans)
1827+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
15761828 , testCase "TextCallLocal" (testCallLocal testtrans)
15771829 -- Unsafe Primitives
15781830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
@@ -1625,17 +1877,3 @@ tests testtrans = return [
16251877 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
16261878 ]
16271879 ]
1628−
1629−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1630−syncBreakConnection breakConnection nid0 nid1 = do
1631− m <- newEmptyMVar
1632− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1633− runProcess nid0 $ do
1634− them <- liftIO $ takeMVar m
1635− pinger <- spawnLocal $ forever $ send them ()
1636− _ <- monitorNode (localNodeId nid1)
1637− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1638− (nodeAddress $ localNodeId nid1)
1639− NodeMonitorNotification _ _ _ <- expect
1640− kill pinger "finished"
1641− return ()