git.iko.soy/distributed-process
on master help sign in
Strip out test modules since relocated to distributed-process-tests
commite52ec08c3b17c0bcdb9f826efca805d2830a130d authorTim Watson <watson.timothy@gmail.com> dateFri 3 Jan 2014, 11:48 (13 years ago) parent9377760
7 files changed−2743
compare with master
unifiedsplit
tests/TestCH.hs−1339 tests/TestClosure.hs−480 tests/TestMx.hs−213 tests/TestReceive.hs−168 tests/TestStats.hs−133 tests/TestTracing.hs−335 tests/TestUtils.hs−75
tests/TestCH.hsdeleted−1339
@@ -1,1339 +0,0 @@
1−module Main where
2−
3−#if ! MIN_VERSION_base(4,6,0)
4−import Prelude hiding (catch)
5−#endif
6−
7−import Data.Binary (Binary(..))
8−import Data.Typeable (Typeable)
9−import Data.Foldable (forM_)
10−import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)
11−import Control.Concurrent.MVar
12− ( MVar
13− , newEmptyMVar
14− , putMVar
15− , takeMVar
16− , readMVar
17− )
18−import Control.Monad (replicateM_, replicateM, forever, void)
19−import Control.Exception (SomeException, throwIO)
20−import qualified Control.Exception as Ex (catch)
21−import Control.Applicative ((<$>), (<*>), pure, (<|>))
22−import qualified Network.Transport as NT (Transport, closeEndPoint)
23−import Network.Socket (sClose)
24−import Network.Transport.TCP
25− ( createTransportExposeInternals
26− , TransportInternals(socketBetween)
27− , defaultTCPParameters
28− )
29−import Control.Distributed.Process
30−import Control.Distributed.Process.Internal.Types
31− ( NodeId(nodeAddress)
32− , LocalNode(localEndPoint)
33− , ProcessExitException(..)
34− , nullProcessId
35− )
36−import Control.Distributed.Process.Node
37−import Control.Distributed.Process.Serializable (Serializable)
38−
39−import Test.HUnit (Assertion, assertFailure)
40−import Test.Framework (Test, defaultMain, testGroup)
41−import Test.Framework.Providers.HUnit (testCase)
42−import Control.Rematch hiding (match)
43−import Control.Rematch.Run (Match(..))
44−
45−newtype Ping = Ping ProcessId
46− deriving (Typeable, Binary, Show)
47−
48−newtype Pong = Pong ProcessId
49− deriving (Typeable, Binary, Show)
50−
51−--------------------------------------------------------------------------------
52−-- Supporting definitions --
53−--------------------------------------------------------------------------------
54−
55−expectThat :: a -> Matcher a -> Assertion
56−expectThat a matcher = case res of
57− MatchSuccess -> return ()
58− (MatchFailure msg) -> assertFailure msg
59− where res = runMatch matcher a
60−
61−-- | Like fork, but throw exceptions in the child thread to the parent
62−forkTry :: IO () -> IO ThreadId
63−forkTry p = do
64− tid <- myThreadId
65− forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
66−
67−-- | The ping server from the paper
68−ping :: Process ()
69−ping = do
70− Pong partner <- expect
71− self <- getSelfPid
72− send partner (Ping self)
73− ping
74−
75−-- | Quick and dirty synchronous version of whereisRemoteAsync
76−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
77−whereisRemote nid string = do
78− whereisRemoteAsync nid string
79− WhereIsReply _ mPid <- expect
80− return mPid
81−
82−data Add = Add ProcessId Double Double deriving (Typeable)
83−data Divide = Divide ProcessId Double Double deriving (Typeable)
84−data DivByZero = DivByZero deriving (Typeable)
85−
86−instance Binary Add where
87− put (Add pid x y) = put pid >> put x >> put y
88− get = Add <$> get <*> get <*> get
89−
90−instance Binary Divide where
91− put (Divide pid x y) = put pid >> put x >> put y
92− get = Divide <$> get <*> get <*> get
93−
94−instance Binary DivByZero where
95− put DivByZero = return ()
96− get = return DivByZero
97−
98−-- The math server from the paper
99−math :: Process ()
100−math = do
101− receiveWait
102− [ match (\(Add pid x y) -> send pid (x + y))
103− , matchIf (\(Divide _ _ y) -> y /= 0)
104− (\(Divide pid x y) -> send pid (x / y))
105− , match (\(Divide pid _ _) -> send pid DivByZero)
106− ]
107− math
108−
109−-- | Monitor or link to a remote node
110−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
111− -> ProcessId -- Process to monitor/link to
112− -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
113− -> Process (Maybe MonitorRef)
114−monitorOrLink mOrL pid mSignal = do
115− result <- if mOrL then Just <$> monitor pid
116− else link pid >> return Nothing
117− -- Monitor is asynchronous, which usually does not matter but if we want a
118− -- *specific* signal then it does. Therefore we wait an arbitrary delay and
119− -- hope that this means the monitor has been set up
120− forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
121− return result
122−
123−monitorTestProcess :: ProcessId -- Process to monitor/link to
124− -> Bool -- 'True' for monitor, 'False' for link
125− -> Bool -- Should we unmonitor?
126− -> DiedReason -- Expected cause of death
127− -> Maybe (MVar ()) -- Signal for 'monitor set up'
128− -> MVar () -- Signal for successful termination
129− -> Process ()
130−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
131− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
132− case (un, mRef) of
133− (True, Nothing) -> do
134− unlink theirAddr
135− liftIO $ putMVar done ()
136− (True, Just ref) -> do
137− unmonitor ref
138− liftIO $ putMVar done ()
139− (False, ref) -> do
140− ProcessMonitorNotification ref' pid reason' <- expect
141− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
142− liftIO $ putMVar done ()
143− )
144− (\(ProcessLinkException pid reason') -> do
145− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
146− liftIO $ putMVar done ()
147− )
148−
149−--------------------------------------------------------------------------------
150−-- The tests proper --
151−--------------------------------------------------------------------------------
152−
153−-- | Basic ping test
154−testPing :: NT.Transport -> Assertion
155−testPing transport = do
156− serverAddr <- newEmptyMVar
157− clientDone <- newEmptyMVar
158−
159− -- Server
160− forkIO $ do
161− localNode <- newLocalNode transport initRemoteTable
162− addr <- forkProcess localNode ping
163− putMVar serverAddr addr
164−
165− -- Client
166− forkIO $ do
167− localNode <- newLocalNode transport initRemoteTable
168− pingServer <- readMVar serverAddr
169−
170− let numPings = 10000
171−
172− runProcess localNode $ do
173− pid <- getSelfPid
174− replicateM_ numPings $ do
175− send pingServer (Pong pid)
176− Ping _ <- expect
177− return ()
178−
179− putMVar clientDone ()
180−
181− takeMVar clientDone
182−
183−-- | Monitor a process on an unreachable node
184−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion
185−testMonitorUnreachable transport mOrL un = do
186− deadProcess <- newEmptyMVar
187− done <- newEmptyMVar
188−
189− forkIO $ do
190− localNode <- newLocalNode transport initRemoteTable
191− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
192− closeLocalNode localNode
193− putMVar deadProcess addr
194−
195− forkIO $ do
196− localNode <- newLocalNode transport initRemoteTable
197− theirAddr <- readMVar deadProcess
198− runProcess localNode $
199− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
200−
201− takeMVar done
202−
203−-- | Monitor a process which terminates normally
204−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
205−testMonitorNormalTermination transport mOrL un = do
206− monitorSetup <- newEmptyMVar
207− monitoredProcess <- newEmptyMVar
208− done <- newEmptyMVar
209−
210− forkIO $ do
211− localNode <- newLocalNode transport initRemoteTable
212− addr <- forkProcess localNode $
213− liftIO $ readMVar monitorSetup
214− putMVar monitoredProcess addr
215−
216− forkIO $ do
217− localNode <- newLocalNode transport initRemoteTable
218− theirAddr <- readMVar monitoredProcess
219− runProcess localNode $
220− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
221−
222− takeMVar done
223−
224−-- | Monitor a process which terminates abnormally
225−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
226−testMonitorAbnormalTermination transport mOrL un = do
227− monitorSetup <- newEmptyMVar
228− monitoredProcess <- newEmptyMVar
229− done <- newEmptyMVar
230−
231− let err = userError "Abnormal termination"
232−
233− forkIO $ do
234− localNode <- newLocalNode transport initRemoteTable
235− addr <- forkProcess localNode . liftIO $ do
236− readMVar monitorSetup
237− throwIO err
238− putMVar monitoredProcess addr
239−
240− forkIO $ do
241− localNode <- newLocalNode transport initRemoteTable
242− theirAddr <- readMVar monitoredProcess
243− runProcess localNode $
244− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
245−
246− takeMVar done
247−
248−-- | Monitor a local process that is already dead
249−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
250−testMonitorLocalDeadProcess transport mOrL un = do
251− processDead <- newEmptyMVar
252− processAddr <- newEmptyMVar
253− localNode <- newLocalNode transport initRemoteTable
254− done <- newEmptyMVar
255−
256− forkIO $ do
257− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
258− putMVar processAddr addr
259−
260− forkIO $ do
261− theirAddr <- readMVar processAddr
262− readMVar processDead
263− runProcess localNode $ do
264− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
265−
266− takeMVar done
267−
268−-- | Monitor a remote process that is already dead
269−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
270−testMonitorRemoteDeadProcess transport mOrL un = do
271− processDead <- newEmptyMVar
272− processAddr <- newEmptyMVar
273− done <- newEmptyMVar
274−
275− forkIO $ do
276− localNode <- newLocalNode transport initRemoteTable
277− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
278− putMVar processAddr addr
279−
280− forkIO $ do
281− localNode <- newLocalNode transport initRemoteTable
282− theirAddr <- readMVar processAddr
283− readMVar processDead
284− runProcess localNode $ do
285− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
286−
287− takeMVar done
288−
289−-- | Monitor a process that becomes disconnected
290−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion
291−testMonitorDisconnect transport mOrL un = do
292− processAddr <- newEmptyMVar
293− monitorSetup <- newEmptyMVar
294− done <- newEmptyMVar
295−
296− forkIO $ do
297− localNode <- newLocalNode transport initRemoteTable
298− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
299− putMVar processAddr addr
300− readMVar monitorSetup
301− NT.closeEndPoint (localEndPoint localNode)
302−
303− forkIO $ do
304− localNode <- newLocalNode transport initRemoteTable
305− theirAddr <- readMVar processAddr
306− runProcess localNode $ do
307− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
308−
309− takeMVar done
310−
311−-- | Test the math server (i.e., receiveWait)
312−testMath :: NT.Transport -> Assertion
313−testMath transport = do
314− serverAddr <- newEmptyMVar
315− clientDone <- newEmptyMVar
316−
317− -- Server
318− forkIO $ do
319− localNode <- newLocalNode transport initRemoteTable
320− addr <- forkProcess localNode math
321− putMVar serverAddr addr
322−
323− -- Client
324− forkIO $ do
325− localNode <- newLocalNode transport initRemoteTable
326− mathServer <- readMVar serverAddr
327−
328− runProcess localNode $ do
329− pid <- getSelfPid
330− send mathServer (Add pid 1 2)
331− 3 <- expect :: Process Double
332− send mathServer (Divide pid 8 2)
333− 4 <- expect :: Process Double
334− send mathServer (Divide pid 8 0)
335− DivByZero <- expect
336− liftIO $ putMVar clientDone ()
337−
338− takeMVar clientDone
339−
340−-- | Send first message (i.e. connect) to an already terminated process
341−-- (without monitoring); then send another message to a second process on
342−-- the same remote node (we're checking that the remote node did not die)
343−testSendToTerminated :: NT.Transport -> Assertion
344−testSendToTerminated transport = do
345− serverAddr1 <- newEmptyMVar
346− serverAddr2 <- newEmptyMVar
347− clientDone <- newEmptyMVar
348−
349− forkIO $ do
350− terminated <- newEmptyMVar
351− localNode <- newLocalNode transport initRemoteTable
352− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
353− addr2 <- forkProcess localNode $ ping
354− readMVar terminated
355− putMVar serverAddr1 addr1
356− putMVar serverAddr2 addr2
357−
358− forkIO $ do
359− localNode <- newLocalNode transport initRemoteTable
360− server1 <- readMVar serverAddr1
361− server2 <- readMVar serverAddr2
362− runProcess localNode $ do
363− pid <- getSelfPid
364− send server1 "Hi"
365− send server2 (Pong pid)
366− Ping pid' <- expect
367− True <- return $ pid' == server2
368− liftIO $ putMVar clientDone ()
369−
370− takeMVar clientDone
371−
372−-- | Test (non-zero) timeout
373−testTimeout :: NT.Transport -> Assertion
374−testTimeout transport = do
375− localNode <- newLocalNode transport initRemoteTable
376− done <- newEmptyMVar
377−
378− runProcess localNode $ do
379− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
380− liftIO $ putMVar done ()
381−
382− takeMVar done
383−
384−-- | Test zero timeout
385−testTimeout0 :: NT.Transport -> Assertion
386−testTimeout0 transport = do
387− serverAddr <- newEmptyMVar
388− clientDone <- newEmptyMVar
389− messagesSent <- newEmptyMVar
390−
391− forkIO $ do
392− localNode <- newLocalNode transport initRemoteTable
393− addr <- forkProcess localNode $ do
394− liftIO $ readMVar messagesSent >> threadDelay 1000000
395− -- Variation on the venerable ping server which uses a zero timeout
396− -- Since we wait for all messages to be sent before doing this receive,
397− -- we should nevertheless find the right message immediately
398− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
399− self <- getSelfPid
400− send partner (Ping self)
401− putMVar serverAddr addr
402−
403− forkIO $ do
404− localNode <- newLocalNode transport initRemoteTable
405− server <- readMVar serverAddr
406− runProcess localNode $ do
407− pid <- getSelfPid
408− -- Send a bunch of messages. A large number of messages that the server
409− -- is not interested in, and then a single message that it wants
410− replicateM_ 10000 $ send server "Irrelevant message"
411− send server (Pong pid)
412− liftIO $ putMVar messagesSent ()
413− Ping _ <- expect
414− liftIO $ putMVar clientDone ()
415−
416− takeMVar clientDone
417−
418−-- | Test typed channels
419−testTypedChannels :: NT.Transport -> Assertion
420−testTypedChannels transport = do
421− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
422− clientDone <- newEmptyMVar
423−
424− forkIO $ do
425− localNode <- newLocalNode transport initRemoteTable
426− forkProcess localNode $ do
427− (serverSendPort, rport) <- newChan
428− liftIO $ putMVar serverChannel serverSendPort
429− (clientSendPort, i) <- receiveChan rport
430− sendChan clientSendPort (even i)
431− return ()
432−
433− forkIO $ do
434− localNode <- newLocalNode transport initRemoteTable
435− serverSendPort <- readMVar serverChannel
436− runProcess localNode $ do
437− (clientSendPort, rport) <- newChan
438− sendChan serverSendPort (clientSendPort, 5)
439− False <- receiveChan rport
440− liftIO $ putMVar clientDone ()
441−
442− takeMVar clientDone
443−
444−-- | Test merging receive ports
445−testMergeChannels :: NT.Transport -> Assertion
446−testMergeChannels transport = do
447− localNode <- newLocalNode transport initRemoteTable
448− testFlat localNode True "aaabbbccc"
449− testFlat localNode False "abcabcabc"
450− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
451− testNested localNode True False "adgadgadgbehbehbehcficficfi"
452− testNested localNode False True "abcabcabcdefdefdefghighighi"
453− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
454− testBlocked localNode True
455− testBlocked localNode False
456− where
457− -- Single layer of merging
458− testFlat :: LocalNode -> Bool -> String -> IO ()
459− testFlat localNode biased expected = do
460− done <- newEmptyMVar
461− forkProcess localNode $ do
462− rs <- mapM charChannel "abc"
463− m <- mergePorts biased rs
464− xs <- replicateM 9 $ receiveChan m
465− True <- return $ xs == expected
466− liftIO $ putMVar done ()
467− takeMVar done
468−
469− -- Two layers of merging
470− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
471− testNested localNode biasedInner biasedOuter expected = do
472− done <- newEmptyMVar
473− forkProcess localNode $ do
474− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
475− ms <- mapM (mergePorts biasedInner) rss
476− m <- mergePorts biasedOuter ms
477− xs <- replicateM (9 * 3) $ receiveChan m
478− True <- return $ xs == expected
479− liftIO $ putMVar done ()
480− takeMVar done
481−
482− -- Test that if no messages are (immediately) available, the scheduler makes no difference
483− testBlocked :: LocalNode -> Bool -> IO ()
484− testBlocked localNode biased = do
485− vs <- replicateM 3 newEmptyMVar
486− done <- newEmptyMVar
487−
488− forkProcess localNode $ do
489− [sa, sb, sc] <- liftIO $ mapM readMVar vs
490− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
491− [ -- a, b, c
492− (sa, 'a')
493− , (sb, 'b')
494− , (sc, 'c')
495− -- a, c, b
496− , (sa, 'a')
497− , (sc, 'c')
498− , (sb, 'b')
499− -- b, a, c
500− , (sb, 'b')
501− , (sa, 'a')
502− , (sc, 'c')
503− -- b, c, a
504− , (sb, 'b')
505− , (sc, 'c')
506− , (sa, 'a')
507− -- c, a, b
508− , (sc, 'c')
509− , (sa, 'a')
510− , (sb, 'b')
511− -- c, b, a
512− , (sc, 'c')
513− , (sb, 'b')
514− , (sa, 'a')
515− ]
516−
517− forkProcess localNode $ do
518− (ss, rs) <- unzip <$> replicateM 3 newChan
519− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
520− m <- mergePorts biased rs
521− xs <- replicateM (6 * 3) $ receiveChan m
522− True <- return $ xs == "abcacbbacbcacabcba"
523− liftIO $ putMVar done ()
524−
525− takeMVar done
526−
527− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
528− mergePorts True = mergePortsBiased
529− mergePorts False = mergePortsRR
530−
531− charChannel :: Char -> Process (ReceivePort Char)
532− charChannel c = do
533− (sport, rport) <- newChan
534− replicateM_ 3 $ sendChan sport c
535− liftIO $ threadDelay 10000 -- Make sure messages have been sent
536− return rport
537−
538−testTerminate :: NT.Transport -> Assertion
539−testTerminate transport = do
540− localNode <- newLocalNode transport initRemoteTable
541− done <- newEmptyMVar
542−
543− pid <- forkProcess localNode $ do
544− liftIO $ threadDelay 100000
545− terminate
546−
547− runProcess localNode $ do
548− ref <- monitor pid
549− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
550− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
551− liftIO $ putMVar done ()
552−
553− takeMVar done
554−
555−testMonitorNode :: NT.Transport -> Assertion
556−testMonitorNode transport = do
557− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
558− done <- newEmptyMVar
559−
560− closeLocalNode node1
561−
562− runProcess node2 $ do
563− ref <- monitorNode (localNodeId node1)
564− NodeMonitorNotification ref' nid DiedDisconnect <- expect
565− True <- return $ ref == ref' && nid == localNodeId node1
566− liftIO $ putMVar done ()
567−
568− takeMVar done
569−
570−testMonitorLiveNode :: NT.Transport -> Assertion
571−testMonitorLiveNode transport = do
572− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
573− ready <- newEmptyMVar
574− done <- newEmptyMVar
575−
576− forkProcess node2 $ do
577− ref <- monitorNode (localNodeId node1)
578− liftIO $ putMVar ready ()
579− NodeMonitorNotification ref' nid _ <- expect
580− True <- return $ ref == ref' && nid == localNodeId node1
581− liftIO $ putMVar done ()
582−
583− takeMVar ready
584− closeLocalNode node1
585−
586− takeMVar done
587−
588−testMonitorChannel :: NT.Transport -> Assertion
589−testMonitorChannel transport = do
590− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
591− gotNotification <- newEmptyMVar
592−
593− pid <- forkProcess node1 $ do
594− sport <- expect :: Process (SendPort ())
595− ref <- monitorPort sport
596− PortMonitorNotification ref' port' reason <- expect
597− -- reason might be DiedUnknownId if the receive port is GCed before the
598− -- monitor is established (TODO: not sure that this is reasonable)
599− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
600− liftIO $ putMVar gotNotification ()
601−
602− runProcess node2 $ do
603− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
604− send pid sport
605− liftIO $ threadDelay 100000
606−
607− takeMVar gotNotification
608−
609−testRegistry :: NT.Transport -> Assertion
610−testRegistry transport = do
611− node <- newLocalNode transport initRemoteTable
612− done <- newEmptyMVar
613−
614− pingServer <- forkProcess node ping
615−
616− runProcess node $ do
617− register "ping" pingServer
618− Just pid <- whereis "ping"
619− True <- return $ pingServer == pid
620− us <- getSelfPid
621− nsend "ping" (Pong us)
622− Ping pid' <- expect
623− True <- return $ pingServer == pid'
624− liftIO $ putMVar done ()
625−
626− takeMVar done
627−
628−testRemoteRegistry :: NT.Transport -> Assertion
629−testRemoteRegistry transport = do
630− node1 <- newLocalNode transport initRemoteTable
631− node2 <- newLocalNode transport initRemoteTable
632− done <- newEmptyMVar
633−
634− pingServer <- forkProcess node1 ping
635−
636− runProcess node2 $ do
637− let nid1 = localNodeId node1
638− registerRemoteAsync nid1 "ping" pingServer
639− receiveWait [
640− matchIf (\(RegisterReply label' _) -> "ping" == label')
641− (\(RegisterReply _ _) -> return ()) ]
642−
643− Just pid <- whereisRemote nid1 "ping"
644− True <- return $ pingServer == pid
645− us <- getSelfPid
646− nsendRemote nid1 "ping" (Pong us)
647− Ping pid' <- expect
648− True <- return $ pingServer == pid'
649− liftIO $ putMVar done ()
650−
651− takeMVar done
652−
653−testSpawnLocal :: NT.Transport -> Assertion
654−testSpawnLocal transport = do
655− node <- newLocalNode transport initRemoteTable
656− done <- newEmptyMVar
657−
658− runProcess node $ do
659− us <- getSelfPid
660−
661− pid <- spawnLocal $ do
662− sport <- expect
663− sendChan sport (1234 :: Int)
664−
665− sport <- spawnChannelLocal $ \rport -> do
666− (1234 :: Int) <- receiveChan rport
667− send us ()
668−
669− send pid sport
670− () <- expect
671− liftIO $ putMVar done ()
672−
673− takeMVar done
674−
675−testReconnect :: NT.Transport -> TransportInternals -> Assertion
676−testReconnect transport transportInternals = do
677− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
678− let nid1 = localNodeId node1
679− nid2 = localNodeId node2
680− processA <- newEmptyMVar
681− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
682−
683− forkProcess node1 $ do
684− us <- getSelfPid
685− liftIO $ putMVar processA us
686− msg1 <- expect
687− msg2 <- expect
688− True <- return $ msg1 == "message 1" && msg2 == "message 3"
689− liftIO $ putMVar sendTestOk ()
690−
691− forkProcess node2 $ do
692− {-
693− - Make sure there is no implicit reconnect on normal message sending
694− -}
695−
696− them <- liftIO $ readMVar processA
697− send them "message 1" >> liftIO (threadDelay 100000)
698−
699− -- Simulate network failure
700− liftIO $ do
701− sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
702− sClose sock
703− threadDelay 10000
704−
705− -- Should not arrive
706− send them "message 2"
707−
708− -- Should arrive
709− reconnect them
710− send them "message 3"
711−
712− liftIO $ takeMVar sendTestOk
713−
714− {-
715− - Test that there *is* implicit reconnect on node controller messages
716− -}
717−
718− us <- getSelfPid
719− registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
720− receiveWait [
721− matchIf (\(RegisterReply label' _) -> "a" == label')
722− (\(RegisterReply _ _) -> return ()) ]
723−
724− Just _ <- whereisRemote nid1 "a"
725−
726−
727− -- Simulate network failure
728− liftIO $ do
729− sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
730− sClose sock
731− threadDelay 10000
732−
733− -- This will happen due to implicit reconnect
734− registerRemoteAsync nid1 "b" us
735− receiveWait [
736− matchIf (\(RegisterReply label' _) -> "b" == label')
737− (\(RegisterReply _ _) -> return ()) ]
738−
739− -- Should happen
740− registerRemoteAsync nid1 "c" us
741− receiveWait [
742− matchIf (\(RegisterReply label' _) -> "c" == label')
743− (\(RegisterReply _ _) -> return ()) ]
744−
745− -- Check
746− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
747− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
748− Just _ <- whereisRemote nid1 "c"
749−
750− liftIO $ putMVar registerTestOk ()
751−
752− takeMVar registerTestOk
753−
754−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
755−-- in between
756−testMatchAny :: NT.Transport -> Assertion
757−testMatchAny transport = do
758− proxyAddr <- newEmptyMVar
759− clientDone <- newEmptyMVar
760−
761− -- Math server
762− forkIO $ do
763− localNode <- newLocalNode transport initRemoteTable
764− mathServer <- forkProcess localNode math
765− proxyServer <- forkProcess localNode $ forever $ do
766− msg <- receiveWait [ matchAny return ]
767− forward msg mathServer
768− putMVar proxyAddr proxyServer
769−
770− -- Client
771− forkIO $ do
772− localNode <- newLocalNode transport initRemoteTable
773− mathServer <- readMVar proxyAddr
774−
775− runProcess localNode $ do
776− pid <- getSelfPid
777− send mathServer (Add pid 1 2)
778− 3 <- expect :: Process Double
779− send mathServer (Divide pid 8 2)
780− 4 <- expect :: Process Double
781− send mathServer (Divide pid 8 0)
782− DivByZero <- expect
783− liftIO $ putMVar clientDone ()
784−
785− takeMVar clientDone
786−
787−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
788−-- in between, however we block 'Divide' requests ....
789−testMatchAnyHandle :: NT.Transport -> Assertion
790−testMatchAnyHandle transport = do
791− proxyAddr <- newEmptyMVar
792− clientDone <- newEmptyMVar
793−
794− -- Math server
795− forkIO $ do
796− localNode <- newLocalNode transport initRemoteTable
797− mathServer <- forkProcess localNode math
798− proxyServer <- forkProcess localNode $ forever $ do
799− receiveWait [
800− matchAny (maybeForward mathServer)
801− ]
802− putMVar proxyAddr proxyServer
803−
804− -- Client
805− forkIO $ do
806− localNode <- newLocalNode transport initRemoteTable
807− mathServer <- readMVar proxyAddr
808−
809− runProcess localNode $ do
810− pid <- getSelfPid
811− send mathServer (Add pid 1 2)
812− 3 <- expect :: Process Double
813− send mathServer (Divide pid 8 2)
814− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
815− liftIO $ putMVar clientDone ()
816−
817− takeMVar clientDone
818− where maybeForward :: ProcessId -> Message -> Process (Maybe ())
819− maybeForward s msg =
820− handleMessage msg (\m@(Add _ _ _) -> send s m)
821−
822−testMatchAnyNoHandle :: NT.Transport -> Assertion
823−testMatchAnyNoHandle transport = do
824− addr <- newEmptyMVar
825− clientDone <- newEmptyMVar
826− serverDone <- newEmptyMVar
827−
828− -- Math server
829− forkIO $ do
830− localNode <- newLocalNode transport initRemoteTable
831− server <- forkProcess localNode $ forever $ do
832− receiveWait [
833− matchAnyIf
834− -- the condition has type `Add -> Bool`
835− (\(Add _ _ _) -> True)
836− -- the match `AbstractMessage -> Process ()` will succeed!
837− (\m -> do
838− -- `String -> Process ()` does *not* match the input types however
839− r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
840− case r of
841− Nothing -> return ()
842− Just _ -> die "NONSENSE")
843− ]
844− -- we *must* have removed the message from our mailbox though!!!
845− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
846− liftIO $ putMVar serverDone ()
847− putMVar addr server
848−
849− -- Client
850− forkIO $ do
851− localNode <- newLocalNode transport initRemoteTable
852− server <- readMVar addr
853−
854− runProcess localNode $ do
855− pid <- getSelfPid
856− send server (Add pid 1 2)
857− -- we only care about the client having sent a message, so we're done
858− liftIO $ putMVar clientDone ()
859−
860− takeMVar clientDone
861− takeMVar serverDone
862−
863−-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
864−-- unless the text body @/= "bar"@ - this case should time out rather than
865−-- removing the message from the process mailbox.
866−testMatchAnyIf :: NT.Transport -> Assertion
867−testMatchAnyIf transport = do
868− echoAddr <- newEmptyMVar
869− clientDone <- newEmptyMVar
870−
871− -- echo server
872− forkIO $ do
873− localNode <- newLocalNode transport initRemoteTable
874− echoServer <- forkProcess localNode $ forever $ do
875− receiveWait [
876− matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
877− tryHandleMessage
878− ]
879− putMVar echoAddr echoServer
880−
881− -- Client
882− forkIO $ do
883− localNode <- newLocalNode transport initRemoteTable
884− server <- readMVar echoAddr
885−
886− runProcess localNode $ do
887− pid <- getSelfPid
888− send server (pid, "foo")
889− "foo" <- expect
890− send server (pid, "baz")
891− "baz" <- expect
892− send server (pid, "bar")
893− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
894− liftIO $ putMVar clientDone ()
895−
896− takeMVar clientDone
897− where tryHandleMessage :: Message -> Process (Maybe ())
898− tryHandleMessage msg =
899− handleMessage msg (\(pid :: ProcessId, (m :: String))
900− -> do { send pid m; return () })
901−
902−testMatchMessageWithUnwrap :: NT.Transport -> Assertion
903−testMatchMessageWithUnwrap transport = do
904− echoAddr <- newEmptyMVar
905− clientDone <- newEmptyMVar
906−
907− -- echo server
908− forkIO $ do
909− localNode <- newLocalNode transport initRemoteTable
910− echoServer <- forkProcess localNode $ forever $ do
911− msg <- receiveWait [
912− matchMessage (\(m :: Message) -> do
913− return m)
914− ]
915− unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
916− case unwrapped of
917− (Just (p, msg')) -> forward msg' p
918− Nothing -> die "unable to unwrap the message"
919− putMVar echoAddr echoServer
920−
921− -- Client
922− forkIO $ do
923− localNode <- newLocalNode transport initRemoteTable
924− server <- readMVar echoAddr
925−
926− runProcess localNode $ do
927− pid <- getSelfPid
928− send server (pid, wrapMessage ("foo" :: String))
929− "foo" <- expect
930− send server (pid, wrapMessage ("baz" :: String))
931− "baz" <- expect
932− liftIO $ putMVar clientDone ()
933−
934− takeMVar clientDone
935−
936−-- Test 'receiveChanTimeout'
937−testReceiveChanTimeout :: NT.Transport -> Assertion
938−testReceiveChanTimeout transport = do
939− done <- newEmptyMVar
940− sendPort <- newEmptyMVar
941−
942− forkTry $ do
943− localNode <- newLocalNode transport initRemoteTable
944− runProcess localNode $ do
945− -- Create a typed channel
946− (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
947− liftIO $ putMVar sendPort sp
948−
949− -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
950− Nothing <- receiveChanTimeout 1000000 rp
951−
952− -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
953− Just True <- receiveChanTimeout 1000000 rp
954−
955− -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
956− Nothing <- receiveChanTimeout 0 rp
957−
958− -- Again, but now there is a message available
959− liftIO $ threadDelay 1000000
960− Just False <- receiveChanTimeout 0 rp
961−
962− liftIO $ putMVar done ()
963−
964− forkTry $ do
965− localNode <- newLocalNode transport initRemoteTable
966− runProcess localNode $ do
967− sp <- liftIO $ readMVar sendPort
968−
969− liftIO $ threadDelay 1500000
970− sendChan sp True
971−
972− liftIO $ threadDelay 500000
973− sendChan sp False
974−
975− takeMVar done
976−
977−-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
978−testReceiveChanFeatures :: NT.Transport -> Assertion
979−testReceiveChanFeatures transport = do
980− done <- newEmptyMVar
981−
982− forkTry $ do
983− localNode <- newLocalNode transport initRemoteTable
984− runProcess localNode $ do
985− (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
986− (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
987−
988− -- Test Functor instance
989−
990− sendChan spInt 2
991− sendChan spBool False
992−
993− rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
994−
995− True <- receiveChan rp1
996− False <- receiveChan rp1
997−
998− -- Test Applicative instance
999−
1000− sendChan spInt 3
1001− sendChan spInt 4
1002−
1003− let rp2 = pure (+) <*> rpInt <*> rpInt
1004−
1005− 7 <- receiveChan rp2
1006−
1007− -- Test Alternative instance
1008−
1009− sendChan spInt 3
1010− sendChan spBool True
1011−
1012− let rp3 = (even <$> rpInt) <|> rpBool
1013−
1014− False <- receiveChan rp3
1015− True <- receiveChan rp3
1016−
1017− -- Test Monad instance
1018−
1019− sendChan spBool True
1020− sendChan spBool False
1021− sendChan spInt 5
1022−
1023− let rp4 :: ReceivePort Int
1024− rp4 = do b <- rpBool
1025− if b
1026− then rpInt
1027− else return 7
1028−
1029− 5 <- receiveChan rp4
1030− 7 <- receiveChan rp4
1031−
1032− liftIO $ putMVar done ()
1033−
1034− takeMVar done
1035−
1036−testKillLocal :: NT.Transport -> Assertion
1037−testKillLocal transport = do
1038− localNode <- newLocalNode transport initRemoteTable
1039− done <- newEmptyMVar
1040−
1041− pid <- forkProcess localNode $ do
1042− liftIO $ threadDelay 1000000
1043−
1044− runProcess localNode $ do
1045− ref <- monitor pid
1046− us <- getSelfPid
1047− kill pid "TestKill"
1048− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1049− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1050− liftIO $ putMVar done ()
1051−
1052− takeMVar done
1053−
1054−testKillRemote :: NT.Transport -> Assertion
1055−testKillRemote transport = do
1056− node1 <- newLocalNode transport initRemoteTable
1057− node2 <- newLocalNode transport initRemoteTable
1058− done <- newEmptyMVar
1059−
1060− pid <- forkProcess node1 $ do
1061− liftIO $ threadDelay 1000000
1062−
1063− runProcess node2 $ do
1064− ref <- monitor pid
1065− us <- getSelfPid
1066− kill pid "TestKill"
1067− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1068− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1069− liftIO $ putMVar done ()
1070−
1071− takeMVar done
1072−
1073−testCatchesExit :: NT.Transport -> Assertion
1074−testCatchesExit transport = do
1075− localNode <- newLocalNode transport initRemoteTable
1076− done <- newEmptyMVar
1077−
1078− _ <- forkProcess localNode $ do
1079− (die ("foobar", 123 :: Int))
1080− `catchesExit` [
1081− (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1082− , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1083− , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1084− -> (liftIO $ putMVar done ()) >> return ()))
1085− ]
1086−
1087− takeMVar done
1088−
1089−testHandleMessageIf :: NT.Transport -> Assertion
1090−testHandleMessageIf transport = do
1091− localNode <- newLocalNode transport initRemoteTable
1092− done <- newEmptyMVar
1093− _ <- forkProcess localNode $ do
1094− self <- getSelfPid
1095− send self (5 :: Integer, 10 :: Integer)
1096− msg <- receiveWait [ matchMessage return ]
1097− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1098− handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1099− (\input -> liftIO $ putMVar done input)
1100− return ()
1101−
1102− result <- takeMVar done
1103− expectThat result $ equalTo (5, 10)
1104−
1105−testCatches :: NT.Transport -> Assertion
1106−testCatches transport = do
1107− localNode <- newLocalNode transport initRemoteTable
1108− done <- newEmptyMVar
1109−
1110− _ <- forkProcess localNode $ do
1111− node <- getSelfNode
1112− (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1113− `catches` [
1114− Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1115− ]
1116−
1117− takeMVar done
1118−
1119−testMaskRestoreScope :: NT.Transport -> Assertion
1120−testMaskRestoreScope transport = do
1121− localNode <- newLocalNode transport initRemoteTable
1122− parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1123− spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1124−
1125− void $ runProcess localNode $ mask $ \unmask -> do
1126− getSelfPid >>= liftIO . putMVar parentPid
1127− void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1128−
1129− parent <- liftIO $ takeMVar parentPid
1130− child <- liftIO $ takeMVar spawnedPid
1131− expectThat parent $ isNot $ equalTo child
1132−
1133−testDie :: NT.Transport -> Assertion
1134−testDie transport = do
1135− localNode <- newLocalNode transport initRemoteTable
1136− done <- newEmptyMVar
1137−
1138− _ <- forkProcess localNode $ do
1139− (die ("foobar", 123 :: Int))
1140− `catchExit` \_from reason -> do
1141− -- TODO: should verify that 'from' has the right value
1142− True <- return $ reason == ("foobar", 123 :: Int)
1143− liftIO $ putMVar done ()
1144−
1145− takeMVar done
1146−
1147−testPrettyExit :: NT.Transport -> Assertion
1148−testPrettyExit transport = do
1149− localNode <- newLocalNode transport initRemoteTable
1150− done <- newEmptyMVar
1151−
1152− _ <- forkProcess localNode $ do
1153− (die "timeout")
1154− `catch` \ex@(ProcessExitException from _) ->
1155− let expected = "exit-from=" ++ (show from)
1156− in do
1157− True <- return $ (show ex) == expected
1158− liftIO $ putMVar done ()
1159−
1160− takeMVar done
1161−
1162−testExitLocal :: NT.Transport -> Assertion
1163−testExitLocal transport = do
1164− localNode <- newLocalNode transport initRemoteTable
1165− supervisedDone <- newEmptyMVar
1166− supervisorDone <- newEmptyMVar
1167−
1168− pid <- forkProcess localNode $ do
1169− (liftIO $ threadDelay 100000)
1170− `catchExit` \_from reason -> do
1171− -- TODO: should verify that 'from' has the right value
1172− True <- return $ reason == "TestExit"
1173− liftIO $ putMVar supervisedDone ()
1174−
1175− runProcess localNode $ do
1176− ref <- monitor pid
1177− exit pid "TestExit"
1178− -- This time the client catches the exception, so it dies normally
1179− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1180− True <- return $ ref == ref' && pid == pid'
1181− liftIO $ putMVar supervisorDone ()
1182−
1183− takeMVar supervisedDone
1184− takeMVar supervisorDone
1185−
1186−testExitRemote :: NT.Transport -> Assertion
1187−testExitRemote transport = do
1188− node1 <- newLocalNode transport initRemoteTable
1189− node2 <- newLocalNode transport initRemoteTable
1190− supervisedDone <- newEmptyMVar
1191− supervisorDone <- newEmptyMVar
1192−
1193− pid <- forkProcess node1 $ do
1194− (liftIO $ threadDelay 100000)
1195− `catchExit` \_from reason -> do
1196− -- TODO: should verify that 'from' has the right value
1197− True <- return $ reason == "TestExit"
1198− liftIO $ putMVar supervisedDone ()
1199−
1200− runProcess node2 $ do
1201− ref <- monitor pid
1202− exit pid "TestExit"
1203− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1204− True <- return $ ref == ref' && pid == pid'
1205− liftIO $ putMVar supervisorDone ()
1206−
1207− takeMVar supervisedDone
1208− takeMVar supervisorDone
1209−
1210−testUnsafeSend :: NT.Transport -> Assertion
1211−testUnsafeSend transport = do
1212− serverAddr <- newEmptyMVar
1213− clientDone <- newEmptyMVar
1214−
1215− localNode <- newLocalNode transport initRemoteTable
1216− void $ forkProcess localNode $ do
1217− self <- getSelfPid
1218− liftIO $ putMVar serverAddr self
1219− clientAddr <- expect
1220− unsafeSend clientAddr ()
1221−
1222− void $ forkProcess localNode $ do
1223− serverPid <- liftIO $ takeMVar serverAddr
1224− getSelfPid >>= unsafeSend serverPid
1225− () <- expect
1226− liftIO $ putMVar clientDone ()
1227−
1228− takeMVar clientDone
1229−
1230−testUnsafeNSend :: NT.Transport -> Assertion
1231−testUnsafeNSend transport = do
1232− clientDone <- newEmptyMVar
1233−
1234− localNode <- newLocalNode transport initRemoteTable
1235−
1236− pid <- forkProcess localNode $ do
1237− () <- expect
1238− liftIO $ putMVar clientDone ()
1239−
1240− void $ runProcess localNode $ do
1241− register "foobar" pid
1242− unsafeNSend "foobar" ()
1243−
1244− takeMVar clientDone
1245−
1246−testUnsafeSendChan :: NT.Transport -> Assertion
1247−testUnsafeSendChan transport = do
1248− serverAddr <- newEmptyMVar
1249− clientDone <- newEmptyMVar
1250−
1251− localNode <- newLocalNode transport initRemoteTable
1252− void $ forkProcess localNode $ do
1253− self <- getSelfPid
1254− liftIO $ putMVar serverAddr self
1255− sp <- expect
1256− unsafeSendChan sp ()
1257−
1258− void $ forkProcess localNode $ do
1259− serverPid <- liftIO $ takeMVar serverAddr
1260− (sp, rp) <- newChan
1261− unsafeSend serverPid sp
1262− () <- receiveChan rp
1263− liftIO $ putMVar clientDone ()
1264−
1265− takeMVar clientDone
1266−
1267−tests :: (NT.Transport, TransportInternals) -> [Test]
1268−tests (transport, transportInternals) = [
1269− testGroup "Basic features" [
1270− testCase "Ping" (testPing transport)
1271− , testCase "Math" (testMath transport)
1272− , testCase "Timeout" (testTimeout transport)
1273− , testCase "Timeout0" (testTimeout0 transport)
1274− , testCase "SendToTerminated" (testSendToTerminated transport)
1275− , testCase "TypedChannnels" (testTypedChannels transport)
1276− , testCase "MergeChannels" (testMergeChannels transport)
1277− , testCase "Terminate" (testTerminate transport)
1278− , testCase "Registry" (testRegistry transport)
1279− , testCase "RemoteRegistry" (testRemoteRegistry transport)
1280− , testCase "SpawnLocal" (testSpawnLocal transport)
1281− , testCase "HandleMessageIf" (testHandleMessageIf transport)
1282− , testCase "MatchAny" (testMatchAny transport)
1283− , testCase "MatchAnyHandle" (testMatchAnyHandle transport)
1284− , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle transport)
1285− , testCase "MatchAnyIf" (testMatchAnyIf transport)
1286− , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap transport)
1287− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)
1288− , testCase "ReceiveChanFeatures" (testReceiveChanFeatures transport)
1289− , testCase "KillLocal" (testKillLocal transport)
1290− , testCase "KillRemote" (testKillRemote transport)
1291− , testCase "Die" (testDie transport)
1292− , testCase "PrettyExit" (testPrettyExit transport)
1293− , testCase "CatchesExit" (testCatchesExit transport)
1294− , testCase "Catches" (testCatches transport)
1295− , testCase "MaskRestoreScope" (testMaskRestoreScope transport)
1296− , testCase "ExitLocal" (testExitLocal transport)
1297− , testCase "ExitRemote" (testExitRemote transport)
1298− -- Unsafe Primitives
1299− , testCase "TestUnsafeSend" (testUnsafeSend transport)
1300− , testCase "TestUnsafeNSend" (testUnsafeNSend transport)
1301− , testCase "TestUnsafeSendChan" (testUnsafeSendChan transport)
1302− ]
1303− , testGroup "Monitoring and Linking" [
1304− -- Monitoring processes
1305− --
1306− -- The "missing" combinations in the list below don't make much sense, as
1307− -- we cannot guarantee that the monitor reply or link exception will not
1308− -- happen before the unmonitor or unlink
1309− testCase "MonitorUnreachable" (testMonitorUnreachable transport True False)
1310− , testCase "MonitorNormalTermination" (testMonitorNormalTermination transport True False)
1311− , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination transport True False)
1312− , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess transport True False)
1313− , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess transport True False)
1314− , testCase "MonitorDisconnect" (testMonitorDisconnect transport True False)
1315− , testCase "LinkUnreachable" (testMonitorUnreachable transport False False)
1316− , testCase "LinkNormalTermination" (testMonitorNormalTermination transport False False)
1317− , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination transport False False)
1318− , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess transport False False)
1319− , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess transport False False)
1320− , testCase "LinkDisconnect" (testMonitorDisconnect transport False False)
1321− , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination transport True True)
1322− , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination transport True True)
1323− , testCase "UnmonitorDisconnect" (testMonitorDisconnect transport True True)
1324− , testCase "UnlinkNormalTermination" (testMonitorNormalTermination transport False True)
1325− , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination transport False True)
1326− , testCase "UnlinkDisconnect" (testMonitorDisconnect transport False True)
1327− -- Monitoring nodes and channels
1328− , testCase "MonitorNode" (testMonitorNode transport)
1329− , testCase "MonitorLiveNode" (testMonitorLiveNode transport)
1330− , testCase "MonitorChannel" (testMonitorChannel transport)
1331− -- Reconnect
1332− , testCase "Reconnect" (testReconnect transport transportInternals)
1333− ]
1334− ]
1335−
1336−main :: IO ()
1337−main = do
1338− Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
1339− defaultMain (tests transport)
tests/TestClosure.hsdeleted−480
@@ -1,480 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Main where
3−
4−import Data.ByteString.Lazy (empty)
5−import Data.Typeable (Typeable)
6−import Control.Monad (join, replicateM, forever, replicateM_, void)
7−import Control.Exception (IOException, throw)
8−import Control.Concurrent (forkIO, threadDelay)
9−import Control.Concurrent.MVar
10− ( MVar
11− , newEmptyMVar
12− , readMVar
13− , takeMVar
14− , putMVar
15− , modifyMVar_
16− , newMVar
17− )
18−import Control.Applicative ((<$>))
19−import System.Random (randomIO)
20−import Network.Transport (Transport)
21−import Network.Transport.TCP
22− ( createTransportExposeInternals
23− , defaultTCPParameters
24− , TransportInternals(socketBetween)
25− )
26−import Network.Socket (sClose)
27−import Control.Distributed.Process
28−import Control.Distributed.Process.Closure
29−import Control.Distributed.Process.Node
30−import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))
31−import Control.Distributed.Static (staticLabel, staticClosure)
32−
33−import Test.HUnit (Assertion)
34−import Test.Framework (Test, defaultMain)
35−import Test.Framework.Providers.HUnit (testCase)
36−
37−--------------------------------------------------------------------------------
38−-- Supporting definitions --
39−--------------------------------------------------------------------------------
40−
41−quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
42−quintuple a b c d e = (a, b, c, d, e)
43−
44−sdictInt :: SerializableDict Int
45−sdictInt = SerializableDict
46−
47−factorial :: Int -> Process Int
48−factorial 0 = return 1
49−factorial n = (n *) <$> factorial (n - 1)
50−
51−addInt :: Int -> Int -> Int
52−addInt x y = x + y
53−
54−putInt :: Int -> MVar Int -> IO ()
55−putInt = flip putMVar
56−
57−sendPid :: ProcessId -> Process ()
58−sendPid toPid = do
59− fromPid <- getSelfPid
60− send toPid fromPid
61−
62−wait :: Int -> Process ()
63−wait = liftIO . threadDelay
64−
65−isPrime :: Integer -> Process Bool
66−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
67− where
68− sieve :: [Integer] -> [Integer]
69− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
70− sieve [] = error "Uh oh -- we've run out of primes"
71−
72−-- | First argument indicates empty closure environment
73−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
74−typedPingServer () rport = forever $ do
75− sport <- receiveChan rport
76− sendChan sport ()
77−
78−signal :: ProcessId -> Process ()
79−signal pid = send pid ()
80−
81−remotable [ 'factorial
82− , 'addInt
83− , 'putInt
84− , 'sendPid
85− , 'sdictInt
86− , 'wait
87− , 'typedPingServer
88− , 'isPrime
89− , 'quintuple
90− , 'signal
91− ]
92−
93−randomElement :: [a] -> IO a
94−randomElement xs = do
95− ix <- randomIO
96− return (xs !! (ix `mod` length xs))
97−
98−remotableDecl [
99− [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
100− dfib (_, reply, 0) = sendChan reply 0
101− dfib (_, reply, 1) = sendChan reply 1
102− dfib (nids, reply, n) = do
103− nid1 <- liftIO $ randomElement nids
104− nid2 <- liftIO $ randomElement nids
105− (sport, rport) <- newChan
106− spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)
107− spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)
108− n1 <- receiveChan rport
109− n2 <- receiveChan rport
110− sendChan reply $ n1 + n2
111− |]
112− ]
113−
114−-- Just try creating a static polymorphic value
115−staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
116− => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
117−staticQuintuple = $(mkStatic 'quintuple)
118−
119−factorialClosure :: Int -> Closure (Process Int)
120−factorialClosure = $(mkClosure 'factorial)
121−
122−addIntClosure :: Int -> Closure (Int -> Int)
123−addIntClosure = $(mkClosure 'addInt)
124−
125−putIntClosure :: Int -> Closure (MVar Int -> IO ())
126−putIntClosure = $(mkClosure 'putInt)
127−
128−sendPidClosure :: ProcessId -> Closure (Process ())
129−sendPidClosure = $(mkClosure 'sendPid)
130−
131−sendFac :: Int -> ProcessId -> Closure (Process ())
132−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid
133−
134−factorialOf :: Closure (Int -> Process Int)
135−factorialOf = staticClosure $(mkStatic 'factorial)
136−
137−factorial' :: Int -> Closure (Process Int)
138−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
139−
140−waitClosure :: Int -> Closure (Process ())
141−waitClosure = $(mkClosure 'wait)
142−
143−simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()
144−simulateNetworkFailure transportInternals fr to = liftIO $ do
145− threadDelay 10000
146− sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
147− sClose sock
148− threadDelay 10000
149−
150−--------------------------------------------------------------------------------
151−-- The tests proper --
152−--------------------------------------------------------------------------------
153−
154−testUnclosure :: Transport -> RemoteTable -> Assertion
155−testUnclosure transport rtable = do
156− node <- newLocalNode transport rtable
157− done <- newEmptyMVar
158− forkProcess node $ do
159− 120 <- join . unClosure $ factorialClosure 5
160− liftIO $ putMVar done ()
161− takeMVar done
162−
163−testBind :: Transport -> RemoteTable -> Assertion
164−testBind transport rtable = do
165− node <- newLocalNode transport rtable
166− done <- newEmptyMVar
167− runProcess node $ do
168− us <- getSelfPid
169− join . unClosure $ sendFac 6 us
170− (720 :: Int) <- expect
171− liftIO $ putMVar done ()
172− takeMVar done
173−
174−testSendPureClosure :: Transport -> RemoteTable -> Assertion
175−testSendPureClosure transport rtable = do
176− serverAddr <- newEmptyMVar
177− serverDone <- newEmptyMVar
178−
179− forkIO $ do
180− node <- newLocalNode transport rtable
181− addr <- forkProcess node $ do
182− cl <- expect
183− fn <- unClosure cl :: Process (Int -> Int)
184− 13 <- return $ fn 6
185− liftIO $ putMVar serverDone ()
186− putMVar serverAddr addr
187−
188− forkIO $ do
189− node <- newLocalNode transport rtable
190− theirAddr <- readMVar serverAddr
191− runProcess node $ send theirAddr (addIntClosure 7)
192−
193− takeMVar serverDone
194−
195−testSendIOClosure :: Transport -> RemoteTable -> Assertion
196−testSendIOClosure transport rtable = do
197− serverAddr <- newEmptyMVar
198− serverDone <- newEmptyMVar
199−
200− forkIO $ do
201− node <- newLocalNode transport rtable
202− addr <- forkProcess node $ do
203− cl <- expect
204− io <- unClosure cl :: Process (MVar Int -> IO ())
205− liftIO $ do
206− someMVar <- newEmptyMVar
207− io someMVar
208− 5 <- readMVar someMVar
209− putMVar serverDone ()
210− putMVar serverAddr addr
211−
212− forkIO $ do
213− node <- newLocalNode transport rtable
214− theirAddr <- readMVar serverAddr
215− runProcess node $ send theirAddr (putIntClosure 5)
216−
217− takeMVar serverDone
218−
219−testSendProcClosure :: Transport -> RemoteTable -> Assertion
220−testSendProcClosure transport rtable = do
221− serverAddr <- newEmptyMVar
222− clientDone <- newEmptyMVar
223−
224− forkIO $ do
225− node <- newLocalNode transport rtable
226− addr <- forkProcess node $ do
227− cl <- expect
228− pr <- unClosure cl :: Process (Int -> Process ())
229− pr 5
230− putMVar serverAddr addr
231−
232− forkIO $ do
233− node <- newLocalNode transport rtable
234− theirAddr <- readMVar serverAddr
235− runProcess node $ do
236− pid <- getSelfPid
237− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
238− 5 <- expect :: Process Int
239− liftIO $ putMVar clientDone ()
240−
241− takeMVar clientDone
242−
243−testSpawn :: Transport -> RemoteTable -> Assertion
244−testSpawn transport rtable = do
245− serverNodeAddr <- newEmptyMVar
246− clientDone <- newEmptyMVar
247−
248− forkIO $ do
249− node <- newLocalNode transport rtable
250− putMVar serverNodeAddr (localNodeId node)
251−
252− forkIO $ do
253− node <- newLocalNode transport rtable
254− nid <- readMVar serverNodeAddr
255− runProcess node $ do
256− pid <- getSelfPid
257− pid' <- spawn nid (sendPidClosure pid)
258− pid'' <- expect
259− True <- return $ pid' == pid''
260− liftIO $ putMVar clientDone ()
261−
262− takeMVar clientDone
263−
264−testCall :: Transport -> RemoteTable -> Assertion
265−testCall transport rtable = do
266− serverNodeAddr <- newEmptyMVar
267− clientDone <- newEmptyMVar
268−
269− forkIO $ do
270− node <- newLocalNode transport rtable
271− putMVar serverNodeAddr (localNodeId node)
272−
273− forkIO $ do
274− node <- newLocalNode transport rtable
275− nid <- readMVar serverNodeAddr
276− runProcess node $ do
277− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
278− liftIO $ putMVar clientDone ()
279−
280− takeMVar clientDone
281−
282−testCallBind :: Transport -> RemoteTable -> Assertion
283−testCallBind transport rtable = do
284− serverNodeAddr <- newEmptyMVar
285− clientDone <- newEmptyMVar
286−
287− forkIO $ do
288− node <- newLocalNode transport rtable
289− putMVar serverNodeAddr (localNodeId node)
290−
291− forkIO $ do
292− node <- newLocalNode transport rtable
293− nid <- readMVar serverNodeAddr
294− runProcess node $ do
295− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
296− liftIO $ putMVar clientDone ()
297−
298− takeMVar clientDone
299−
300−testSeq :: Transport -> RemoteTable -> Assertion
301−testSeq transport rtable = do
302− node <- newLocalNode transport rtable
303− done <- newEmptyMVar
304− runProcess node $ do
305− us <- getSelfPid
306− join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
307− 120 :: Int <- expect
308− 720 :: Int <- expect
309− liftIO $ putMVar done ()
310− takeMVar done
311−
312−-- Test 'spawnSupervised'
313−--
314−-- Set up a supervisor, spawn a child, then have a third process monitor the
315−-- child. The supervisor then throws an exception, the child dies because it
316−-- was linked to the supervisor, and the third process notices that the child
317−-- dies.
318−testSpawnSupervised :: Transport -> RemoteTable -> Assertion
319−testSpawnSupervised transport rtable = do
320− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
321− [superPid, childPid] <- replicateM 2 $ newEmptyMVar
322− thirdProcessDone <- newEmptyMVar
323−
324− forkProcess node1 $ do
325− us <- getSelfPid
326− liftIO $ putMVar superPid us
327− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
328− liftIO $ do
329− putMVar childPid child
330− threadDelay 500000 -- Give the child a chance to link to us
331− throw supervisorDeath
332−
333− forkProcess node2 $ do
334− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
335− ref <- monitor child
336− ProcessMonitorNotification ref' pid' (DiedException e) <- expect
337− True <- return $ ref' == ref
338− && pid' == child
339− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
340− liftIO $ putMVar thirdProcessDone ()
341−
342− takeMVar thirdProcessDone
343− where
344− supervisorDeath :: IOException
345− supervisorDeath = userError "Supervisor died"
346−
347−testSpawnInvalid :: Transport -> RemoteTable -> Assertion
348−testSpawnInvalid transport rtable = do
349− node <- newLocalNode transport rtable
350− done <- newEmptyMVar
351− forkProcess node $ do
352− (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
353− ProcessMonitorNotification ref' pid' _reason <- expect
354− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
355− True <- return $ ref' == ref && pid == pid'
356− liftIO $ putMVar done ()
357− takeMVar done
358−
359−testClosureExpect :: Transport -> RemoteTable -> Assertion
360−testClosureExpect transport rtable = do
361− node <- newLocalNode transport rtable
362− done <- newEmptyMVar
363− runProcess node $ do
364− nodeId <- getSelfNode
365− us <- getSelfPid
366− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
367− send them (1234 :: Int)
368− (1234 :: Int) <- expect
369− liftIO $ putMVar done ()
370− takeMVar done
371−
372−testSpawnChannel :: Transport -> RemoteTable -> Assertion
373−testSpawnChannel transport rtable = do
374− done <- newEmptyMVar
375− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
376−
377− forkProcess node1 $ do
378− pingServer <- spawnChannel
379− (sdictSendPort sdictUnit)
380− (localNodeId node2)
381− ($(mkClosure 'typedPingServer) ())
382− (sendReply, receiveReply) <- newChan
383− sendChan pingServer sendReply
384− receiveChan receiveReply
385− liftIO $ putMVar done ()
386−
387− takeMVar done
388−
389−testTDict :: Transport -> RemoteTable -> Assertion
390−testTDict transport rtable = do
391− done <- newEmptyMVar
392− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
393− forkProcess node1 $ do
394− True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
395− liftIO $ putMVar done ()
396− takeMVar done
397−
398−testFib :: Transport -> RemoteTable -> Assertion
399−testFib transport rtable = do
400− nodes <- replicateM 4 $ newLocalNode transport rtable
401− done <- newEmptyMVar
402−
403− forkProcess (head nodes) $ do
404− (sport, rport) <- newChan
405− spawnLocal $ dfib (map localNodeId nodes, sport, 10)
406− 55 <- receiveChan rport :: Process Integer
407− liftIO $ putMVar done ()
408−
409− takeMVar done
410−
411−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion
412−testSpawnReconnect transport rtable transportInternals = do
413− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
414− let nid1 = localNodeId node1
415− nid2 = localNodeId node2
416− done <- newEmptyMVar
417− iv <- newMVar (0 :: Int)
418−
419− incr <- forkProcess node1 $ forever $ do
420− () <- expect
421− liftIO $ modifyMVar_ iv (return . (+ 1))
422−
423− forkProcess node2 $ do
424− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)
425− simulateNetworkFailure transportInternals nid2 nid1
426− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)
427− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)
428−
429− liftIO $ threadDelay 100000
430−
431− count <- liftIO $ takeMVar iv
432− True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
433−
434− liftIO $ putMVar done ()
435−
436− takeMVar done
437−
438−-- | 'spawn' used to ave a race condition which would be triggered if the
439−-- spawning process terminates immediately after spawning
440−testSpawnTerminate :: Transport -> RemoteTable -> Assertion
441−testSpawnTerminate transport rtable = do
442− slave <- newLocalNode transport rtable
443− master <- newLocalNode transport rtable
444− masterDone <- newEmptyMVar
445−
446− runProcess master $ do
447− us <- getSelfPid
448− replicateM_ 1000 . spawnLocal . void . spawn (localNodeId slave) $ $(mkClosure 'signal) us
449− replicateM_ 1000 $ (expect :: Process ())
450− liftIO $ putMVar masterDone ()
451−
452− takeMVar masterDone
453−
454−tests :: (Transport, TransportInternals) -> RemoteTable -> [Test]
455−tests (transport, transportInternals) rtable = [
456− testCase "Unclosure" (testUnclosure transport rtable)
457− , testCase "Bind" (testBind transport rtable)
458− , testCase "SendPureClosure" (testSendPureClosure transport rtable)
459− , testCase "SendIOClosure" (testSendIOClosure transport rtable)
460− , testCase "SendProcClosure" (testSendProcClosure transport rtable)
461− , testCase "Spawn" (testSpawn transport rtable)
462− , testCase "Call" (testCall transport rtable)
463− , testCase "CallBind" (testCallBind transport rtable)
464− , testCase "Seq" (testSeq transport rtable)
465− , testCase "SpawnSupervised" (testSpawnSupervised transport rtable)
466− , testCase "SpawnInvalid" (testSpawnInvalid transport rtable)
467− , testCase "ClosureExpect" (testClosureExpect transport rtable)
468− , testCase "SpawnChannel" (testSpawnChannel transport rtable)
469− , testCase "TDict" (testTDict transport rtable)
470− , testCase "Fib" (testFib transport rtable)
471− , testCase "SpawnTerminate" (testSpawnTerminate transport rtable)
472− , testCase "SpawnReconnect" (testSpawnReconnect transport rtable transportInternals)
473− ]
474−
475−
476−main :: IO ()
477−main = do
478− Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
479− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
480− defaultMain (tests transport rtable)
tests/TestMx.hsdeleted−213
@@ -1,213 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−module Main where
3−
4−import Control.Concurrent (threadDelay)
5−import Control.Distributed.Process
6−import Control.Distributed.Process.Management
7− ( MxEvent(..)
8− , MxAgentId(..)
9− , mxAgent
10− , mxSink
11− , mxReady
12− , liftMX
13− , mxGetLocal
14− , mxSetLocal
15− , mxNotify
16− , mxBroadcast
17− , mxGetId
18− , mxGet
19− , mxSet
20− , mxClear
21− , mxPurgeTable
22− , mxDropTable
23− )
24−import Control.Distributed.Process.Node
25− ( LocalNode
26− )
27−import Data.Binary
28−import Data.List (find)
29−import Data.Maybe (isJust)
30−import Data.Typeable
31−import GHC.Generics
32−import qualified Network.Transport as NT
33−#if ! MIN_VERSION_base(4,6,0)
34−import Prelude hiding (catch, log)
35−#endif
36−
37−import Test.Framework
38− ( Test
39− , testGroup
40− )
41−import Test.Framework.Providers.HUnit (testCase)
42−import TestUtils
43−
44−data Publish = Publish
45− deriving (Typeable, Generic, Eq)
46−
47−instance Binary Publish where
48−
49−testAgentBroadcast :: TestResult (Maybe ()) -> Process ()
50−testAgentBroadcast result = do
51− (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())
52−
53− publisher <- mxAgent (MxAgentId "publisher-agent") () [
54− mxSink $ \() -> mxBroadcast Publish >> mxReady
55− ]
56−
57− consumer <- mxAgent (MxAgentId "consumer-agent") () [
58− mxSink $ \Publish -> (liftMX $ sendChan resultSP ()) >> mxReady
59− ]
60−
61− mxNotify ()
62− -- once the publisher has seen our message, it will broadcast the Publish
63− stash result =<< receiveChanTimeout 1000000 resultRP
64−
65− kill publisher "finished"
66− kill consumer "finished"
67−
68−testAgentEventHandling :: TestResult Bool -> Process ()
69−testAgentEventHandling result = do
70− let initState = [] :: [MxEvent]
71− agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [
72− (mxSink $ \ev -> do
73− st <- mxGetLocal
74− let act =
75− case ev of
76− (MxSpawned _) -> mxSetLocal (ev:st)
77− (MxProcessDied _ _) -> mxSetLocal (ev:st)
78− _ -> return ()
79− act >> mxReady),
80− (mxSink $ \(ev, sp :: SendPort Bool) -> do
81− st <- mxGetLocal
82− let found =
83− case ev of
84− MxSpawned p ->
85− isJust $ find (\ev' ->
86− case ev' of
87− (MxSpawned p') -> p' == p
88− _ -> False) st
89− MxProcessDied p r ->
90− isJust $ find (\ev' ->
91− case ev' of
92− (MxProcessDied p' r') -> p' == p && r == r'
93− _ -> False) st
94− _ -> False
95− liftMX $ sendChan sp found
96− mxReady)
97− ]
98−
99− _ <- monitor agentPid
100− (sp, rp) <- newChan
101− pid <- spawnLocal $ sendChan sp ()
102− () <- receiveChan rp
103−
104− -- By waiting for a monitor notification, we have a
105− -- higher probably that the agent has seen
106− monitor pid
107− receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]
108−
109− (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
110− mxNotify (MxSpawned pid, replyTo)
111− mxNotify (MxProcessDied pid DiedNormal, replyTo)
112−
113− seenAlive <- receiveChan reply
114− seenDead <- receiveChan reply
115−
116− stash result $ seenAlive && seenDead
117−
118−testAgentPublication :: TestResult (Maybe Publish) -> Process ()
119−testAgentPublication result = do
120− (syncChan, rp) <- newChan
121− let ourId = MxAgentId "publication-agent"
122− agentPid <- mxAgent ourId () [
123− mxSink $ \() -> do
124− selfId <- mxGetId
125− liftMX $ mxSet selfId "publish" Publish >> sendChan syncChan ()
126− mxReady
127− ]
128−
129− mxNotify ()
130− () <- receiveChan rp
131−
132− stash result =<< mxGet ourId "publish"
133−
134− mref <- monitor agentPid
135− kill agentPid "finished"
136− receiveWait [
137− matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)
138− ((\_ -> return ()))
139− ]
140−
141−testAgentTableClear :: Int -> TestResult (Maybe Int, Maybe Int) -> Process ()
142−testAgentTableClear val result =
143− let tId = (MxAgentId "agent-1")
144− tKey = "key-1" in do
145− mxSet tId tKey val
146− get1 <- mxGet tId tKey
147− mxClear tId tKey
148− get2 <- mxGet tId tKey
149− stash result (get1, get2)
150−
151−testAgentTablePurge :: TestResult (Maybe Int) -> Process ()
152−testAgentTablePurge result =
153− let tId = MxAgentId "agent-2"
154− tKey = "key-2" in do
155− mxSet tId tKey (12345 :: Int)
156− mxPurgeTable tId
157− stash result =<< mxGet tId tKey
158−
159−testAgentTableDelete :: Int
160− -> TestResult (Maybe Int, Maybe Int, Maybe Int)
161− -> Process ()
162−testAgentTableDelete val result =
163− let tId = (MxAgentId "agent-3")
164− tKey = "key-3" in do
165− mxSet tId tKey val
166− get1 <- mxGet tId tKey
167− mxDropTable tId
168− get2 <- mxGet tId tKey
169− mxSet tId tKey val
170− get3 <- mxGet tId tKey
171− stash result (get1, get2, get3)
172−
173−tests :: LocalNode -> IO [Test]
174−tests node1 = do
175− return [
176− testGroup "Mx Agents" [
177− testCase "Event Handling"
178− (delayedAssertion
179− "expected True, but events where not as expected"
180− node1 True testAgentEventHandling)
181− , testCase "Inter-Agent Broadcast"
182− (delayedAssertion
183− "expected (Just ()), but no broadcast was received"
184− node1 (Just ()) testAgentBroadcast)
185− ],
186− testGroup "Mx Global Properties" [
187− testCase "Global Property Publication"
188− (delayedAssertion
189− "expected (Just Publish), but no table entry was found"
190− node1 (Just Publish) testAgentPublication)
191− , testCase "Clearing Global Properties"
192− (delayedAssertion
193− "expected (Just 1024, Nothing): invalid table entry found!"
194− node1 (Just 1024, Nothing) (testAgentTableClear 1024))
195− , testCase "Purging Global Tables"
196− (delayedAssertion
197− "expected Nothing, but a table entry was found"
198− node1 Nothing testAgentTablePurge)
199− , testCase "Deleting and (Re)Creating Global Tables"
200− (delayedAssertion
201− "expected (Just 15, Nothing, Just 15): invalid table entry found!"
202− node1 (Just 15, Nothing, Just 15) (testAgentTableDelete 15))
203− ]]
204−
205−statsTests :: NT.Transport -> IO [Test]
206−statsTests _ = do
207− mkNode "8080" >>= tests >>= return
208−
209−main :: IO ()
210−main = do
211− testMain $ statsTests
212− threadDelay 100000
213−
tests/TestReceive.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
2−{-# OPTIONS_GHC -Wall #-}
3−import Control.Distributed.Process
4−import Control.Distributed.Process.Closure
5−import Control.Distributed.Process.Node
6−
7−import Network.Transport (Transport)
8−import Network.Transport.TCP
9− ( createTransportExposeInternals
10− , defaultTCPParameters
11− , TransportInternals(socketBetween)
12− )
13−
14−import Control.Monad
15−import Text.Printf
16−import Data.DeriveTH
17−import Data.Binary
18−import Data.Typeable
19−
20−import Test.HUnit (Assertion, (@?=))
21−import Test.Framework (Test, defaultMain)
22−import Test.Framework.Providers.HUnit (testCase)
23−
24−-- Tests:
25−
26−-- 1. 2 matchChans, receive on each one
27−-- 2. matchChan/matchIf, receive on each one
28−-- 3. matchIf/matchChan, receive on each one
29−-- 4. matchIf/matchChan/matchIf, receive on each one
30−
31−recTest1 :: ReceivePort ()
32− -> SendPort String
33− -> ReceivePort String -> ReceivePort String
34− -> Process ()
35−recTest1 wait sync r1 r2 = do
36− forever $ do
37− receiveChan wait
38− r <- receiveWait
39− [ matchChan r1 $ \s -> return ("received1 " ++ s)
40− , matchChan r2 $ \s -> return ("received2 " ++ s)
41− ]
42− sendChan sync r
43−
44−recTest2 :: ReceivePort ()
45− -> SendPort String
46− -> ReceivePort String -> ReceivePort String
47− -> Process ()
48−recTest2 wait sync r1 r2 = do
49− forever $ do
50− receiveChan wait
51− r <- receiveWait
52− [ matchChan r1 $ \s -> return ("received1 " ++ s)
53− , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
54− ]
55− sendChan sync r
56−
57−recTest3 :: ReceivePort ()
58− -> SendPort String
59− -> ReceivePort String -> ReceivePort String
60− -> Process ()
61−recTest3 wait sync r1 r2 = do
62− forever $ do
63− receiveChan wait
64− r <- receiveWait
65− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
66− , matchChan r1 $ \s -> return ("received2 " ++ s)
67− ]
68− sendChan sync r
69−
70−recTest4 :: ReceivePort ()
71− -> SendPort String
72− -> ReceivePort String -> ReceivePort String
73− -> Process ()
74−recTest4 wait sync r1 r2 = do
75− forever $ do
76− receiveChan wait
77− r <- receiveWait
78− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
79− , matchChan r1 $ \s -> return ("received2 " ++ s)
80− , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
81− ]
82− sendChan sync r
83−
84−
85−master :: Process ()
86−master = do
87−
88− (waits,waitr) <- newChan
89− (syncs,syncr) <- newChan
90− let go expect = do
91− sendChan waits ()
92− r <- receiveChan syncr
93− liftIO $ print (r,expect, r == expect)
94− liftIO $ r @?= expect
95−
96− liftIO $ putStrLn "---- Test 1 ----"
97− (s1,r1) <- newChan
98− (s2,r2) <- newChan
99− p <- spawnLocal (recTest1 waitr syncs r1 r2)
100−
101− sendChan s1 "a" >> go "received1 a"
102− sendChan s2 "b" >> go "received2 b"
103− sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
104− go "received2 b"
105−
106− kill p "BANG"
107−
108− liftIO $ putStrLn "\n---- Test 2 ----"
109− (s1,r1) <- newChan
110− (s2,r2) <- newChan
111− p <- spawnLocal (recTest2 waitr syncs r1 r2)
112−
113− sendChan s1 "a" >> go "received1 a"
114− send p "foo" >> go "received2 foo"
115− sendChan s1 "a" >> send p "foo" >> go "received1 a"
116− sendChan s1 "a" >> send p "bar" >> go "received1 a"
117− go "received2 foo"
118−
119− kill p "BANG"
120−
121− liftIO $ putStrLn "\n---- Test 3 ----"
122− (s1,r1) <- newChan
123− (s2,r2) <- newChan
124− p <- spawnLocal (recTest3 waitr syncs r1 r2)
125−
126− sendChan s1 "a" >> go "received2 a"
127− send p "foo" >> go "received1 foo"
128− sendChan s1 "a" >> send p "foo" >> go "received1 foo"
129− sendChan s1 "a" >> send p "bar" >> go "received2 a"
130− go "received2 a"
131−
132− kill p "BANG"
133−
134− liftIO $ putStrLn "\n---- Test 4 ----"
135− (s1,r1) <- newChan
136− (s2,r2) <- newChan
137− p <- spawnLocal (recTest4 waitr syncs r1 r2)
138−
139− sendChan s1 "a" >> go "received2 a"
140− send p "foo" >> go "received1 foo"
141− send p "bar" >> go "received3 bar"
142− sendChan s1 "a" >> send p "foo" >> go "received1 foo"
143− send p "bar" >> go "received2 a"
144− send p "foo" >> go "received1 foo" >> go "received3 bar"
145−
146− kill p "BANG"
147−
148− terminate
149−
150−
151−testReceive :: Transport -> RemoteTable -> Assertion
152−testReceive transport rtable = do
153− node <- newLocalNode transport rtable
154− runProcess node $ master
155−
156−tests :: (Transport, TransportInternals) -> RemoteTable -> [Test]
157−tests (transport, transportInternals) rtable = [
158− testCase "testReceive" (testReceive transport rtable)
159− ]
160−
161−-- NB. test doesn't work, because failure exceptions don't get
162−-- propagated. The test always claims to succeed, even if it failed.
163−
164−main :: IO ()
165−main = do
166− Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
167− let rtable = initRemoteTable
168− defaultMain (tests transport rtable)
tests/TestStats.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Main where
4−
5−import Control.Concurrent.MVar
6− ( MVar
7− , newEmptyMVar
8− , putMVar
9− , takeMVar
10− )
11−import Control.Distributed.Process
12−import Control.Distributed.Process.Node
13− ( forkProcess
14− , LocalNode)
15−import Data.Binary()
16−import Data.Typeable()
17−import qualified Network.Transport as NT
18−
19−#if ! MIN_VERSION_base(4,6,0)
20−import Prelude hiding (catch)
21−#endif
22−
23−import Test.Framework
24− ( Test
25− , testGroup
26− )
27−import Test.HUnit (Assertion)
28−import Test.Framework.Providers.HUnit (testCase)
29−import TestUtils
30−
31−testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
32−testLocalDeadProcessInfo result = do
33− pid <- spawnLocal $ do "finish" <- expect; return ()
34− mref <- monitor pid
35− send pid "finish"
36− _ <- receiveWait [
37− matchIf (\(ProcessMonitorNotification ref' pid' r) ->
38− ref' == mref && pid' == pid && r == DiedNormal)
39− (\p -> return p)
40− ]
41− getProcessInfo pid >>= stash result
42−
43−testLocalLiveProcessInfo :: TestResult Bool -> Process ()
44−testLocalLiveProcessInfo result = do
45− self <- getSelfPid
46− node <- getSelfNode
47− register "foobar" self
48−
49− mon <- liftIO $ newEmptyMVar
50− -- TODO: we can't get the mailbox's length
51− -- mapM (send self) ["hello", "there", "mr", "process"]
52− pid <- spawnLocal $ do
53− link self
54− mRef <- monitor self
55− stash mon mRef
56− "die" <- expect
57− return ()
58−
59− monRef <- liftIO $ takeMVar mon
60−
61− mpInfo <- getProcessInfo self
62− case mpInfo of
63− Nothing -> stash result False
64− Just p -> verifyPInfo p pid monRef node
65− where verifyPInfo :: ProcessInfo
66− -> ProcessId
67− -> MonitorRef
68− -> NodeId
69− -> Process ()
70− verifyPInfo pInfo pid mref node =
71− stash result $ infoNode pInfo == node &&
72− infoLinks pInfo == [pid] &&
73− infoMonitors pInfo == [(pid, mref)] &&
74−-- infoMessageQueueLength pInfo == Just 4 &&
75− infoRegisteredNames pInfo == ["foobar"]
76−
77−testRemoteLiveProcessInfo :: LocalNode -> Assertion
78−testRemoteLiveProcessInfo node1 = do
79− serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
80− liftIO $ launchRemote serverAddr
81− serverPid <- liftIO $ takeMVar serverAddr
82− withActiveRemote node1 $ \result -> do
83− self <- getSelfPid
84− link serverPid
85− -- our send op shouldn't overtake link or monitor requests AFAICT
86− -- so a little table tennis should get us synchronised properly
87− send serverPid (self, "ping")
88− "pong" <- expect
89− pInfo <- getProcessInfo serverPid
90− stash result $ pInfo /= Nothing
91− where
92− launchRemote :: MVar ProcessId -> IO ()
93− launchRemote locMV = do
94− node2 <- liftIO $ mkNode "8082"
95− _ <- liftIO $ forkProcess node2 $ do
96− self <- getSelfPid
97− liftIO $ putMVar locMV self
98− _ <- receiveWait [
99− match (\(pid, "ping") -> send pid "pong")
100− ]
101− "stop" <- expect
102− return ()
103− return ()
104−
105− withActiveRemote :: LocalNode
106− -> ((TestResult Bool -> Process ()) -> Assertion)
107− withActiveRemote n = do
108− a <- delayedAssertion "getProcessInfo remotePid failed" n True
109− return a
110−
111−tests :: LocalNode -> IO [Test]
112−tests node1 = do
113− return [
114− testGroup "Process Info" [
115− testCase "testLocalDeadProcessInfo"
116− (delayedAssertion
117− "expected dead process-info to be ProcessInfoNone"
118− node1 (Nothing) testLocalDeadProcessInfo)
119− , testCase "testLocalLiveProcessInfo"
120− (delayedAssertion
121− "expected process-info to be correctly populated"
122− node1 True testLocalLiveProcessInfo)
123− , testCase "testRemoveLiveProcessInfo"
124− (testRemoteLiveProcessInfo node1)
125− ] ]
126−
127−statsTests :: NT.Transport -> IO [Test]
128−statsTests _ = do
129− mkNode "8080" >>= tests >>= return
130−
131−main :: IO ()
132−main = testMain $ statsTests
133−
tests/TestTracing.hsdeleted−335
@@ -1,335 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Main where
4−
5−import Control.Concurrent (threadDelay)
6−import Control.Concurrent.MVar
7− ( MVar
8− , newEmptyMVar
9− , newMVar
10− , putMVar
11− , takeMVar
12− )
13−import Control.Distributed.Process
14−import Control.Distributed.Process.Debug
15−import Control.Distributed.Process.Management
16− ( MxEvent(..)
17− )
18−import Control.Distributed.Process.Node
19− ( forkProcess
20− , closeLocalNode
21− , LocalNode)
22−import qualified Network.Transport as NT
23−
24−#if ! MIN_VERSION_base(4,6,0)
25−import Prelude hiding (catch, log)
26−#endif
27−
28−import Test.Framework
29− ( Test
30− , testGroup
31− )
32−import Test.Framework.Providers.HUnit (testCase)
33−import TestUtils
34−
35−testSpawnTracing :: TestResult Bool -> Process ()
36−testSpawnTracing result = do
37− setTraceFlags defaultTraceFlags {
38− traceSpawned = (Just TraceAll)
39− , traceDied = (Just TraceAll)
40− }
41−
42− evSpawned <- liftIO $ newEmptyMVar
43− evDied <- liftIO $ newEmptyMVar
44− tracer <- startTracer $ \ev -> do
45− case ev of
46− (MxSpawned p) -> liftIO $ putMVar evSpawned p
47− (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)
48− _ -> return ()
49−
50− (sp, rp) <- newChan
51− pid <- spawnLocal $ sendChan sp ()
52− () <- receiveChan rp
53−
54− tracedAlive <- liftIO $ takeMVar evSpawned
55− (tracedDead, tracedReason) <- liftIO $ takeMVar evDied
56−
57− mref <- monitor tracer
58− stopTracer -- this is asynchronous, so we need to wait...
59− receiveWait [
60− matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)
61− ((\_ -> return ()))
62− ]
63− setTraceFlags defaultTraceFlags
64− stash result (tracedAlive == pid &&
65− tracedDead == pid &&
66− tracedReason == DiedNormal)
67−
68−testTraceRecvExplicitPid :: TestResult Bool -> Process ()
69−testTraceRecvExplicitPid result = do
70− res <- liftIO $ newEmptyMVar
71− pid <- spawnLocal $ do
72− self <- getSelfPid
73− expect >>= (flip sendChan) self
74− withFlags defaultTraceFlags {
75− traceRecv = traceOnly [pid]
76− } $ do
77− withTracer
78− (\ev ->
79− case ev of
80− (MxReceived pid' _) -> stash res (pid == pid')
81− _ -> return ()) $ do
82− (sp, rp) <- newChan
83− send pid sp
84− p <- receiveChan rp
85− res' <- liftIO $ takeMVar res
86− stash result (res' && (p == pid))
87− return ()
88−
89−testTraceRecvNamedPid :: TestResult Bool -> Process ()
90−testTraceRecvNamedPid result = do
91− res <- liftIO $ newEmptyMVar
92− pid <- spawnLocal $ do
93− self <- getSelfPid
94− register "foobar" self
95− expect >>= (flip sendChan) self
96− withFlags defaultTraceFlags {
97− traceRecv = traceOnly ["foobar"]
98− } $ do
99− withTracer
100− (\ev ->
101− case ev of
102− (MxReceived pid' _) -> stash res (pid == pid')
103− _ -> return ()) $ do
104− (sp, rp) <- newChan
105− send pid sp
106− p <- receiveChan rp
107− res' <- liftIO $ takeMVar res
108− stash result (res' && (p == pid))
109− return ()
110−
111−testTraceSending :: TestResult Bool -> Process ()
112−testTraceSending result = do
113− pid <- spawnLocal $ (expect :: Process String) >> return ()
114− self <- getSelfPid
115− res <- liftIO $ newEmptyMVar
116− withFlags defaultTraceFlags { traceSend = traceOn } $ do
117− withTracer
118− (\ev ->
119− case ev of
120− (MxSent to from msg) -> do
121− (Just s) <- unwrapMessage msg :: Process (Maybe String)
122− stash res (to == pid && from == self && s == "hello there")
123− stash res (to == pid && from == self)
124− _ ->
125− return ()) $ do
126− send pid "hello there"
127− res' <- liftIO $ takeMVar res
128− stash result res'
129−
130−testTraceRegistration :: TestResult Bool -> Process ()
131−testTraceRegistration result = do
132− (sp, rp) <- newChan
133− pid <- spawnLocal $ do
134− self <- getSelfPid
135− () <- expect
136− register "foobar" self
137− sendChan sp ()
138− () <- expect
139− return ()
140− res <- liftIO $ newEmptyMVar
141− withFlags defaultTraceFlags { traceRegistered = traceOn } $ do
142− withTracer
143− (\ev ->
144− case ev of
145− MxRegistered p s ->
146− stash res (p == pid && s == "foobar")
147− _ ->
148− return ()) $ do
149− _ <- monitor pid
150− send pid ()
151− () <- receiveChan rp
152− send pid ()
153− receiveWait [
154− match (\(ProcessMonitorNotification _ _ _) -> return ())
155− ]
156− res' <- liftIO $ takeMVar res
157− stash result res'
158−
159−testTraceUnRegistration :: TestResult Bool -> Process ()
160−testTraceUnRegistration result = do
161− pid <- spawnLocal $ do
162− () <- expect
163− unregister "foobar"
164− () <- expect
165− return ()
166− register "foobar" pid
167− res <- liftIO $ newEmptyMVar
168− withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do
169− withTracer
170− (\ev ->
171− case ev of
172− MxUnRegistered p n -> do
173− stash res (p == pid && n == "foobar")
174− send pid ()
175− _ ->
176− return ()) $ do
177− mref <- monitor pid
178− send pid ()
179− receiveWait [
180− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
181− (\_ -> return ())
182− ]
183− res' <- liftIO $ takeMVar res
184− stash result res'
185−
186−testTraceLayering :: TestResult () -> Process ()
187−testTraceLayering result = do
188− pid <- spawnLocal $ do
189− getSelfPid >>= register "foobar"
190− () <- expect
191− traceMessage ("traceMsg", 123 :: Int)
192− return ()
193− withFlags defaultTraceFlags {
194− traceDied = traceOnly [pid]
195− , traceRecv = traceOnly ["foobar"]
196− } $ doTest pid result
197− return ()
198− where
199− doTest :: ProcessId -> MVar () -> Process ()
200− doTest pid result' = do
201− -- TODO: this is pretty gross, even for a test case
202− died <- liftIO $ newEmptyMVar
203− withTracer
204− (\ev ->
205− case ev of
206− MxProcessDied _ _ -> liftIO $ putMVar died ()
207− _ -> return ())
208− ( do {
209− recv <- liftIO $ newEmptyMVar
210− ; withTracer
211− (\ev' ->
212− case ev' of
213− MxReceived _ _ -> liftIO $ putMVar recv ()
214− _ -> return ())
215− ( do {
216− user <- liftIO $ newEmptyMVar
217− ; withTracer
218− (\ev'' ->
219− case ev'' of
220− MxUser _ -> liftIO $ putMVar user ()
221− _ -> return ())
222− (send pid () >> (liftIO $ takeMVar user))
223− ; liftIO $ takeMVar recv
224− })
225− ; liftIO $ takeMVar died
226− })
227− liftIO $ putMVar result' ()
228−
229−testRemoteTraceRelay :: TestResult Bool -> Process ()
230−testRemoteTraceRelay result =
231− let flags = defaultTraceFlags { traceSpawned = traceOn }
232− in do
233− node2 <- liftIO $ mkNode "8082"
234− mvNid <- liftIO $ newEmptyMVar
235−
236− -- As well as needing node2's NodeId, we want to
237− -- redirect all its logs back here, to avoid generating
238− -- garbage on stderr for the duration of the test run.
239− -- Here we set up that relay, and then wait for a signal
240− -- that the tracer (on node1) has seen the expected
241− -- MxSpawned message, at which point we're finished
242− (Just log') <- whereis "logger"
243− pid <- liftIO $ forkProcess node2 $ do
244− logRelay <- spawnLocal $ relay log'
245− reregister "logger" logRelay
246− getSelfNode >>= stash mvNid >> (expect :: Process ())
247−
248− nid <- liftIO $ takeMVar mvNid
249− mref <- monitor pid
250− observedPid <- liftIO $ newEmptyMVar
251− spawnedPid <- liftIO $ newEmptyMVar
252− setTraceFlagsRemote flags nid
253−
254− withFlags defaultTraceFlags { traceSpawned = traceOn } $ do
255− withTracer
256− (\ev ->
257− case ev of
258− MxSpawned p -> stash observedPid p >> send pid ()
259− _ -> return ()) $ do
260− relayPid <- startTraceRelay nid
261− liftIO $ threadDelay 1000000
262− p <- liftIO $ forkProcess node2 $ do
263− expectTimeout 1000000 :: Process (Maybe ())
264− return ()
265− stash spawnedPid p
266−
267− -- Now we wait for (the outer) pid to exit. This won't happen until
268− -- our tracer has seen the trace event for `p' and send `p' the
269− -- message its waiting for prior to exiting
270− receiveWait [
271− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
272− (\_ -> return ())
273− ]
274−
275− relayRef <- monitor relayPid
276− kill relayPid "stop"
277− receiveWait [
278− matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)
279− (\_ -> return ())
280− ]
281− observed <- liftIO $ takeMVar observedPid
282− expected <- liftIO $ takeMVar spawnedPid
283− stash result (observed == expected)
284− -- and just to be polite...
285− liftIO $ closeLocalNode node2
286−
287−tests :: LocalNode -> IO [Test]
288−tests node1 = do
289− -- if we execute the test cases in parallel, the
290− -- various tracers will race with one another and
291− -- we'll get garbage results (or worse, deadlocks)
292− lock <- liftIO $ newMVar ()
293− return [
294− testGroup "Tracing" [
295− testCase "Spawn Tracing"
296− (synchronisedAssertion
297− "expected dead process-info to be ProcessInfoNone"
298− node1 True testSpawnTracing lock)
299− , testCase "Recv Tracing (Explicit Pid)"
300− (synchronisedAssertion
301− "expected a recv trace for the supplied pid"
302− node1 True testTraceRecvExplicitPid lock)
303− , testCase "Recv Tracing (Named Pid)"
304− (synchronisedAssertion
305− "expected a recv trace for the process registered as 'foobar'"
306− node1 True testTraceRecvNamedPid lock)
307− , testCase "Trace Send(er)"
308− (synchronisedAssertion
309− "expected a 'send' trace with the requisite fields set"
310− node1 True testTraceSending lock)
311− , testCase "Trace Registration"
312− (synchronisedAssertion
313− "expected a 'registered' trace"
314− node1 True testTraceRegistration lock)
315− , testCase "Trace Unregistration"
316− (synchronisedAssertion
317− "expected an 'unregistered' trace"
318− node1 True testTraceUnRegistration lock)
319− , testCase "Trace Layering"
320− (synchronisedAssertion
321− "expected blah"
322− node1 () testTraceLayering lock)
323− , testCase "Remote Trace Relay"
324− (synchronisedAssertion
325− "expected blah"
326− node1 True testRemoteTraceRelay lock)
327− ] ]
328−
329−timerTests :: NT.Transport -> IO [Test]
330−timerTests _ = do
331− mkNode "8080" >>= tests >>= return
332−
333−main :: IO ()
334−main = testMain $ timerTests
335−
tests/TestUtils.hsdeleted−75
@@ -1,75 +0,0 @@
1−-- | General testing support. Just @import TestUtils@ in your test module.
2−module TestUtils where
3−
4−#if ! MIN_VERSION_base(4,6,0)
5−import Prelude hiding (catch)
6−#endif
7−import Control.Concurrent.MVar
8− ( MVar
9− , newEmptyMVar
10− , takeMVar
11− , putMVar
12− )
13−
14−import Control.Distributed.Process
15−import Control.Distributed.Process.Node
16−import Control.Distributed.Process.Serializable()
17−import Test.HUnit (Assertion)
18−import Test.HUnit.Base (assertBool)
19−import Test.Framework (Test, defaultMain)
20−
21−import Network.Transport.TCP
22−import qualified Network.Transport as NT
23−
24−-- these utilities have been cribbed from distributed-process-platform
25−-- we should really find a way to share them...
26−
27−mkNode :: String -> IO LocalNode
28−mkNode port = do
29− Right (transport1, _) <- createTransportExposeInternals
30− "127.0.0.1" port defaultTCPParameters
31− newLocalNode transport1 initRemoteTable
32−
33−-- | Given a @builder@ function, make and run a test suite on a single transport
34−testMain :: (NT.Transport -> IO [Test]) -> IO ()
35−testMain builder = do
36− Right (transport, _) <- createTransportExposeInternals
37− "127.0.0.1" "10001" defaultTCPParameters
38− testData <- builder transport
39− defaultMain testData
40−
41−-- | A mutable cell containing a test result.
42−type TestResult a = MVar a
43−
44−synchronisedAssertion :: (Eq a)
45− => String
46− -> LocalNode
47− -> a
48− -> (TestResult a -> Process ())
49− -> MVar ()
50− -> Assertion
51−synchronisedAssertion note localNode expected testProc lock = do
52− result <- newEmptyMVar
53− _ <- forkProcess localNode $ do
54− acquire lock
55− finally (testProc result)
56− (release lock)
57− assertComplete note result expected
58− where acquire lock' = liftIO $ takeMVar lock'
59− release lock' = liftIO $ putMVar lock' ()
60−
61−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
62− (TestResult a -> Process ()) -> Assertion
63−delayedAssertion note localNode expected testProc = do
64− result <- newEmptyMVar
65− _ <- forkProcess localNode $ testProc result
66− assertComplete note result expected
67−
68−assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
69−assertComplete msg mv a = do
70− b <- takeMVar mv
71− assertBool msg (a == b)
72−
73−stash :: TestResult a -> a -> Process ()
74−stash mvar x = liftIO $ putMVar mvar x
75−