@@ -9,6 +9,7 @@ import Network.Transport.Test (TestTransport(..))
9import Data.Binary (Binary(..))
9import Data.Binary (Binary(..))
10import Data.Typeable (Typeable)
10import Data.Typeable (Typeable)
11import Data.Foldable (forM_)
11import Data.Foldable (forM_)
12+import Data.Function (fix)
12import Data.IORef
13import Data.IORef
13 ( readIORef
14 ( readIORef
14 , writeIORef
15 , writeIORef
@@ -24,24 +25,32 @@ import Control.Concurrent.MVar
25import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
26import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
26import Control.Exception (SomeException, throwIO, ErrorCall(..))
27import Control.Exception (SomeException, throwIO, ErrorCall(..))
27−import qualified Control.Exception as Ex (catch)
28+import Control.Monad.Catch (try, catch, finally, mask, onException)
28−import Control.Applicative ((<$>), (<*>), pure, (<|>))
29+import Control.Applicative ((<|>))
29import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
30import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
30−import Control.Distributed.Process
31+import Control.Distributed.Process hiding
31import Control.Distributed.Process.Internal.Types
38import Control.Distributed.Process.Internal.Types
32− ( NodeId(nodeAddress)
33− , LocalNode(localEndPoint)
39+ ( LocalNode(localEndPoint)
34 , ProcessExitException(..)
40 , ProcessExitException(..)
35 , nullProcessId
41 , nullProcessId
36 , createUnencodedMessage
42 , createUnencodedMessage
38import Control.Distributed.Process.Node
44import 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)
39import Control.Distributed.Process.Serializable (Serializable)
48import Control.Distributed.Process.Serializable (Serializable)
40−
49+import Data.Maybe (isNothing, isJust)
41−import Test.HUnit (Assertion, assertFailure)
50+import Test.HUnit (Assertion, assertBool, assertFailure)
42import Test.Framework (Test, testGroup)
51import Test.Framework (Test, testGroup)
43import Test.Framework.Providers.HUnit (testCase)
52import Test.Framework.Providers.HUnit (testCase)
44−import Control.Rematch hiding (match)
53+import Control.Rematch hiding (match, isNothing, isJust)
45import Control.Rematch.Run (Match(..))
54import Control.Rematch.Run (Match(..))
47newtype Ping = Ping ProcessId
56newtype Ping = Ping ProcessId
@@ -64,7 +73,7 @@ expectThat a matcher = case res of
64forkTry :: IO () -> IO ThreadId
73forkTry :: IO () -> IO ThreadId
65forkTry p = do
74forkTry p = do
66 tid <- myThreadId
75 tid <- myThreadId
67− forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
76+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
69-- | The ping server from the paper
78-- | The ping server from the paper
70ping :: Process ()
79ping :: Process ()
@@ -74,12 +83,46 @@ ping = do
74 send partner (Ping self)
83 send partner (Ping self)
86+verifyClient :: String -> MVar Bool -> IO ()
87+verifyClient s b = takeMVar b >>= assertBool s
89+expectPing :: MVar Bool -> Process ()
90+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
92+ checkPing (Ping _) = True
77-- | Quick and dirty synchronous version of whereisRemoteAsync
94-- | Quick and dirty synchronous version of whereisRemoteAsync
78whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
95whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
79whereisRemote nid string = do
96whereisRemote nid string = do
80 whereisRemoteAsync nid string
97 whereisRemoteAsync nid string
81− WhereIsReply _ mPid <- expect
99+ match (\(WhereIsReply _ mPid) -> return mPid)
102+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
103+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
105+waitForExit :: ProcessId -> Process DiedReason
106+waitForExit pid = monitor pid >>= waitForDown
108+waitForDown :: MonitorRef -> Process DiedReason
110+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
111+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
113+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
114+syncBreakConnection breakConnection nid0 nid1 = do
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"
82− return mPid
125+ return ()
84data Add = Add ProcessId Double Double deriving (Typeable)
127data Add = Add ProcessId Double Double deriving (Typeable)
85data Divide = Divide ProcessId Double Double deriving (Typeable)
128data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -154,12 +197,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
154 unmonitor ref
197 unmonitor ref
155 liftIO $ putMVar done ()
198 liftIO $ putMVar done ()
156 (False, ref) -> do
199 (False, ref) -> do
157− ProcessMonitorNotification ref' pid reason' <- expect
201+ match (\(ProcessMonitorNotification ref' pid reason') -> do
203+ assertBool "Bad Monitor Signal"
158− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
204+ (Just ref' == ref && pid == theirAddr &&
205+ mOrL && reason == reason')
159− liftIO $ putMVar done ()
206+ putMVar done ())
161 (\(ProcessLinkException pid reason') -> do
209 (\(ProcessLinkException pid reason') -> do
210+ (liftIO $ assertBool "link exception unmatched" $
162− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
211+ pid == theirAddr && not mOrL && not un && reason == reason')
163 liftIO $ putMVar done ()
212 liftIO $ putMVar done ()
@@ -190,8 +239,10 @@ testPing TestTransport{..} = do
190 pid <- getSelfPid
239 pid <- getSelfPid
191 replicateM_ numPings $ do
240 replicateM_ numPings $ do
192 send pingServer (Pong pid)
241 send pingServer (Pong pid)
193− Ping _ <- expect
242+ p <- expectTimeout 3000000
194− return ()
244+ Just (Ping _) -> return ()
245+ Nothing -> die "Failed to receive Ping"
196 putMVar clientDone ()
247 putMVar clientDone ()
@@ -278,7 +329,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
278 runProcess localNode $ do
329 runProcess localNode $ do
279 monitor theirAddr
330 monitor theirAddr
280 -- wait for the process to die
331 -- wait for the process to die
281− ProcessMonitorNotification _ _ _ <- expect
332+ expect :: Process ProcessMonitorNotification
282 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
333 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
284 takeMVar done
335 takeMVar done
@@ -352,14 +403,17 @@ testMath TestTransport{..} = do
352 runProcess localNode $ do
403 runProcess localNode $ do
353 pid <- getSelfPid
404 pid <- getSelfPid
354 send mathServer (Add pid 1 2)
405 send mathServer (Add pid 1 2)
355− 3 <- expect :: Process Double
406+ three <- expect :: Process Double
356 send mathServer (Divide pid 8 2)
407 send mathServer (Divide pid 8 2)
357− 4 <- expect :: Process Double
408+ four <- expect :: Process Double
358 send mathServer (Divide pid 8 0)
409 send mathServer (Divide pid 8 0)
359− DivByZero <- expect
410+ divByZ <- expect
360− liftIO $ putMVar clientDone ()
411+ liftIO $ putMVar clientDone (three, four, divByZ)
362− takeMVar clientDone
413+ res <- takeMVar clientDone
415+ (3, 4, DivByZero) -> return ()
416+ _ -> error $ "Something went horribly wrong"
364-- | Send first message (i.e. connect) to an already terminated process
418-- | Send first message (i.e. connect) to an already terminated process
365-- (without monitoring); then send another message to a second process on
419-- (without monitoring); then send another message to a second process on
@@ -387,11 +441,9 @@ testSendToTerminated TestTransport{..} = do
387 pid <- getSelfPid
441 pid <- getSelfPid
388 send server1 "Hi"
442 send server1 "Hi"
389 send server2 (Pong pid)
443 send server2 (Pong pid)
391− True <- return $ pid' == server2
392− liftIO $ putMVar clientDone ()
444+ expectPing clientDone
394− takeMVar clientDone
446+ verifyClient "Expected Ping from server" clientDone
396-- | Test (non-zero) timeout
448-- | Test (non-zero) timeout
397testTimeout :: TestTransport -> Assertion
449testTimeout :: TestTransport -> Assertion
@@ -400,26 +452,24 @@ testTimeout TestTransport{..} = do
400 done <- newEmptyMVar
452 done <- newEmptyMVar
402 runProcess localNode $ do
454 runProcess localNode $ do
403− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
455+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
404− liftIO $ putMVar done ()
456+ liftIO $ putMVar done $ res == Nothing
406− takeMVar done
458+ verifyClient "Expected receiveTimeout to timeout..." done
408-- | Test zero timeout
460-- | Test zero timeout
409testTimeout0 :: TestTransport -> Assertion
461testTimeout0 :: TestTransport -> Assertion
410testTimeout0 TestTransport{..} = do
462testTimeout0 TestTransport{..} = do
411 serverAddr <- newEmptyMVar
463 serverAddr <- newEmptyMVar
412 clientDone <- newEmptyMVar
464 clientDone <- newEmptyMVar
413− messagesSent <- newEmptyMVar
415 forkIO $ do
466 forkIO $ do
416 localNode <- newLocalNode testTransport initRemoteTable
467 localNode <- newLocalNode testTransport initRemoteTable
417 addr <- forkProcess localNode $ do
468 addr <- forkProcess localNode $ do
418− liftIO $ readMVar messagesSent >> threadDelay 1000000
419 -- Variation on the venerable ping server which uses a zero timeout
469 -- Variation on the venerable ping server which uses a zero timeout
420− -- Since we wait for all messages to be sent before doing this receive,
470+ partner <- fix $ \loop ->
421− -- we should nevertheless find the right message immediately
422− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
471+ receiveTimeout 0 [match (\(Pong partner) -> return partner)]
472+ >>= maybe (liftIO (threadDelay 100000) >> loop) return
423 self <- getSelfPid
473 self <- getSelfPid
424 send partner (Ping self)
474 send partner (Ping self)
425 putMVar serverAddr addr
475 putMVar serverAddr addr
@@ -433,11 +483,9 @@ testTimeout0 TestTransport{..} = do
433 -- is not interested in, and then a single message that it wants
483 -- is not interested in, and then a single message that it wants
434 replicateM_ 10000 $ send server "Irrelevant message"
484 replicateM_ 10000 $ send server "Irrelevant message"
435 send server (Pong pid)
485 send server (Pong pid)
436− liftIO $ putMVar messagesSent ()
438− liftIO $ putMVar clientDone ()
486+ expectPing clientDone
440− takeMVar clientDone
488+ verifyClient "Expected Ping from server" clientDone
442-- | Test typed channels
490-- | Test typed channels
443testTypedChannels :: TestTransport -> Assertion
491testTypedChannels :: TestTransport -> Assertion
@@ -460,10 +508,10 @@ testTypedChannels TestTransport{..} = do
460 runProcess localNode $ do
508 runProcess localNode $ do
461 (clientSendPort, rport) <- newChan
509 (clientSendPort, rport) <- newChan
462 sendChan serverSendPort (clientSendPort, 5)
510 sendChan serverSendPort (clientSendPort, 5)
463− False <- receiveChan rport
511+ ch <- receiveChan rport
464− liftIO $ putMVar clientDone ()
512+ liftIO $ putMVar clientDone $ ch == False
466− takeMVar clientDone
514+ verifyClient "Expected channel to send 'False'" clientDone
468-- | Test merging receive ports
516-- | Test merging receive ports
469testMergeChannels :: TestTransport -> Assertion
517testMergeChannels :: TestTransport -> Assertion
@@ -486,9 +534,8 @@ testMergeChannels TestTransport{..} = do
486 rs <- mapM charChannel "abc"
534 rs <- mapM charChannel "abc"
487 m <- mergePorts biased rs
535 m <- mergePorts biased rs
488 xs <- replicateM 9 $ receiveChan m
536 xs <- replicateM 9 $ receiveChan m
489− True <- return $ xs == expected
490− liftIO $ putMVar done ()
537+ liftIO $ putMVar done $ xs == expected
491− takeMVar done
538+ verifyClient "Expected single layer merge to match expected ordering" done
493 -- Two layers of merging
540 -- Two layers of merging
494 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
541 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -499,9 +546,8 @@ testMergeChannels TestTransport{..} = do
499 ms <- mapM (mergePorts biasedInner) rss
546 ms <- mapM (mergePorts biasedInner) rss
500 m <- mergePorts biasedOuter ms
547 m <- mergePorts biasedOuter ms
501 xs <- replicateM (9 * 3) $ receiveChan m
548 xs <- replicateM (9 * 3) $ receiveChan m
502− True <- return $ xs == expected
549+ liftIO $ putMVar done $ xs == expected
503− liftIO $ putMVar done ()
550+ verifyClient "Expected nested channels to match expeted ordering" done
506 -- Test that if no messages are (immediately) available, the scheduler makes no difference
552 -- Test that if no messages are (immediately) available, the scheduler makes no difference
507 testBlocked :: LocalNode -> Bool -> IO ()
553 testBlocked :: LocalNode -> Bool -> IO ()
@@ -510,43 +556,45 @@ testMergeChannels TestTransport{..} = do
510 done <- newEmptyMVar
556 done <- newEmptyMVar
512 forkProcess localNode $ do
558 forkProcess localNode $ do
513− [sa, sb, sc] <- liftIO $ mapM readMVar vs
559+ ss <- liftIO $ mapM readMVar vs
514− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
562+ mapM_ ((>> pause 10000) . uncurry sendChan)
515− [ -- a, b, c
563+ [ -- a, b, c
516− (sa, 'a')
564+ (sa, 'a')
517− , (sb, 'b')
565+ , (sb, 'b')
518− , (sc, 'c')
566+ , (sc, 'c')
519− -- a, c, b
567+ -- a, c, b
520− , (sa, 'a')
568+ , (sa, 'a')
521− , (sc, 'c')
569+ , (sc, 'c')
522− , (sb, 'b')
570+ , (sb, 'b')
523− -- b, a, c
571+ -- b, a, c
524− , (sb, 'b')
572+ , (sb, 'b')
525− , (sa, 'a')
573+ , (sa, 'a')
526− , (sc, 'c')
574+ , (sc, 'c')
527− -- b, c, a
575+ -- b, c, a
528− , (sb, 'b')
576+ , (sb, 'b')
529− , (sc, 'c')
577+ , (sc, 'c')
530− , (sa, 'a')
578+ , (sa, 'a')
531− -- c, a, b
579+ -- c, a, b
532− , (sc, 'c')
580+ , (sc, 'c')
533− , (sa, 'a')
581+ , (sa, 'a')
534− , (sb, 'b')
582+ , (sb, 'b')
535− -- c, b, a
583+ -- c, b, a
536− , (sc, 'c')
584+ , (sc, 'c')
537− , (sb, 'b')
585+ , (sb, 'b')
538− , (sa, 'a')
586+ , (sa, 'a')
588+ _ -> die "Something went horribly wrong"
541 forkProcess localNode $ do
590 forkProcess localNode $ do
542 (ss, rs) <- unzip <$> replicateM 3 newChan
591 (ss, rs) <- unzip <$> replicateM 3 newChan
543 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
592 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
544 m <- mergePorts biased rs
593 m <- mergePorts biased rs
545 xs <- replicateM (6 * 3) $ receiveChan m
594 xs <- replicateM (6 * 3) $ receiveChan m
546− True <- return $ xs == "abcacbbacbcacabcba"
547− liftIO $ putMVar done ()
595+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
549− takeMVar done
597+ verifyClient "Expected merged ports to match expected ordering" done
551 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
599 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
552 mergePorts True = mergePortsBiased
600 mergePorts True = mergePortsBiased
@@ -562,19 +610,11 @@ testMergeChannels TestTransport{..} = do
562testTerminate :: TestTransport -> Assertion
610testTerminate :: TestTransport -> Assertion
563testTerminate TestTransport{..} = do
611testTerminate TestTransport{..} = do
564 localNode <- newLocalNode testTransport initRemoteTable
612 localNode <- newLocalNode testTransport initRemoteTable
565− done <- newEmptyMVar
567− pid <- forkProcess localNode $ do
568− liftIO $ threadDelay 100000
571 runProcess localNode $ do
613 runProcess localNode $ do
572− ref <- monitor pid
614+ e <- try terminate :: Process (Either ProcessTerminationException ())
573− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
615+ if either show show e == show ProcessTerminationException
574− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
616+ then return ()
575− liftIO $ putMVar done ()
617+ else die "Unexpected result from terminate"
579testMonitorNode :: TestTransport -> Assertion
619testMonitorNode :: TestTransport -> Assertion
580testMonitorNode TestTransport{..} = do
620testMonitorNode TestTransport{..} = do
@@ -585,11 +625,12 @@ testMonitorNode TestTransport{..} = do
586 runProcess node2 $ do
626 runProcess node2 $ do
587 ref <- monitorNode (localNodeId node1)
627 ref <- monitorNode (localNodeId node1)
588− NodeMonitorNotification ref' nid DiedDisconnect <- expect
629+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
589− True <- return $ ref == ref' && nid == localNodeId node1
630+ return $ ref == ref' && nid == localNodeId node1)
590− liftIO $ putMVar done ()
631+ ] >>= liftIO . putMVar done
592− takeMVar done
633+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
594testMonitorLiveNode :: TestTransport -> Assertion
635testMonitorLiveNode :: TestTransport -> Assertion
595testMonitorLiveNode TestTransport{..} = do
636testMonitorLiveNode TestTransport{..} = do
@@ -604,15 +645,16 @@ testMonitorLiveNode TestTransport{..} = do
604 liftIO $ putMVar ready ()
645 liftIO $ putMVar ready ()
605 liftIO $ takeMVar readyr
646 liftIO $ takeMVar readyr
606 send p ()
647 send p ()
607− NodeMonitorNotification ref' nid _ <- expect
649+ match (\(NodeMonitorNotification ref' nid _) ->
608− True <- return $ ref == ref' && nid == localNodeId node1
650+ (return $ ref == ref' && nid == localNodeId node1))
609− liftIO $ putMVar done ()
651+ ] >>= liftIO . putMVar done
611 takeMVar ready
653 takeMVar ready
612 closeLocalNode node1
654 closeLocalNode node1
613 putMVar readyr ()
655 putMVar readyr ()
615− takeMVar done
657+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
617testMonitorChannel :: TestTransport -> Assertion
659testMonitorChannel :: TestTransport -> Assertion
618testMonitorChannel TestTransport{..} = do
660testMonitorChannel TestTransport{..} = do
@@ -622,18 +664,20 @@ testMonitorChannel TestTransport{..} = do
622 pid <- forkProcess node1 $ do
664 pid <- forkProcess node1 $ do
623 sport <- expect :: Process (SendPort ())
665 sport <- expect :: Process (SendPort ())
624 ref <- monitorPort sport
666 ref <- monitorPort sport
625− PortMonitorNotification ref' port' reason <- expect
667+ receiveWait [
626− -- reason might be DiedUnknownId if the receive port is GCed before the
668+ -- reason might be DiedUnknownId if the receive port is GCed before the
627− -- monitor is established (TODO: not sure that this is reasonable)
669+ -- monitor is established (TODO: not sure that this is reasonable)
670+ match (\(PortMonitorNotification ref' port' reason) ->
671+ return $ ref' == ref && port' == sendPortId sport &&
628− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
672+ (reason == DiedNormal || reason == DiedUnknownId))
629− liftIO $ putMVar gotNotification ()
673+ ] >>= liftIO . putMVar gotNotification
631 runProcess node2 $ do
675 runProcess node2 $ do
632 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
676 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
633 send pid sport
677 send pid sport
634 liftIO $ threadDelay 100000
678 liftIO $ threadDelay 100000
636− takeMVar gotNotification
680+ verifyClient "Expected PortMonitorNotification" gotNotification
638testRegistry :: TestTransport -> Assertion
682testRegistry :: TestTransport -> Assertion
639testRegistry TestTransport{..} = do
683testRegistry TestTransport{..} = do
@@ -645,20 +689,28 @@ testRegistry TestTransport{..} = do
646 runProcess node $ do
690 runProcess node $ do
647 register "ping" pingServer
691 register "ping" pingServer
648− Just pid <- whereis "ping"
692+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
649− True <- return $ pingServer == pid
650 us <- getSelfPid
693 us <- getSelfPid
651 nsend "ping" (Pong us)
694 nsend "ping" (Pong us)
652− Ping pid' <- expect
695+ receiveWait [
653− True <- return $ pingServer == pid'
696+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
654− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
697+ ]
655− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
698+ checkRegException "dead" Nothing deadProcess
656− True <- return $ x == pingServer
699+ checkRegException "ping" (Just pingServer) deadProcess
657− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
700+ try (unregister "dead") >>= checkReg "dead" Nothing
658 liftIO $ putMVar done ()
701 liftIO $ putMVar done ()
660 takeMVar done
703 takeMVar done
706+ checkRegException name pid dead =
707+ try (register name dead) >>= checkReg name pid
709+ checkReg name pid res =
711+ Left (ProcessRegistrationException name pid) -> return ()
712+ _ -> die $ "Unexpected Registration" ++ show res
662testRegistryRemoteProcess :: TestTransport -> Assertion
714testRegistryRemoteProcess :: TestTransport -> Assertion
663testRegistryRemoteProcess TestTransport{..} = do
715testRegistryRemoteProcess TestTransport{..} = do
664 node1 <- newLocalNode testTransport initRemoteTable
716 node1 <- newLocalNode testTransport initRemoteTable
@@ -669,13 +721,13 @@ testRegistryRemoteProcess TestTransport{..} = do
670 runProcess node2 $ do
722 runProcess node2 $ do
671 register "ping" pingServer
723 register "ping" pingServer
672− Just pid <- whereis "ping"
724+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
673− True <- return $ pingServer == pid
674 us <- getSelfPid
725 us <- getSelfPid
675 nsend "ping" (Pong us)
726 nsend "ping" (Pong us)
676− Ping pid' <- expect
727+ receiveWait [
677− True <- return $ pingServer == pid'
728+ matchIf (\(Ping pid') -> pingServer == pid')
678− liftIO $ putMVar done ()
729+ (const $ liftIO $ putMVar done ())
680 takeMVar done
732 takeMVar done
@@ -683,7 +735,6 @@ testRemoteRegistry :: TestTransport -> Assertion
683testRemoteRegistry TestTransport{..} = do
735testRemoteRegistry TestTransport{..} = do
684 node1 <- newLocalNode testTransport initRemoteTable
736 node1 <- newLocalNode testTransport initRemoteTable
685 node2 <- newLocalNode testTransport initRemoteTable
737 node2 <- newLocalNode testTransport initRemoteTable
686− done <- newEmptyMVar
688 pingServer <- forkProcess node1 ping
739 pingServer <- forkProcess node1 ping
689 deadProcess <- forkProcess node1 (return ())
740 deadProcess <- forkProcess node1 (return ())
@@ -696,32 +747,34 @@ testRemoteRegistry TestTransport{..} = do
696 "ping" == label' && pid == pingServer)
747 "ping" == label' && pid == pingServer)
697 (\(RegisterReply _ _ _) -> return ()) ]
748 (\(RegisterReply _ _ _) -> return ()) ]
699− Just pid <- whereisRemote nid1 "ping"
750+ pid <- verifyWhereIsRemote nid1 "ping"
700− True <- return $ pingServer == pid
751+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
701 us <- getSelfPid
753 us <- getSelfPid
702 nsendRemote nid1 "ping" (Pong us)
754 nsendRemote nid1 "ping" (Pong us)
703− Ping pid' <- expect
755+ receiveWait [
704− True <- return $ pingServer == pid'
756+ match (\(Ping pid') -> return $ pingServer == pid')
757+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
706 -- test that if process was not registered Nothing is returned
759 -- test that if process was not registered Nothing is returned
707 -- in owner field.
760 -- in owner field.
708 registerRemoteAsync nid1 "dead" deadProcess
761 registerRemoteAsync nid1 "dead" deadProcess
710− matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
762+ receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
711− (\(RegisterReply _ _ _) -> return ()) ]
763+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764+ ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
712 registerRemoteAsync nid1 "ping" deadProcess
766 registerRemoteAsync nid1 "ping" deadProcess
713 receiveWait [
767 receiveWait [
714− matchIf (\(RegisterReply label' False (Just pid)) ->
768+ matchIf (\(RegisterReply label' False mPid) ->
715− "ping" == label' && pid == pingServer)
769+ "ping" == label' && isJust mPid)
716− (\(RegisterReply _ _ _) -> return ()) ]
770+ (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771+ ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
717 unregisterRemoteAsync nid1 "dead"
773 unregisterRemoteAsync nid1 "dead"
718 receiveWait [
774 receiveWait [
719− matchIf (\(RegisterReply label' False Nothing) ->
775+ matchIf (\(RegisterReply label' _ _) -> "dead" == label')
720− "dead" == label' && pid == pingServer)
776+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
721− (\(RegisterReply _ _ _) -> return ()) ]
777+ ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
722− liftIO $ putMVar done ()
726testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
779testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
727testRemoteRegistryRemoteProcess TestTransport{..} = do
780testRemoteRegistryRemoteProcess TestTransport{..} = do
@@ -737,15 +790,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
737 receiveWait [
790 receiveWait [
738 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
791 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
739 (\(RegisterReply _ _ _) -> return ()) ]
792 (\(RegisterReply _ _ _) -> return ()) ]
740− Just pid <- whereisRemote nid1 "ping"
793+ pid <- verifyWhereIsRemote nid1 "ping"
741− True <- return $ pingServer == pid
794+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
742 us <- getSelfPid
795 us <- getSelfPid
743 nsendRemote nid1 "ping" (Pong us)
796 nsendRemote nid1 "ping" (Pong us)
744− Ping pid' <- expect
797+ receiveWait [
745− True <- return $ pingServer == pid'
798+ match (\(Ping pid') -> return $ pingServer == pid')
746− liftIO $ putMVar done ()
799+ ] >>= liftIO . putMVar done
748− takeMVar done
801+ verifyClient "Expected Ping with ping server's ProcessId" done
750testSpawnLocal :: TestTransport -> Assertion
803testSpawnLocal :: TestTransport -> Assertion
751testSpawnLocal TestTransport{..} = do
804testSpawnLocal TestTransport{..} = do
@@ -759,15 +812,14 @@ testSpawnLocal TestTransport{..} = do
759 sport <- expect
812 sport <- expect
760 sendChan sport (1234 :: Int)
813 sendChan sport (1234 :: Int)
762− sport <- spawnChannelLocal $ \rport -> do
815+ sport <- spawnChannelLocal $
763− (1234 :: Int) <- receiveChan rport
816+ \rport -> (receiveChan rport :: Process Int) >>= send us
766 send pid sport
818 send pid sport
768− liftIO $ putMVar done ()
819+ expect >>= liftIO . putMVar done
770− takeMVar done
821+ res <- takeMVar done
822+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
772testSpawnAsyncStrictness :: TestTransport -> Assertion
824testSpawnAsyncStrictness :: TestTransport -> Assertion
773testSpawnAsyncStrictness TestTransport{..} = do
825testSpawnAsyncStrictness TestTransport{..} = do
@@ -796,8 +848,9 @@ testReconnect TestTransport{..} = do
796 liftIO $ putMVar processA us
848 liftIO $ putMVar processA us
797 msg1 <- expect
849 msg1 <- expect
798 msg2 <- expect
850 msg2 <- expect
799− True <- return $ msg1 == "message 1" && msg2 == "message 3"
852+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
800− liftIO $ putMVar sendTestOk ()
853+ putMVar sendTestOk ()
802 forkProcess node2 $ do
855 forkProcess node2 $ do
@@ -830,7 +883,7 @@ testReconnect TestTransport{..} = do
830 matchIf (\(RegisterReply label' _ _) -> "a" == label')
883 matchIf (\(RegisterReply label' _ _) -> "a" == label')
831 (\(RegisterReply _ _ _) -> return ()) ]
884 (\(RegisterReply _ _ _) -> return ()) ]
833− Just _ <- whereisRemote nid1 "a"
886+ _ <- whereisRemote nid1 "a"
836 -- Simulate network failure
889 -- Simulate network failure
@@ -849,9 +902,10 @@ testReconnect TestTransport{..} = do
849 (\(RegisterReply _ _ _) -> return ()) ]
902 (\(RegisterReply _ _ _) -> return ()) ]
852− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
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
853− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
907+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
854− Just _ <- whereisRemote nid1 "c"
908+ verifyWhereIsRemote nid1 "c"
856 liftIO $ putMVar registerTestOk ()
910 liftIO $ putMVar registerTestOk ()
@@ -892,19 +946,19 @@ testUSend usendPrim TestTransport{..} numMessages = do
892 isSorted _ = True
946 isSorted _ = True
893 -- The list can't be null since there are no failures after sending
947 -- The list can't be null since there are no failures after sending
894 -- the last message.
948 -- the last message.
895− True <- return $ isSorted msgs && not (null msgs)
949+ liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
896− liftIO $ putMVar usendTestOk ()
898 forkProcess node2 $ do
951 forkProcess node2 $ do
899 them <- liftIO $ readMVar processA
952 them <- liftIO $ readMVar processA
900 getSelfPid >>= send them
953 getSelfPid >>= send them
901− () <- expect
954+ expect :: Process ()
902 forM_ [1..numMessages] $ \i -> do
955 forM_ [1..numMessages] $ \i -> do
903 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
956 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
904 usendPrim them i
957 usendPrim them i
905 liftIO (threadDelay 30000)
958 liftIO (threadDelay 30000)
907− takeMVar usendTestOk
960+ res <- takeMVar usendTestOk
961+ assertBool "Unexpected failure after sending last msg" res
909-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
963-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
910-- in between
964-- in between
@@ -930,14 +984,17 @@ testMatchAny TestTransport{..} = do
930 runProcess localNode $ do
984 runProcess localNode $ do
931 pid <- getSelfPid
985 pid <- getSelfPid
932 send mathServer (Add pid 1 2)
986 send mathServer (Add pid 1 2)
933− 3 <- expect :: Process Double
987+ three <- expect :: Process Double
934 send mathServer (Divide pid 8 2)
988 send mathServer (Divide pid 8 2)
935− 4 <- expect :: Process Double
989+ four <- expect :: Process Double
936 send mathServer (Divide pid 8 0)
990 send mathServer (Divide pid 8 0)
937− DivByZero <- expect
991+ divByZ <- expect
938− liftIO $ putMVar clientDone ()
992+ liftIO $ putMVar clientDone (three, four, divByZ)
940− takeMVar clientDone
994+ res <- takeMVar clientDone
996+ (3, 4, DivByZero) -> return ()
997+ _ -> error "Unexpected result"
942-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
999-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
943-- in between, however we block 'Divide' requests ....
1000-- in between, however we block 'Divide' requests ....
@@ -964,12 +1021,13 @@ testMatchAnyHandle TestTransport{..} = do
964 runProcess localNode $ do
1021 runProcess localNode $ do
965 pid <- getSelfPid
1022 pid <- getSelfPid
966 send mathServer (Add pid 1 2)
1023 send mathServer (Add pid 1 2)
967− 3 <- expect :: Process Double
1024+ three <- expect :: Process Double
968 send mathServer (Divide pid 8 2)
1025 send mathServer (Divide pid 8 2)
969− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1026+ res <- (expectTimeout 100000) :: Process (Maybe Double)
970− liftIO $ putMVar clientDone ()
1027+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1029+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
973 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1031 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
974 maybeForward s msg =
1032 maybeForward s msg =
975 handleMessage msg (\m@(Add _ _ _) -> send s m)
1033 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -997,8 +1055,10 @@ testMatchAnyNoHandle TestTransport{..} = do
997 Just _ -> die "NONSENSE")
1055 Just _ -> die "NONSENSE")
999 -- we *must* have removed the message from our mailbox though!!!
1057 -- we *must* have removed the message from our mailbox though!!!
1000− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1058+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1060+ assertBool "Expected timeout!" $ res == Nothing
1001− liftIO $ putMVar serverDone ()
1061+ putMVar serverDone ()
1002 putMVar addr server
1062 putMVar addr server
1004 -- Client
1064 -- Client
@@ -1041,14 +1101,21 @@ testMatchAnyIf TestTransport{..} = do
1041 runProcess localNode $ do
1101 runProcess localNode $ do
1042 pid <- getSelfPid
1102 pid <- getSelfPid
1043 send server (pid, "foo")
1103 send server (pid, "foo")
1044− "foo" <- expect
1104+ foo <- expect
1045− send server (pid, "baz")
1105+ -- provoking what would be the wrong ordering is informative here...
1046− "baz" <- expect
1106+
1047 send server (pid, "bar")
1107 send server (pid, "bar")
1048− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1108+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1110+ send server (pid, "baz")
1049− liftIO $ putMVar clientDone ()
1113+ liftIO $ putMVar clientDone (foo, bar, baz)
1115+ res <- takeMVar clientDone
1116+ let res' = res == ("foo", Nothing, "baz")
1117+ assertBool "Expected timeout due to type mismatch" res'
1051− takeMVar clientDone
1052 where tryHandleMessage :: Message -> Process (Maybe ())
1119 where tryHandleMessage :: Message -> Process (Maybe ())
1053 tryHandleMessage msg =
1120 tryHandleMessage msg =
1054 handleMessage msg (\(pid :: ProcessId, (m :: String))
1121 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1081,17 +1148,19 @@ testMatchMessageWithUnwrap TestTransport{..} = do
1081 runProcess localNode $ do
1148 runProcess localNode $ do
1082 pid <- getSelfPid
1149 pid <- getSelfPid
1083 send server (pid, wrapMessage ("foo" :: String))
1150 send server (pid, wrapMessage ("foo" :: String))
1084− "foo" <- expect
1151+ foo <- expect
1085 send server (pid, wrapMessage ("baz" :: String))
1152 send server (pid, wrapMessage ("baz" :: String))
1086− "baz" <- expect
1153+ baz <- expect
1087− liftIO $ putMVar clientDone ()
1154+ liftIO $ putMVar clientDone (foo, baz)
1089− takeMVar clientDone
1156+ res <- takeMVar clientDone
1157+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1091-- Test 'receiveChanTimeout'
1159-- Test 'receiveChanTimeout'
1092testReceiveChanTimeout :: TestTransport -> Assertion
1160testReceiveChanTimeout :: TestTransport -> Assertion
1093testReceiveChanTimeout TestTransport{..} = do
1161testReceiveChanTimeout TestTransport{..} = do
1094 done <- newEmptyMVar
1162 done <- newEmptyMVar
1163+ mvSender <- newEmptyMVar
1095 sendPort <- newEmptyMVar
1164 sendPort <- newEmptyMVar
1097 forkTry $ do
1166 forkTry $ do
@@ -1101,18 +1170,32 @@ testReceiveChanTimeout TestTransport{..} = do
1101 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1170 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1102 liftIO $ putMVar sendPort sp
1171 liftIO $ putMVar sendPort sp
1104− -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
1173+ -- Wait for a message with a delay. No message arrives, we should get
1174+ -- Nothing after the delay.
1105− Nothing <- receiveChanTimeout 1000000 rp
1175+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1177+ -- Let the sender know that it can send a message.
1178+ liftIO $ putMVar mvSender ()
1107− -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
1180+ -- Wait for a message with a delay again. Now a message arrives after
1108− Just True <- receiveChanTimeout 1000000 rp
1182+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1183+ liftIO $ assertBool "Expected result to be 'True'" res
1110− -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
1185+ -- Wait for a message with zero timeout: non-blocking check. No message is
1186+ -- available, we get Nothing
1111− Nothing <- receiveChanTimeout 0 rp
1187+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1189+ -- Let the sender know that it can send a message.
1190+ liftIO $ putMVar mvSender ()
1113 -- Again, but now there is a message available
1192 -- Again, but now there is a message available
1114− liftIO $ threadDelay 1000000
1194+ liftIO $ threadDelay 100000
1115− Just False <- receiveChanTimeout 0 rp
1195+ mb <- receiveChanTimeout 0 rp
1197+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1117 liftIO $ putMVar done ()
1200 liftIO $ putMVar done ()
@@ -1121,10 +1204,11 @@ testReceiveChanTimeout TestTransport{..} = do
1121 runProcess localNode $ do
1204 runProcess localNode $ do
1122 sp <- liftIO $ readMVar sendPort
1205 sp <- liftIO $ readMVar sendPort
1207+ liftIO $ takeMVar mvSender
1124− liftIO $ threadDelay 1500000
1208+ liftIO $ threadDelay 100000
1125 sendChan sp True
1209 sendChan sp True
1127− liftIO $ threadDelay 500000
1211+ liftIO $ takeMVar mvSender
1128 sendChan sp False
1212 sendChan sp False
1130 takeMVar done
1214 takeMVar done
@@ -1147,8 +1231,8 @@ testReceiveChanFeatures TestTransport{..} = do
1148 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1232 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1150− True <- receiveChan rp1
1234+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1151− False <- receiveChan rp1
1235+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1153 -- Test Applicative instance
1237 -- Test Applicative instance
@@ -1157,7 +1241,7 @@ testReceiveChanFeatures TestTransport{..} = do
1158 let rp2 = pure (+) <*> rpInt <*> rpInt
1242 let rp2 = pure (+) <*> rpInt <*> rpInt
1160− 7 <- receiveChan rp2
1244+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1162 -- Test Alternative instance
1246 -- Test Alternative instance
@@ -1166,8 +1250,8 @@ testReceiveChanFeatures TestTransport{..} = do
1167 let rp3 = (even <$> rpInt) <|> rpBool
1251 let rp3 = (even <$> rpInt) <|> rpBool
1169− False <- receiveChan rp3
1253+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1170− True <- receiveChan rp3
1254+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
1172 -- Test Monad instance
1256 -- Test Monad instance
@@ -1181,17 +1265,86 @@ testReceiveChanFeatures TestTransport{..} = do
1181 then rpInt
1265 then rpInt
1182 else return 7
1266 else return 7
1184− 5 <- receiveChan rp4
1268+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1185− 7 <- receiveChan rp4
1269+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1187 liftIO $ putMVar done ()
1271 liftIO $ putMVar done ()
1189 takeMVar done
1273 takeMVar done
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
1282+ pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283+ liftIO $ putMVar tchMV tCh
1284+ expect :: Process ()
1287+ expect :: Process ()
1289+ mRefPid <- monitor pid
1291+ cPid <- spawnLocal $ do
1292+ (sp', rp) <- liftIO $ takeMVar tchMV
1293+ -- say "picked up our test channel"
1295+ -- say "told pid to continue"
1296+ res <- receiveChanTimeout delay rp
1298+ Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299+ Just () -> do mr <- monitor pid
1301+ -- say "sending pid a second () will cause it to exit"
1304+ -- say "make sure we see a DOWN notification for pid having stopped"
1305+ receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1307+ -- now that pid has died, the send port should be useless...
1308+ liftIO $ putMVar tchMV (sp', rp)
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
1316+ mRefCPid <- monitor cPid
1319+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1323+ -- say "seen first pid die..."
1325+ (sendPort, _) <- liftIO $ takeMVar tchMV
1326+ sendChan sendPort ()
1327+ -- say "sent () after owning pid died"
1329+ -- let cPid know we've written to the channel...
1333+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1337+ -- say "seen both pids die now..."
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
1191testKillLocal :: TestTransport -> Assertion
1345testKillLocal :: TestTransport -> Assertion
1192testKillLocal TestTransport{..} = do
1346testKillLocal TestTransport{..} = do
1193 localNode <- newLocalNode testTransport initRemoteTable
1347 localNode <- newLocalNode testTransport initRemoteTable
1194− done <- newEmptyMVar
1196 pid <- forkProcess localNode $ do
1349 pid <- forkProcess localNode $ do
1197 liftIO $ threadDelay 1000000
1350 liftIO $ threadDelay 1000000
@@ -1200,17 +1353,18 @@ testKillLocal TestTransport{..} = do
1200 ref <- monitor pid
1353 ref <- monitor pid
1201 us <- getSelfPid
1354 us <- getSelfPid
1202 kill pid "TestKill"
1355 kill pid "TestKill"
1203− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1356+ mn <- expect
1358+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1204− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1359+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1205− liftIO $ putMVar done ()
1360+ True -> return ()
1206−
1361+ False -> die "Invalid ProcessMonitorNotification received"
1207− takeMVar done
1362+ _ -> die "Something went horribly wrong"
1209testKillRemote :: TestTransport -> Assertion
1364testKillRemote :: TestTransport -> Assertion
1210testKillRemote TestTransport{..} = do
1365testKillRemote TestTransport{..} = do
1211 node1 <- newLocalNode testTransport initRemoteTable
1366 node1 <- newLocalNode testTransport initRemoteTable
1212 node2 <- newLocalNode testTransport initRemoteTable
1367 node2 <- newLocalNode testTransport initRemoteTable
1213− done <- newEmptyMVar
1215 pid <- forkProcess node1 $ do
1369 pid <- forkProcess node1 $ do
1216 liftIO $ threadDelay 1000000
1370 liftIO $ threadDelay 1000000
@@ -1219,11 +1373,17 @@ testKillRemote TestTransport{..} = do
1219 ref <- monitor pid
1373 ref <- monitor pid
1220 us <- getSelfPid
1374 us <- getSelfPid
1221 kill pid "TestKill"
1375 kill pid "TestKill"
1222− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1378+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1223− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1379+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1224− liftIO $ putMVar done ()
1380+ (True, True, True) -> return ()
1225−
1381+ (a, b, c) -> do
1226− takeMVar done
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"
1228testCatchesExit :: TestTransport -> Assertion
1388testCatchesExit :: TestTransport -> Assertion
1229testCatchesExit TestTransport{..} = do
1389testCatchesExit TestTransport{..} = do
@@ -1249,7 +1409,10 @@ testHandleMessageIf TestTransport{..} = do
1249 self <- getSelfPid
1409 self <- getSelfPid
1250 send self (5 :: Integer, 10 :: Integer)
1410 send self (5 :: Integer, 10 :: Integer)
1251 msg <- receiveWait [ matchMessage return ]
1411 msg <- receiveWait [ matchMessage return ]
1252− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1412+ handleMessageIf msg
1414+ (\() -> die "whoops") >>= maybe (return ())
1415+ (const $ die "Expected Mismatch")
1253 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1416 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1254 (\input -> liftIO $ putMVar done input)
1417 (\input -> liftIO $ putMVar done input)
1255 return ()
1418 return ()
@@ -1294,8 +1457,11 @@ testDie TestTransport{..} = do
1294 (die ("foobar", 123 :: Int))
1457 (die ("foobar", 123 :: Int))
1295 `catchExit` \_from reason -> do
1458 `catchExit` \_from reason -> do
1296 -- TODO: should verify that 'from' has the right value
1459 -- TODO: should verify that 'from' has the right value
1297− True <- return $ reason == ("foobar", 123 :: Int)
1460+ let res = reason == ("foobar", 123 :: Int)
1298 liftIO $ putMVar done ()
1461 liftIO $ putMVar done ()
1464+ else die "Something went horribly wrong"
1300 takeMVar done
1466 takeMVar done
@@ -1309,8 +1475,11 @@ testPrettyExit TestTransport{..} = do
1309 `catch` \ex@(ProcessExitException from _) ->
1475 `catch` \ex@(ProcessExitException from _) ->
1310 let expected = "exit-from=" ++ (show from)
1476 let expected = "exit-from=" ++ (show from)
1312− True <- return $ (show ex) == expected
1478+ let res = (show ex) == expected
1313 liftIO $ putMVar done ()
1479 liftIO $ putMVar done ()
1482+ else die "Something went horribly wrong"
1315 takeMVar done
1484 takeMVar done
@@ -1326,17 +1495,26 @@ testExitLocal TestTransport{..} = do
1326 pid <- forkProcess localNode $ do
1495 pid <- forkProcess localNode $ do
1327 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1496 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1328 -- TODO: should verify that 'from' has the right value
1497 -- TODO: should verify that 'from' has the right value
1329− True <- return $ reason == "TestExit"
1498+ res <- return $ reason == "TestExit"
1330 liftIO $ putMVar supervisedDone ()
1499 liftIO $ putMVar supervisedDone ()
1502+ else die "Something went horribly wrong"
1332 runProcess localNode $ do
1504 runProcess localNode $ do
1333 liftIO $ takeMVar handlerSetUp
1505 liftIO $ takeMVar handlerSetUp
1334 ref <- monitor pid
1506 ref <- monitor pid
1335 exit pid "TestExit"
1507 exit pid "TestExit"
1336 -- This time the client catches the exception, so it dies normally
1508 -- This time the client catches the exception, so it dies normally
1337− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1511+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1338− True <- return $ ref == ref' && pid == pid'
1512+ let res = ref == ref' && pid == pid'
1339− liftIO $ putMVar supervisorDone ()
1513+ liftIO $ putMVar supervisorDone ()
1516+ else die "Something went horribly wrong"
1517+ _ -> die "Something went horribly wrong"
1341 takeMVar supervisedDone
1519 takeMVar supervisedDone
1342 takeMVar supervisorDone
1520 takeMVar supervisorDone
@@ -1352,19 +1530,98 @@ testExitRemote TestTransport{..} = do
1352 (receiveWait [] :: Process ()) -- block forever
1530 (receiveWait [] :: Process ()) -- block forever
1353 `catchExit` \_from reason -> do
1531 `catchExit` \_from reason -> do
1354 -- TODO: should verify that 'from' has the right value
1532 -- TODO: should verify that 'from' has the right value
1355− True <- return $ reason == "TestExit"
1533+ res <- return $ reason == "TestExit"
1356 liftIO $ putMVar supervisedDone ()
1534 liftIO $ putMVar supervisedDone ()
1537+ else die "Something went horribly wrong"
1358 runProcess node2 $ do
1539 runProcess node2 $ do
1359 ref <- monitor pid
1540 ref <- monitor pid
1360 exit pid "TestExit"
1541 exit pid "TestExit"
1361− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1544+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1362− True <- return $ ref == ref' && pid == pid'
1545+ res' <- return $ ref == ref' && pid == pid'
1363− liftIO $ putMVar supervisorDone ()
1546+ liftIO $ putMVar supervisorDone ()
1549+ else die "Something went horribly wrong"
1550+ _ -> die "Something went horribly wrong"
1365 takeMVar supervisedDone
1552 takeMVar supervisedDone
1366 takeMVar supervisorDone
1553 takeMVar supervisorDone
1555+testRegistryMonitoring :: TestTransport -> Assertion
1556+testRegistryMonitoring TestTransport{..} = do
1557+ node1 <- newLocalNode testTransport initRemoteTable
1558+ node2 <- newLocalNode testTransport initRemoteTable
1560+ let nid = localNodeId node2
1561+ pid <- forkProcess node1 $ do
1563+ runUntilRegistered nid self
1564+ say $ (show self) ++ " registered as " ++ regName
1565+ expect :: Process ()
1566+ say $ (show self) ++ " exiting normally"
1568+ runProcess node2 $ do
1569+ register regName pid
1570+ say $ regName ++ " registered to " ++ show pid
1571+ res <- whereis regName
1573+ say $ " sent finish signal to " ++ show pid
1575+ liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
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 ]
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
1596+ runProcess node2 $ delayUntilMaybeUnregistered nid pid
1598+ regHere <- newEmptyMVar
1599+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600+ res <- takeMVar regHere
1602+ Nothing -> return ()
1603+ Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1606+ runUntilRegistered nid us = do
1607+ whereisRemoteAsync nid regName
1609+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610+ (const $ return ())
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 ())
1620+ Just () -> return ()
1621+ Nothing -> delayUntilMaybeUnregistered nid p
1623+ regName = "testRegisterRemote"
1368testUnsafeSend :: TestTransport -> Assertion
1625testUnsafeSend :: TestTransport -> Assertion
1369testUnsafeSend TestTransport{..} = do
1626testUnsafeSend TestTransport{..} = do
1370 serverAddr <- newEmptyMVar
1627 serverAddr <- newEmptyMVar
@@ -1380,8 +1637,26 @@ testUnsafeSend TestTransport{..} = do
1380 void $ forkProcess localNode $ do
1637 void $ forkProcess localNode $ do
1381 serverPid <- liftIO $ takeMVar serverAddr
1638 serverPid <- liftIO $ takeMVar serverAddr
1382 getSelfPid >>= unsafeSend serverPid
1639 getSelfPid >>= unsafeSend serverPid
1383− () <- expect
1640+ expect >>= liftIO . putMVar clientDone
1642+ takeMVar clientDone
1644+testUnsafeUSend :: TestTransport -> Assertion
1645+testUnsafeUSend TestTransport{..} = do
1646+ serverAddr <- newEmptyMVar
1647+ clientDone <- newEmptyMVar
1649+ localNode <- newLocalNode testTransport initRemoteTable
1650+ void $ forkProcess localNode $ do
1384− liftIO $ putMVar clientDone ()
1652+ liftIO $ putMVar serverAddr self
1653+ clientAddr <- expect
1654+ unsafeUSend clientAddr ()
1656+ void $ forkProcess localNode $ do
1657+ serverPid <- liftIO $ takeMVar serverAddr
1658+ getSelfPid >>= unsafeUSend serverPid
1659+ expect >>= liftIO . putMVar clientDone
1386 takeMVar clientDone
1661 takeMVar clientDone
@@ -1392,8 +1667,7 @@ testUnsafeNSend TestTransport{..} = do
1392 localNode <- newLocalNode testTransport initRemoteTable
1667 localNode <- newLocalNode testTransport initRemoteTable
1394 pid <- forkProcess localNode $ do
1669 pid <- forkProcess localNode $ do
1396− liftIO $ putMVar clientDone ()
1670+ expect >>= liftIO . putMVar clientDone
1398 void $ runProcess localNode $ do
1672 void $ runProcess localNode $ do
1399 register "foobar" pid
1673 register "foobar" pid
@@ -1401,6 +1675,24 @@ testUnsafeNSend TestTransport{..} = do
1402 takeMVar clientDone
1676 takeMVar clientDone
1678+testUnsafeNSendRemote :: TestTransport -> Assertion
1679+testUnsafeNSendRemote TestTransport{..} = do
1680+ clientDone <- newEmptyMVar
1682+ localNode1 <- newLocalNode testTransport initRemoteTable
1683+ localNode2 <- newLocalNode testTransport initRemoteTable
1685+ _ <- forkProcess localNode1 $ do
1686+ getSelfPid >>= register "foobar"
1687+ liftIO $ putMVar clientDone ()
1688+ expect >>= liftIO . putMVar clientDone
1690+ takeMVar clientDone
1691+ void $ runProcess localNode2 $ do
1692+ unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1694+ takeMVar clientDone
1404testUnsafeSendChan :: TestTransport -> Assertion
1696testUnsafeSendChan :: TestTransport -> Assertion
1405testUnsafeSendChan TestTransport{..} = do
1697testUnsafeSendChan TestTransport{..} = do
1406 serverAddr <- newEmptyMVar
1698 serverAddr <- newEmptyMVar
@@ -1417,7 +1709,7 @@ testUnsafeSendChan TestTransport{..} = do
1417 serverPid <- liftIO $ takeMVar serverAddr
1709 serverPid <- liftIO $ takeMVar serverAddr
1418 (sp, rp) <- newChan
1710 (sp, rp) <- newChan
1419 unsafeSend serverPid sp
1711 unsafeSend serverPid sp
1420− () <- receiveChan rp
1712+ receiveChan rp :: Process ()
1421 liftIO $ putMVar clientDone ()
1713 liftIO $ putMVar clientDone ()
1423 takeMVar clientDone
1715 takeMVar clientDone
@@ -1431,8 +1723,8 @@ testCallLocal TestTransport{..} = do
1431 runProcess node $ do
1723 runProcess node $ do
1432 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1724 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1433 liftIO $ putMVar result r
1725 liftIO $ putMVar result r
1434− True <- takeMVar result
1727+ takeMVar result >>= assertBool "Expected 'True'"
1437 -- Testing that when callLocal is interrupted, the worker is interrupted.
1729 -- Testing that when callLocal is interrupted, the worker is interrupted.
1438 ibox <- newIORef False
1730 ibox <- newIORef False
@@ -1449,10 +1741,9 @@ testCallLocal TestTransport{..} = do
1449 (send keeper ())
1741 (send keeper ())
1450 caller <- expect
1742 caller <- expect
1451 exit caller "test"
1743 exit caller "test"
1452− () <- expect
1744+ expect :: Process ()
1454− True <- readIORef ibox
1746+ readIORef ibox >>= assertBool "Expected 'True'"
1457 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1748 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1458 ibox2 <- newIORef False
1749 ibox2 <- newIORef False
@@ -1461,8 +1752,8 @@ testCallLocal TestTransport{..} = do
1461 liftIO $ writeIORef ibox2 $ case r of
1752 liftIO $ writeIORef ibox2 $ case r of
1462 Left (ErrorCall "e") -> True
1753 Left (ErrorCall "e") -> True
1463 _ -> False
1754 _ -> False
1464− True <- readIORef ibox
1756+ readIORef ibox >>= assertBool "Expected 'True'"
1467 -- Test that caller waits for the worker in correct situation
1758 -- Test that caller waits for the worker in correct situation
1468 ibox3 <- newIORef False
1759 ibox3 <- newIORef False
@@ -1479,8 +1770,8 @@ testCallLocal TestTransport{..} = do
1479 liftIO $ putMVar result3 =<< readIORef ibox3
1770 liftIO $ putMVar result3 =<< readIORef ibox3
1480 worker <- expect
1771 worker <- expect
1481 send worker ()
1772 send worker ()
1482− True <- takeMVar result3
1774+ takeMVar result3 >>= assertBool "Expected 'True'"
1485 -- Test that caller waits for the worker in case when caller gets an exception
1776 -- Test that caller waits for the worker in case when caller gets an exception
1486 ibox4 <- newIORef False
1777 ibox4 <- newIORef False
@@ -1496,13 +1787,9 @@ testCallLocal TestTransport{..} = do
1496 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1787 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1497 caller <- expect
1788 caller <- expect
1498 exit caller "hi!"
1789 exit caller "hi!"
1499− True <- takeMVar result4
1501− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1791+ takeMVar result4 >>= assertBool "Expected 'True'"
1792+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1507tests :: TestTransport -> IO [Test]
1794tests :: TestTransport -> IO [Test]
1508tests testtrans = return [
1795tests testtrans = return [
@@ -1527,6 +1814,7 @@ tests testtrans = return [
1527 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1528 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1529 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)
1530 , testCase "KillLocal" (testKillLocal testtrans)
1818 , testCase "KillLocal" (testKillLocal testtrans)
1531 , testCase "KillRemote" (testKillRemote testtrans)
1819 , testCase "KillRemote" (testKillRemote testtrans)
1532 , testCase "Die" (testDie testtrans)
1820 , testCase "Die" (testDie testtrans)
@@ -1536,10 +1824,13 @@ tests testtrans = return [
1536 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1537 , testCase "ExitLocal" (testExitLocal testtrans)
1825 , testCase "ExitLocal" (testExitLocal testtrans)
1538 , testCase "ExitRemote" (testExitRemote testtrans)
1826 , testCase "ExitRemote" (testExitRemote testtrans)
1827+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1539 , testCase "TextCallLocal" (testCallLocal testtrans)
1828 , testCase "TextCallLocal" (testCallLocal testtrans)
1540 -- Unsafe Primitives
1829 -- Unsafe Primitives
1541 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1831+ , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1542 , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1832 , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1833+ , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1543 , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1834 , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1544 -- usend
1835 -- usend
1545 , testCase "USend" (testUSend usend testtrans 50)
1836 , testCase "USend" (testUSend usend testtrans 50)
@@ -1586,17 +1877,3 @@ tests testtrans = return [
1586 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1877 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1590−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1591−syncBreakConnection breakConnection nid0 nid1 = do
1593− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1594− runProcess nid0 $ do
1595− them <- liftIO $ takeMVar m
1596− pinger <- spawnLocal $ forever $ send them ()
1597− _ <- monitorNode (localNodeId nid1)
1598− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1599− (nodeAddress $ localNodeId nid1)
1600− NodeMonitorNotification _ _ _ <- expect
1601− kill pinger "finished"