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