@@ -1,1879 +0,0 @@
1−module Control.Distributed.Process.Tests.CH (tests) where
2−
3−#if ! MIN_VERSION_base(4,6,0)
4−import Prelude hiding (catch)
5−#endif
6−
7−import Network.Transport.Test (TestTransport(..))
8−
9−import Data.Binary (Binary(..))
10−import Data.Typeable (Typeable)
11−import Data.Foldable (forM_)
12−import Data.Function (fix)
13−import Data.IORef
14− ( readIORef
15− , writeIORef
16− , newIORef
17− )
18−import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)
19−import Control.Concurrent.MVar
20− ( MVar
21− , newEmptyMVar
22− , putMVar
23− , takeMVar
24− , readMVar
25− )
26−import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
27−import Control.Exception (SomeException, throwIO, ErrorCall(..))
28−import Control.Monad.Catch (try, catch, finally, mask, onException)
29−import Control.Applicative ((<|>))
30−import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31−import Control.Distributed.Process hiding
32− ( try
33− , catch
34− , finally
35− , mask
36− , onException
37− )
38−import Control.Distributed.Process.Internal.Types
39− ( LocalNode(localEndPoint)
40− , ProcessExitException(..)
41− , nullProcessId
42− , createUnencodedMessage
43− )
44−import 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)
48−import Control.Distributed.Process.Serializable (Serializable)
49−import Data.Maybe (isNothing, isJust)
50−import Test.HUnit (Assertion, assertBool, assertFailure)
51−import Test.Framework (Test, testGroup)
52−import Test.Framework.Providers.HUnit (testCase)
53−import Control.Rematch hiding (match, isNothing, isJust)
54−import Control.Rematch.Run (Match(..))
55−
56−newtype Ping = Ping ProcessId
57− deriving (Typeable, Binary, Show)
58−
59−newtype Pong = Pong ProcessId
60− deriving (Typeable, Binary, Show)
61−
62−--------------------------------------------------------------------------------
63−-- Supporting definitions --
64−--------------------------------------------------------------------------------
65−
66−expectThat :: a -> Matcher a -> Assertion
67−expectThat a matcher = case res of
68− MatchSuccess -> return ()
69− (MatchFailure msg) -> assertFailure msg
70− where res = runMatch matcher a
71−
72−-- | Like fork, but throw exceptions in the child thread to the parent
73−forkTry :: IO () -> IO ThreadId
74−forkTry p = do
75− tid <- myThreadId
76− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
77−
78−-- | The ping server from the paper
79−ping :: Process ()
80−ping = do
81− Pong partner <- expect
82− self <- getSelfPid
83− send partner (Ping self)
84− ping
85−
86−verifyClient :: String -> MVar Bool -> IO ()
87−verifyClient s b = takeMVar b >>= assertBool s
88−
89−expectPing :: MVar Bool -> Process ()
90−expectPing mv = expect >>= liftIO . putMVar mv . checkPing
91− where
92− checkPing (Ping _) = True
93−
94−-- | Quick and dirty synchronous version of whereisRemoteAsync
95−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
96−whereisRemote nid string = do
97− whereisRemoteAsync nid string
98− receiveWait [
99− match (\(WhereIsReply _ mPid) -> return mPid)
100− ]
101−
102−verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
103−verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
104−
105−waitForExit :: ProcessId -> Process DiedReason
106−waitForExit pid = monitor pid >>= waitForDown
107−
108−waitForDown :: MonitorRef -> Process DiedReason
109−waitForDown ref =
110− receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
111− (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
112−
113−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
114−syncBreakConnection breakConnection nid0 nid1 = do
115− m <- newEmptyMVar
116− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
117− runProcess nid0 $ do
118− them <- liftIO $ takeMVar m
119− pinger <- spawnLocal $ forever $ send them ()
120− _ <- monitorNode (localNodeId nid1)
121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
122− (nodeAddress $ localNodeId nid1)
123− NodeMonitorNotification _ _ _ <- expect
124− kill pinger "finished"
125− return ()
126−
127−data Add = Add ProcessId Double Double deriving (Typeable)
128−data Divide = Divide ProcessId Double Double deriving (Typeable)
129−data DivByZero = DivByZero deriving (Typeable)
130−
131−instance Binary Add where
132− put (Add pid x y) = put pid >> put x >> put y
133− get = Add <$> get <*> get <*> get
134−
135−instance Binary Divide where
136− put (Divide pid x y) = put pid >> put x >> put y
137− get = Divide <$> get <*> get <*> get
138−
139−instance Binary DivByZero where
140− put DivByZero = return ()
141− get = return DivByZero
142−
143−-- The math server from the paper
144−math :: Process ()
145−math = do
146− receiveWait
147− [ match (\(Add pid x y) -> send pid (x + y))
148− , matchIf (\(Divide _ _ y) -> y /= 0)
149− (\(Divide pid x y) -> send pid (x / y))
150− , match (\(Divide pid _ _) -> send pid DivByZero)
151− ]
152− math
153−
154−-- | Monitor or link to a remote node
155−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
156− -> ProcessId -- ^ Process to monitor/link to
157− -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up
158− -> Process (Maybe MonitorRef)
159−monitorOrLink mOrL pid mSignal = do
160− result <- if mOrL then Just <$> monitor pid
161− else link pid >> return Nothing
162− -- Monitor is asynchronous, which usually does not matter but if we want a
163− -- *specific* signal then it does. Therefore we wait until the MonitorRef is
164− -- listed in the ProcessInfo and hope that this means the monitor has been set
165− -- up.
166− forM_ mSignal $ \signal -> do
167− self <- getSelfPid
168− spawnLocal $ do
169− let waitForMOrL = do
170− liftIO $ threadDelay 100000
171− mpinfo <- getProcessInfo pid
172− case mpinfo of
173− Nothing -> waitForMOrL
174− Just pinfo ->
175− if mOrL then
176− unless (result == lookup self (infoMonitors pinfo)) waitForMOrL
177− else
178− unless (elem self $ infoLinks pinfo) waitForMOrL
179− waitForMOrL
180− liftIO $ putMVar signal ()
181− return result
182−
183−monitorTestProcess :: ProcessId -- Process to monitor/link to
184− -> Bool -- 'True' for monitor, 'False' for link
185− -> Bool -- Should we unmonitor?
186− -> DiedReason -- Expected cause of death
187− -> Maybe (MVar ()) -- Signal for 'monitor set up'
188− -> MVar () -- Signal for successful termination
189− -> Process ()
190−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
191− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
192− case (un, mRef) of
193− (True, Nothing) -> do
194− unlink theirAddr
195− liftIO $ putMVar done ()
196− (True, Just ref) -> do
197− unmonitor ref
198− liftIO $ putMVar done ()
199− (False, ref) -> do
200− receiveWait [
201− match (\(ProcessMonitorNotification ref' pid reason') -> do
202− liftIO $ do
203− assertBool "Bad Monitor Signal"
204− (Just ref' == ref && pid == theirAddr &&
205− mOrL && reason == reason')
206− putMVar done ())
207− ]
208− )
209− (\(ProcessLinkException pid reason') -> do
210− (liftIO $ assertBool "link exception unmatched" $
211− pid == theirAddr && not mOrL && not un && reason == reason')
212− liftIO $ putMVar done ()
213− )
214−
215−--------------------------------------------------------------------------------
216−-- The tests proper --
217−--------------------------------------------------------------------------------
218−
219−-- | Basic ping test
220−testPing :: TestTransport -> Assertion
221−testPing TestTransport{..} = do
222− serverAddr <- newEmptyMVar
223− clientDone <- newEmptyMVar
224−
225− -- Server
226− forkIO $ do
227− localNode <- newLocalNode testTransport initRemoteTable
228− addr <- forkProcess localNode ping
229− putMVar serverAddr addr
230−
231− -- Client
232− forkIO $ do
233− localNode <- newLocalNode testTransport initRemoteTable
234− pingServer <- readMVar serverAddr
235−
236− let numPings = 10000
237−
238− runProcess localNode $ do
239− pid <- getSelfPid
240− replicateM_ numPings $ do
241− send pingServer (Pong pid)
242− p <- expectTimeout 3000000
243− case p of
244− Just (Ping _) -> return ()
245− Nothing -> die "Failed to receive Ping"
246−
247− putMVar clientDone ()
248−
249− takeMVar clientDone
250−
251−-- | Monitor a process on an unreachable node
252−testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
253−testMonitorUnreachable TestTransport{..} mOrL un = do
254− deadProcess <- newEmptyMVar
255− done <- newEmptyMVar
256−
257− forkIO $ do
258− localNode <- newLocalNode testTransport initRemoteTable
259− addr <- forkProcess localNode expect
260− closeLocalNode localNode
261− putMVar deadProcess addr
262−
263− forkIO $ do
264− localNode <- newLocalNode testTransport initRemoteTable
265− theirAddr <- readMVar deadProcess
266− runProcess localNode $
267− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
268−
269− takeMVar done
270−
271−-- | Monitor a process which terminates normally
272−testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion
273−testMonitorNormalTermination TestTransport{..} mOrL un = do
274− monitorSetup <- newEmptyMVar
275− monitoredProcess <- newEmptyMVar
276− done <- newEmptyMVar
277−
278− forkIO $ do
279− localNode <- newLocalNode testTransport initRemoteTable
280− addr <- forkProcess localNode $
281− liftIO $ readMVar monitorSetup
282− putMVar monitoredProcess addr
283−
284− forkIO $ do
285− localNode <- newLocalNode testTransport initRemoteTable
286− theirAddr <- readMVar monitoredProcess
287− runProcess localNode $
288− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
289−
290− takeMVar done
291−
292−-- | Monitor a process which terminates abnormally
293−testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion
294−testMonitorAbnormalTermination TestTransport{..} mOrL un = do
295− monitorSetup <- newEmptyMVar
296− monitoredProcess <- newEmptyMVar
297− done <- newEmptyMVar
298−
299− let err = userError "Abnormal termination"
300−
301− forkIO $ do
302− localNode <- newLocalNode testTransport initRemoteTable
303− addr <- forkProcess localNode . liftIO $ do
304− readMVar monitorSetup
305− throwIO err
306− putMVar monitoredProcess addr
307−
308− forkIO $ do
309− localNode <- newLocalNode testTransport initRemoteTable
310− theirAddr <- readMVar monitoredProcess
311− runProcess localNode $
312− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
313−
314− takeMVar done
315−
316−-- | Monitor a local process that is already dead
317−testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
318−testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
319− processAddr <- newEmptyMVar
320− localNode <- newLocalNode testTransport initRemoteTable
321− done <- newEmptyMVar
322−
323− forkIO $ do
324− addr <- forkProcess localNode $ return ()
325− putMVar processAddr addr
326−
327− forkIO $ do
328− theirAddr <- readMVar processAddr
329− runProcess localNode $ do
330− monitor theirAddr
331− -- wait for the process to die
332− expect :: Process ProcessMonitorNotification
333− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
334−
335− takeMVar done
336−
337−-- | Monitor a remote process that is already dead
338−testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
339−testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do
340− processDead <- newEmptyMVar
341− processAddr <- newEmptyMVar
342− done <- newEmptyMVar
343−
344− forkIO $ do
345− localNode <- newLocalNode testTransport initRemoteTable
346− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
347− putMVar processAddr addr
348−
349− forkIO $ do
350− localNode <- newLocalNode testTransport initRemoteTable
351− theirAddr <- readMVar processAddr
352− readMVar processDead
353− runProcess localNode $ do
354− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
355−
356− takeMVar done
357−
358−-- | Monitor a process that becomes disconnected
359−testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
360−testMonitorDisconnect TestTransport{..} mOrL un = do
361− processAddr <- newEmptyMVar
362− processAddr2 <- newEmptyMVar
363− monitorSetup <- newEmptyMVar
364− done <- newEmptyMVar
365−
366− forkIO $ do
367− localNode <- newLocalNode testTransport initRemoteTable
368− addr <- forkProcess localNode $ expect
369− addr2 <- forkProcess localNode $ return ()
370− putMVar processAddr addr
371− readMVar monitorSetup
372− NT.closeEndPoint (localEndPoint localNode)
373− putMVar processAddr2 addr2
374−
375− forkIO $ do
376− localNode <- newLocalNode testTransport initRemoteTable
377− theirAddr <- readMVar processAddr
378− forkProcess localNode $ do
379− lc <- liftIO $ readMVar processAddr2
380− send lc ()
381− runProcess localNode $ do
382− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
383−
384− takeMVar done
385−
386−-- | Test the math server (i.e., receiveWait)
387−testMath :: TestTransport -> Assertion
388−testMath TestTransport{..} = do
389− serverAddr <- newEmptyMVar
390− clientDone <- newEmptyMVar
391−
392− -- Server
393− forkIO $ do
394− localNode <- newLocalNode testTransport initRemoteTable
395− addr <- forkProcess localNode math
396− putMVar serverAddr addr
397−
398− -- Client
399− forkIO $ do
400− localNode <- newLocalNode testTransport initRemoteTable
401− mathServer <- readMVar serverAddr
402−
403− runProcess localNode $ do
404− pid <- getSelfPid
405− send mathServer (Add pid 1 2)
406− three <- expect :: Process Double
407− send mathServer (Divide pid 8 2)
408− four <- expect :: Process Double
409− send mathServer (Divide pid 8 0)
410− divByZ <- expect
411− liftIO $ putMVar clientDone (three, four, divByZ)
412−
413− res <- takeMVar clientDone
414− case res of
415− (3, 4, DivByZero) -> return ()
416− _ -> error $ "Something went horribly wrong"
417−
418−-- | Send first message (i.e. connect) to an already terminated process
419−-- (without monitoring); then send another message to a second process on
420−-- the same remote node (we're checking that the remote node did not die)
421−testSendToTerminated :: TestTransport -> Assertion
422−testSendToTerminated TestTransport{..} = do
423− serverAddr1 <- newEmptyMVar
424− serverAddr2 <- newEmptyMVar
425− clientDone <- newEmptyMVar
426−
427− forkIO $ do
428− terminated <- newEmptyMVar
429− localNode <- newLocalNode testTransport initRemoteTable
430− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
431− addr2 <- forkProcess localNode $ ping
432− readMVar terminated
433− putMVar serverAddr1 addr1
434− putMVar serverAddr2 addr2
435−
436− forkIO $ do
437− localNode <- newLocalNode testTransport initRemoteTable
438− server1 <- readMVar serverAddr1
439− server2 <- readMVar serverAddr2
440− runProcess localNode $ do
441− pid <- getSelfPid
442− send server1 "Hi"
443− send server2 (Pong pid)
444− expectPing clientDone
445−
446− verifyClient "Expected Ping from server" clientDone
447−
448−-- | Test (non-zero) timeout
449−testTimeout :: TestTransport -> Assertion
450−testTimeout TestTransport{..} = do
451− localNode <- newLocalNode testTransport initRemoteTable
452− done <- newEmptyMVar
453−
454− runProcess localNode $ do
455− res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
456− liftIO $ putMVar done $ res == Nothing
457−
458− verifyClient "Expected receiveTimeout to timeout..." done
459−
460−-- | Test zero timeout
461−testTimeout0 :: TestTransport -> Assertion
462−testTimeout0 TestTransport{..} = do
463− serverAddr <- newEmptyMVar
464− clientDone <- newEmptyMVar
465−
466− forkIO $ do
467− localNode <- newLocalNode testTransport initRemoteTable
468− addr <- forkProcess localNode $ do
469− -- Variation on the venerable ping server which uses a zero timeout
470− partner <- fix $ \loop ->
471− receiveTimeout 0 [match (\(Pong partner) -> return partner)]
472− >>= maybe (liftIO (threadDelay 100000) >> loop) return
473− self <- getSelfPid
474− send partner (Ping self)
475− putMVar serverAddr addr
476−
477− forkIO $ do
478− localNode <- newLocalNode testTransport initRemoteTable
479− server <- readMVar serverAddr
480− runProcess localNode $ do
481− pid <- getSelfPid
482− -- Send a bunch of messages. A large number of messages that the server
483− -- is not interested in, and then a single message that it wants
484− replicateM_ 10000 $ send server "Irrelevant message"
485− send server (Pong pid)
486− expectPing clientDone
487−
488− verifyClient "Expected Ping from server" clientDone
489−
490−-- | Test typed channels
491−testTypedChannels :: TestTransport -> Assertion
492−testTypedChannels TestTransport{..} = do
493− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
494− clientDone <- newEmptyMVar
495−
496− forkIO $ do
497− localNode <- newLocalNode testTransport initRemoteTable
498− forkProcess localNode $ do
499− (serverSendPort, rport) <- newChan
500− liftIO $ putMVar serverChannel serverSendPort
501− (clientSendPort, i) <- receiveChan rport
502− sendChan clientSendPort (even i)
503− return ()
504−
505− forkIO $ do
506− localNode <- newLocalNode testTransport initRemoteTable
507− serverSendPort <- readMVar serverChannel
508− runProcess localNode $ do
509− (clientSendPort, rport) <- newChan
510− sendChan serverSendPort (clientSendPort, 5)
511− ch <- receiveChan rport
512− liftIO $ putMVar clientDone $ ch == False
513−
514− verifyClient "Expected channel to send 'False'" clientDone
515−
516−-- | Test merging receive ports
517−testMergeChannels :: TestTransport -> Assertion
518−testMergeChannels TestTransport{..} = do
519− localNode <- newLocalNode testTransport initRemoteTable
520− testFlat localNode True "aaabbbccc"
521− testFlat localNode False "abcabcabc"
522− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
523− testNested localNode True False "adgadgadgbehbehbehcficficfi"
524− testNested localNode False True "abcabcabcdefdefdefghighighi"
525− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
526− testBlocked localNode True
527− testBlocked localNode False
528− where
529− -- Single layer of merging
530− testFlat :: LocalNode -> Bool -> String -> IO ()
531− testFlat localNode biased expected = do
532− done <- newEmptyMVar
533− forkProcess localNode $ do
534− rs <- mapM charChannel "abc"
535− m <- mergePorts biased rs
536− xs <- replicateM 9 $ receiveChan m
537− liftIO $ putMVar done $ xs == expected
538− verifyClient "Expected single layer merge to match expected ordering" done
539−
540− -- Two layers of merging
541− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
542− testNested localNode biasedInner biasedOuter expected = do
543− done <- newEmptyMVar
544− forkProcess localNode $ do
545− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
546− ms <- mapM (mergePorts biasedInner) rss
547− m <- mergePorts biasedOuter ms
548− xs <- replicateM (9 * 3) $ receiveChan m
549− liftIO $ putMVar done $ xs == expected
550− verifyClient "Expected nested channels to match expeted ordering" done
551−
552− -- Test that if no messages are (immediately) available, the scheduler makes no difference
553− testBlocked :: LocalNode -> Bool -> IO ()
554− testBlocked localNode biased = do
555− vs <- replicateM 3 newEmptyMVar
556− done <- newEmptyMVar
557−
558− forkProcess localNode $ do
559− ss <- liftIO $ mapM readMVar vs
560− case ss of
561− [sa, sb, sc] ->
562− mapM_ ((>> pause 10000) . uncurry sendChan)
563− [ -- a, b, c
564− (sa, 'a')
565− , (sb, 'b')
566− , (sc, 'c')
567− -- a, c, b
568− , (sa, 'a')
569− , (sc, 'c')
570− , (sb, 'b')
571− -- b, a, c
572− , (sb, 'b')
573− , (sa, 'a')
574− , (sc, 'c')
575− -- b, c, a
576− , (sb, 'b')
577− , (sc, 'c')
578− , (sa, 'a')
579− -- c, a, b
580− , (sc, 'c')
581− , (sa, 'a')
582− , (sb, 'b')
583− -- c, b, a
584− , (sc, 'c')
585− , (sb, 'b')
586− , (sa, 'a')
587− ]
588− _ -> die "Something went horribly wrong"
589−
590− forkProcess localNode $ do
591− (ss, rs) <- unzip <$> replicateM 3 newChan
592− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
593− m <- mergePorts biased rs
594− xs <- replicateM (6 * 3) $ receiveChan m
595− liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
596−
597− verifyClient "Expected merged ports to match expected ordering" done
598−
599− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
600− mergePorts True = mergePortsBiased
601− mergePorts False = mergePortsRR
602−
603− charChannel :: Char -> Process (ReceivePort Char)
604− charChannel c = do
605− (sport, rport) <- newChan
606− replicateM_ 3 $ sendChan sport c
607− liftIO $ threadDelay 10000 -- Make sure messages have been sent
608− return rport
609−
610−testTerminate :: TestTransport -> Assertion
611−testTerminate TestTransport{..} = do
612− localNode <- newLocalNode testTransport initRemoteTable
613− runProcess localNode $ do
614− e <- try terminate :: Process (Either ProcessTerminationException ())
615− if either show show e == show ProcessTerminationException
616− then return ()
617− else die "Unexpected result from terminate"
618−
619−testMonitorNode :: TestTransport -> Assertion
620−testMonitorNode TestTransport{..} = do
621− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
622− done <- newEmptyMVar
623−
624− closeLocalNode node1
625−
626− runProcess node2 $ do
627− ref <- monitorNode (localNodeId node1)
628− receiveWait [
629− match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
630− return $ ref == ref' && nid == localNodeId node1)
631− ] >>= liftIO . putMVar done
632−
633− verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
634−
635−testMonitorLiveNode :: TestTransport -> Assertion
636−testMonitorLiveNode TestTransport{..} = do
637− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
638− ready <- newEmptyMVar
639− readyr <- newEmptyMVar
640− done <- newEmptyMVar
641−
642− p <- forkProcess node1 $ return ()
643− forkProcess node2 $ do
644− ref <- monitorNode (localNodeId node1)
645− liftIO $ putMVar ready ()
646− liftIO $ takeMVar readyr
647− send p ()
648− receiveWait [
649− match (\(NodeMonitorNotification ref' nid _) ->
650− (return $ ref == ref' && nid == localNodeId node1))
651− ] >>= liftIO . putMVar done
652−
653− takeMVar ready
654− closeLocalNode node1
655− putMVar readyr ()
656−
657− verifyClient "Expected NodeMonitorNotification for LIVE node" done
658−
659−testMonitorChannel :: TestTransport -> Assertion
660−testMonitorChannel TestTransport{..} = do
661− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
662− gotNotification <- newEmptyMVar
663−
664− pid <- forkProcess node1 $ do
665− sport <- expect :: Process (SendPort ())
666− ref <- monitorPort sport
667− receiveWait [
668− -- reason might be DiedUnknownId if the receive port is GCed before the
669− -- monitor is established (TODO: not sure that this is reasonable)
670− match (\(PortMonitorNotification ref' port' reason) ->
671− return $ ref' == ref && port' == sendPortId sport &&
672− (reason == DiedNormal || reason == DiedUnknownId))
673− ] >>= liftIO . putMVar gotNotification
674−
675− runProcess node2 $ do
676− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
677− send pid sport
678− liftIO $ threadDelay 100000
679−
680− verifyClient "Expected PortMonitorNotification" gotNotification
681−
682−testRegistry :: TestTransport -> Assertion
683−testRegistry TestTransport{..} = do
684− node <- newLocalNode testTransport initRemoteTable
685− done <- newEmptyMVar
686−
687− pingServer <- forkProcess node ping
688− deadProcess <- forkProcess node (return ())
689−
690− runProcess node $ do
691− register "ping" pingServer
692− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
693− us <- getSelfPid
694− nsend "ping" (Pong us)
695− receiveWait [
696− matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
697− ]
698− checkRegException "dead" Nothing deadProcess
699− checkRegException "ping" (Just pingServer) deadProcess
700− try (unregister "dead") >>= checkReg "dead" Nothing
701− liftIO $ putMVar done ()
702−
703− takeMVar done
704−
705− where
706− checkRegException name pid dead =
707− try (register name dead) >>= checkReg name pid
708−
709− checkReg name pid res =
710− case res of
711− Left (ProcessRegistrationException name pid) -> return ()
712− _ -> die $ "Unexpected Registration" ++ show res
713−
714−testRegistryRemoteProcess :: TestTransport -> Assertion
715−testRegistryRemoteProcess TestTransport{..} = do
716− node1 <- newLocalNode testTransport initRemoteTable
717− node2 <- newLocalNode testTransport initRemoteTable
718− done <- newEmptyMVar
719−
720− pingServer <- forkProcess node1 ping
721−
722− runProcess node2 $ do
723− register "ping" pingServer
724− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
725− us <- getSelfPid
726− nsend "ping" (Pong us)
727− receiveWait [
728− matchIf (\(Ping pid') -> pingServer == pid')
729− (const $ liftIO $ putMVar done ())
730− ]
731−
732− takeMVar done
733−
734−testRemoteRegistry :: TestTransport -> Assertion
735−testRemoteRegistry TestTransport{..} = do
736− node1 <- newLocalNode testTransport initRemoteTable
737− node2 <- newLocalNode testTransport initRemoteTable
738−
739− pingServer <- forkProcess node1 ping
740− deadProcess <- forkProcess node1 (return ())
741−
742− runProcess node2 $ do
743− let nid1 = localNodeId node1
744− registerRemoteAsync nid1 "ping" pingServer
745− receiveWait [
746− matchIf (\(RegisterReply label' _ (Just pid)) ->
747− "ping" == label' && pid == pingServer)
748− (\(RegisterReply _ _ _) -> return ()) ]
749−
750− pid <- verifyWhereIsRemote nid1 "ping"
751− liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
752−
753− us <- getSelfPid
754− nsendRemote nid1 "ping" (Pong us)
755− receiveWait [
756− match (\(Ping pid') -> return $ pingServer == pid')
757− ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
758−
759− -- test that if process was not registered Nothing is returned
760− -- in owner field.
761− registerRemoteAsync nid1 "dead" deadProcess
762− receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
763− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764− ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
765−
766− registerRemoteAsync nid1 "ping" deadProcess
767− receiveWait [
768− matchIf (\(RegisterReply label' False mPid) ->
769− "ping" == label' && isJust mPid)
770− (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771− ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
772−
773− unregisterRemoteAsync nid1 "dead"
774− receiveWait [
775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
778−
779−testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
780−testRemoteRegistryRemoteProcess TestTransport{..} = do
781− node1 <- newLocalNode testTransport initRemoteTable
782− node2 <- newLocalNode testTransport initRemoteTable
783− done <- newEmptyMVar
784−
785− pingServer <- forkProcess node2 ping
786−
787− runProcess node2 $ do
788− let nid1 = localNodeId node1
789− registerRemoteAsync nid1 "ping" pingServer
790− receiveWait [
791− matchIf (\(RegisterReply label' _ _) -> "ping" == label')
792− (\(RegisterReply _ _ _) -> return ()) ]
793− pid <- verifyWhereIsRemote nid1 "ping"
794− liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
795− us <- getSelfPid
796− nsendRemote nid1 "ping" (Pong us)
797− receiveWait [
798− match (\(Ping pid') -> return $ pingServer == pid')
799− ] >>= liftIO . putMVar done
800−
801− verifyClient "Expected Ping with ping server's ProcessId" done
802−
803−testSpawnLocal :: TestTransport -> Assertion
804−testSpawnLocal TestTransport{..} = do
805− node <- newLocalNode testTransport initRemoteTable
806− done <- newEmptyMVar
807−
808− runProcess node $ do
809− us <- getSelfPid
810−
811− pid <- spawnLocal $ do
812− sport <- expect
813− sendChan sport (1234 :: Int)
814−
815− sport <- spawnChannelLocal $
816− \rport -> (receiveChan rport :: Process Int) >>= send us
817−
818− send pid sport
819− expect >>= liftIO . putMVar done
820−
821− res <- takeMVar done
822− assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
823−
824−testSpawnAsyncStrictness :: TestTransport -> Assertion
825−testSpawnAsyncStrictness TestTransport{..} = do
826− node <- newLocalNode testTransport initRemoteTable
827− done <- newEmptyMVar
828−
829− runProcess node $ do
830− here <-getSelfNode
831−
832− ev <- try $ spawnAsync here (error "boom")
833− liftIO $ case ev of
834− Right _ -> putMVar done (error "Exception didn't fire")
835− Left (_::SomeException) -> putMVar done (return ())
836−
837− join $ takeMVar done
838−
839−testReconnect :: TestTransport -> Assertion
840−testReconnect TestTransport{..} = do
841− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
842− let nid1 = localNodeId node1
843− processA <- newEmptyMVar
844− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
845−
846− forkProcess node1 $ do
847− us <- getSelfPid
848− liftIO $ putMVar processA us
849− msg1 <- expect
850− msg2 <- expect
851− liftIO $ do
852− assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
853− putMVar sendTestOk ()
854−
855− forkProcess node2 $ do
856− {-
857− - Make sure there is no implicit reconnect on normal message sending
858− -}
859−
860− them <- liftIO $ readMVar processA
861− send them "message 1" >> liftIO (threadDelay 100000)
862−
863− -- Simulate network failure
864− liftIO $ syncBreakConnection testBreakConnection node1 node2
865−
866−
867− -- Should not arrive
868− send them "message 2"
869−
870− -- Should arrive
871− reconnect them
872− send them "message 3"
873−
874− liftIO $ takeMVar sendTestOk
875−
876− {-
877− - Test that there *is* implicit reconnect on node controller messages
878− -}
879−
880− us <- getSelfPid
881− registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
882− receiveWait [
883− matchIf (\(RegisterReply label' _ _) -> "a" == label')
884− (\(RegisterReply _ _ _) -> return ()) ]
885−
886− _ <- whereisRemote nid1 "a"
887−
888−
889− -- Simulate network failure
890− liftIO $ syncBreakConnection testBreakConnection node1 node2
891−
892− -- This will happen due to implicit reconnect
893− registerRemoteAsync nid1 "b" us
894− receiveWait [
895− matchIf (\(RegisterReply label' _ _) -> "b" == label')
896− (\(RegisterReply _ _ _) -> return ()) ]
897−
898− -- Should happen
899− registerRemoteAsync nid1 "c" us
900− receiveWait [
901− matchIf (\(RegisterReply label' _ _) -> "c" == label')
902− (\(RegisterReply _ _ _) -> return ()) ]
903−
904− -- Check
905− mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
906− liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
907− verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
908− verifyWhereIsRemote nid1 "c"
909−
910− liftIO $ putMVar registerTestOk ()
911−
912− takeMVar registerTestOk
913−
914−-- | Tests that unreliable messages arrive sorted even when there are connection
915−-- failures.
916−testUSend :: (ProcessId -> Int -> Process ())
917− -> TestTransport -> Int -> Assertion
918−testUSend usendPrim TestTransport{..} numMessages = do
919− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
920− let nid1 = localNodeId node1
921− nid2 = localNodeId node2
922− processA <- newEmptyMVar
923− usendTestOk <- newEmptyMVar
924−
925− forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do
926− us <- getSelfPid
927− liftIO $ putMVar processA us
928− them <- expect
929− send them ()
930− _ <- monitor them
931− let -- Collects messages from 'them' until the sender dies.
932− -- Disconnection notifications are ignored.
933− receiveMessages :: Process [Int]
934− receiveMessages = receiveWait
935− [ match $ \mn -> case mn of
936− ProcessMonitorNotification _ _ DiedDisconnect -> do
937− monitor them
938− receiveMessages
939− _ -> return []
940− , match $ \i -> fmap (i :) receiveMessages
941− ]
942− msgs <- receiveMessages
943− let -- Checks that the input list is sorted.
944− isSorted :: [Int] -> Bool
945− isSorted (x : xs@(y : _)) = x <= y && isSorted xs
946− isSorted _ = True
947− -- The list can't be null since there are no failures after sending
948− -- the last message.
949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
950−
951− forkProcess node2 $ do
952− them <- liftIO $ readMVar processA
953− getSelfPid >>= send them
954− expect :: Process ()
955− forM_ [1..numMessages] $ \i -> do
956− liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
957− usendPrim them i
958− liftIO (threadDelay 30000)
959−
960− res <- takeMVar usendTestOk
961− assertBool "Unexpected failure after sending last msg" res
962−
963−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
964−-- in between
965−testMatchAny :: TestTransport -> Assertion
966−testMatchAny TestTransport{..} = do
967− proxyAddr <- newEmptyMVar
968− clientDone <- newEmptyMVar
969−
970− -- Math server
971− forkIO $ do
972− localNode <- newLocalNode testTransport initRemoteTable
973− mathServer <- forkProcess localNode math
974− proxyServer <- forkProcess localNode $ forever $ do
975− msg <- receiveWait [ matchAny return ]
976− forward msg mathServer
977− putMVar proxyAddr proxyServer
978−
979− -- Client
980− forkIO $ do
981− localNode <- newLocalNode testTransport initRemoteTable
982− mathServer <- readMVar proxyAddr
983−
984− runProcess localNode $ do
985− pid <- getSelfPid
986− send mathServer (Add pid 1 2)
987− three <- expect :: Process Double
988− send mathServer (Divide pid 8 2)
989− four <- expect :: Process Double
990− send mathServer (Divide pid 8 0)
991− divByZ <- expect
992− liftIO $ putMVar clientDone (three, four, divByZ)
993−
994− res <- takeMVar clientDone
995− case res of
996− (3, 4, DivByZero) -> return ()
997− _ -> error "Unexpected result"
998−
999−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
1000−-- in between, however we block 'Divide' requests ....
1001−testMatchAnyHandle :: TestTransport -> Assertion
1002−testMatchAnyHandle TestTransport{..} = do
1003− proxyAddr <- newEmptyMVar
1004− clientDone <- newEmptyMVar
1005−
1006− -- Math server
1007− forkIO $ do
1008− localNode <- newLocalNode testTransport initRemoteTable
1009− mathServer <- forkProcess localNode math
1010− proxyServer <- forkProcess localNode $ forever $ do
1011− receiveWait [
1012− matchAny (maybeForward mathServer)
1013− ]
1014− putMVar proxyAddr proxyServer
1015−
1016− -- Client
1017− forkIO $ do
1018− localNode <- newLocalNode testTransport initRemoteTable
1019− mathServer <- readMVar proxyAddr
1020−
1021− runProcess localNode $ do
1022− pid <- getSelfPid
1023− send mathServer (Add pid 1 2)
1024− three <- expect :: Process Double
1025− send mathServer (Divide pid 8 2)
1026− res <- (expectTimeout 100000) :: Process (Maybe Double)
1027− liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1028−
1029− verifyClient "Expected Nothing (i.e. timeout)" clientDone
1030−
1031− where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1032− maybeForward s msg =
1033− handleMessage msg (\m@(Add _ _ _) -> send s m)
1034−
1035−testMatchAnyNoHandle :: TestTransport -> Assertion
1036−testMatchAnyNoHandle TestTransport{..} = do
1037− addr <- newEmptyMVar
1038− clientDone <- newEmptyMVar
1039− serverDone <- newEmptyMVar
1040−
1041− -- Math server
1042− forkIO $ do
1043− localNode <- newLocalNode testTransport initRemoteTable
1044− server <- forkProcess localNode $ forever $ do
1045− receiveWait [
1046− matchAnyIf
1047− -- the condition has type `Add -> Bool`
1048− (\(Add _ _ _) -> True)
1049− -- the match `AbstractMessage -> Process ()` will succeed!
1050− (\m -> do
1051− -- `String -> Process ()` does *not* match the input types however
1052− r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
1053− case r of
1054− Nothing -> return ()
1055− Just _ -> die "NONSENSE")
1056− ]
1057− -- we *must* have removed the message from our mailbox though!!!
1058− res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1059− liftIO $ do
1060− assertBool "Expected timeout!" $ res == Nothing
1061− putMVar serverDone ()
1062− putMVar addr server
1063−
1064− -- Client
1065− forkIO $ do
1066− localNode <- newLocalNode testTransport initRemoteTable
1067− server <- readMVar addr
1068−
1069− runProcess localNode $ do
1070− pid <- getSelfPid
1071− send server (Add pid 1 2)
1072− -- we only care about the client having sent a message, so we're done
1073− liftIO $ putMVar clientDone ()
1074−
1075− takeMVar clientDone
1076− takeMVar serverDone
1077−
1078−-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
1079−-- unless the text body @/= "bar"@ - this case should time out rather than
1080−-- removing the message from the process mailbox.
1081−testMatchAnyIf :: TestTransport -> Assertion
1082−testMatchAnyIf TestTransport{..} = do
1083− echoAddr <- newEmptyMVar
1084− clientDone <- newEmptyMVar
1085−
1086− -- echo server
1087− forkIO $ do
1088− localNode <- newLocalNode testTransport initRemoteTable
1089− echoServer <- forkProcess localNode $ forever $ do
1090− receiveWait [
1091− matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
1092− tryHandleMessage
1093− ]
1094− putMVar echoAddr echoServer
1095−
1096− -- Client
1097− forkIO $ do
1098− localNode <- newLocalNode testTransport initRemoteTable
1099− server <- readMVar echoAddr
1100−
1101− runProcess localNode $ do
1102− pid <- getSelfPid
1103− send server (pid, "foo")
1104− foo <- expect
1105− -- provoking what would be the wrong ordering is informative here...
1106−
1107− send server (pid, "bar")
1108− bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1109−
1110− send server (pid, "baz")
1111− baz <- expect
1112−
1113− liftIO $ putMVar clientDone (foo, bar, baz)
1114−
1115− res <- takeMVar clientDone
1116− let res' = res == ("foo", Nothing, "baz")
1117− assertBool "Expected timeout due to type mismatch" res'
1118−
1119− where tryHandleMessage :: Message -> Process (Maybe ())
1120− tryHandleMessage msg =
1121− handleMessage msg (\(pid :: ProcessId, (m :: String))
1122− -> do { send pid m; return () })
1123−
1124−testMatchMessageWithUnwrap :: TestTransport -> Assertion
1125−testMatchMessageWithUnwrap TestTransport{..} = do
1126− echoAddr <- newEmptyMVar
1127− clientDone <- newEmptyMVar
1128−
1129− -- echo server
1130− forkIO $ do
1131− localNode <- newLocalNode testTransport initRemoteTable
1132− echoServer <- forkProcess localNode $ forever $ do
1133− msg <- receiveWait [
1134− matchMessage (\(m :: Message) -> do
1135− return m)
1136− ]
1137− unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
1138− case unwrapped of
1139− (Just (p, msg')) -> forward msg' p
1140− Nothing -> die "unable to unwrap the message"
1141− putMVar echoAddr echoServer
1142−
1143− -- Client
1144− forkIO $ do
1145− localNode <- newLocalNode testTransport initRemoteTable
1146− server <- readMVar echoAddr
1147−
1148− runProcess localNode $ do
1149− pid <- getSelfPid
1150− send server (pid, wrapMessage ("foo" :: String))
1151− foo <- expect
1152− send server (pid, wrapMessage ("baz" :: String))
1153− baz <- expect
1154− liftIO $ putMVar clientDone (foo, baz)
1155−
1156− res <- takeMVar clientDone
1157− assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1158−
1159−-- Test 'receiveChanTimeout'
1160−testReceiveChanTimeout :: TestTransport -> Assertion
1161−testReceiveChanTimeout TestTransport{..} = do
1162− done <- newEmptyMVar
1163− mvSender <- newEmptyMVar
1164− sendPort <- newEmptyMVar
1165−
1166− forkTry $ do
1167− localNode <- newLocalNode testTransport initRemoteTable
1168− runProcess localNode $ do
1169− -- Create a typed channel
1170− (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1171− liftIO $ putMVar sendPort sp
1172−
1173− -- Wait for a message with a delay. No message arrives, we should get
1174− -- Nothing after the delay.
1175− receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1176−
1177− -- Let the sender know that it can send a message.
1178− liftIO $ putMVar mvSender ()
1179−
1180− -- Wait for a message with a delay again. Now a message arrives after
1181− -- 0.1 seconds
1182− res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1183− liftIO $ assertBool "Expected result to be 'True'" res
1184−
1185− -- Wait for a message with zero timeout: non-blocking check. No message is
1186− -- available, we get Nothing
1187− receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1188−
1189− -- Let the sender know that it can send a message.
1190− liftIO $ putMVar mvSender ()
1191−
1192− -- Again, but now there is a message available
1193− fix $ \loop -> do
1194− liftIO $ threadDelay 100000
1195− mb <- receiveChanTimeout 0 rp
1196− case mb of
1197− Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1198− _ -> loop
1199−
1200− liftIO $ putMVar done ()
1201−
1202− forkTry $ do
1203− localNode <- newLocalNode testTransport initRemoteTable
1204− runProcess localNode $ do
1205− sp <- liftIO $ readMVar sendPort
1206−
1207− liftIO $ takeMVar mvSender
1208− liftIO $ threadDelay 100000
1209− sendChan sp True
1210−
1211− liftIO $ takeMVar mvSender
1212− sendChan sp False
1213−
1214− takeMVar done
1215−
1216−-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1217−testReceiveChanFeatures :: TestTransport -> Assertion
1218−testReceiveChanFeatures TestTransport{..} = do
1219− done <- newEmptyMVar
1220−
1221− forkTry $ do
1222− localNode <- newLocalNode testTransport initRemoteTable
1223− runProcess localNode $ do
1224− (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1225− (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1226−
1227− -- Test Functor instance
1228−
1229− sendChan spInt 2
1230− sendChan spBool False
1231−
1232− rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1233−
1234− receiveChan rp1 >>= liftIO . assertBool "Expected True"
1235− receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1236−
1237− -- Test Applicative instance
1238−
1239− sendChan spInt 3
1240− sendChan spInt 4
1241−
1242− let rp2 = pure (+) <*> rpInt <*> rpInt
1243−
1244− receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1245−
1246− -- Test Alternative instance
1247−
1248− sendChan spInt 3
1249− sendChan spBool True
1250−
1251− let rp3 = (even <$> rpInt) <|> rpBool
1252−
1253− receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1254− receiveChan rp3 >>= liftIO . assertBool "Expected True"
1255−
1256− -- Test Monad instance
1257−
1258− sendChan spBool True
1259− sendChan spBool False
1260− sendChan spInt 5
1261−
1262− let rp4 :: ReceivePort Int
1263− rp4 = do b <- rpBool
1264− if b
1265− then rpInt
1266− else return 7
1267−
1268− receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1269− receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1270−
1271− liftIO $ putMVar done ()
1272−
1273− takeMVar done
1274−
1275−testChanLifecycle :: TestTransport -> Assertion
1276−testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1277− result <- newEmptyMVar
1278− tchMV <- newEmptyMVar
1279− localNode <- newLocalNode testTransport initRemoteTable
1280− runProcess localNode $ do
1281−
1282− pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283− liftIO $ putMVar tchMV tCh
1284− expect :: Process ()
1285− let (sp, _) = tCh
1286− sendChan sp ()
1287− expect :: Process ()
1288−
1289− mRefPid <- monitor pid
1290−
1291− cPid <- spawnLocal $ do
1292− (sp', rp) <- liftIO $ takeMVar tchMV
1293− -- say "picked up our test channel"
1294− send pid ()
1295− -- say "told pid to continue"
1296− res <- receiveChanTimeout delay rp
1297− case res of
1298− Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299− Just () -> do mr <- monitor pid
1300− pause 10000
1301− -- say "sending pid a second () will cause it to exit"
1302− send pid ()
1303−
1304− -- say "make sure we see a DOWN notification for pid having stopped"
1305− receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1306−
1307− -- now that pid has died, the send port should be useless...
1308− liftIO $ putMVar tchMV (sp', rp)
1309−
1310− -- let's verify that we do not see the message from our
1311− -- parent process on the channel, once pid has died...
1312− recv <- receiveChanTimeout delay rp
1313− -- say $ "finished waiting for second (), writing result" ++ (show recv)
1314− liftIO $ putMVar result $ isNothing recv
1315−
1316− mRefCPid <- monitor cPid
1317−
1318− receiveWait
1319− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1320− (\_ -> return ())
1321− ]
1322−
1323− -- say "seen first pid die..."
1324−
1325− (sendPort, _) <- liftIO $ takeMVar tchMV
1326− sendChan sendPort ()
1327− -- say "sent () after owning pid died"
1328−
1329− -- let cPid know we've written to the channel...
1330− send cPid ()
1331−
1332− receiveWait
1333− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1334− (\_ -> return ())
1335− ]
1336−
1337− -- say "seen both pids die now..."
1338−
1339− -- and wait on the result back in IO land...
1340− testRes <- takeMVar result
1341− -- runProcess localNode $ say "got result..."
1342− assertBool "Expected sending on the channel to fail, but received data!" testRes
1343−
1344−
1345−testKillLocal :: TestTransport -> Assertion
1346−testKillLocal TestTransport{..} = do
1347− localNode <- newLocalNode testTransport initRemoteTable
1348−
1349− pid <- forkProcess localNode $ do
1350− liftIO $ threadDelay 1000000
1351−
1352− runProcess localNode $ do
1353− ref <- monitor pid
1354− us <- getSelfPid
1355− kill pid "TestKill"
1356− mn <- expect
1357− case mn of
1358− ProcessMonitorNotification ref' pid' (DiedException ex) ->
1359− case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1360− True -> return ()
1361− False -> die "Invalid ProcessMonitorNotification received"
1362− _ -> die "Something went horribly wrong"
1363−
1364−testKillRemote :: TestTransport -> Assertion
1365−testKillRemote TestTransport{..} = do
1366− node1 <- newLocalNode testTransport initRemoteTable
1367− node2 <- newLocalNode testTransport initRemoteTable
1368−
1369− pid <- forkProcess node1 $ do
1370− liftIO $ threadDelay 1000000
1371−
1372− runProcess node2 $ do
1373− ref <- monitor pid
1374− us <- getSelfPid
1375− kill pid "TestKill"
1376− mn <- expect
1377− case mn of
1378− ProcessMonitorNotification ref' pid' (DiedException reason) ->
1379− case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1380− (True, True, True) -> return ()
1381− (a, b, c) -> do
1382− let a' = if a then "" else "Invalid ref"
1383− let b' = if b then "" else "Invalid pid"
1384− let c' = if c then "" else "Invalid message"
1385− die $ unwords [a', b', c']
1386− _ -> die "Received unexpected message"
1387−
1388−testCatchesExit :: TestTransport -> Assertion
1389−testCatchesExit TestTransport{..} = do
1390− localNode <- newLocalNode testTransport initRemoteTable
1391− done <- newEmptyMVar
1392−
1393− _ <- forkProcess localNode $ do
1394− (die ("foobar", 123 :: Int))
1395− `catchesExit` [
1396− (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1397− , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1398− , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1399− -> (liftIO $ putMVar done ()) >> return ()))
1400− ]
1401−
1402− takeMVar done
1403−
1404−testHandleMessageIf :: TestTransport -> Assertion
1405−testHandleMessageIf TestTransport{..} = do
1406− localNode <- newLocalNode testTransport initRemoteTable
1407− done <- newEmptyMVar
1408− _ <- forkProcess localNode $ do
1409− self <- getSelfPid
1410− send self (5 :: Integer, 10 :: Integer)
1411− msg <- receiveWait [ matchMessage return ]
1412− handleMessageIf msg
1413− (\() -> True)
1414− (\() -> die "whoops") >>= maybe (return ())
1415− (const $ die "Expected Mismatch")
1416− handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1417− (\input -> liftIO $ putMVar done input)
1418− return ()
1419−
1420− result <- takeMVar done
1421− expectThat result $ equalTo (5, 10)
1422−
1423−testCatches :: TestTransport -> Assertion
1424−testCatches TestTransport{..} = do
1425− localNode <- newLocalNode testTransport initRemoteTable
1426− done <- newEmptyMVar
1427−
1428− _ <- forkProcess localNode $ do
1429− node <- getSelfNode
1430− (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1431− `catches` [
1432− Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1433− ]
1434−
1435− takeMVar done
1436−
1437−testMaskRestoreScope :: TestTransport -> Assertion
1438−testMaskRestoreScope TestTransport{..} = do
1439− localNode <- newLocalNode testTransport initRemoteTable
1440− parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1441− spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1442−
1443− void $ runProcess localNode $ mask $ \unmask -> do
1444− getSelfPid >>= liftIO . putMVar parentPid
1445− void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1446−
1447− parent <- liftIO $ takeMVar parentPid
1448− child <- liftIO $ takeMVar spawnedPid
1449− expectThat parent $ isNot $ equalTo child
1450−
1451−testDie :: TestTransport -> Assertion
1452−testDie TestTransport{..} = do
1453− localNode <- newLocalNode testTransport initRemoteTable
1454− done <- newEmptyMVar
1455−
1456− _ <- forkProcess localNode $ do
1457− (die ("foobar", 123 :: Int))
1458− `catchExit` \_from reason -> do
1459− -- TODO: should verify that 'from' has the right value
1460− let res = reason == ("foobar", 123 :: Int)
1461− liftIO $ putMVar done ()
1462− if res
1463− then return ()
1464− else die "Something went horribly wrong"
1465−
1466− takeMVar done
1467−
1468−testPrettyExit :: TestTransport -> Assertion
1469−testPrettyExit TestTransport{..} = do
1470− localNode <- newLocalNode testTransport initRemoteTable
1471− done <- newEmptyMVar
1472−
1473− _ <- forkProcess localNode $ do
1474− (die "timeout")
1475− `catch` \ex@(ProcessExitException from _) ->
1476− let expected = "exit-from=" ++ (show from)
1477− in do
1478− let res = (show ex) == expected
1479− liftIO $ putMVar done ()
1480− if res
1481− then return ()
1482− else die "Something went horribly wrong"
1483−
1484− takeMVar done
1485−
1486−testExitLocal :: TestTransport -> Assertion
1487−testExitLocal TestTransport{..} = do
1488− localNode <- newLocalNode testTransport initRemoteTable
1489− supervisedDone <- newEmptyMVar
1490− supervisorDone <- newEmptyMVar
1491− -- XXX: we guarantee that exception handler will be set up
1492− -- regardless if forkProcess preserve masking state or not.
1493− handlerSetUp <- newEmptyMVar
1494−
1495− pid <- forkProcess localNode $ do
1496− (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1497− -- TODO: should verify that 'from' has the right value
1498− res <- return $ reason == "TestExit"
1499− liftIO $ putMVar supervisedDone ()
1500− if res
1501− then return ()
1502− else die "Something went horribly wrong"
1503−
1504− runProcess localNode $ do
1505− liftIO $ takeMVar handlerSetUp
1506− ref <- monitor pid
1507− exit pid "TestExit"
1508− -- This time the client catches the exception, so it dies normally
1509− mn <- expect
1510− case mn of
1511− ProcessMonitorNotification ref' pid' DiedNormal -> do
1512− let res = ref == ref' && pid == pid'
1513− liftIO $ putMVar supervisorDone ()
1514− if res
1515− then return ()
1516− else die "Something went horribly wrong"
1517− _ -> die "Something went horribly wrong"
1518−
1519− takeMVar supervisedDone
1520− takeMVar supervisorDone
1521−
1522−testExitRemote :: TestTransport -> Assertion
1523−testExitRemote TestTransport{..} = do
1524− node1 <- newLocalNode testTransport initRemoteTable
1525− node2 <- newLocalNode testTransport initRemoteTable
1526− supervisedDone <- newEmptyMVar
1527− supervisorDone <- newEmptyMVar
1528−
1529− pid <- forkProcess node1 $ do
1530− (receiveWait [] :: Process ()) -- block forever
1531− `catchExit` \_from reason -> do
1532− -- TODO: should verify that 'from' has the right value
1533− res <- return $ reason == "TestExit"
1534− liftIO $ putMVar supervisedDone ()
1535− if res
1536− then return ()
1537− else die "Something went horribly wrong"
1538−
1539− runProcess node2 $ do
1540− ref <- monitor pid
1541− exit pid "TestExit"
1542− mn <- expect
1543− case mn of
1544− ProcessMonitorNotification ref' pid' DiedNormal -> do
1545− res' <- return $ ref == ref' && pid == pid'
1546− liftIO $ putMVar supervisorDone ()
1547− if res'
1548− then return ()
1549− else die "Something went horribly wrong"
1550− _ -> die "Something went horribly wrong"
1551−
1552− takeMVar supervisedDone
1553− takeMVar supervisorDone
1554−
1555−testRegistryMonitoring :: TestTransport -> Assertion
1556−testRegistryMonitoring TestTransport{..} = do
1557− node1 <- newLocalNode testTransport initRemoteTable
1558− node2 <- newLocalNode testTransport initRemoteTable
1559−
1560− let nid = localNodeId node2
1561− pid <- forkProcess node1 $ do
1562− self <- getSelfPid
1563− runUntilRegistered nid self
1564− say $ (show self) ++ " registered as " ++ regName
1565− expect :: Process ()
1566− say $ (show self) ++ " exiting normally"
1567−
1568− runProcess node2 $ do
1569− register regName pid
1570− say $ regName ++ " registered to " ++ show pid
1571− res <- whereis regName
1572− send pid ()
1573− say $ " sent finish signal to " ++ show pid
1574− us <- getSelfPid
1575− liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
1576−
1577−
1578− -- This delay isn't essential!
1579− -- The test case passes perfectly fine without it (feel free to comment out
1580− -- and see), however waiting a few seconds here, makes it much more likely
1581− -- that in delayUntilMaybeUnregistered we will hit the match case right
1582− -- away, and thus not be subjected to a 20 second delay. The value of 4
1583− -- seconds appears to work optimally on osx and across several linux distros
1584− -- running in virtual machines (which is essentially what we do in CI)
1585− void $ receiveTimeout 4000000 [ matchAny return ]
1586−
1587− -- This delay doesn't serve much purpose in the happy path, however if some
1588− -- future patch breaks the cooperative behaviour of node controllers viz
1589− -- remote process registration and notification taking place via ncEffectDied,
1590− -- there would be the possibility of a race in the test case should we attempt
1591− -- to evaluate `whereis regName` on node2 right away. In case the name is still
1592− -- erroneously registered, observing the 20 second delay (or lack of), could at
1593− -- least give a hint that something is wrong, and we give up our time slice
1594− -- so that there's a higher change the registrations have been cleaned up
1595− -- in either case.
1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid
1597−
1598− regHere <- newEmptyMVar
1599− runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600− res <- takeMVar regHere
1601− case res of
1602− Nothing -> return ()
1603− Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1604−
1605− where
1606− runUntilRegistered nid us = do
1607− whereisRemoteAsync nid regName
1608− receiveWait [
1609− matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610− (const $ return ())
1611− ]
1612−
1613− delayUntilMaybeUnregistered nid p = do
1614− whereisRemoteAsync nid regName
1615− res <- receiveTimeout 20000000 {- 20 sec delay -} [
1616− matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)
1617− (const $ return ())
1618− ]
1619− case res of
1620− Just () -> return ()
1621− Nothing -> delayUntilMaybeUnregistered nid p
1622−
1623− regName = "testRegisterRemote"
1624−
1625−testUnsafeSend :: TestTransport -> Assertion
1626−testUnsafeSend TestTransport{..} = do
1627− serverAddr <- newEmptyMVar
1628− clientDone <- newEmptyMVar
1629−
1630− localNode <- newLocalNode testTransport initRemoteTable
1631− void $ forkProcess localNode $ do
1632− self <- getSelfPid
1633− liftIO $ putMVar serverAddr self
1634− clientAddr <- expect
1635− unsafeSend clientAddr ()
1636−
1637− void $ forkProcess localNode $ do
1638− serverPid <- liftIO $ takeMVar serverAddr
1639− getSelfPid >>= unsafeSend serverPid
1640− expect >>= liftIO . putMVar clientDone
1641−
1642− takeMVar clientDone
1643−
1644−testUnsafeUSend :: TestTransport -> Assertion
1645−testUnsafeUSend TestTransport{..} = do
1646− serverAddr <- newEmptyMVar
1647− clientDone <- newEmptyMVar
1648−
1649− localNode <- newLocalNode testTransport initRemoteTable
1650− void $ forkProcess localNode $ do
1651− self <- getSelfPid
1652− liftIO $ putMVar serverAddr self
1653− clientAddr <- expect
1654− unsafeUSend clientAddr ()
1655−
1656− void $ forkProcess localNode $ do
1657− serverPid <- liftIO $ takeMVar serverAddr
1658− getSelfPid >>= unsafeUSend serverPid
1659− expect >>= liftIO . putMVar clientDone
1660−
1661− takeMVar clientDone
1662−
1663−testUnsafeNSend :: TestTransport -> Assertion
1664−testUnsafeNSend TestTransport{..} = do
1665− clientDone <- newEmptyMVar
1666−
1667− localNode <- newLocalNode testTransport initRemoteTable
1668−
1669− pid <- forkProcess localNode $ do
1670− expect >>= liftIO . putMVar clientDone
1671−
1672− void $ runProcess localNode $ do
1673− register "foobar" pid
1674− unsafeNSend "foobar" ()
1675−
1676− takeMVar clientDone
1677−
1678−testUnsafeNSendRemote :: TestTransport -> Assertion
1679−testUnsafeNSendRemote TestTransport{..} = do
1680− clientDone <- newEmptyMVar
1681−
1682− localNode1 <- newLocalNode testTransport initRemoteTable
1683− localNode2 <- newLocalNode testTransport initRemoteTable
1684−
1685− _ <- forkProcess localNode1 $ do
1686− getSelfPid >>= register "foobar"
1687− liftIO $ putMVar clientDone ()
1688− expect >>= liftIO . putMVar clientDone
1689−
1690− takeMVar clientDone
1691− void $ runProcess localNode2 $ do
1692− unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1693−
1694− takeMVar clientDone
1695−
1696−testUnsafeSendChan :: TestTransport -> Assertion
1697−testUnsafeSendChan TestTransport{..} = do
1698− serverAddr <- newEmptyMVar
1699− clientDone <- newEmptyMVar
1700−
1701− localNode <- newLocalNode testTransport initRemoteTable
1702− void $ forkProcess localNode $ do
1703− self <- getSelfPid
1704− liftIO $ putMVar serverAddr self
1705− sp <- expect
1706− unsafeSendChan sp ()
1707−
1708− void $ forkProcess localNode $ do
1709− serverPid <- liftIO $ takeMVar serverAddr
1710− (sp, rp) <- newChan
1711− unsafeSend serverPid sp
1712− receiveChan rp :: Process ()
1713− liftIO $ putMVar clientDone ()
1714−
1715− takeMVar clientDone
1716−
1717−testCallLocal :: TestTransport -> Assertion
1718−testCallLocal TestTransport{..} = do
1719− node <- newLocalNode testTransport initRemoteTable
1720−
1721− -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1722− result <- newEmptyMVar
1723− runProcess node $ do
1724− r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1725− liftIO $ putMVar result r
1726−
1727− takeMVar result >>= assertBool "Expected 'True'"
1728−
1729− -- Testing that when callLocal is interrupted, the worker is interrupted.
1730− ibox <- newIORef False
1731− runProcess node $ do
1732− keeper <- getSelfPid
1733− spawnLocal $ do
1734− caller <- getSelfPid
1735− send keeper caller
1736− onException
1737− (callLocal $ do
1738− onException (do send keeper caller
1739− expect)
1740− (do liftIO $ writeIORef ibox True))
1741− (send keeper ())
1742− caller <- expect
1743− exit caller "test"
1744− expect :: Process ()
1745−
1746− readIORef ibox >>= assertBool "Expected 'True'"
1747−
1748− -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1749− ibox2 <- newIORef False
1750− runProcess node $ do
1751− r <- try (callLocal $ error "e" >> return ())
1752− liftIO $ writeIORef ibox2 $ case r of
1753− Left (ErrorCall "e") -> True
1754− _ -> False
1755−
1756− readIORef ibox >>= assertBool "Expected 'True'"
1757−
1758− -- Test that caller waits for the worker in correct situation
1759− ibox3 <- newIORef False
1760− result3 <- newEmptyMVar
1761− runProcess node $ do
1762− keeper <- getSelfPid
1763− spawnLocal $ do
1764− callLocal $
1765− (do us <- getSelfPid
1766− send keeper us
1767− () <- expect
1768− liftIO yield)
1769− `finally` (liftIO $ writeIORef ibox3 True)
1770− liftIO $ putMVar result3 =<< readIORef ibox3
1771− worker <- expect
1772− send worker ()
1773−
1774− takeMVar result3 >>= assertBool "Expected 'True'"
1775−
1776− -- Test that caller waits for the worker in case when caller gets an exception
1777− ibox4 <- newIORef False
1778− result4 <- newEmptyMVar
1779− runProcess node $ do
1780− keeper <- getSelfPid
1781− spawnLocal $ do
1782− caller <- getSelfPid
1783− callLocal
1784− ((do send keeper caller
1785− expect)
1786− `finally` (liftIO $ writeIORef ibox4 True))
1787− `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1788− caller <- expect
1789− exit caller "hi!"
1790−
1791− takeMVar result4 >>= assertBool "Expected 'True'"
1792− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1793−
1794−tests :: TestTransport -> IO [Test]
1795−tests testtrans = return [
1796− testGroup "Basic features" [
1797− testCase "Ping" (testPing testtrans)
1798− , testCase "Math" (testMath testtrans)
1799− , testCase "Timeout" (testTimeout testtrans)
1800− , testCase "Timeout0" (testTimeout0 testtrans)
1801− , testCase "SendToTerminated" (testSendToTerminated testtrans)
1802− , testCase "TypedChannnels" (testTypedChannels testtrans)
1803− , testCase "Terminate" (testTerminate testtrans)
1804− , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1805− , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1806− , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1807− , testCase "SpawnLocal" (testSpawnLocal testtrans)
1808− , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1809− , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1810− , testCase "MatchAny" (testMatchAny testtrans)
1811− , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1812− , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1813− , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1814− , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1815− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1816− , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)
1818− , testCase "KillLocal" (testKillLocal testtrans)
1819− , testCase "KillRemote" (testKillRemote testtrans)
1820− , testCase "Die" (testDie testtrans)
1821− , testCase "PrettyExit" (testPrettyExit testtrans)
1822− , testCase "CatchesExit" (testCatchesExit testtrans)
1823− , testCase "Catches" (testCatches testtrans)
1824− , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1825− , testCase "ExitLocal" (testExitLocal testtrans)
1826− , testCase "ExitRemote" (testExitRemote testtrans)
1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1828− , testCase "TextCallLocal" (testCallLocal testtrans)
1829− -- Unsafe Primitives
1830− , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1831− , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1832− , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1833− , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1834− , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1835− -- usend
1836− , testCase "USend" (testUSend usend testtrans 50)
1837− , testCase "UForward"
1838− (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1839− testtrans 50
1840− )
1841− ]
1842− , testGroup "Monitoring and Linking" [
1843− -- Monitoring processes
1844− --
1845− -- The "missing" combinations in the list below don't make much sense, as
1846− -- we cannot guarantee that the monitor reply or link exception will not
1847− -- happen before the unmonitor or unlink
1848− testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1849− , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1850− , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1851− , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1852− , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1853− , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1854− , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1855− , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1856− , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1857− , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1858− , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1859− , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1860− , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1861− , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1862− , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1863− , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1864− , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1865− -- Monitoring nodes and channels
1866− , testCase "MonitorNode" (testMonitorNode testtrans)
1867− , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1868− , testCase "MonitorChannel" (testMonitorChannel testtrans)
1869− -- Reconnect
1870− ]
1871−
1872− -- Tests that fail occasionally and should be revised
1873− , testGroup "Flaky" [
1874− testCase "Reconnect" (testReconnect testtrans)
1875− , testCase "Registry" (testRegistry testtrans)
1876− , testCase "MergeChannels" (testMergeChannels testtrans)
1877− , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1878− ]
1879− ]