git.iko.soy/distributed-process
on 1d099cc help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs
1647 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 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 mvSender <- newEmptyMVar
1085 sendPort <- newEmptyMVar
1087 forkTry $ do
1088 localNode <- newLocalNode testTransport initRemoteTable
1089 runProcess localNode $ do
1090 -- Create a typed channel
1091 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1092 liftIO $ putMVar sendPort sp
1094 -- Wait for a message with a delay. No message arrives, we should get
1095 -- Nothing after the delay.
1096 Nothing <- receiveChanTimeout 100000 rp
1098 -- Let the sender know that it can send a message.
1099 liftIO $ putMVar mvSender ()
1101 -- Wait for a message with a delay again. Now a message arrives after
1102 -- 0.1 seconds
1103 Just True <- receiveChanTimeout 20000000 rp
1105 -- Wait for a message with zero timeout: non-blocking check. No message is
1106 -- available, we get Nothing
1107 Nothing <- receiveChanTimeout 0 rp
1109 -- Let the sender know that it can send a message.
1110 liftIO $ putMVar mvSender ()
1112 -- Again, but now there is a message available
1113 fix $ \loop -> do
1114 liftIO $ threadDelay 100000
1115 mb <- receiveChanTimeout 0 rp
1116 case mb of
1117 Just b -> do False <- return b; return ()
1118 _ -> loop
1120 liftIO $ putMVar done ()
1122 forkTry $ do
1123 localNode <- newLocalNode testTransport initRemoteTable
1124 runProcess localNode $ do
1125 sp <- liftIO $ readMVar sendPort
1127 liftIO $ takeMVar mvSender
1128 liftIO $ threadDelay 100000
1129 sendChan sp True
1131 liftIO $ takeMVar mvSender
1132 sendChan sp False
1134 takeMVar done
1136-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1137testReceiveChanFeatures :: TestTransport -> Assertion
1138testReceiveChanFeatures TestTransport{..} = do
1139 done <- newEmptyMVar
1141 forkTry $ do
1142 localNode <- newLocalNode testTransport initRemoteTable
1143 runProcess localNode $ do
1144 (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1145 (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1147 -- Test Functor instance
1149 sendChan spInt 2
1150 sendChan spBool False
1152 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1154 True <- receiveChan rp1
1155 False <- receiveChan rp1
1157 -- Test Applicative instance
1159 sendChan spInt 3
1160 sendChan spInt 4
1162 let rp2 = pure (+) <*> rpInt <*> rpInt
1164 7 <- receiveChan rp2
1166 -- Test Alternative instance
1168 sendChan spInt 3
1169 sendChan spBool True
1171 let rp3 = (even <$> rpInt) <|> rpBool
1173 False <- receiveChan rp3
1174 True <- receiveChan rp3
1176 -- Test Monad instance
1178 sendChan spBool True
1179 sendChan spBool False
1180 sendChan spInt 5
1182 let rp4 :: ReceivePort Int
1183 rp4 = do b <- rpBool
1184 if b
1185 then rpInt
1186 else return 7
1188 5 <- receiveChan rp4
1189 7 <- receiveChan rp4
1191 liftIO $ putMVar done ()
1193 takeMVar done
1195testKillLocal :: TestTransport -> Assertion
1196testKillLocal TestTransport{..} = do
1197 localNode <- newLocalNode testTransport initRemoteTable
1198 done <- newEmptyMVar
1200 pid <- forkProcess localNode $ do
1201 liftIO $ threadDelay 1000000
1203 runProcess localNode $ do
1204 ref <- monitor pid
1205 us <- getSelfPid
1206 kill pid "TestKill"
1207 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1208 True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1209 liftIO $ putMVar done ()
1211 takeMVar done
1213testKillRemote :: TestTransport -> Assertion
1214testKillRemote TestTransport{..} = do
1215 node1 <- newLocalNode testTransport initRemoteTable
1216 node2 <- newLocalNode testTransport initRemoteTable
1217 done <- newEmptyMVar
1219 pid <- forkProcess node1 $ do
1220 liftIO $ threadDelay 1000000
1222 runProcess node2 $ do
1223 ref <- monitor pid
1224 us <- getSelfPid
1225 kill pid "TestKill"
1226 ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1227 True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1228 liftIO $ putMVar done ()
1230 takeMVar done
1232testCatchesExit :: TestTransport -> Assertion
1233testCatchesExit TestTransport{..} = do
1234 localNode <- newLocalNode testTransport initRemoteTable
1235 done <- newEmptyMVar
1237 _ <- forkProcess localNode $ do
1238 (die ("foobar", 123 :: Int))
1239 `catchesExit` [
1240 (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1241 , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1242 , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1243 -> (liftIO $ putMVar done ()) >> return ()))
1246 takeMVar done
1248testHandleMessageIf :: TestTransport -> Assertion
1249testHandleMessageIf TestTransport{..} = do
1250 localNode <- newLocalNode testTransport initRemoteTable
1251 done <- newEmptyMVar
1252 _ <- forkProcess localNode $ do
1253 self <- getSelfPid
1254 send self (5 :: Integer, 10 :: Integer)
1255 msg <- receiveWait [ matchMessage return ]
1256 Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1257 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1258 (\input -> liftIO $ putMVar done input)
1259 return ()
1261 result <- takeMVar done
1262 expectThat result $ equalTo (5, 10)
1264testCatches :: TestTransport -> Assertion
1265testCatches TestTransport{..} = do
1266 localNode <- newLocalNode testTransport initRemoteTable
1267 done <- newEmptyMVar
1269 _ <- forkProcess localNode $ do
1270 node <- getSelfNode
1271 (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1272 `catches` [
1273 Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1276 takeMVar done
1278testMaskRestoreScope :: TestTransport -> Assertion
1279testMaskRestoreScope TestTransport{..} = do
1280 localNode <- newLocalNode testTransport initRemoteTable
1281 parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1282 spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1284 void $ runProcess localNode $ mask $ \unmask -> do
1285 getSelfPid >>= liftIO . putMVar parentPid
1286 void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1288 parent <- liftIO $ takeMVar parentPid
1289 child <- liftIO $ takeMVar spawnedPid
1290 expectThat parent $ isNot $ equalTo child
1292testDie :: TestTransport -> Assertion
1293testDie TestTransport{..} = do
1294 localNode <- newLocalNode testTransport initRemoteTable
1295 done <- newEmptyMVar
1297 _ <- forkProcess localNode $ do
1298 (die ("foobar", 123 :: Int))
1299 `catchExit` \_from reason -> do
1300 -- TODO: should verify that 'from' has the right value
1301 True <- return $ reason == ("foobar", 123 :: Int)
1302 liftIO $ putMVar done ()
1304 takeMVar done
1306testPrettyExit :: TestTransport -> Assertion
1307testPrettyExit TestTransport{..} = do
1308 localNode <- newLocalNode testTransport initRemoteTable
1309 done <- newEmptyMVar
1311 _ <- forkProcess localNode $ do
1312 (die "timeout")
1313 `catch` \ex@(ProcessExitException from _) ->
1314 let expected = "exit-from=" ++ (show from)
1315 in do
1316 True <- return $ (show ex) == expected
1317 liftIO $ putMVar done ()
1319 takeMVar done
1321testExitLocal :: TestTransport -> Assertion
1322testExitLocal TestTransport{..} = do
1323 localNode <- newLocalNode testTransport initRemoteTable
1324 supervisedDone <- newEmptyMVar
1325 supervisorDone <- newEmptyMVar
1326 -- XXX: we guarantee that exception handler will be set up
1327 -- regardless if forkProcess preserve masking state or not.
1328 handlerSetUp <- newEmptyMVar
1330 pid <- forkProcess localNode $ do
1331 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1332 -- TODO: should verify that 'from' has the right value
1333 True <- return $ reason == "TestExit"
1334 liftIO $ putMVar supervisedDone ()
1336 runProcess localNode $ do
1337 liftIO $ takeMVar handlerSetUp
1338 ref <- monitor pid
1339 exit pid "TestExit"
1340 -- This time the client catches the exception, so it dies normally
1341 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1342 True <- return $ ref == ref' && pid == pid'
1343 liftIO $ putMVar supervisorDone ()
1345 takeMVar supervisedDone
1346 takeMVar supervisorDone
1348testExitRemote :: TestTransport -> Assertion
1349testExitRemote TestTransport{..} = do
1350 node1 <- newLocalNode testTransport initRemoteTable
1351 node2 <- newLocalNode testTransport initRemoteTable
1352 supervisedDone <- newEmptyMVar
1353 supervisorDone <- newEmptyMVar
1355 pid <- forkProcess node1 $ do
1356 (receiveWait [] :: Process ()) -- block forever
1357 `catchExit` \_from reason -> do
1358 -- TODO: should verify that 'from' has the right value
1359 True <- return $ reason == "TestExit"
1360 liftIO $ putMVar supervisedDone ()
1362 runProcess node2 $ do
1363 ref <- monitor pid
1364 exit pid "TestExit"
1365 ProcessMonitorNotification ref' pid' DiedNormal <- expect
1366 True <- return $ ref == ref' && pid == pid'
1367 liftIO $ putMVar supervisorDone ()
1369 takeMVar supervisedDone
1370 takeMVar supervisorDone
1372testUnsafeSend :: TestTransport -> Assertion
1373testUnsafeSend TestTransport{..} = do
1374 serverAddr <- newEmptyMVar
1375 clientDone <- newEmptyMVar
1377 localNode <- newLocalNode testTransport initRemoteTable
1378 void $ forkProcess localNode $ do
1379 self <- getSelfPid
1380 liftIO $ putMVar serverAddr self
1381 clientAddr <- expect
1382 unsafeSend clientAddr ()
1384 void $ forkProcess localNode $ do
1385 serverPid <- liftIO $ takeMVar serverAddr
1386 getSelfPid >>= unsafeSend serverPid
1387 () <- expect
1388 liftIO $ putMVar clientDone ()
1390 takeMVar clientDone
1392testUnsafeUSend :: TestTransport -> Assertion
1393testUnsafeUSend TestTransport{..} = do
1394 serverAddr <- newEmptyMVar
1395 clientDone <- newEmptyMVar
1397 localNode <- newLocalNode testTransport initRemoteTable
1398 void $ forkProcess localNode $ do
1399 self <- getSelfPid
1400 liftIO $ putMVar serverAddr self
1401 clientAddr <- expect
1402 unsafeUSend clientAddr ()
1404 void $ forkProcess localNode $ do
1405 serverPid <- liftIO $ takeMVar serverAddr
1406 getSelfPid >>= unsafeUSend serverPid
1407 () <- expect
1408 liftIO $ putMVar clientDone ()
1410 takeMVar clientDone
1412testUnsafeNSend :: TestTransport -> Assertion
1413testUnsafeNSend TestTransport{..} = do
1414 clientDone <- newEmptyMVar
1416 localNode <- newLocalNode testTransport initRemoteTable
1418 pid <- forkProcess localNode $ do
1419 () <- expect
1420 liftIO $ putMVar clientDone ()
1422 void $ runProcess localNode $ do
1423 register "foobar" pid
1424 unsafeNSend "foobar" ()
1426 takeMVar clientDone
1428testUnsafeNSendRemote :: TestTransport -> Assertion
1429testUnsafeNSendRemote TestTransport{..} = do
1430 clientDone <- newEmptyMVar
1432 localNode1 <- newLocalNode testTransport initRemoteTable
1433 localNode2 <- newLocalNode testTransport initRemoteTable
1435 _ <- forkProcess localNode1 $ do
1436 getSelfPid >>= register "foobar"
1437 liftIO $ putMVar clientDone ()
1438 () <- expect
1439 liftIO $ putMVar clientDone ()
1441 takeMVar clientDone
1442 void $ runProcess localNode2 $ do
1443 unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1445 takeMVar clientDone
1447testUnsafeSendChan :: TestTransport -> Assertion
1448testUnsafeSendChan TestTransport{..} = do
1449 serverAddr <- newEmptyMVar
1450 clientDone <- newEmptyMVar
1452 localNode <- newLocalNode testTransport initRemoteTable
1453 void $ forkProcess localNode $ do
1454 self <- getSelfPid
1455 liftIO $ putMVar serverAddr self
1456 sp <- expect
1457 unsafeSendChan sp ()
1459 void $ forkProcess localNode $ do
1460 serverPid <- liftIO $ takeMVar serverAddr
1461 (sp, rp) <- newChan
1462 unsafeSend serverPid sp
1463 () <- receiveChan rp
1464 liftIO $ putMVar clientDone ()
1466 takeMVar clientDone
1468testCallLocal :: TestTransport -> Assertion
1469testCallLocal TestTransport{..} = do
1470 node <- newLocalNode testTransport initRemoteTable
1472 -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1473 result <- newEmptyMVar
1474 runProcess node $ do
1475 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1476 liftIO $ putMVar result r
1477 True <- takeMVar result
1478 return ()
1480 -- Testing that when callLocal is interrupted, the worker is interrupted.
1481 ibox <- newIORef False
1482 runProcess node $ do
1483 keeper <- getSelfPid
1484 spawnLocal $ do
1485 caller <- getSelfPid
1486 send keeper caller
1487 onException
1488 (callLocal $ do
1489 onException (do send keeper caller
1490 expect)
1491 (do liftIO $ writeIORef ibox True))
1492 (send keeper ())
1493 caller <- expect
1494 exit caller "test"
1495 () <- expect
1496 return ()
1497 True <- readIORef ibox
1498 return ()
1500 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1501 ibox2 <- newIORef False
1502 runProcess node $ do
1503 r <- try (callLocal $ error "e" >> return ())
1504 liftIO $ writeIORef ibox2 $ case r of
1505 Left (ErrorCall "e") -> True
1506 _ -> False
1507 True <- readIORef ibox
1508 return ()
1510 -- Test that caller waits for the worker in correct situation
1511 ibox3 <- newIORef False
1512 result3 <- newEmptyMVar
1513 runProcess node $ do
1514 keeper <- getSelfPid
1515 spawnLocal $ do
1516 callLocal $
1517 (do us <- getSelfPid
1518 send keeper us
1519 () <- expect
1520 liftIO yield)
1521 `finally` (liftIO $ writeIORef ibox3 True)
1522 liftIO $ putMVar result3 =<< readIORef ibox3
1523 worker <- expect
1524 send worker ()
1525 True <- takeMVar result3
1526 return ()
1528 -- Test that caller waits for the worker in case when caller gets an exception
1529 ibox4 <- newIORef False
1530 result4 <- newEmptyMVar
1531 runProcess node $ do
1532 keeper <- getSelfPid
1533 spawnLocal $ do
1534 caller <- getSelfPid
1535 callLocal
1536 ((do send keeper caller
1537 expect)
1538 `finally` (liftIO $ writeIORef ibox4 True))
1539 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1540 caller <- expect
1541 exit caller "hi!"
1542 True <- takeMVar result4
1543 return ()
1544 -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1550tests :: TestTransport -> IO [Test]
1551tests testtrans = return [
1552 testGroup "Basic features" [
1553 testCase "Ping" (testPing testtrans)
1554 , testCase "Math" (testMath testtrans)
1555 , testCase "Timeout" (testTimeout testtrans)
1556 , testCase "Timeout0" (testTimeout0 testtrans)
1557 , testCase "SendToTerminated" (testSendToTerminated testtrans)
1558 , testCase "TypedChannnels" (testTypedChannels testtrans)
1559 , testCase "Terminate" (testTerminate testtrans)
1560 , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1561 , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1562 , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1563 , testCase "SpawnLocal" (testSpawnLocal testtrans)
1564 , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1565 , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1566 , testCase "MatchAny" (testMatchAny testtrans)
1567 , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1568 , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1569 , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1570 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1571 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1572 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1573 , testCase "KillLocal" (testKillLocal testtrans)
1574 , testCase "KillRemote" (testKillRemote testtrans)
1575 , testCase "Die" (testDie testtrans)
1576 , testCase "PrettyExit" (testPrettyExit testtrans)
1577 , testCase "CatchesExit" (testCatchesExit testtrans)
1578 , testCase "Catches" (testCatches testtrans)
1579 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1580 , testCase "ExitLocal" (testExitLocal testtrans)
1581 , testCase "ExitRemote" (testExitRemote testtrans)
1582 , testCase "TextCallLocal" (testCallLocal testtrans)
1583 -- Unsafe Primitives
1584 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1585 , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1586 , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1587 , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1588 , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1589 -- usend
1590 , testCase "USend" (testUSend usend testtrans 50)
1591 , testCase "UForward"
1592 (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1593 testtrans 50
1596 , testGroup "Monitoring and Linking" [
1597 -- Monitoring processes
1598 --
1599 -- The "missing" combinations in the list below don't make much sense, as
1600 -- we cannot guarantee that the monitor reply or link exception will not
1601 -- happen before the unmonitor or unlink
1602 testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1603 , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1604 , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1605 , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1606 , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1607 , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1608 , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1609 , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1610 , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1611 , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1612 , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1613 , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1614 , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1615 , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1616 , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1617 , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1618 , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1619 -- Monitoring nodes and channels
1620 , testCase "MonitorNode" (testMonitorNode testtrans)
1621 , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1622 , testCase "MonitorChannel" (testMonitorChannel testtrans)
1623 -- Reconnect
1626 -- Tests that fail occasionally and should be revised
1627 , testGroup "Flaky" [
1628 testCase "Reconnect" (testReconnect testtrans)
1629 , testCase "Registry" (testRegistry testtrans)
1630 , testCase "MergeChannels" (testMergeChannels testtrans)
1631 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1635syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1636syncBreakConnection breakConnection nid0 nid1 = do
1637 m <- newEmptyMVar
1638 _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1639 runProcess nid0 $ do
1640 them <- liftIO $ takeMVar m
1641 pinger <- spawnLocal $ forever $ send them ()
1642 _ <- monitorNode (localNodeId nid1)
1643 liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1644 (nodeAddress $ localNodeId nid1)
1645 NodeMonitorNotification _ _ _ <- expect
1646 kill pinger "finished"
1647 return ()