@@ -25,32 +25,24 @@ import Control.Concurrent.MVar
2525 )
2626import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
2727import Control.Exception (SomeException, throwIO, ErrorCall(..))
28−import Control.Monad.Catch (try, catch, finally, mask, onException)
29−import Control.Applicative ((<|>))
28+import qualified Control.Exception as Ex (catch)
29+import Control.Applicative ((<$>), (<*>), pure, (<|>))
3030import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31−import Control.Distributed.Process hiding
32− ( try
33− , catch
34− , finally
35− , mask
36− , onException
37− )
31+import Control.Distributed.Process
3832import Control.Distributed.Process.Internal.Types
39− ( LocalNode(localEndPoint)
33+ ( NodeId(nodeAddress)
34+ , LocalNode(localEndPoint)
4035 , ProcessExitException(..)
4136 , nullProcessId
4237 , createUnencodedMessage
4338 )
4439import 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)
4840import Control.Distributed.Process.Serializable (Serializable)
49−import Data.Maybe (isNothing, isJust)
50−import Test.HUnit (Assertion, assertBool, assertFailure)
41+
42+import Test.HUnit (Assertion, assertFailure)
5143import Test.Framework (Test, testGroup)
5244import Test.Framework.Providers.HUnit (testCase)
53−import Control.Rematch hiding (match, isNothing, isJust)
45+import Control.Rematch hiding (match)
5446import Control.Rematch.Run (Match(..))
5547
5648newtype Ping = Ping ProcessId
@@ -73,7 +65,7 @@ expectThat a matcher = case res of
7365forkTry :: IO () -> IO ThreadId
7466forkTry p = do
7567 tid <- myThreadId
76− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
68+ forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
7769
7870-- | The ping server from the paper
7971ping :: Process ()
@@ -83,46 +75,12 @@ ping = do
8375 send partner (Ping self)
8476 ping
8577
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−
9478-- | Quick and dirty synchronous version of whereisRemoteAsync
9579whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
9680whereisRemote nid string = do
9781 whereisRemoteAsync nid string
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 ()
82+ WhereIsReply _ mPid <- expect
83+ return mPid
12684
12785data Add = Add ProcessId Double Double deriving (Typeable)
12886data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -197,18 +155,12 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
197155 unmonitor ref
198156 liftIO $ putMVar done ()
199157 (False, ref) -> do
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− ]
158+ ProcessMonitorNotification ref' pid reason' <- expect
159+ True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
160+ liftIO $ putMVar done ()
208161 )
209162 (\(ProcessLinkException pid reason') -> do
210− (liftIO $ assertBool "link exception unmatched" $
211− pid == theirAddr && not mOrL && not un && reason == reason')
163+ True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
212164 liftIO $ putMVar done ()
213165 )
214166
@@ -239,10 +191,8 @@ testPing TestTransport{..} = do
239191 pid <- getSelfPid
240192 replicateM_ numPings $ do
241193 send pingServer (Pong pid)
242− p <- expectTimeout 3000000
243− case p of
244− Just (Ping _) -> return ()
245− Nothing -> die "Failed to receive Ping"
194+ Ping _ <- expect
195+ return ()
246196
247197 putMVar clientDone ()
248198
@@ -329,7 +279,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
329279 runProcess localNode $ do
330280 monitor theirAddr
331281 -- wait for the process to die
332− expect :: Process ProcessMonitorNotification
282+ ProcessMonitorNotification _ _ _ <- expect
333283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
334284
335285 takeMVar done
@@ -403,17 +353,14 @@ testMath TestTransport{..} = do
403353 runProcess localNode $ do
404354 pid <- getSelfPid
405355 send mathServer (Add pid 1 2)
406− three <- expect :: Process Double
356+ 3 <- expect :: Process Double
407357 send mathServer (Divide pid 8 2)
408− four <- expect :: Process Double
358+ 4 <- expect :: Process Double
409359 send mathServer (Divide pid 8 0)
410− divByZ <- expect
411− liftIO $ putMVar clientDone (three, four, divByZ)
360+ DivByZero <- expect
361+ liftIO $ putMVar clientDone ()
412362
413− res <- takeMVar clientDone
414− case res of
415− (3, 4, DivByZero) -> return ()
416− _ -> error $ "Something went horribly wrong"
363+ takeMVar clientDone
417364
418365-- | Send first message (i.e. connect) to an already terminated process
419366-- (without monitoring); then send another message to a second process on
@@ -441,9 +388,11 @@ testSendToTerminated TestTransport{..} = do
441388 pid <- getSelfPid
442389 send server1 "Hi"
443390 send server2 (Pong pid)
444− expectPing clientDone
391+ Ping pid' <- expect
392+ True <- return $ pid' == server2
393+ liftIO $ putMVar clientDone ()
445394
446− verifyClient "Expected Ping from server" clientDone
395+ takeMVar clientDone
447396
448397-- | Test (non-zero) timeout
449398testTimeout :: TestTransport -> Assertion
@@ -452,10 +401,10 @@ testTimeout TestTransport{..} = do
452401 done <- newEmptyMVar
453402
454403 runProcess localNode $ do
455− res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
456− liftIO $ putMVar done $ res == Nothing
404+ Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
405+ liftIO $ putMVar done ()
457406
458− verifyClient "Expected receiveTimeout to timeout..." done
407+ takeMVar done
459408
460409-- | Test zero timeout
461410testTimeout0 :: TestTransport -> Assertion
@@ -483,9 +432,10 @@ testTimeout0 TestTransport{..} = do
483432 -- is not interested in, and then a single message that it wants
484433 replicateM_ 10000 $ send server "Irrelevant message"
485434 send server (Pong pid)
486− expectPing clientDone
435+ Ping _ <- expect
436+ liftIO $ putMVar clientDone ()
487437
488− verifyClient "Expected Ping from server" clientDone
438+ takeMVar clientDone
489439
490440-- | Test typed channels
491441testTypedChannels :: TestTransport -> Assertion
@@ -508,10 +458,10 @@ testTypedChannels TestTransport{..} = do
508458 runProcess localNode $ do
509459 (clientSendPort, rport) <- newChan
510460 sendChan serverSendPort (clientSendPort, 5)
511− ch <- receiveChan rport
512− liftIO $ putMVar clientDone $ ch == False
461+ False <- receiveChan rport
462+ liftIO $ putMVar clientDone ()
513463
514− verifyClient "Expected channel to send 'False'" clientDone
464+ takeMVar clientDone
515465
516466-- | Test merging receive ports
517467testMergeChannels :: TestTransport -> Assertion
@@ -534,8 +484,9 @@ testMergeChannels TestTransport{..} = do
534484 rs <- mapM charChannel "abc"
535485 m <- mergePorts biased rs
536486 xs <- replicateM 9 $ receiveChan m
537− liftIO $ putMVar done $ xs == expected
538− verifyClient "Expected single layer merge to match expected ordering" done
487+ True <- return $ xs == expected
488+ liftIO $ putMVar done ()
489+ takeMVar done
539490
540491 -- Two layers of merging
541492 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -546,8 +497,9 @@ testMergeChannels TestTransport{..} = do
546497 ms <- mapM (mergePorts biasedInner) rss
547498 m <- mergePorts biasedOuter ms
548499 xs <- replicateM (9 * 3) $ receiveChan m
549− liftIO $ putMVar done $ xs == expected
550− verifyClient "Expected nested channels to match expeted ordering" done
500+ True <- return $ xs == expected
501+ liftIO $ putMVar done ()
502+ takeMVar done
551503
552504 -- Test that if no messages are (immediately) available, the scheduler makes no difference
553505 testBlocked :: LocalNode -> Bool -> IO ()
@@ -556,45 +508,43 @@ testMergeChannels TestTransport{..} = do
556508 done <- newEmptyMVar
557509
558510 forkProcess localNode $ do
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"
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+ ]
589538
590539 forkProcess localNode $ do
591540 (ss, rs) <- unzip <$> replicateM 3 newChan
592541 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
593542 m <- mergePorts biased rs
594543 xs <- replicateM (6 * 3) $ receiveChan m
595− liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
544+ True <- return $ xs == "abcacbbacbcacabcba"
545+ liftIO $ putMVar done ()
596546
597− verifyClient "Expected merged ports to match expected ordering" done
547+ takeMVar done
598548
599549 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
600550 mergePorts True = mergePortsBiased
@@ -610,11 +560,19 @@ testMergeChannels TestTransport{..} = do
610560testTerminate :: TestTransport -> Assertion
611561testTerminate TestTransport{..} = do
612562 localNode <- newLocalNode testTransport initRemoteTable
563+ done <- newEmptyMVar
564+
565+ pid <- forkProcess localNode $ do
566+ liftIO $ threadDelay 100000
567+ terminate
568+
613569 runProcess localNode $ do
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"
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
618576
619577testMonitorNode :: TestTransport -> Assertion
620578testMonitorNode TestTransport{..} = do
@@ -625,12 +583,11 @@ testMonitorNode TestTransport{..} = do
625583
626584 runProcess node2 $ do
627585 ref <- monitorNode (localNodeId node1)
628− receiveWait [
629− match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
630− return $ ref == ref' && nid == localNodeId node1)
631− ] >>= liftIO . putMVar done
586+ NodeMonitorNotification ref' nid DiedDisconnect <- expect
587+ True <- return $ ref == ref' && nid == localNodeId node1
588+ liftIO $ putMVar done ()
632589
633− verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
590+ takeMVar done
634591
635592testMonitorLiveNode :: TestTransport -> Assertion
636593testMonitorLiveNode TestTransport{..} = do
@@ -645,16 +602,15 @@ testMonitorLiveNode TestTransport{..} = do
645602 liftIO $ putMVar ready ()
646603 liftIO $ takeMVar readyr
647604 send p ()
648− receiveWait [
649− match (\(NodeMonitorNotification ref' nid _) ->
650− (return $ ref == ref' && nid == localNodeId node1))
651− ] >>= liftIO . putMVar done
605+ NodeMonitorNotification ref' nid _ <- expect
606+ True <- return $ ref == ref' && nid == localNodeId node1
607+ liftIO $ putMVar done ()
652608
653609 takeMVar ready
654610 closeLocalNode node1
655611 putMVar readyr ()
656612
657− verifyClient "Expected NodeMonitorNotification for LIVE node" done
613+ takeMVar done
658614
659615testMonitorChannel :: TestTransport -> Assertion
660616testMonitorChannel TestTransport{..} = do
@@ -664,20 +620,18 @@ testMonitorChannel TestTransport{..} = do
664620 pid <- forkProcess node1 $ do
665621 sport <- expect :: Process (SendPort ())
666622 ref <- monitorPort sport
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
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 ()
674628
675629 runProcess node2 $ do
676630 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
677631 send pid sport
678632 liftIO $ threadDelay 100000
679633
680− verifyClient "Expected PortMonitorNotification" gotNotification
634+ takeMVar gotNotification
681635
682636testRegistry :: TestTransport -> Assertion
683637testRegistry TestTransport{..} = do
@@ -689,28 +643,20 @@ testRegistry TestTransport{..} = do
689643
690644 runProcess node $ do
691645 register "ping" pingServer
692− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
646+ Just pid <- whereis "ping"
647+ True <- return $ pingServer == pid
693648 us <- getSelfPid
694649 nsend "ping" (Pong us)
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
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"
701656 liftIO $ putMVar done ()
702657
703658 takeMVar done
704659
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−
714660testRegistryRemoteProcess :: TestTransport -> Assertion
715661testRegistryRemoteProcess TestTransport{..} = do
716662 node1 <- newLocalNode testTransport initRemoteTable
@@ -721,13 +667,13 @@ testRegistryRemoteProcess TestTransport{..} = do
721667
722668 runProcess node2 $ do
723669 register "ping" pingServer
724− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
670+ Just pid <- whereis "ping"
671+ True <- return $ pingServer == pid
725672 us <- getSelfPid
726673 nsend "ping" (Pong us)
727− receiveWait [
728− matchIf (\(Ping pid') -> pingServer == pid')
729− (const $ liftIO $ putMVar done ())
730− ]
674+ Ping pid' <- expect
675+ True <- return $ pingServer == pid'
676+ liftIO $ putMVar done ()
731677
732678 takeMVar done
733679
@@ -735,6 +681,7 @@ testRemoteRegistry :: TestTransport -> Assertion
735681testRemoteRegistry TestTransport{..} = do
736682 node1 <- newLocalNode testTransport initRemoteTable
737683 node2 <- newLocalNode testTransport initRemoteTable
684+ done <- newEmptyMVar
738685
739686 pingServer <- forkProcess node1 ping
740687 deadProcess <- forkProcess node1 (return ())
@@ -747,34 +694,32 @@ testRemoteRegistry TestTransport{..} = do
747694 "ping" == label' && pid == pingServer)
748695 (\(RegisterReply _ _ _) -> return ()) ]
749696
750− pid <- verifyWhereIsRemote nid1 "ping"
751− liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
752−
697+ Just pid <- whereisRemote nid1 "ping"
698+ True <- return $ pingServer == pid
753699 us <- getSelfPid
754700 nsendRemote nid1 "ping" (Pong us)
755− receiveWait [
756− match (\(Ping pid') -> return $ pingServer == pid')
757− ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
701+ Ping pid' <- expect
702+ True <- return $ pingServer == pid'
758703
759704 -- test that if process was not registered Nothing is returned
760705 -- in owner field.
761706 registerRemoteAsync nid1 "dead" deadProcess
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−
707+ receiveWait [
708+ matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
709+ (\(RegisterReply _ _ _) -> return ()) ]
766710 registerRemoteAsync nid1 "ping" deadProcess
767711 receiveWait [
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−
712+ matchIf (\(RegisterReply label' False (Just pid)) ->
713+ "ping" == label' && pid == pingServer)
714+ (\(RegisterReply _ _ _) -> return ()) ]
773715 unregisterRemoteAsync nid1 "dead"
774716 receiveWait [
775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
717+ matchIf (\(RegisterReply label' False Nothing) ->
718+ "dead" == label' && pid == pingServer)
719+ (\(RegisterReply _ _ _) -> return ()) ]
720+ liftIO $ putMVar done ()
721+
722+ takeMVar done
778723
779724testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
780725testRemoteRegistryRemoteProcess TestTransport{..} = do
@@ -790,15 +735,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
790735 receiveWait [
791736 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
792737 (\(RegisterReply _ _ _) -> return ()) ]
793− pid <- verifyWhereIsRemote nid1 "ping"
794− liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
738+ Just pid <- whereisRemote nid1 "ping"
739+ True <- return $ pingServer == pid
795740 us <- getSelfPid
796741 nsendRemote nid1 "ping" (Pong us)
797− receiveWait [
798− match (\(Ping pid') -> return $ pingServer == pid')
799− ] >>= liftIO . putMVar done
742+ Ping pid' <- expect
743+ True <- return $ pingServer == pid'
744+ liftIO $ putMVar done ()
800745
801− verifyClient "Expected Ping with ping server's ProcessId" done
746+ takeMVar done
802747
803748testSpawnLocal :: TestTransport -> Assertion
804749testSpawnLocal TestTransport{..} = do
@@ -812,14 +757,15 @@ testSpawnLocal TestTransport{..} = do
812757 sport <- expect
813758 sendChan sport (1234 :: Int)
814759
815− sport <- spawnChannelLocal $
816− \rport -> (receiveChan rport :: Process Int) >>= send us
760+ sport <- spawnChannelLocal $ \rport -> do
761+ (1234 :: Int) <- receiveChan rport
762+ send us ()
817763
818764 send pid sport
819− expect >>= liftIO . putMVar done
765+ () <- expect
766+ liftIO $ putMVar done ()
820767
821− res <- takeMVar done
822− assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
768+ takeMVar done
823769
824770testSpawnAsyncStrictness :: TestTransport -> Assertion
825771testSpawnAsyncStrictness TestTransport{..} = do
@@ -848,9 +794,8 @@ testReconnect TestTransport{..} = do
848794 liftIO $ putMVar processA us
849795 msg1 <- expect
850796 msg2 <- expect
851− liftIO $ do
852− assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
853− putMVar sendTestOk ()
797+ True <- return $ msg1 == "message 1" && msg2 == "message 3"
798+ liftIO $ putMVar sendTestOk ()
854799
855800 forkProcess node2 $ do
856801 {-
@@ -883,7 +828,7 @@ testReconnect TestTransport{..} = do
883828 matchIf (\(RegisterReply label' _ _) -> "a" == label')
884829 (\(RegisterReply _ _ _) -> return ()) ]
885830
886− _ <- whereisRemote nid1 "a"
831+ Just _ <- whereisRemote nid1 "a"
887832
888833
889834 -- Simulate network failure
@@ -902,10 +847,9 @@ testReconnect TestTransport{..} = do
902847 (\(RegisterReply _ _ _) -> return ()) ]
903848
904849 -- Check
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"
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"
909853
910854 liftIO $ putMVar registerTestOk ()
911855
@@ -946,19 +890,19 @@ testUSend usendPrim TestTransport{..} numMessages = do
946890 isSorted _ = True
947891 -- The list can't be null since there are no failures after sending
948892 -- the last message.
949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
893+ True <- return $ isSorted msgs && not (null msgs)
894+ liftIO $ putMVar usendTestOk ()
950895
951896 forkProcess node2 $ do
952897 them <- liftIO $ readMVar processA
953898 getSelfPid >>= send them
954− expect :: Process ()
899+ () <- expect
955900 forM_ [1..numMessages] $ \i -> do
956901 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
957902 usendPrim them i
958903 liftIO (threadDelay 30000)
959904
960− res <- takeMVar usendTestOk
961− assertBool "Unexpected failure after sending last msg" res
905+ takeMVar usendTestOk
962906
963907-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
964908-- in between
@@ -984,17 +928,14 @@ testMatchAny TestTransport{..} = do
984928 runProcess localNode $ do
985929 pid <- getSelfPid
986930 send mathServer (Add pid 1 2)
987− three <- expect :: Process Double
931+ 3 <- expect :: Process Double
988932 send mathServer (Divide pid 8 2)
989− four <- expect :: Process Double
933+ 4 <- expect :: Process Double
990934 send mathServer (Divide pid 8 0)
991− divByZ <- expect
992− liftIO $ putMVar clientDone (three, four, divByZ)
935+ DivByZero <- expect
936+ liftIO $ putMVar clientDone ()
993937
994− res <- takeMVar clientDone
995− case res of
996− (3, 4, DivByZero) -> return ()
997− _ -> error "Unexpected result"
938+ takeMVar clientDone
998939
999940-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
1000941-- in between, however we block 'Divide' requests ....
@@ -1021,13 +962,12 @@ testMatchAnyHandle TestTransport{..} = do
1021962 runProcess localNode $ do
1022963 pid <- getSelfPid
1023964 send mathServer (Add pid 1 2)
1024− three <- expect :: Process Double
965+ 3 <- expect :: Process Double
1025966 send mathServer (Divide pid 8 2)
1026− res <- (expectTimeout 100000) :: Process (Maybe Double)
1027− liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1028−
1029− verifyClient "Expected Nothing (i.e. timeout)" clientDone
967+ Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
968+ liftIO $ putMVar clientDone ()
1030969
970+ takeMVar clientDone
1031971 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1032972 maybeForward s msg =
1033973 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -1055,10 +995,8 @@ testMatchAnyNoHandle TestTransport{..} = do
1055995 Just _ -> die "NONSENSE")
1056996 ]
1057997 -- we *must* have removed the message from our mailbox though!!!
1058− res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1059− liftIO $ do
1060− assertBool "Expected timeout!" $ res == Nothing
1061− putMVar serverDone ()
998+ Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
999+ liftIO $ putMVar serverDone ()
10621000 putMVar addr server
10631001
10641002 -- Client
@@ -1101,21 +1039,14 @@ testMatchAnyIf TestTransport{..} = do
11011039 runProcess localNode $ do
11021040 pid <- getSelfPid
11031041 send server (pid, "foo")
1104− foo <- expect
1105− -- provoking what would be the wrong ordering is informative here...
1106−
1107− send server (pid, "bar")
1108− bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1109−
1042+ "foo" <- expect
11101043 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'
1044+ "baz" <- expect
1045+ send server (pid, "bar")
1046+ Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1047+ liftIO $ putMVar clientDone ()
11181048
1049+ takeMVar clientDone
11191050 where tryHandleMessage :: Message -> Process (Maybe ())
11201051 tryHandleMessage msg =
11211052 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1148,19 +1079,17 @@ testMatchMessageWithUnwrap TestTransport{..} = do
11481079 runProcess localNode $ do
11491080 pid <- getSelfPid
11501081 send server (pid, wrapMessage ("foo" :: String))
1151− foo <- expect
1082+ "foo" <- expect
11521083 send server (pid, wrapMessage ("baz" :: String))
1153− baz <- expect
1154− liftIO $ putMVar clientDone (foo, baz)
1084+ "baz" <- expect
1085+ liftIO $ putMVar clientDone ()
11551086
1156− res <- takeMVar clientDone
1157− assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1087+ takeMVar clientDone
11581088
11591089-- Test 'receiveChanTimeout'
11601090testReceiveChanTimeout :: TestTransport -> Assertion
11611091testReceiveChanTimeout TestTransport{..} = do
11621092 done <- newEmptyMVar
1163− mvSender <- newEmptyMVar
11641093 sendPort <- newEmptyMVar
11651094
11661095 forkTry $ do
@@ -1170,32 +1099,18 @@ testReceiveChanTimeout TestTransport{..} = do
11701099 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
11711100 liftIO $ putMVar sendPort sp
11721101
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
1102+ -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
1103+ Nothing <- receiveChanTimeout 1000000 rp
11841104
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")
1105+ -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
1106+ Just True <- receiveChanTimeout 1000000 rp
11881107
1189− -- Let the sender know that it can send a message.
1190− liftIO $ putMVar mvSender ()
1108+ -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
1109+ Nothing <- receiveChanTimeout 0 rp
11911110
11921111 -- Again, but now there is a message available
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
1112+ liftIO $ threadDelay 1000000
1113+ Just False <- receiveChanTimeout 0 rp
11991114
12001115 liftIO $ putMVar done ()
12011116
@@ -1204,11 +1119,10 @@ testReceiveChanTimeout TestTransport{..} = do
12041119 runProcess localNode $ do
12051120 sp <- liftIO $ readMVar sendPort
12061121
1207− liftIO $ takeMVar mvSender
1208− liftIO $ threadDelay 100000
1122+ liftIO $ threadDelay 1500000
12091123 sendChan sp True
12101124
1211− liftIO $ takeMVar mvSender
1125+ liftIO $ threadDelay 500000
12121126 sendChan sp False
12131127
12141128 takeMVar done
@@ -1231,8 +1145,8 @@ testReceiveChanFeatures TestTransport{..} = do
12311145
12321146 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
12331147
1234− receiveChan rp1 >>= liftIO . assertBool "Expected True"
1235− receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1148+ True <- receiveChan rp1
1149+ False <- receiveChan rp1
12361150
12371151 -- Test Applicative instance
12381152
@@ -1241,7 +1155,7 @@ testReceiveChanFeatures TestTransport{..} = do
12411155
12421156 let rp2 = pure (+) <*> rpInt <*> rpInt
12431157
1244− receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1158+ 7 <- receiveChan rp2
12451159
12461160 -- Test Alternative instance
12471161
@@ -1250,8 +1164,8 @@ testReceiveChanFeatures TestTransport{..} = do
12501164
12511165 let rp3 = (even <$> rpInt) <|> rpBool
12521166
1253− receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1254− receiveChan rp3 >>= liftIO . assertBool "Expected True"
1167+ False <- receiveChan rp3
1168+ True <- receiveChan rp3
12551169
12561170 -- Test Monad instance
12571171
@@ -1265,86 +1179,17 @@ testReceiveChanFeatures TestTransport{..} = do
12651179 then rpInt
12661180 else return 7
12671181
1268− receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1269− receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1182+ 5 <- receiveChan rp4
1183+ 7 <- receiveChan rp4
12701184
12711185 liftIO $ putMVar done ()
12721186
12731187 takeMVar done
12741188
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−
13451189testKillLocal :: TestTransport -> Assertion
13461190testKillLocal TestTransport{..} = do
13471191 localNode <- newLocalNode testTransport initRemoteTable
1192+ done <- newEmptyMVar
13481193
13491194 pid <- forkProcess localNode $ do
13501195 liftIO $ threadDelay 1000000
@@ -1353,18 +1198,17 @@ testKillLocal TestTransport{..} = do
13531198 ref <- monitor pid
13541199 us <- getSelfPid
13551200 kill pid "TestKill"
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"
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
13631206
13641207testKillRemote :: TestTransport -> Assertion
13651208testKillRemote TestTransport{..} = do
13661209 node1 <- newLocalNode testTransport initRemoteTable
13671210 node2 <- newLocalNode testTransport initRemoteTable
1211+ done <- newEmptyMVar
13681212
13691213 pid <- forkProcess node1 $ do
13701214 liftIO $ threadDelay 1000000
@@ -1373,17 +1217,11 @@ testKillRemote TestTransport{..} = do
13731217 ref <- monitor pid
13741218 us <- getSelfPid
13751219 kill pid "TestKill"
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"
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
13871225
13881226testCatchesExit :: TestTransport -> Assertion
13891227testCatchesExit TestTransport{..} = do
@@ -1409,10 +1247,7 @@ testHandleMessageIf TestTransport{..} = do
14091247 self <- getSelfPid
14101248 send self (5 :: Integer, 10 :: Integer)
14111249 msg <- receiveWait [ matchMessage return ]
1412− handleMessageIf msg
1413− (\() -> True)
1414− (\() -> die "whoops") >>= maybe (return ())
1415− (const $ die "Expected Mismatch")
1250+ Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
14161251 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
14171252 (\input -> liftIO $ putMVar done input)
14181253 return ()
@@ -1457,11 +1292,8 @@ testDie TestTransport{..} = do
14571292 (die ("foobar", 123 :: Int))
14581293 `catchExit` \_from reason -> do
14591294 -- TODO: should verify that 'from' has the right value
1460− let res = reason == ("foobar", 123 :: Int)
1295+ True <- return $ reason == ("foobar", 123 :: Int)
14611296 liftIO $ putMVar done ()
1462− if res
1463− then return ()
1464− else die "Something went horribly wrong"
14651297
14661298 takeMVar done
14671299
@@ -1475,11 +1307,8 @@ testPrettyExit TestTransport{..} = do
14751307 `catch` \ex@(ProcessExitException from _) ->
14761308 let expected = "exit-from=" ++ (show from)
14771309 in do
1478− let res = (show ex) == expected
1310+ True <- return $ (show ex) == expected
14791311 liftIO $ putMVar done ()
1480− if res
1481− then return ()
1482− else die "Something went horribly wrong"
14831312
14841313 takeMVar done
14851314
@@ -1495,26 +1324,17 @@ testExitLocal TestTransport{..} = do
14951324 pid <- forkProcess localNode $ do
14961325 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
14971326 -- TODO: should verify that 'from' has the right value
1498− res <- return $ reason == "TestExit"
1327+ True <- return $ reason == "TestExit"
14991328 liftIO $ putMVar supervisedDone ()
1500− if res
1501− then return ()
1502− else die "Something went horribly wrong"
15031329
15041330 runProcess localNode $ do
15051331 liftIO $ takeMVar handlerSetUp
15061332 ref <- monitor pid
15071333 exit pid "TestExit"
15081334 -- This time the client catches the exception, so it dies normally
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"
1335+ ProcessMonitorNotification ref' pid' DiedNormal <- expect
1336+ True <- return $ ref == ref' && pid == pid'
1337+ liftIO $ putMVar supervisorDone ()
15181338
15191339 takeMVar supervisedDone
15201340 takeMVar supervisorDone
@@ -1530,98 +1350,19 @@ testExitRemote TestTransport{..} = do
15301350 (receiveWait [] :: Process ()) -- block forever
15311351 `catchExit` \_from reason -> do
15321352 -- TODO: should verify that 'from' has the right value
1533− res <- return $ reason == "TestExit"
1353+ True <- return $ reason == "TestExit"
15341354 liftIO $ putMVar supervisedDone ()
1535− if res
1536− then return ()
1537− else die "Something went horribly wrong"
15381355
15391356 runProcess node2 $ do
15401357 ref <- monitor pid
15411358 exit pid "TestExit"
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"
1359+ ProcessMonitorNotification ref' pid' DiedNormal <- expect
1360+ True <- return $ ref == ref' && pid == pid'
1361+ liftIO $ putMVar supervisorDone ()
15511362
15521363 takeMVar supervisedDone
15531364 takeMVar supervisorDone
15541365
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−
16251366testUnsafeSend :: TestTransport -> Assertion
16261367testUnsafeSend TestTransport{..} = do
16271368 serverAddr <- newEmptyMVar
@@ -1637,7 +1378,8 @@ testUnsafeSend TestTransport{..} = do
16371378 void $ forkProcess localNode $ do
16381379 serverPid <- liftIO $ takeMVar serverAddr
16391380 getSelfPid >>= unsafeSend serverPid
1640− expect >>= liftIO . putMVar clientDone
1381+ () <- expect
1382+ liftIO $ putMVar clientDone ()
16411383
16421384 takeMVar clientDone
16431385
@@ -1656,7 +1398,8 @@ testUnsafeUSend TestTransport{..} = do
16561398 void $ forkProcess localNode $ do
16571399 serverPid <- liftIO $ takeMVar serverAddr
16581400 getSelfPid >>= unsafeUSend serverPid
1659− expect >>= liftIO . putMVar clientDone
1401+ () <- expect
1402+ liftIO $ putMVar clientDone ()
16601403
16611404 takeMVar clientDone
16621405
@@ -1667,7 +1410,8 @@ testUnsafeNSend TestTransport{..} = do
16671410 localNode <- newLocalNode testTransport initRemoteTable
16681411
16691412 pid <- forkProcess localNode $ do
1670− expect >>= liftIO . putMVar clientDone
1413+ () <- expect
1414+ liftIO $ putMVar clientDone ()
16711415
16721416 void $ runProcess localNode $ do
16731417 register "foobar" pid
@@ -1685,7 +1429,8 @@ testUnsafeNSendRemote TestTransport{..} = do
16851429 _ <- forkProcess localNode1 $ do
16861430 getSelfPid >>= register "foobar"
16871431 liftIO $ putMVar clientDone ()
1688− expect >>= liftIO . putMVar clientDone
1432+ () <- expect
1433+ liftIO $ putMVar clientDone ()
16891434
16901435 takeMVar clientDone
16911436 void $ runProcess localNode2 $ do
@@ -1709,7 +1454,7 @@ testUnsafeSendChan TestTransport{..} = do
17091454 serverPid <- liftIO $ takeMVar serverAddr
17101455 (sp, rp) <- newChan
17111456 unsafeSend serverPid sp
1712− receiveChan rp :: Process ()
1457+ () <- receiveChan rp
17131458 liftIO $ putMVar clientDone ()
17141459
17151460 takeMVar clientDone
@@ -1723,8 +1468,8 @@ testCallLocal TestTransport{..} = do
17231468 runProcess node $ do
17241469 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
17251470 liftIO $ putMVar result r
1726−
1727− takeMVar result >>= assertBool "Expected 'True'"
1471+ True <- takeMVar result
1472+ return ()
17281473
17291474 -- Testing that when callLocal is interrupted, the worker is interrupted.
17301475 ibox <- newIORef False
@@ -1741,9 +1486,10 @@ testCallLocal TestTransport{..} = do
17411486 (send keeper ())
17421487 caller <- expect
17431488 exit caller "test"
1744− expect :: Process ()
1745−
1746− readIORef ibox >>= assertBool "Expected 'True'"
1489+ () <- expect
1490+ return ()
1491+ True <- readIORef ibox
1492+ return ()
17471493
17481494 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
17491495 ibox2 <- newIORef False
@@ -1752,8 +1498,8 @@ testCallLocal TestTransport{..} = do
17521498 liftIO $ writeIORef ibox2 $ case r of
17531499 Left (ErrorCall "e") -> True
17541500 _ -> False
1755−
1756− readIORef ibox >>= assertBool "Expected 'True'"
1501+ True <- readIORef ibox
1502+ return ()
17571503
17581504 -- Test that caller waits for the worker in correct situation
17591505 ibox3 <- newIORef False
@@ -1770,8 +1516,8 @@ testCallLocal TestTransport{..} = do
17701516 liftIO $ putMVar result3 =<< readIORef ibox3
17711517 worker <- expect
17721518 send worker ()
1773−
1774− takeMVar result3 >>= assertBool "Expected 'True'"
1519+ True <- takeMVar result3
1520+ return ()
17751521
17761522 -- Test that caller waits for the worker in case when caller gets an exception
17771523 ibox4 <- newIORef False
@@ -1787,10 +1533,14 @@ testCallLocal TestTransport{..} = do
17871533 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
17881534 caller <- expect
17891535 exit caller "hi!"
1790−
1791− takeMVar result4 >>= assertBool "Expected 'True'"
1536+ True <- takeMVar result4
1537+ return ()
17921538 -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
17931539
1540+
1541+
1542+
1543+
17941544tests :: TestTransport -> IO [Test]
17951545tests testtrans = return [
17961546 testGroup "Basic features" [
@@ -1814,7 +1564,6 @@ tests testtrans = return [
18141564 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
18151565 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
18161566 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)
18181567 , testCase "KillLocal" (testKillLocal testtrans)
18191568 , testCase "KillRemote" (testKillRemote testtrans)
18201569 , testCase "Die" (testDie testtrans)
@@ -1824,7 +1573,6 @@ tests testtrans = return [
18241573 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
18251574 , testCase "ExitLocal" (testExitLocal testtrans)
18261575 , testCase "ExitRemote" (testExitRemote testtrans)
1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
18281576 , testCase "TextCallLocal" (testCallLocal testtrans)
18291577 -- Unsafe Primitives
18301578 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
@@ -1877,3 +1625,17 @@ tests testtrans = return [
18771625 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
18781626 ]
18791627 ]
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 ()