@@ -0,0 +1,1879 @@
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+ ]