git.iko.soy/distributed-process
on 42c71eb help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs
1632 lines 55 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 runProcess localNode $ do
564 e <- try terminate :: Process (Either ProcessTerminationException ())
565 True <- return $ either show show e == show ProcessTerminationException
566 return ()
568testMonitorNode :: TestTransport -> Assertion
569testMonitorNode TestTransport{..} = do
570 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
571 done <- newEmptyMVar
573 closeLocalNode node1
575 runProcess node2 $ do
576 ref <- monitorNode (localNodeId node1)
577 NodeMonitorNotification ref' nid DiedDisconnect <- expect
578 True <- return $ ref == ref' && nid == localNodeId node1
579 liftIO $ putMVar done ()
581 takeMVar done
583testMonitorLiveNode :: TestTransport -> Assertion
584testMonitorLiveNode TestTransport{..} = do
585 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
586 ready <- newEmptyMVar
587 readyr <- newEmptyMVar
588 done <- newEmptyMVar
590 p <- forkProcess node1 $ return ()
591 forkProcess node2 $ do
592 ref <- monitorNode (localNodeId node1)
593 liftIO $ putMVar ready ()
594 liftIO $ takeMVar readyr
595 send p ()
596 NodeMonitorNotification ref' nid _ <- expect
597 True <- return $ ref == ref' && nid == localNodeId node1
598 liftIO $ putMVar done ()
600 takeMVar ready
601 closeLocalNode node1
602 putMVar readyr ()
604 takeMVar done
606testMonitorChannel :: TestTransport -> Assertion
607testMonitorChannel TestTransport{..} = do
608 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
609 gotNotification <- newEmptyMVar
611 pid <- forkProcess node1 $ do
612 sport <- expect :: Process (SendPort ())
613 ref <- monitorPort sport
614 PortMonitorNotification ref' port' reason <- expect
615 -- reason might be DiedUnknownId if the receive port is GCed before the
616 -- monitor is established (TODO: not sure that this is reasonable)
617 return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
618 liftIO $ putMVar gotNotification ()
620 runProcess node2 $ do
621 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
622 send pid sport
623 liftIO $ threadDelay 100000
625 takeMVar gotNotification
627testRegistry :: TestTransport -> Assertion
628testRegistry TestTransport{..} = do
629 node <- newLocalNode testTransport initRemoteTable
630 done <- newEmptyMVar
632 pingServer <- forkProcess node ping
633 deadProcess <- forkProcess node (return ())
635 runProcess node $ do
636 register "ping" pingServer
637 Just pid <- whereis "ping"
638 True <- return $ pingServer == pid
639 us <- getSelfPid
640 nsend "ping" (Pong us)
641 Ping pid' <- expect
642 True <- return $ pingServer == pid'
643 Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
644 Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
645 True <- return $ x == pingServer
646 Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
647 liftIO $ putMVar done ()
649 takeMVar done
651testRegistryRemoteProcess :: TestTransport -> Assertion
652testRegistryRemoteProcess TestTransport{..} = do
653 node1 <- newLocalNode testTransport initRemoteTable
654 node2 <- newLocalNode testTransport initRemoteTable
655 done <- newEmptyMVar
657 pingServer <- forkProcess node1 ping
659 runProcess node2 $ do
660 register "ping" pingServer
661 Just pid <- whereis "ping"
662 True <- return $ pingServer == pid
663 us <- getSelfPid
664 nsend "ping" (Pong us)
665 Ping pid' <- expect
666 True <- return $ pingServer == pid'
667 liftIO $ putMVar done ()
669 takeMVar done
671testRemoteRegistry :: TestTransport -> Assertion
672testRemoteRegistry TestTransport{..} = do
673 node1 <- newLocalNode testTransport initRemoteTable
674 node2 <- newLocalNode testTransport initRemoteTable
675 done <- newEmptyMVar
677 pingServer <- forkProcess node1 ping
678 deadProcess <- forkProcess node1 (return ())
680 runProcess node2 $ do
681 let nid1 = localNodeId node1
682 registerRemoteAsync nid1 "ping" pingServer
683 receiveWait [
684 matchIf (\(RegisterReply label' _ (Just pid)) ->
685 "ping" == label' && pid == pingServer)
686 (\(RegisterReply _ _ _) -> return ()) ]
688 Just pid <- whereisRemote nid1 "ping"
689 True <- return $ pingServer == pid
690 us <- getSelfPid
691 nsendRemote nid1 "ping" (Pong us)
692 Ping pid' <- expect
693 True <- return $ pingServer == pid'
695 -- test that if process was not registered Nothing is returned
696 -- in owner field.
697 registerRemoteAsync nid1 "dead" deadProcess
698 receiveWait [
699 matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
700 (\(RegisterReply _ _ _) -> return ()) ]
701 registerRemoteAsync nid1 "ping" deadProcess
702 receiveWait [
703 matchIf (\(RegisterReply label' False (Just pid)) ->
704 "ping" == label' && pid == pingServer)
705 (\(RegisterReply _ _ _) -> return ()) ]
706 unregisterRemoteAsync nid1 "dead"
707 receiveWait [
708 matchIf (\(RegisterReply label' False Nothing) ->
709 "dead" == label' && pid == pingServer)
710 (\(RegisterReply _ _ _) -> return ()) ]
711 liftIO $ putMVar done ()
713 takeMVar done
715testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
716testRemoteRegistryRemoteProcess TestTransport{..} = do
717 node1 <- newLocalNode testTransport initRemoteTable
718 node2 <- newLocalNode testTransport initRemoteTable
719 done <- newEmptyMVar
721 pingServer <- forkProcess node2 ping
723 runProcess node2 $ do
724 let nid1 = localNodeId node1
725 registerRemoteAsync nid1 "ping" pingServer
726 receiveWait [
727 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
728 (\(RegisterReply _ _ _) -> return ()) ]
729 Just pid <- whereisRemote nid1 "ping"
730 True <- return $ pingServer == pid
731 us <- getSelfPid
732 nsendRemote nid1 "ping" (Pong us)
733 Ping pid' <- expect
734 True <- return $ pingServer == pid'
735 liftIO $ putMVar done ()
737 takeMVar done
739testSpawnLocal :: TestTransport -> Assertion
740testSpawnLocal TestTransport{..} = do
741 node <- newLocalNode testTransport initRemoteTable
742 done <- newEmptyMVar
744 runProcess node $ do
745 us <- getSelfPid
747 pid <- spawnLocal $ do
748 sport <- expect
749 sendChan sport (1234 :: Int)
751 sport <- spawnChannelLocal $ \rport -> do
752 (1234 :: Int) <- receiveChan rport
753 send us ()
755 send pid sport
756 () <- expect
757 liftIO $ putMVar done ()
759 takeMVar done
761testSpawnAsyncStrictness :: TestTransport -> Assertion
762testSpawnAsyncStrictness TestTransport{..} = do
763 node <- newLocalNode testTransport initRemoteTable
764 done <- newEmptyMVar
766 runProcess node $ do
767 here <-getSelfNode
769 ev <- try $ spawnAsync here (error "boom")
770 liftIO $ case ev of
771 Right _ -> putMVar done (error "Exception didn't fire")
772 Left (_::SomeException) -> putMVar done (return ())
774 join $ takeMVar done
776testReconnect :: TestTransport -> Assertion
777testReconnect TestTransport{..} = do
778 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
779 let nid1 = localNodeId node1
780 processA <- newEmptyMVar
781 [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
783 forkProcess node1 $ do
784 us <- getSelfPid
785 liftIO $ putMVar processA us
786 msg1 <- expect
787 msg2 <- expect
788 True <- return $ msg1 == "message 1" && msg2 == "message 3"
789 liftIO $ putMVar sendTestOk ()
791 forkProcess node2 $ do
792 {-
793 - Make sure there is no implicit reconnect on normal message sending
794 -}
796 them <- liftIO $ readMVar processA
797 send them "message 1" >> liftIO (threadDelay 100000)
799 -- Simulate network failure
800 liftIO $ syncBreakConnection testBreakConnection node1 node2
803 -- Should not arrive
804 send them "message 2"
806 -- Should arrive
807 reconnect them
808 send them "message 3"
810 liftIO $ takeMVar sendTestOk
812 {-
813 - Test that there *is* implicit reconnect on node controller messages
814 -}
816 us <- getSelfPid
817 registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
818 receiveWait [
819 matchIf (\(RegisterReply label' _ _) -> "a" == label')
820 (\(RegisterReply _ _ _) -> return ()) ]
822 Just _ <- whereisRemote nid1 "a"
825 -- Simulate network failure
826 liftIO $ syncBreakConnection testBreakConnection node1 node2
828 -- This will happen due to implicit reconnect
829 registerRemoteAsync nid1 "b" us
830 receiveWait [
831 matchIf (\(RegisterReply label' _ _) -> "b" == label')
832 (\(RegisterReply _ _ _) -> return ()) ]
834 -- Should happen
835 registerRemoteAsync nid1 "c" us
836 receiveWait [
837 matchIf (\(RegisterReply label' _ _) -> "c" == label')
838 (\(RegisterReply _ _ _) -> return ()) ]
840 -- Check
841 Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
842 Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
843 Just _ <- whereisRemote nid1 "c"
845 liftIO $ putMVar registerTestOk ()
847 takeMVar registerTestOk
849-- | Tests that unreliable messages arrive sorted even when there are connection
850-- failures.
851testUSend :: (ProcessId -> Int -> Process ())
852 -> TestTransport -> Int -> Assertion
853testUSend usendPrim TestTransport{..} numMessages = do
854 [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
855 let nid1 = localNodeId node1
856 nid2 = localNodeId node2
857 processA <- newEmptyMVar
858 usendTestOk <- newEmptyMVar
860 forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do
861 us <- getSelfPid
862 liftIO $ putMVar processA us
863 them <- expect
864 send them ()
865 _ <- monitor them
866 let -- Collects messages from 'them' until the sender dies.
867 -- Disconnection notifications are ignored.
868 receiveMessages :: Process [Int]
869 receiveMessages = receiveWait
870 [ match $ \mn -> case mn of
871 ProcessMonitorNotification _ _ DiedDisconnect -> do
872 monitor them
873 receiveMessages
874 _ -> return []
875 , match $ \i -> fmap (i :) receiveMessages
876 ]
877 msgs <- receiveMessages
878 let -- Checks that the input list is sorted.
879 isSorted :: [Int] -> Bool
880 isSorted (x : xs@(y : _)) = x <= y && isSorted xs
881 isSorted _ = True
882 -- The list can't be null since there are no failures after sending
883 -- the last message.
884 True <- return $ isSorted msgs && not (null msgs)
885 liftIO $ putMVar usendTestOk ()
887 forkProcess node2 $ do
888 them <- liftIO $ readMVar processA
889 getSelfPid >>= send them
890 () <- expect
891 forM_ [1..numMessages] $ \i -> do
892 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
893 usendPrim them i
894 liftIO (threadDelay 30000)
896 takeMVar usendTestOk
898-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
899-- in between
900testMatchAny :: TestTransport -> Assertion
901testMatchAny TestTransport{..} = do
902 proxyAddr <- newEmptyMVar
903 clientDone <- newEmptyMVar
905 -- Math server
906 forkIO $ do
907 localNode <- newLocalNode testTransport initRemoteTable
908 mathServer <- forkProcess localNode math
909 proxyServer <- forkProcess localNode $ forever $ do
910 msg <- receiveWait [ matchAny return ]
911 forward msg mathServer
912 putMVar proxyAddr proxyServer
914 -- Client
915 forkIO $ do
916 localNode <- newLocalNode testTransport initRemoteTable
917 mathServer <- readMVar proxyAddr
919 runProcess localNode $ do
920 pid <- getSelfPid
921 send mathServer (Add pid 1 2)
922 3 <- expect :: Process Double
923 send mathServer (Divide pid 8 2)
924 4 <- expect :: Process Double
925 send mathServer (Divide pid 8 0)
926 DivByZero <- expect
927 liftIO $ putMVar clientDone ()
929 takeMVar clientDone
931-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
932-- in between, however we block 'Divide' requests ....
933testMatchAnyHandle :: TestTransport -> Assertion
934testMatchAnyHandle TestTransport{..} = do
935 proxyAddr <- newEmptyMVar
936 clientDone <- newEmptyMVar
938 -- Math server
939 forkIO $ do
940 localNode <- newLocalNode testTransport initRemoteTable
941 mathServer <- forkProcess localNode math
942 proxyServer <- forkProcess localNode $ forever $ do
943 receiveWait [
944 matchAny (maybeForward mathServer)
945 ]
946 putMVar proxyAddr proxyServer
948 -- Client
949 forkIO $ do
950 localNode <- newLocalNode testTransport initRemoteTable
951 mathServer <- readMVar proxyAddr
953 runProcess localNode $ do
954 pid <- getSelfPid
955 send mathServer (Add pid 1 2)
956 3 <- expect :: Process Double
957 send mathServer (Divide pid 8 2)
958 Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
959 liftIO $ putMVar clientDone ()
961 takeMVar clientDone
962 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
963 maybeForward s msg =
964 handleMessage msg (\m@(Add _ _ _) -> send s m)
966testMatchAnyNoHandle :: TestTransport -> Assertion
967testMatchAnyNoHandle TestTransport{..} = do
968 addr <- newEmptyMVar
969 clientDone <- newEmptyMVar
970 serverDone <- newEmptyMVar
972 -- Math server
973 forkIO $ do
974 localNode <- newLocalNode testTransport initRemoteTable
975 server <- forkProcess localNode $ forever $ do
976 receiveWait [
977 matchAnyIf
978 -- the condition has type `Add -> Bool`
979 (\(Add _ _ _) -> True)
980 -- the match `AbstractMessage -> Process ()` will succeed!
981 (\m -> do
982 -- `String -> Process ()` does *not* match the input types however
983 r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
984 case r of
985 Nothing -> return ()
986 Just _ -> die "NONSENSE")
987 ]
988 -- we *must* have removed the message from our mailbox though!!!
989 Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
990 liftIO $ putMVar serverDone ()
991 putMVar addr server
993 -- Client
994 forkIO $ do
995 localNode <- newLocalNode testTransport initRemoteTable
996 server <- readMVar addr
998 runProcess localNode $ do
999 pid <- getSelfPid
1000 send server (Add pid 1 2)
1001 -- we only care about the client having sent a message, so we're done
1002 liftIO $ putMVar clientDone ()
1004 takeMVar clientDone
1005 takeMVar serverDone
1007-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
1008-- unless the text body @/= "bar"@ - this case should time out rather than
1009-- removing the message from the process mailbox.
1010testMatchAnyIf :: TestTransport -> Assertion
1011testMatchAnyIf TestTransport{..} = do
1012 echoAddr <- newEmptyMVar
1013 clientDone <- newEmptyMVar
1015 -- echo server
1016 forkIO $ do
1017 localNode <- newLocalNode testTransport initRemoteTable
1018 echoServer <- forkProcess localNode $ forever $ do
1019 receiveWait [
1020 matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
1021 tryHandleMessage
1023 putMVar echoAddr echoServer
1025 -- Client
1026 forkIO $ do
1027 localNode <- newLocalNode testTransport initRemoteTable
1028 server <- readMVar echoAddr
1030 runProcess localNode $ do
1031 pid <- getSelfPid
1032 send server (pid, "foo")
1033 "foo" <- expect
1034 send server (pid, "baz")
1035 "baz" <- expect
1036 send server (pid, "bar")
1037 Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1038 liftIO $ putMVar clientDone ()
1040 takeMVar clientDone
1041 where tryHandleMessage :: Message -> Process (Maybe ())
1042 tryHandleMessage msg =
1043 handleMessage msg (\(pid :: ProcessId, (m :: String))
1044 -> do { send pid m; return () })
1046testMatchMessageWithUnwrap :: TestTransport -> Assertion
1047testMatchMessageWithUnwrap TestTransport{..} = do
1048 echoAddr <- newEmptyMVar
1049 clientDone <- newEmptyMVar
1051 -- echo server
1052 forkIO $ do
1053 localNode <- newLocalNode testTransport initRemoteTable
1054 echoServer <- forkProcess localNode $ forever $ do
1055 msg <- receiveWait [
1056 matchMessage (\(m :: Message) -> do
1057 return m)
1059 unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
1060 case unwrapped of
1061 (Just (p, msg')) -> forward msg' p
1062 Nothing -> die "unable to unwrap the message"
1063 putMVar echoAddr echoServer
1065 -- Client
1066 forkIO $ do
1067 localNode <- newLocalNode testTransport initRemoteTable
1068 server <- readMVar echoAddr
1070 runProcess localNode $ do
1071 pid <- getSelfPid
1072 send server (pid, wrapMessage ("foo" :: String))
1073 "foo" <- expect
1074 send server (pid, wrapMessage ("baz" :: String))
1075 "baz" <- expect
1076 liftIO $ putMVar clientDone ()
1078 takeMVar clientDone
1080-- Test 'receiveChanTimeout'
1081testReceiveChanTimeout :: TestTransport -> Assertion
1082testReceiveChanTimeout TestTransport{..} = do
1083 done <- newEmptyMVar
1084 sendPort <- newEmptyMVar
1086 forkTry $ do
1087 localNode <- newLocalNode testTransport initRemoteTable
1088 runProcess localNode $ do
1089 -- Create a typed channel
1090 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1091 liftIO $ putMVar sendPort sp
1093 -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
1094 Nothing <- receiveChanTimeout 1000000 rp
1096 -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
1097 Just True <- receiveChanTimeout 1000000 rp
1099 -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing
1100 Nothing <- receiveChanTimeout 0 rp
1102 -- Again, but now there is a message available
1103 liftIO $ threadDelay 1000000
1104 Just False <- receiveChanTimeout 0 rp
1106 liftIO $ putMVar done ()
1108 forkTry $ do
1109 localNode <- newLocalNode testTransport initRemoteTable
1110 runProcess localNode $ do
1111 sp <- liftIO $ readMVar sendPort
1113 liftIO $ threadDelay 1500000
1114 sendChan sp True
1116 liftIO $ threadDelay 500000
1117 sendChan sp False
1119 takeMVar done
1121-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1122testReceiveChanFeatures :: TestTransport -> Assertion
1123testReceiveChanFeatures TestTransport{..} = do
1124 done <- newEmptyMVar
1126 forkTry $ do
1127 localNode <- newLocalNode testTransport initRemoteTable
1128 runProcess localNode $ do
1129 (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1130 (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1132 -- Test Functor instance
1134 sendChan spInt 2
1135 sendChan spBool False
1137 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1139 True <- receiveChan rp1
1140 False <- receiveChan rp1
1142 -- Test Applicative instance
1144 sendChan spInt 3
1145 sendChan spInt 4
1147 let rp2 = pure (+) <*> rpInt <*> rpInt
1149 7 <- receiveChan rp2
1151 -- Test Alternative instance
1153 sendChan spInt 3
1154 sendChan spBool True
1156 let rp3 = (even <$> rpInt) <|> rpBool
1158 False <- receiveChan rp3
1159 True <- receiveChan rp3
1161 -- Test Monad instance
1163 sendChan spBool True
1164 sendChan spBool False
1165 sendChan spInt 5
1167 let rp4 :: ReceivePort Int
1168 rp4 = do b <- rpBool
1169 if b
1170 then rpInt
1171 else return 7
1173 5 <- receiveChan rp4
1174 7 <- receiveChan rp4
1176 liftIO $ putMVar done ()
1178 takeMVar done
1180testKillLocal :: TestTransport -> Assertion
1181testKillLocal TestTransport{..} = do
1182 localNode <- newLocalNode testTransport initRemoteTable
1183 done <- newEmptyMVar
1185 pid <- forkProcess localNode $ do
1186 liftIO $ threadDelay 1000000
1188 runProcess localNode $ do
1189 ref <- monitor pid
1190 us <- getSelfPid
1191 kill pid "TestKill"
1192 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1193 True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1194 liftIO $ putMVar done ()
1196 takeMVar done
1198testKillRemote :: TestTransport -> Assertion
1199testKillRemote TestTransport{..} = do
1200 node1 <- newLocalNode testTransport initRemoteTable
1201 node2 <- newLocalNode testTransport initRemoteTable
1202 done <- newEmptyMVar
1204 pid <- forkProcess node1 $ do
1205 liftIO $ threadDelay 1000000
1207 runProcess node2 $ do
1208 ref <- monitor pid
1209 us <- getSelfPid
1210 kill pid "TestKill"
1211 ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1212 True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1213 liftIO $ putMVar done ()
1215 takeMVar done
1217testCatchesExit :: TestTransport -> Assertion
1218testCatchesExit TestTransport{..} = do
1219 localNode <- newLocalNode testTransport initRemoteTable
1220 done <- newEmptyMVar
1222 _ <- forkProcess localNode $ do
1223 (die ("foobar", 123 :: Int))
1224 `catchesExit` [
1225 (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1226 , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1227 , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1228 -> (liftIO $ putMVar done ()) >> return ()))
1231 takeMVar done
1233testHandleMessageIf :: TestTransport -> Assertion
1234testHandleMessageIf TestTransport{..} = do
1235 localNode <- newLocalNode testTransport initRemoteTable
1236 done <- newEmptyMVar
1237 _ <- forkProcess localNode $ do
1238 self <- getSelfPid
1239 send self (5 :: Integer, 10 :: Integer)
1240 msg <- receiveWait [ matchMessage return ]
1241 Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1242 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1243 (\input -> liftIO $ putMVar done input)
1244 return ()
1246 result <- takeMVar done
1247 expectThat result $ equalTo (5, 10)
1249testCatches :: TestTransport -> Assertion
1250testCatches TestTransport{..} = do
1251 localNode <- newLocalNode testTransport initRemoteTable
1252 done <- newEmptyMVar
1254 _ <- forkProcess localNode $ do
1255 node <- getSelfNode
1256 (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1257 `catches` [
1258 Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1261 takeMVar done
1263testMaskRestoreScope :: TestTransport -> Assertion
1264testMaskRestoreScope TestTransport{..} = do
1265 localNode <- newLocalNode testTransport initRemoteTable
1266 parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1267 spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1269 void $ runProcess localNode $ mask $ \unmask -> do
1270 getSelfPid >>= liftIO . putMVar parentPid
1271 void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1273 parent <- liftIO $ takeMVar parentPid
1274 child <- liftIO $ takeMVar spawnedPid
1275 expectThat parent $ isNot $ equalTo child
1277testDie :: TestTransport -> Assertion
1278testDie TestTransport{..} = do
1279 localNode <- newLocalNode testTransport initRemoteTable
1280 done <- newEmptyMVar
1282 _ <- forkProcess localNode $ do
1283 (die ("foobar", 123 :: Int))
1284 `catchExit` \_from reason -> do
1285 -- TODO: should verify that 'from' has the right value
1286 True <- return $ reason == ("foobar", 123 :: Int)
1287 liftIO $ putMVar done ()
1289 takeMVar done
1291testPrettyExit :: TestTransport -> Assertion
1292testPrettyExit TestTransport{..} = do
1293 localNode <- newLocalNode testTransport initRemoteTable
1294 done <- newEmptyMVar
1296 _ <- forkProcess localNode $ do
1297 (die "timeout")
1298 `catch` \ex@(ProcessExitException from _) ->
1299 let expected = "exit-from=" ++ (show from)
1300 in do
1301 True <- return $ (show ex) == expected
1302 liftIO $ putMVar done ()
1304 takeMVar done
1306testExitLocal :: TestTransport -> Assertion
1307testExitLocal TestTransport{..} = do
1308 localNode <- newLocalNode testTransport initRemoteTable
1309 supervisedDone <- newEmptyMVar
1310 supervisorDone <- newEmptyMVar
1311 -- XXX: we guarantee that exception handler will be set up
1312 -- regardless if forkProcess preserve masking state or not.
1313 handlerSetUp <- newEmptyMVar
1315 pid <- forkProcess localNode $ do
1316 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1317 -- TODO: should verify that 'from' has the right value
1318 True <- return $ reason == "TestExit"
1319 liftIO $ putMVar supervisedDone ()
1321 runProcess localNode $ do
1322 liftIO $ takeMVar handlerSetUp
1323 ref <- monitor pid
1324 exit pid "TestExit"
1325 -- This time the client catches the exception, so it dies normally
1326 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1327 True <- return $ ref == ref' && pid == pid'
1328 liftIO $ putMVar supervisorDone ()
1330 takeMVar supervisedDone
1331 takeMVar supervisorDone
1333testExitRemote :: TestTransport -> Assertion
1334testExitRemote TestTransport{..} = do
1335 node1 <- newLocalNode testTransport initRemoteTable
1336 node2 <- newLocalNode testTransport initRemoteTable
1337 supervisedDone <- newEmptyMVar
1338 supervisorDone <- newEmptyMVar
1340 pid <- forkProcess node1 $ do
1341 (receiveWait [] :: Process ()) -- block forever
1342 `catchExit` \_from reason -> do
1343 -- TODO: should verify that 'from' has the right value
1344 True <- return $ reason == "TestExit"
1345 liftIO $ putMVar supervisedDone ()
1347 runProcess node2 $ do
1348 ref <- monitor pid
1349 exit pid "TestExit"
1350 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1351 True <- return $ ref == ref' && pid == pid'
1352 liftIO $ putMVar supervisorDone ()
1354 takeMVar supervisedDone
1355 takeMVar supervisorDone
1357testUnsafeSend :: TestTransport -> Assertion
1358testUnsafeSend TestTransport{..} = do
1359 serverAddr <- newEmptyMVar
1360 clientDone <- newEmptyMVar
1362 localNode <- newLocalNode testTransport initRemoteTable
1363 void $ forkProcess localNode $ do
1364 self <- getSelfPid
1365 liftIO $ putMVar serverAddr self
1366 clientAddr <- expect
1367 unsafeSend clientAddr ()
1369 void $ forkProcess localNode $ do
1370 serverPid <- liftIO $ takeMVar serverAddr
1371 getSelfPid >>= unsafeSend serverPid
1372 () <- expect
1373 liftIO $ putMVar clientDone ()
1375 takeMVar clientDone
1377testUnsafeUSend :: TestTransport -> Assertion
1378testUnsafeUSend TestTransport{..} = do
1379 serverAddr <- newEmptyMVar
1380 clientDone <- newEmptyMVar
1382 localNode <- newLocalNode testTransport initRemoteTable
1383 void $ forkProcess localNode $ do
1384 self <- getSelfPid
1385 liftIO $ putMVar serverAddr self
1386 clientAddr <- expect
1387 unsafeUSend clientAddr ()
1389 void $ forkProcess localNode $ do
1390 serverPid <- liftIO $ takeMVar serverAddr
1391 getSelfPid >>= unsafeUSend serverPid
1392 () <- expect
1393 liftIO $ putMVar clientDone ()
1395 takeMVar clientDone
1397testUnsafeNSend :: TestTransport -> Assertion
1398testUnsafeNSend TestTransport{..} = do
1399 clientDone <- newEmptyMVar
1401 localNode <- newLocalNode testTransport initRemoteTable
1403 pid <- forkProcess localNode $ do
1404 () <- expect
1405 liftIO $ putMVar clientDone ()
1407 void $ runProcess localNode $ do
1408 register "foobar" pid
1409 unsafeNSend "foobar" ()
1411 takeMVar clientDone
1413testUnsafeNSendRemote :: TestTransport -> Assertion
1414testUnsafeNSendRemote TestTransport{..} = do
1415 clientDone <- newEmptyMVar
1417 localNode1 <- newLocalNode testTransport initRemoteTable
1418 localNode2 <- newLocalNode testTransport initRemoteTable
1420 _ <- forkProcess localNode1 $ do
1421 getSelfPid >>= register "foobar"
1422 liftIO $ putMVar clientDone ()
1423 () <- expect
1424 liftIO $ putMVar clientDone ()
1426 takeMVar clientDone
1427 void $ runProcess localNode2 $ do
1428 unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1430 takeMVar clientDone
1432testUnsafeSendChan :: TestTransport -> Assertion
1433testUnsafeSendChan TestTransport{..} = do
1434 serverAddr <- newEmptyMVar
1435 clientDone <- newEmptyMVar
1437 localNode <- newLocalNode testTransport initRemoteTable
1438 void $ forkProcess localNode $ do
1439 self <- getSelfPid
1440 liftIO $ putMVar serverAddr self
1441 sp <- expect
1442 unsafeSendChan sp ()
1444 void $ forkProcess localNode $ do
1445 serverPid <- liftIO $ takeMVar serverAddr
1446 (sp, rp) <- newChan
1447 unsafeSend serverPid sp
1448 () <- receiveChan rp
1449 liftIO $ putMVar clientDone ()
1451 takeMVar clientDone
1453testCallLocal :: TestTransport -> Assertion
1454testCallLocal TestTransport{..} = do
1455 node <- newLocalNode testTransport initRemoteTable
1457 -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1458 result <- newEmptyMVar
1459 runProcess node $ do
1460 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1461 liftIO $ putMVar result r
1462 True <- takeMVar result
1463 return ()
1465 -- Testing that when callLocal is interrupted, the worker is interrupted.
1466 ibox <- newIORef False
1467 runProcess node $ do
1468 keeper <- getSelfPid
1469 spawnLocal $ do
1470 caller <- getSelfPid
1471 send keeper caller
1472 onException
1473 (callLocal $ do
1474 onException (do send keeper caller
1475 expect)
1476 (do liftIO $ writeIORef ibox True))
1477 (send keeper ())
1478 caller <- expect
1479 exit caller "test"
1480 () <- expect
1481 return ()
1482 True <- readIORef ibox
1483 return ()
1485 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1486 ibox2 <- newIORef False
1487 runProcess node $ do
1488 r <- try (callLocal $ error "e" >> return ())
1489 liftIO $ writeIORef ibox2 $ case r of
1490 Left (ErrorCall "e") -> True
1491 _ -> False
1492 True <- readIORef ibox
1493 return ()
1495 -- Test that caller waits for the worker in correct situation
1496 ibox3 <- newIORef False
1497 result3 <- newEmptyMVar
1498 runProcess node $ do
1499 keeper <- getSelfPid
1500 spawnLocal $ do
1501 callLocal $
1502 (do us <- getSelfPid
1503 send keeper us
1504 () <- expect
1505 liftIO yield)
1506 `finally` (liftIO $ writeIORef ibox3 True)
1507 liftIO $ putMVar result3 =<< readIORef ibox3
1508 worker <- expect
1509 send worker ()
1510 True <- takeMVar result3
1511 return ()
1513 -- Test that caller waits for the worker in case when caller gets an exception
1514 ibox4 <- newIORef False
1515 result4 <- newEmptyMVar
1516 runProcess node $ do
1517 keeper <- getSelfPid
1518 spawnLocal $ do
1519 caller <- getSelfPid
1520 callLocal
1521 ((do send keeper caller
1522 expect)
1523 `finally` (liftIO $ writeIORef ibox4 True))
1524 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1525 caller <- expect
1526 exit caller "hi!"
1527 True <- takeMVar result4
1528 return ()
1529 -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1535tests :: TestTransport -> IO [Test]
1536tests testtrans = return [
1537 testGroup "Basic features" [
1538 testCase "Ping" (testPing testtrans)
1539 , testCase "Math" (testMath testtrans)
1540 , testCase "Timeout" (testTimeout testtrans)
1541 , testCase "Timeout0" (testTimeout0 testtrans)
1542 , testCase "SendToTerminated" (testSendToTerminated testtrans)
1543 , testCase "TypedChannnels" (testTypedChannels testtrans)
1544 , testCase "Terminate" (testTerminate testtrans)
1545 , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1546 , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1547 , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1548 , testCase "SpawnLocal" (testSpawnLocal testtrans)
1549 , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1550 , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1551 , testCase "MatchAny" (testMatchAny testtrans)
1552 , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1553 , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1554 , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1555 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1556 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1557 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1558 , testCase "KillLocal" (testKillLocal testtrans)
1559 , testCase "KillRemote" (testKillRemote testtrans)
1560 , testCase "Die" (testDie testtrans)
1561 , testCase "PrettyExit" (testPrettyExit testtrans)
1562 , testCase "CatchesExit" (testCatchesExit testtrans)
1563 , testCase "Catches" (testCatches testtrans)
1564 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1565 , testCase "ExitLocal" (testExitLocal testtrans)
1566 , testCase "ExitRemote" (testExitRemote testtrans)
1567 , testCase "TextCallLocal" (testCallLocal testtrans)
1568 -- Unsafe Primitives
1569 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1570 , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1571 , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1572 , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1573 , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1574 -- usend
1575 , testCase "USend" (testUSend usend testtrans 50)
1576 , testCase "UForward"
1577 (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1578 testtrans 50
1581 , testGroup "Monitoring and Linking" [
1582 -- Monitoring processes
1583 --
1584 -- The "missing" combinations in the list below don't make much sense, as
1585 -- we cannot guarantee that the monitor reply or link exception will not
1586 -- happen before the unmonitor or unlink
1587 testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1588 , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1589 , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1590 , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1591 , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1592 , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1593 , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1594 , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1595 , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1596 , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1597 , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1598 , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1599 , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1600 , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1601 , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1602 , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1603 , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1604 -- Monitoring nodes and channels
1605 , testCase "MonitorNode" (testMonitorNode testtrans)
1606 , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1607 , testCase "MonitorChannel" (testMonitorChannel testtrans)
1608 -- Reconnect
1611 -- Tests that fail occasionally and should be revised
1612 , testGroup "Flaky" [
1613 testCase "Reconnect" (testReconnect testtrans)
1614 , testCase "Registry" (testRegistry testtrans)
1615 , testCase "MergeChannels" (testMergeChannels testtrans)
1616 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1620syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1621syncBreakConnection breakConnection nid0 nid1 = do
1622 m <- newEmptyMVar
1623 _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1624 runProcess nid0 $ do
1625 them <- liftIO $ takeMVar m
1626 pinger <- spawnLocal $ forever $ send them ()
1627 _ <- monitorNode (localNodeId nid1)
1628 liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1629 (nodeAddress $ localNodeId nid1)
1630 NodeMonitorNotification _ _ _ <- expect
1631 kill pinger "finished"
1632 return ()