git.iko.soy/distributed-process
on 0bf7c90 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs
1641 lines 56 kB history raw
1module Control.Distributed.Process.Tests.CH (tests) where
3#if ! MIN_VERSION_base(4,6,0)
4import Prelude hiding (catch)
5#endif
7import Network.Transport.Test (TestTransport(..))
9import Data.Binary (Binary(..))
10import Data.Typeable (Typeable)
11import Data.Foldable (forM_)
12import Data.Function (fix)
13import Data.IORef
14 ( readIORef
15 , writeIORef
16 , newIORef
17 )
18import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)
19import Control.Concurrent.MVar
20 ( MVar
21 , newEmptyMVar
22 , putMVar
23 , takeMVar
24 , readMVar
25 )
26import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
27import Control.Exception (SomeException, throwIO, ErrorCall(..))
28import qualified Control.Exception as Ex (catch)
29import Control.Applicative ((<$>), (<*>), pure, (<|>))
30import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31import Control.Distributed.Process
32import Control.Distributed.Process.Internal.Types
33 ( NodeId(nodeAddress)
34 , LocalNode(localEndPoint)
35 , ProcessExitException(..)
36 , nullProcessId
37 , createUnencodedMessage
38 )
39import Control.Distributed.Process.Node
40import Control.Distributed.Process.Serializable (Serializable)
42import Test.HUnit (Assertion, assertFailure)
43import Test.Framework (Test, testGroup)
44import Test.Framework.Providers.HUnit (testCase)
45import Control.Rematch hiding (match)
46import Control.Rematch.Run (Match(..))
48newtype Ping = Ping ProcessId
49 deriving (Typeable, Binary, Show)
51newtype Pong = Pong ProcessId
52 deriving (Typeable, Binary, Show)
54--------------------------------------------------------------------------------
55-- Supporting definitions --
56--------------------------------------------------------------------------------
58expectThat :: a -> Matcher a -> Assertion
59expectThat a matcher = case res of
60 MatchSuccess -> return ()
61 (MatchFailure msg) -> assertFailure msg
62 where res = runMatch matcher a
64-- | Like fork, but throw exceptions in the child thread to the parent
65forkTry :: IO () -> IO ThreadId
66forkTry p = do
67 tid <- myThreadId
68 forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
70-- | The ping server from the paper
71ping :: Process ()
72ping = do
73 Pong partner <- expect
74 self <- getSelfPid
75 send partner (Ping self)
76 ping
78-- | Quick and dirty synchronous version of whereisRemoteAsync
79whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
80whereisRemote nid string = do
81 whereisRemoteAsync nid string
82 WhereIsReply _ mPid <- expect
83 return mPid
85data Add = Add ProcessId Double Double deriving (Typeable)
86data Divide = Divide ProcessId Double Double deriving (Typeable)
87data DivByZero = DivByZero deriving (Typeable)
89instance Binary Add where
90 put (Add pid x y) = put pid >> put x >> put y
91 get = Add <$> get <*> get <*> get
93instance Binary Divide where
94 put (Divide pid x y) = put pid >> put x >> put y
95 get = Divide <$> get <*> get <*> get
97instance Binary DivByZero where
98 put DivByZero = return ()
99 get = return DivByZero
101-- The math server from the paper
102math :: Process ()
103math = do
104 receiveWait
105 [ match (\(Add pid x y) -> send pid (x + y))
106 , matchIf (\(Divide _ _ y) -> y /= 0)
107 (\(Divide pid x y) -> send pid (x / y))
108 , match (\(Divide pid _ _) -> send pid DivByZero)
109 ]
110 math
112-- | Monitor or link to a remote node
113monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
114 -> ProcessId -- ^ Process to monitor/link to
115 -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up
116 -> Process (Maybe MonitorRef)
117monitorOrLink mOrL pid mSignal = do
118 result <- if mOrL then Just <$> monitor pid
119 else link pid >> return Nothing
120 -- Monitor is asynchronous, which usually does not matter but if we want a
121 -- *specific* signal then it does. Therefore we wait until the MonitorRef is
122 -- listed in the ProcessInfo and hope that this means the monitor has been set
123 -- up.
124 forM_ mSignal $ \signal -> do
125 self <- getSelfPid
126 spawnLocal $ do
127 let waitForMOrL = do
128 liftIO $ threadDelay 100000
129 mpinfo <- getProcessInfo pid
130 case mpinfo of
131 Nothing -> waitForMOrL
132 Just pinfo ->
133 if mOrL then
134 unless (result == lookup self (infoMonitors pinfo)) waitForMOrL
135 else
136 unless (elem self $ infoLinks pinfo) waitForMOrL
137 waitForMOrL
138 liftIO $ putMVar signal ()
139 return result
141monitorTestProcess :: ProcessId -- Process to monitor/link to
142 -> Bool -- 'True' for monitor, 'False' for link
143 -> Bool -- Should we unmonitor?
144 -> DiedReason -- Expected cause of death
145 -> Maybe (MVar ()) -- Signal for 'monitor set up'
146 -> MVar () -- Signal for successful termination
147 -> Process ()
148monitorTestProcess theirAddr mOrL un reason monitorSetup done =
149 catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
150 case (un, mRef) of
151 (True, Nothing) -> do
152 unlink theirAddr
153 liftIO $ putMVar done ()
154 (True, Just ref) -> do
155 unmonitor ref
156 liftIO $ putMVar done ()
157 (False, ref) -> do
158 ProcessMonitorNotification ref' pid reason' <- expect
159 True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
160 liftIO $ putMVar done ()
161 )
162 (\(ProcessLinkException pid reason') -> do
163 True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
164 liftIO $ putMVar done ()
165 )
167--------------------------------------------------------------------------------
168-- The tests proper --
169--------------------------------------------------------------------------------
171-- | Basic ping test
172testPing :: TestTransport -> Assertion
173testPing TestTransport{..} = do
174 serverAddr <- newEmptyMVar
175 clientDone <- newEmptyMVar
177 -- Server
178 forkIO $ do
179 localNode <- newLocalNode testTransport initRemoteTable
180 addr <- forkProcess localNode ping
181 putMVar serverAddr addr
183 -- Client
184 forkIO $ do
185 localNode <- newLocalNode testTransport initRemoteTable
186 pingServer <- readMVar serverAddr
188 let numPings = 10000
190 runProcess localNode $ do
191 pid <- getSelfPid
192 replicateM_ numPings $ do
193 send pingServer (Pong pid)
194 Ping _ <- expect
195 return ()
197 putMVar clientDone ()
199 takeMVar clientDone
201-- | Monitor a process on an unreachable node
202testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
203testMonitorUnreachable TestTransport{..} mOrL un = do
204 deadProcess <- newEmptyMVar
205 done <- newEmptyMVar
207 forkIO $ do
208 localNode <- newLocalNode testTransport initRemoteTable
209 addr <- forkProcess localNode expect
210 closeLocalNode localNode
211 putMVar deadProcess addr
213 forkIO $ do
214 localNode <- newLocalNode testTransport initRemoteTable
215 theirAddr <- readMVar deadProcess
216 runProcess localNode $
217 monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
219 takeMVar done
221-- | Monitor a process which terminates normally
222testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion
223testMonitorNormalTermination TestTransport{..} mOrL un = do
224 monitorSetup <- newEmptyMVar
225 monitoredProcess <- newEmptyMVar
226 done <- newEmptyMVar
228 forkIO $ do
229 localNode <- newLocalNode testTransport initRemoteTable
230 addr <- forkProcess localNode $
231 liftIO $ readMVar monitorSetup
232 putMVar monitoredProcess addr
234 forkIO $ do
235 localNode <- newLocalNode testTransport initRemoteTable
236 theirAddr <- readMVar monitoredProcess
237 runProcess localNode $
238 monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
240 takeMVar done
242-- | Monitor a process which terminates abnormally
243testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion
244testMonitorAbnormalTermination TestTransport{..} mOrL un = do
245 monitorSetup <- newEmptyMVar
246 monitoredProcess <- newEmptyMVar
247 done <- newEmptyMVar
249 let err = userError "Abnormal termination"
251 forkIO $ do
252 localNode <- newLocalNode testTransport initRemoteTable
253 addr <- forkProcess localNode . liftIO $ do
254 readMVar monitorSetup
255 throwIO err
256 putMVar monitoredProcess addr
258 forkIO $ do
259 localNode <- newLocalNode testTransport initRemoteTable
260 theirAddr <- readMVar monitoredProcess
261 runProcess localNode $
262 monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
264 takeMVar done
266-- | Monitor a local process that is already dead
267testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
268testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
269 processAddr <- newEmptyMVar
270 localNode <- newLocalNode testTransport initRemoteTable
271 done <- newEmptyMVar
273 forkIO $ do
274 addr <- forkProcess localNode $ return ()
275 putMVar processAddr addr
277 forkIO $ do
278 theirAddr <- readMVar processAddr
279 runProcess localNode $ do
280 monitor theirAddr
281 -- wait for the process to die
282 ProcessMonitorNotification _ _ _ <- expect
283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
285 takeMVar done
287-- | Monitor a remote process that is already dead
288testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
289testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do
290 processDead <- newEmptyMVar
291 processAddr <- newEmptyMVar
292 done <- newEmptyMVar
294 forkIO $ do
295 localNode <- newLocalNode testTransport initRemoteTable
296 addr <- forkProcess localNode . liftIO $ putMVar processDead ()
297 putMVar processAddr addr
299 forkIO $ do
300 localNode <- newLocalNode testTransport initRemoteTable
301 theirAddr <- readMVar processAddr
302 readMVar processDead
303 runProcess localNode $ do
304 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
306 takeMVar done
308-- | Monitor a process that becomes disconnected
309testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
310testMonitorDisconnect TestTransport{..} mOrL un = do
311 processAddr <- newEmptyMVar
312 processAddr2 <- newEmptyMVar
313 monitorSetup <- newEmptyMVar
314 done <- newEmptyMVar
316 forkIO $ do
317 localNode <- newLocalNode testTransport initRemoteTable
318 addr <- forkProcess localNode $ expect
319 addr2 <- forkProcess localNode $ return ()
320 putMVar processAddr addr
321 readMVar monitorSetup
322 NT.closeEndPoint (localEndPoint localNode)
323 putMVar processAddr2 addr2
325 forkIO $ do
326 localNode <- newLocalNode testTransport initRemoteTable
327 theirAddr <- readMVar processAddr
328 forkProcess localNode $ do
329 lc <- liftIO $ readMVar processAddr2
330 send lc ()
331 runProcess localNode $ do
332 monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
334 takeMVar done
336-- | Test the math server (i.e., receiveWait)
337testMath :: TestTransport -> Assertion
338testMath TestTransport{..} = do
339 serverAddr <- newEmptyMVar
340 clientDone <- newEmptyMVar
342 -- Server
343 forkIO $ do
344 localNode <- newLocalNode testTransport initRemoteTable
345 addr <- forkProcess localNode math
346 putMVar serverAddr addr
348 -- Client
349 forkIO $ do
350 localNode <- newLocalNode testTransport initRemoteTable
351 mathServer <- readMVar serverAddr
353 runProcess localNode $ do
354 pid <- getSelfPid
355 send mathServer (Add pid 1 2)
356 3 <- expect :: Process Double
357 send mathServer (Divide pid 8 2)
358 4 <- expect :: Process Double
359 send mathServer (Divide pid 8 0)
360 DivByZero <- expect
361 liftIO $ putMVar clientDone ()
363 takeMVar clientDone
365-- | Send first message (i.e. connect) to an already terminated process
366-- (without monitoring); then send another message to a second process on
367-- the same remote node (we're checking that the remote node did not die)
368testSendToTerminated :: TestTransport -> Assertion
369testSendToTerminated TestTransport{..} = do
370 serverAddr1 <- newEmptyMVar
371 serverAddr2 <- newEmptyMVar
372 clientDone <- newEmptyMVar
374 forkIO $ do
375 terminated <- newEmptyMVar
376 localNode <- newLocalNode testTransport initRemoteTable
377 addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
378 addr2 <- forkProcess localNode $ ping
379 readMVar terminated
380 putMVar serverAddr1 addr1
381 putMVar serverAddr2 addr2
383 forkIO $ do
384 localNode <- newLocalNode testTransport initRemoteTable
385 server1 <- readMVar serverAddr1
386 server2 <- readMVar serverAddr2
387 runProcess localNode $ do
388 pid <- getSelfPid
389 send server1 "Hi"
390 send server2 (Pong pid)
391 Ping pid' <- expect
392 True <- return $ pid' == server2
393 liftIO $ putMVar clientDone ()
395 takeMVar clientDone
397-- | Test (non-zero) timeout
398testTimeout :: TestTransport -> Assertion
399testTimeout TestTransport{..} = do
400 localNode <- newLocalNode testTransport initRemoteTable
401 done <- newEmptyMVar
403 runProcess localNode $ do
404 Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
405 liftIO $ putMVar done ()
407 takeMVar done
409-- | Test zero timeout
410testTimeout0 :: TestTransport -> Assertion
411testTimeout0 TestTransport{..} = do
412 serverAddr <- newEmptyMVar
413 clientDone <- newEmptyMVar
415 forkIO $ do
416 localNode <- newLocalNode testTransport initRemoteTable
417 addr <- forkProcess localNode $ do
418 -- Variation on the venerable ping server which uses a zero timeout
419 partner <- fix $ \loop ->
420 receiveTimeout 0 [match (\(Pong partner) -> return partner)]
421 >>= maybe (liftIO (threadDelay 100000) >> loop) return
422 self <- getSelfPid
423 send partner (Ping self)
424 putMVar serverAddr addr
426 forkIO $ do
427 localNode <- newLocalNode testTransport initRemoteTable
428 server <- readMVar serverAddr
429 runProcess localNode $ do
430 pid <- getSelfPid
431 -- Send a bunch of messages. A large number of messages that the server
432 -- is not interested in, and then a single message that it wants
433 replicateM_ 10000 $ send server "Irrelevant message"
434 send server (Pong pid)
435 Ping _ <- expect
436 liftIO $ putMVar clientDone ()
438 takeMVar clientDone
440-- | Test typed channels
441testTypedChannels :: TestTransport -> Assertion
442testTypedChannels TestTransport{..} = do
443 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
444 clientDone <- newEmptyMVar
446 forkIO $ do
447 localNode <- newLocalNode testTransport initRemoteTable
448 forkProcess localNode $ do
449 (serverSendPort, rport) <- newChan
450 liftIO $ putMVar serverChannel serverSendPort
451 (clientSendPort, i) <- receiveChan rport
452 sendChan clientSendPort (even i)
453 return ()
455 forkIO $ do
456 localNode <- newLocalNode testTransport initRemoteTable
457 serverSendPort <- readMVar serverChannel
458 runProcess localNode $ do
459 (clientSendPort, rport) <- newChan
460 sendChan serverSendPort (clientSendPort, 5)
461 False <- receiveChan rport
462 liftIO $ putMVar clientDone ()
464 takeMVar clientDone
466-- | Test merging receive ports
467testMergeChannels :: TestTransport -> Assertion
468testMergeChannels TestTransport{..} = do
469 localNode <- newLocalNode testTransport initRemoteTable
470 testFlat localNode True "aaabbbccc"
471 testFlat localNode False "abcabcabc"
472 testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
473 testNested localNode True False "adgadgadgbehbehbehcficficfi"
474 testNested localNode False True "abcabcabcdefdefdefghighighi"
475 testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
476 testBlocked localNode True
477 testBlocked localNode False
478 where
479 -- Single layer of merging
480 testFlat :: LocalNode -> Bool -> String -> IO ()
481 testFlat localNode biased expected = do
482 done <- newEmptyMVar
483 forkProcess localNode $ do
484 rs <- mapM charChannel "abc"
485 m <- mergePorts biased rs
486 xs <- replicateM 9 $ receiveChan m
487 True <- return $ xs == expected
488 liftIO $ putMVar done ()
489 takeMVar done
491 -- Two layers of merging
492 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
493 testNested localNode biasedInner biasedOuter expected = do
494 done <- newEmptyMVar
495 forkProcess localNode $ do
496 rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
497 ms <- mapM (mergePorts biasedInner) rss
498 m <- mergePorts biasedOuter ms
499 xs <- replicateM (9 * 3) $ receiveChan m
500 True <- return $ xs == expected
501 liftIO $ putMVar done ()
502 takeMVar done
504 -- Test that if no messages are (immediately) available, the scheduler makes no difference
505 testBlocked :: LocalNode -> Bool -> IO ()
506 testBlocked localNode biased = do
507 vs <- replicateM 3 newEmptyMVar
508 done <- newEmptyMVar
510 forkProcess localNode $ do
511 [sa, sb, sc] <- liftIO $ mapM readMVar vs
512 mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
513 [ -- a, b, c
514 (sa, 'a')
515 , (sb, 'b')
516 , (sc, 'c')
517 -- a, c, b
518 , (sa, 'a')
519 , (sc, 'c')
520 , (sb, 'b')
521 -- b, a, c
522 , (sb, 'b')
523 , (sa, 'a')
524 , (sc, 'c')
525 -- b, c, a
526 , (sb, 'b')
527 , (sc, 'c')
528 , (sa, 'a')
529 -- c, a, b
530 , (sc, 'c')
531 , (sa, 'a')
532 , (sb, 'b')
533 -- c, b, a
534 , (sc, 'c')
535 , (sb, 'b')
536 , (sa, 'a')
537 ]
539 forkProcess localNode $ do
540 (ss, rs) <- unzip <$> replicateM 3 newChan
541 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
542 m <- mergePorts biased rs
543 xs <- replicateM (6 * 3) $ receiveChan m
544 True <- return $ xs == "abcacbbacbcacabcba"
545 liftIO $ putMVar done ()
547 takeMVar done
549 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
550 mergePorts True = mergePortsBiased
551 mergePorts False = mergePortsRR
553 charChannel :: Char -> Process (ReceivePort Char)
554 charChannel c = do
555 (sport, rport) <- newChan
556 replicateM_ 3 $ sendChan sport c
557 liftIO $ threadDelay 10000 -- Make sure messages have been sent
558 return rport
560testTerminate :: TestTransport -> Assertion
561testTerminate TestTransport{..} = do
562 localNode <- newLocalNode testTransport initRemoteTable
563 done <- newEmptyMVar
565 pid <- forkProcess localNode $ do
566 liftIO $ threadDelay 100000
567 terminate
569 runProcess localNode $ do
570 ref <- monitor pid
571 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
572 True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
573 liftIO $ putMVar done ()
575 takeMVar done
577testMonitorNode :: TestTransport -> Assertion
578testMonitorNode TestTransport{..} = do
579 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
580 done <- newEmptyMVar
582 closeLocalNode node1
584 runProcess node2 $ do
585 ref <- monitorNode (localNodeId node1)
586 NodeMonitorNotification ref' nid DiedDisconnect <- expect
587 True <- return $ ref == ref' && nid == localNodeId node1
588 liftIO $ putMVar done ()
590 takeMVar done
592testMonitorLiveNode :: TestTransport -> Assertion
593testMonitorLiveNode TestTransport{..} = do
594 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
595 ready <- newEmptyMVar
596 readyr <- newEmptyMVar
597 done <- newEmptyMVar
599 p <- forkProcess node1 $ return ()
600 forkProcess node2 $ do
601 ref <- monitorNode (localNodeId node1)
602 liftIO $ putMVar ready ()
603 liftIO $ takeMVar readyr
604 send p ()
605 NodeMonitorNotification ref' nid _ <- expect
606 True <- return $ ref == ref' && nid == localNodeId node1
607 liftIO $ putMVar done ()
609 takeMVar ready
610 closeLocalNode node1
611 putMVar readyr ()
613 takeMVar done
615testMonitorChannel :: TestTransport -> Assertion
616testMonitorChannel TestTransport{..} = do
617 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
618 gotNotification <- newEmptyMVar
620 pid <- forkProcess node1 $ do
621 sport <- expect :: Process (SendPort ())
622 ref <- monitorPort sport
623 PortMonitorNotification ref' port' reason <- expect
624 -- reason might be DiedUnknownId if the receive port is GCed before the
625 -- monitor is established (TODO: not sure that this is reasonable)
626 return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
627 liftIO $ putMVar gotNotification ()
629 runProcess node2 $ do
630 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
631 send pid sport
632 liftIO $ threadDelay 100000
634 takeMVar gotNotification
636testRegistry :: TestTransport -> Assertion
637testRegistry TestTransport{..} = do
638 node <- newLocalNode testTransport initRemoteTable
639 done <- newEmptyMVar
641 pingServer <- forkProcess node ping
642 deadProcess <- forkProcess node (return ())
644 runProcess node $ do
645 register "ping" pingServer
646 Just pid <- whereis "ping"
647 True <- return $ pingServer == pid
648 us <- getSelfPid
649 nsend "ping" (Pong us)
650 Ping pid' <- expect
651 True <- return $ pingServer == pid'
652 Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
653 Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
654 True <- return $ x == pingServer
655 Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
656 liftIO $ putMVar done ()
658 takeMVar done
660testRegistryRemoteProcess :: TestTransport -> Assertion
661testRegistryRemoteProcess TestTransport{..} = do
662 node1 <- newLocalNode testTransport initRemoteTable
663 node2 <- newLocalNode testTransport initRemoteTable
664 done <- newEmptyMVar
666 pingServer <- forkProcess node1 ping
668 runProcess node2 $ do
669 register "ping" pingServer
670 Just pid <- whereis "ping"
671 True <- return $ pingServer == pid
672 us <- getSelfPid
673 nsend "ping" (Pong us)
674 Ping pid' <- expect
675 True <- return $ pingServer == pid'
676 liftIO $ putMVar done ()
678 takeMVar done
680testRemoteRegistry :: TestTransport -> Assertion
681testRemoteRegistry TestTransport{..} = do
682 node1 <- newLocalNode testTransport initRemoteTable
683 node2 <- newLocalNode testTransport initRemoteTable
684 done <- newEmptyMVar
686 pingServer <- forkProcess node1 ping
687 deadProcess <- forkProcess node1 (return ())
689 runProcess node2 $ do
690 let nid1 = localNodeId node1
691 registerRemoteAsync nid1 "ping" pingServer
692 receiveWait [
693 matchIf (\(RegisterReply label' _ (Just pid)) ->
694 "ping" == label' && pid == pingServer)
695 (\(RegisterReply _ _ _) -> return ()) ]
697 Just pid <- whereisRemote nid1 "ping"
698 True <- return $ pingServer == pid
699 us <- getSelfPid
700 nsendRemote nid1 "ping" (Pong us)
701 Ping pid' <- expect
702 True <- return $ pingServer == pid'
704 -- test that if process was not registered Nothing is returned
705 -- in owner field.
706 registerRemoteAsync nid1 "dead" deadProcess
707 receiveWait [
708 matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
709 (\(RegisterReply _ _ _) -> return ()) ]
710 registerRemoteAsync nid1 "ping" deadProcess
711 receiveWait [
712 matchIf (\(RegisterReply label' False (Just pid)) ->
713 "ping" == label' && pid == pingServer)
714 (\(RegisterReply _ _ _) -> return ()) ]
715 unregisterRemoteAsync nid1 "dead"
716 receiveWait [
717 matchIf (\(RegisterReply label' False Nothing) ->
718 "dead" == label' && pid == pingServer)
719 (\(RegisterReply _ _ _) -> return ()) ]
720 liftIO $ putMVar done ()
722 takeMVar done
724testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
725testRemoteRegistryRemoteProcess TestTransport{..} = do
726 node1 <- newLocalNode testTransport initRemoteTable
727 node2 <- newLocalNode testTransport initRemoteTable
728 done <- newEmptyMVar
730 pingServer <- forkProcess node2 ping
732 runProcess node2 $ do
733 let nid1 = localNodeId node1
734 registerRemoteAsync nid1 "ping" pingServer
735 receiveWait [
736 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
737 (\(RegisterReply _ _ _) -> return ()) ]
738 Just pid <- whereisRemote nid1 "ping"
739 True <- return $ pingServer == pid
740 us <- getSelfPid
741 nsendRemote nid1 "ping" (Pong us)
742 Ping pid' <- expect
743 True <- return $ pingServer == pid'
744 liftIO $ putMVar done ()
746 takeMVar done
748testSpawnLocal :: TestTransport -> Assertion
749testSpawnLocal TestTransport{..} = do
750 node <- newLocalNode testTransport initRemoteTable
751 done <- newEmptyMVar
753 runProcess node $ do
754 us <- getSelfPid
756 pid <- spawnLocal $ do
757 sport <- expect
758 sendChan sport (1234 :: Int)
760 sport <- spawnChannelLocal $ \rport -> do
761 (1234 :: Int) <- receiveChan rport
762 send us ()
764 send pid sport
765 () <- expect
766 liftIO $ putMVar done ()
768 takeMVar done
770testSpawnAsyncStrictness :: TestTransport -> Assertion
771testSpawnAsyncStrictness TestTransport{..} = do
772 node <- newLocalNode testTransport initRemoteTable
773 done <- newEmptyMVar
775 runProcess node $ do
776 here <-getSelfNode
778 ev <- try $ spawnAsync here (error "boom")
779 liftIO $ case ev of
780 Right _ -> putMVar done (error "Exception didn't fire")
781 Left (_::SomeException) -> putMVar done (return ())
783 join $ takeMVar done
785testReconnect :: TestTransport -> Assertion
786testReconnect TestTransport{..} = do
787 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
788 let nid1 = localNodeId node1
789 processA <- newEmptyMVar
790 [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
792 forkProcess node1 $ do
793 us <- getSelfPid
794 liftIO $ putMVar processA us
795 msg1 <- expect
796 msg2 <- expect
797 True <- return $ msg1 == "message 1" && msg2 == "message 3"
798 liftIO $ putMVar sendTestOk ()
800 forkProcess node2 $ do
801 {-
802 - Make sure there is no implicit reconnect on normal message sending
803 -}
805 them <- liftIO $ readMVar processA
806 send them "message 1" >> liftIO (threadDelay 100000)
808 -- Simulate network failure
809 liftIO $ syncBreakConnection testBreakConnection node1 node2
812 -- Should not arrive
813 send them "message 2"
815 -- Should arrive
816 reconnect them
817 send them "message 3"
819 liftIO $ takeMVar sendTestOk
821 {-
822 - Test that there *is* implicit reconnect on node controller messages
823 -}
825 us <- getSelfPid
826 registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
827 receiveWait [
828 matchIf (\(RegisterReply label' _ _) -> "a" == label')
829 (\(RegisterReply _ _ _) -> return ()) ]
831 Just _ <- whereisRemote nid1 "a"
834 -- Simulate network failure
835 liftIO $ syncBreakConnection testBreakConnection node1 node2
837 -- This will happen due to implicit reconnect
838 registerRemoteAsync nid1 "b" us
839 receiveWait [
840 matchIf (\(RegisterReply label' _ _) -> "b" == label')
841 (\(RegisterReply _ _ _) -> return ()) ]
843 -- Should happen
844 registerRemoteAsync nid1 "c" us
845 receiveWait [
846 matchIf (\(RegisterReply label' _ _) -> "c" == label')
847 (\(RegisterReply _ _ _) -> return ()) ]
849 -- Check
850 Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
851 Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
852 Just _ <- whereisRemote nid1 "c"
854 liftIO $ putMVar registerTestOk ()
856 takeMVar registerTestOk
858-- | Tests that unreliable messages arrive sorted even when there are connection
859-- failures.
860testUSend :: (ProcessId -> Int -> Process ())
861 -> TestTransport -> Int -> Assertion
862testUSend usendPrim TestTransport{..} numMessages = do
863 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
864 let nid1 = localNodeId node1
865 nid2 = localNodeId node2
866 processA <- newEmptyMVar
867 usendTestOk <- newEmptyMVar
869 forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do
870 us <- getSelfPid
871 liftIO $ putMVar processA us
872 them <- expect
873 send them ()
874 _ <- monitor them
875 let -- Collects messages from 'them' until the sender dies.
876 -- Disconnection notifications are ignored.
877 receiveMessages :: Process [Int]
878 receiveMessages = receiveWait
879 [ match $ \mn -> case mn of
880 ProcessMonitorNotification _ _ DiedDisconnect -> do
881 monitor them
882 receiveMessages
883 _ -> return []
884 , match $ \i -> fmap (i :) receiveMessages
885 ]
886 msgs <- receiveMessages
887 let -- Checks that the input list is sorted.
888 isSorted :: [Int] -> Bool
889 isSorted (x : xs@(y : _)) = x <= y && isSorted xs
890 isSorted _ = True
891 -- The list can't be null since there are no failures after sending
892 -- the last message.
893 True <- return $ isSorted msgs && not (null msgs)
894 liftIO $ putMVar usendTestOk ()
896 forkProcess node2 $ do
897 them <- liftIO $ readMVar processA
898 getSelfPid >>= send them
899 () <- expect
900 forM_ [1..numMessages] $ \i -> do
901 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
902 usendPrim them i
903 liftIO (threadDelay 30000)
905 takeMVar usendTestOk
907-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
908-- in between
909testMatchAny :: TestTransport -> Assertion
910testMatchAny TestTransport{..} = do
911 proxyAddr <- newEmptyMVar
912 clientDone <- newEmptyMVar
914 -- Math server
915 forkIO $ do
916 localNode <- newLocalNode testTransport initRemoteTable
917 mathServer <- forkProcess localNode math
918 proxyServer <- forkProcess localNode $ forever $ do
919 msg <- receiveWait [ matchAny return ]
920 forward msg mathServer
921 putMVar proxyAddr proxyServer
923 -- Client
924 forkIO $ do
925 localNode <- newLocalNode testTransport initRemoteTable
926 mathServer <- readMVar proxyAddr
928 runProcess localNode $ do
929 pid <- getSelfPid
930 send mathServer (Add pid 1 2)
931 3 <- expect :: Process Double
932 send mathServer (Divide pid 8 2)
933 4 <- expect :: Process Double
934 send mathServer (Divide pid 8 0)
935 DivByZero <- expect
936 liftIO $ putMVar clientDone ()
938 takeMVar clientDone
940-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
941-- in between, however we block 'Divide' requests ....
942testMatchAnyHandle :: TestTransport -> Assertion
943testMatchAnyHandle TestTransport{..} = do
944 proxyAddr <- newEmptyMVar
945 clientDone <- newEmptyMVar
947 -- Math server
948 forkIO $ do
949 localNode <- newLocalNode testTransport initRemoteTable
950 mathServer <- forkProcess localNode math
951 proxyServer <- forkProcess localNode $ forever $ do
952 receiveWait [
953 matchAny (maybeForward mathServer)
954 ]
955 putMVar proxyAddr proxyServer
957 -- Client
958 forkIO $ do
959 localNode <- newLocalNode testTransport initRemoteTable
960 mathServer <- readMVar proxyAddr
962 runProcess localNode $ do
963 pid <- getSelfPid
964 send mathServer (Add pid 1 2)
965 3 <- expect :: Process Double
966 send mathServer (Divide pid 8 2)
967 Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
968 liftIO $ putMVar clientDone ()
970 takeMVar clientDone
971 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
972 maybeForward s msg =
973 handleMessage msg (\m@(Add _ _ _) -> send s m)
975testMatchAnyNoHandle :: TestTransport -> Assertion
976testMatchAnyNoHandle TestTransport{..} = do
977 addr <- newEmptyMVar
978 clientDone <- newEmptyMVar
979 serverDone <- newEmptyMVar
981 -- Math server
982 forkIO $ do
983 localNode <- newLocalNode testTransport initRemoteTable
984 server <- forkProcess localNode $ forever $ do
985 receiveWait [
986 matchAnyIf
987 -- the condition has type `Add -> Bool`
988 (\(Add _ _ _) -> True)
989 -- the match `AbstractMessage -> Process ()` will succeed!
990 (\m -> do
991 -- `String -> Process ()` does *not* match the input types however
992 r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
993 case r of
994 Nothing -> return ()
995 Just _ -> die "NONSENSE")
996 ]
997 -- we *must* have removed the message from our mailbox though!!!
998 Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
999 liftIO $ putMVar serverDone ()
1000 putMVar addr server
1002 -- Client
1003 forkIO $ do
1004 localNode <- newLocalNode testTransport initRemoteTable
1005 server <- readMVar addr
1007 runProcess localNode $ do
1008 pid <- getSelfPid
1009 send server (Add pid 1 2)
1010 -- we only care about the client having sent a message, so we're done
1011 liftIO $ putMVar clientDone ()
1013 takeMVar clientDone
1014 takeMVar serverDone
1016-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
1017-- unless the text body @/= "bar"@ - this case should time out rather than
1018-- removing the message from the process mailbox.
1019testMatchAnyIf :: TestTransport -> Assertion
1020testMatchAnyIf TestTransport{..} = do
1021 echoAddr <- newEmptyMVar
1022 clientDone <- newEmptyMVar
1024 -- echo server
1025 forkIO $ do
1026 localNode <- newLocalNode testTransport initRemoteTable
1027 echoServer <- forkProcess localNode $ forever $ do
1028 receiveWait [
1029 matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
1030 tryHandleMessage
1032 putMVar echoAddr echoServer
1034 -- Client
1035 forkIO $ do
1036 localNode <- newLocalNode testTransport initRemoteTable
1037 server <- readMVar echoAddr
1039 runProcess localNode $ do
1040 pid <- getSelfPid
1041 send server (pid, "foo")
1042 "foo" <- expect
1043 send server (pid, "baz")
1044 "baz" <- expect
1045 send server (pid, "bar")
1046 Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1047 liftIO $ putMVar clientDone ()
1049 takeMVar clientDone
1050 where tryHandleMessage :: Message -> Process (Maybe ())
1051 tryHandleMessage msg =
1052 handleMessage msg (\(pid :: ProcessId, (m :: String))
1053 -> do { send pid m; return () })
1055testMatchMessageWithUnwrap :: TestTransport -> Assertion
1056testMatchMessageWithUnwrap TestTransport{..} = do
1057 echoAddr <- newEmptyMVar
1058 clientDone <- newEmptyMVar
1060 -- echo server
1061 forkIO $ do
1062 localNode <- newLocalNode testTransport initRemoteTable
1063 echoServer <- forkProcess localNode $ forever $ do
1064 msg <- receiveWait [
1065 matchMessage (\(m :: Message) -> do
1066 return m)
1068 unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
1069 case unwrapped of
1070 (Just (p, msg')) -> forward msg' p
1071 Nothing -> die "unable to unwrap the message"
1072 putMVar echoAddr echoServer
1074 -- Client
1075 forkIO $ do
1076 localNode <- newLocalNode testTransport initRemoteTable
1077 server <- readMVar echoAddr
1079 runProcess localNode $ do
1080 pid <- getSelfPid
1081 send server (pid, wrapMessage ("foo" :: String))
1082 "foo" <- expect
1083 send server (pid, wrapMessage ("baz" :: String))
1084 "baz" <- expect
1085 liftIO $ putMVar clientDone ()
1087 takeMVar clientDone
1089-- Test 'receiveChanTimeout'
1090testReceiveChanTimeout :: TestTransport -> Assertion
1091testReceiveChanTimeout TestTransport{..} = do
1092 done <- newEmptyMVar
1093 sendPort <- newEmptyMVar
1095 forkTry $ do
1096 localNode <- newLocalNode testTransport initRemoteTable
1097 runProcess localNode $ do
1098 -- Create a typed channel
1099 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1100 liftIO $ putMVar sendPort sp
1102 -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
1103 Nothing <- receiveChanTimeout 1000000 rp
1105 -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
1106 Just True <- receiveChanTimeout 1000000 rp
1108 -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
1109 Nothing <- receiveChanTimeout 0 rp
1111 -- Again, but now there is a message available
1112 liftIO $ threadDelay 1000000
1113 Just False <- receiveChanTimeout 0 rp
1115 liftIO $ putMVar done ()
1117 forkTry $ do
1118 localNode <- newLocalNode testTransport initRemoteTable
1119 runProcess localNode $ do
1120 sp <- liftIO $ readMVar sendPort
1122 liftIO $ threadDelay 1500000
1123 sendChan sp True
1125 liftIO $ threadDelay 500000
1126 sendChan sp False
1128 takeMVar done
1130-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1131testReceiveChanFeatures :: TestTransport -> Assertion
1132testReceiveChanFeatures TestTransport{..} = do
1133 done <- newEmptyMVar
1135 forkTry $ do
1136 localNode <- newLocalNode testTransport initRemoteTable
1137 runProcess localNode $ do
1138 (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1139 (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1141 -- Test Functor instance
1143 sendChan spInt 2
1144 sendChan spBool False
1146 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1148 True <- receiveChan rp1
1149 False <- receiveChan rp1
1151 -- Test Applicative instance
1153 sendChan spInt 3
1154 sendChan spInt 4
1156 let rp2 = pure (+) <*> rpInt <*> rpInt
1158 7 <- receiveChan rp2
1160 -- Test Alternative instance
1162 sendChan spInt 3
1163 sendChan spBool True
1165 let rp3 = (even <$> rpInt) <|> rpBool
1167 False <- receiveChan rp3
1168 True <- receiveChan rp3
1170 -- Test Monad instance
1172 sendChan spBool True
1173 sendChan spBool False
1174 sendChan spInt 5
1176 let rp4 :: ReceivePort Int
1177 rp4 = do b <- rpBool
1178 if b
1179 then rpInt
1180 else return 7
1182 5 <- receiveChan rp4
1183 7 <- receiveChan rp4
1185 liftIO $ putMVar done ()
1187 takeMVar done
1189testKillLocal :: TestTransport -> Assertion
1190testKillLocal TestTransport{..} = do
1191 localNode <- newLocalNode testTransport initRemoteTable
1192 done <- newEmptyMVar
1194 pid <- forkProcess localNode $ do
1195 liftIO $ threadDelay 1000000
1197 runProcess localNode $ do
1198 ref <- monitor pid
1199 us <- getSelfPid
1200 kill pid "TestKill"
1201 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1202 True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1203 liftIO $ putMVar done ()
1205 takeMVar done
1207testKillRemote :: TestTransport -> Assertion
1208testKillRemote TestTransport{..} = do
1209 node1 <- newLocalNode testTransport initRemoteTable
1210 node2 <- newLocalNode testTransport initRemoteTable
1211 done <- newEmptyMVar
1213 pid <- forkProcess node1 $ do
1214 liftIO $ threadDelay 1000000
1216 runProcess node2 $ do
1217 ref <- monitor pid
1218 us <- getSelfPid
1219 kill pid "TestKill"
1220 ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1221 True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1222 liftIO $ putMVar done ()
1224 takeMVar done
1226testCatchesExit :: TestTransport -> Assertion
1227testCatchesExit TestTransport{..} = do
1228 localNode <- newLocalNode testTransport initRemoteTable
1229 done <- newEmptyMVar
1231 _ <- forkProcess localNode $ do
1232 (die ("foobar", 123 :: Int))
1233 `catchesExit` [
1234 (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1235 , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1236 , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1237 -> (liftIO $ putMVar done ()) >> return ()))
1240 takeMVar done
1242testHandleMessageIf :: TestTransport -> Assertion
1243testHandleMessageIf TestTransport{..} = do
1244 localNode <- newLocalNode testTransport initRemoteTable
1245 done <- newEmptyMVar
1246 _ <- forkProcess localNode $ do
1247 self <- getSelfPid
1248 send self (5 :: Integer, 10 :: Integer)
1249 msg <- receiveWait [ matchMessage return ]
1250 Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1251 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1252 (\input -> liftIO $ putMVar done input)
1253 return ()
1255 result <- takeMVar done
1256 expectThat result $ equalTo (5, 10)
1258testCatches :: TestTransport -> Assertion
1259testCatches TestTransport{..} = do
1260 localNode <- newLocalNode testTransport initRemoteTable
1261 done <- newEmptyMVar
1263 _ <- forkProcess localNode $ do
1264 node <- getSelfNode
1265 (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1266 `catches` [
1267 Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1270 takeMVar done
1272testMaskRestoreScope :: TestTransport -> Assertion
1273testMaskRestoreScope TestTransport{..} = do
1274 localNode <- newLocalNode testTransport initRemoteTable
1275 parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1276 spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1278 void $ runProcess localNode $ mask $ \unmask -> do
1279 getSelfPid >>= liftIO . putMVar parentPid
1280 void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1282 parent <- liftIO $ takeMVar parentPid
1283 child <- liftIO $ takeMVar spawnedPid
1284 expectThat parent $ isNot $ equalTo child
1286testDie :: TestTransport -> Assertion
1287testDie TestTransport{..} = do
1288 localNode <- newLocalNode testTransport initRemoteTable
1289 done <- newEmptyMVar
1291 _ <- forkProcess localNode $ do
1292 (die ("foobar", 123 :: Int))
1293 `catchExit` \_from reason -> do
1294 -- TODO: should verify that 'from' has the right value
1295 True <- return $ reason == ("foobar", 123 :: Int)
1296 liftIO $ putMVar done ()
1298 takeMVar done
1300testPrettyExit :: TestTransport -> Assertion
1301testPrettyExit TestTransport{..} = do
1302 localNode <- newLocalNode testTransport initRemoteTable
1303 done <- newEmptyMVar
1305 _ <- forkProcess localNode $ do
1306 (die "timeout")
1307 `catch` \ex@(ProcessExitException from _) ->
1308 let expected = "exit-from=" ++ (show from)
1309 in do
1310 True <- return $ (show ex) == expected
1311 liftIO $ putMVar done ()
1313 takeMVar done
1315testExitLocal :: TestTransport -> Assertion
1316testExitLocal TestTransport{..} = do
1317 localNode <- newLocalNode testTransport initRemoteTable
1318 supervisedDone <- newEmptyMVar
1319 supervisorDone <- newEmptyMVar
1320 -- XXX: we guarantee that exception handler will be set up
1321 -- regardless if forkProcess preserve masking state or not.
1322 handlerSetUp <- newEmptyMVar
1324 pid <- forkProcess localNode $ do
1325 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1326 -- TODO: should verify that 'from' has the right value
1327 True <- return $ reason == "TestExit"
1328 liftIO $ putMVar supervisedDone ()
1330 runProcess localNode $ do
1331 liftIO $ takeMVar handlerSetUp
1332 ref <- monitor pid
1333 exit pid "TestExit"
1334 -- This time the client catches the exception, so it dies normally
1335 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1336 True <- return $ ref == ref' && pid == pid'
1337 liftIO $ putMVar supervisorDone ()
1339 takeMVar supervisedDone
1340 takeMVar supervisorDone
1342testExitRemote :: TestTransport -> Assertion
1343testExitRemote TestTransport{..} = do
1344 node1 <- newLocalNode testTransport initRemoteTable
1345 node2 <- newLocalNode testTransport initRemoteTable
1346 supervisedDone <- newEmptyMVar
1347 supervisorDone <- newEmptyMVar
1349 pid <- forkProcess node1 $ do
1350 (receiveWait [] :: Process ()) -- block forever
1351 `catchExit` \_from reason -> do
1352 -- TODO: should verify that 'from' has the right value
1353 True <- return $ reason == "TestExit"
1354 liftIO $ putMVar supervisedDone ()
1356 runProcess node2 $ do
1357 ref <- monitor pid
1358 exit pid "TestExit"
1359 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1360 True <- return $ ref == ref' && pid == pid'
1361 liftIO $ putMVar supervisorDone ()
1363 takeMVar supervisedDone
1364 takeMVar supervisorDone
1366testUnsafeSend :: TestTransport -> Assertion
1367testUnsafeSend TestTransport{..} = do
1368 serverAddr <- newEmptyMVar
1369 clientDone <- newEmptyMVar
1371 localNode <- newLocalNode testTransport initRemoteTable
1372 void $ forkProcess localNode $ do
1373 self <- getSelfPid
1374 liftIO $ putMVar serverAddr self
1375 clientAddr <- expect
1376 unsafeSend clientAddr ()
1378 void $ forkProcess localNode $ do
1379 serverPid <- liftIO $ takeMVar serverAddr
1380 getSelfPid >>= unsafeSend serverPid
1381 () <- expect
1382 liftIO $ putMVar clientDone ()
1384 takeMVar clientDone
1386testUnsafeUSend :: TestTransport -> Assertion
1387testUnsafeUSend TestTransport{..} = do
1388 serverAddr <- newEmptyMVar
1389 clientDone <- newEmptyMVar
1391 localNode <- newLocalNode testTransport initRemoteTable
1392 void $ forkProcess localNode $ do
1393 self <- getSelfPid
1394 liftIO $ putMVar serverAddr self
1395 clientAddr <- expect
1396 unsafeUSend clientAddr ()
1398 void $ forkProcess localNode $ do
1399 serverPid <- liftIO $ takeMVar serverAddr
1400 getSelfPid >>= unsafeUSend serverPid
1401 () <- expect
1402 liftIO $ putMVar clientDone ()
1404 takeMVar clientDone
1406testUnsafeNSend :: TestTransport -> Assertion
1407testUnsafeNSend TestTransport{..} = do
1408 clientDone <- newEmptyMVar
1410 localNode <- newLocalNode testTransport initRemoteTable
1412 pid <- forkProcess localNode $ do
1413 () <- expect
1414 liftIO $ putMVar clientDone ()
1416 void $ runProcess localNode $ do
1417 register "foobar" pid
1418 unsafeNSend "foobar" ()
1420 takeMVar clientDone
1422testUnsafeNSendRemote :: TestTransport -> Assertion
1423testUnsafeNSendRemote TestTransport{..} = do
1424 clientDone <- newEmptyMVar
1426 localNode1 <- newLocalNode testTransport initRemoteTable
1427 localNode2 <- newLocalNode testTransport initRemoteTable
1429 _ <- forkProcess localNode1 $ do
1430 getSelfPid >>= register "foobar"
1431 liftIO $ putMVar clientDone ()
1432 () <- expect
1433 liftIO $ putMVar clientDone ()
1435 takeMVar clientDone
1436 void $ runProcess localNode2 $ do
1437 unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1439 takeMVar clientDone
1441testUnsafeSendChan :: TestTransport -> Assertion
1442testUnsafeSendChan TestTransport{..} = do
1443 serverAddr <- newEmptyMVar
1444 clientDone <- newEmptyMVar
1446 localNode <- newLocalNode testTransport initRemoteTable
1447 void $ forkProcess localNode $ do
1448 self <- getSelfPid
1449 liftIO $ putMVar serverAddr self
1450 sp <- expect
1451 unsafeSendChan sp ()
1453 void $ forkProcess localNode $ do
1454 serverPid <- liftIO $ takeMVar serverAddr
1455 (sp, rp) <- newChan
1456 unsafeSend serverPid sp
1457 () <- receiveChan rp
1458 liftIO $ putMVar clientDone ()
1460 takeMVar clientDone
1462testCallLocal :: TestTransport -> Assertion
1463testCallLocal TestTransport{..} = do
1464 node <- newLocalNode testTransport initRemoteTable
1466 -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1467 result <- newEmptyMVar
1468 runProcess node $ do
1469 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1470 liftIO $ putMVar result r
1471 True <- takeMVar result
1472 return ()
1474 -- Testing that when callLocal is interrupted, the worker is interrupted.
1475 ibox <- newIORef False
1476 runProcess node $ do
1477 keeper <- getSelfPid
1478 spawnLocal $ do
1479 caller <- getSelfPid
1480 send keeper caller
1481 onException
1482 (callLocal $ do
1483 onException (do send keeper caller
1484 expect)
1485 (do liftIO $ writeIORef ibox True))
1486 (send keeper ())
1487 caller <- expect
1488 exit caller "test"
1489 () <- expect
1490 return ()
1491 True <- readIORef ibox
1492 return ()
1494 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1495 ibox2 <- newIORef False
1496 runProcess node $ do
1497 r <- try (callLocal $ error "e" >> return ())
1498 liftIO $ writeIORef ibox2 $ case r of
1499 Left (ErrorCall "e") -> True
1500 _ -> False
1501 True <- readIORef ibox
1502 return ()
1504 -- Test that caller waits for the worker in correct situation
1505 ibox3 <- newIORef False
1506 result3 <- newEmptyMVar
1507 runProcess node $ do
1508 keeper <- getSelfPid
1509 spawnLocal $ do
1510 callLocal $
1511 (do us <- getSelfPid
1512 send keeper us
1513 () <- expect
1514 liftIO yield)
1515 `finally` (liftIO $ writeIORef ibox3 True)
1516 liftIO $ putMVar result3 =<< readIORef ibox3
1517 worker <- expect
1518 send worker ()
1519 True <- takeMVar result3
1520 return ()
1522 -- Test that caller waits for the worker in case when caller gets an exception
1523 ibox4 <- newIORef False
1524 result4 <- newEmptyMVar
1525 runProcess node $ do
1526 keeper <- getSelfPid
1527 spawnLocal $ do
1528 caller <- getSelfPid
1529 callLocal
1530 ((do send keeper caller
1531 expect)
1532 `finally` (liftIO $ writeIORef ibox4 True))
1533 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1534 caller <- expect
1535 exit caller "hi!"
1536 True <- takeMVar result4
1537 return ()
1538 -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1544tests :: TestTransport -> IO [Test]
1545tests testtrans = return [
1546 testGroup "Basic features" [
1547 testCase "Ping" (testPing testtrans)
1548 , testCase "Math" (testMath testtrans)
1549 , testCase "Timeout" (testTimeout testtrans)
1550 , testCase "Timeout0" (testTimeout0 testtrans)
1551 , testCase "SendToTerminated" (testSendToTerminated testtrans)
1552 , testCase "TypedChannnels" (testTypedChannels testtrans)
1553 , testCase "Terminate" (testTerminate testtrans)
1554 , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1555 , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1556 , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1557 , testCase "SpawnLocal" (testSpawnLocal testtrans)
1558 , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1559 , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1560 , testCase "MatchAny" (testMatchAny testtrans)
1561 , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1562 , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1563 , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1564 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1565 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1566 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1567 , testCase "KillLocal" (testKillLocal testtrans)
1568 , testCase "KillRemote" (testKillRemote testtrans)
1569 , testCase "Die" (testDie testtrans)
1570 , testCase "PrettyExit" (testPrettyExit testtrans)
1571 , testCase "CatchesExit" (testCatchesExit testtrans)
1572 , testCase "Catches" (testCatches testtrans)
1573 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1574 , testCase "ExitLocal" (testExitLocal testtrans)
1575 , testCase "ExitRemote" (testExitRemote testtrans)
1576 , testCase "TextCallLocal" (testCallLocal testtrans)
1577 -- Unsafe Primitives
1578 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1579 , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1580 , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1581 , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1582 , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1583 -- usend
1584 , testCase "USend" (testUSend usend testtrans 50)
1585 , testCase "UForward"
1586 (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1587 testtrans 50
1590 , testGroup "Monitoring and Linking" [
1591 -- Monitoring processes
1592 --
1593 -- The "missing" combinations in the list below don't make much sense, as
1594 -- we cannot guarantee that the monitor reply or link exception will not
1595 -- happen before the unmonitor or unlink
1596 testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1597 , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1598 , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1599 , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1600 , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1601 , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1602 , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1603 , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1604 , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1605 , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1606 , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1607 , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1608 , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1609 , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1610 , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1611 , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1612 , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1613 -- Monitoring nodes and channels
1614 , testCase "MonitorNode" (testMonitorNode testtrans)
1615 , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1616 , testCase "MonitorChannel" (testMonitorChannel testtrans)
1617 -- Reconnect
1620 -- Tests that fail occasionally and should be revised
1621 , testGroup "Flaky" [
1622 testCase "Reconnect" (testReconnect testtrans)
1623 , testCase "Registry" (testRegistry testtrans)
1624 , testCase "MergeChannels" (testMergeChannels testtrans)
1625 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1629syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1630syncBreakConnection breakConnection nid0 nid1 = do
1631 m <- newEmptyMVar
1632 _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1633 runProcess nid0 $ do
1634 them <- liftIO $ takeMVar m
1635 pinger <- spawnLocal $ forever $ send them ()
1636 _ <- monitorNode (localNodeId nid1)
1637 liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1638 (nodeAddress $ localNodeId nid1)
1639 NodeMonitorNotification _ _ _ <- expect
1640 kill pinger "finished"
1641 return ()