@@ -0,0 +1,1879 @@
1+module Control.Distributed.Process.Tests.CH (tests) where
3+#if ! MIN_VERSION_base(4,6,0)
4+import Prelude hiding (catch)
7+import Network.Transport.Test (TestTransport(..))
9+import Data.Binary (Binary(..))
10+import Data.Typeable (Typeable)
11+import Data.Foldable (forM_)
12+import Data.Function (fix)
18+import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)
19+import Control.Concurrent.MVar
26+import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
27+import Control.Exception (SomeException, throwIO, ErrorCall(..))
28+import Control.Monad.Catch (try, catch, finally, mask, onException)
29+import Control.Applicative ((<|>))
30+import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31+import Control.Distributed.Process hiding
38+import Control.Distributed.Process.Internal.Types
39+ ( LocalNode(localEndPoint)
40+ , ProcessExitException(..)
42+ , createUnencodedMessage
44+import Control.Distributed.Process.Node
45+import Control.Distributed.Process.Debug
46+import Control.Distributed.Process.Management.Internal.Types
47+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)
48+import Control.Distributed.Process.Serializable (Serializable)
49+import Data.Maybe (isNothing, isJust)
50+import Test.HUnit (Assertion, assertBool, assertFailure)
51+import Test.Framework (Test, testGroup)
52+import Test.Framework.Providers.HUnit (testCase)
53+import Control.Rematch hiding (match, isNothing, isJust)
54+import Control.Rematch.Run (Match(..))
56+newtype Ping = Ping ProcessId
57+ deriving (Typeable, Binary, Show)
59+newtype Pong = Pong ProcessId
60+ deriving (Typeable, Binary, Show)
62+--------------------------------------------------------------------------------
63+-- Supporting definitions --
64+--------------------------------------------------------------------------------
66+expectThat :: a -> Matcher a -> Assertion
67+expectThat a matcher = case res of
68+ MatchSuccess -> return ()
69+ (MatchFailure msg) -> assertFailure msg
70+ where res = runMatch matcher a
72+-- | Like fork, but throw exceptions in the child thread to the parent
73+forkTry :: IO () -> IO ThreadId
76+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
78+-- | The ping server from the paper
81+ Pong partner <- expect
83+ send partner (Ping self)
86+verifyClient :: String -> MVar Bool -> IO ()
87+verifyClient s b = takeMVar b >>= assertBool s
89+expectPing :: MVar Bool -> Process ()
90+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
92+ checkPing (Ping _) = True
94+-- | Quick and dirty synchronous version of whereisRemoteAsync
95+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
96+whereisRemote nid string = do
97+ whereisRemoteAsync nid string
99+ match (\(WhereIsReply _ mPid) -> return mPid)
102+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
103+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
105+waitForExit :: ProcessId -> Process DiedReason
106+waitForExit pid = monitor pid >>= waitForDown
108+waitForDown :: MonitorRef -> Process DiedReason
110+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
111+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
113+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
114+syncBreakConnection breakConnection nid0 nid1 = do
116+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
117+ runProcess nid0 $ do
118+ them <- liftIO $ takeMVar m
119+ pinger <- spawnLocal $ forever $ send them ()
120+ _ <- monitorNode (localNodeId nid1)
121+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
122+ (nodeAddress $ localNodeId nid1)
123+ NodeMonitorNotification _ _ _ <- expect
124+ kill pinger "finished"
127+data Add = Add ProcessId Double Double deriving (Typeable)
128+data Divide = Divide ProcessId Double Double deriving (Typeable)
129+data DivByZero = DivByZero deriving (Typeable)
131+instance Binary Add where
132+ put (Add pid x y) = put pid >> put x >> put y
133+ get = Add <$> get <*> get <*> get
135+instance Binary Divide where
136+ put (Divide pid x y) = put pid >> put x >> put y
137+ get = Divide <$> get <*> get <*> get
139+instance Binary DivByZero where
140+ put DivByZero = return ()
141+ get = return DivByZero
143+-- The math server from the paper
147+ [ match (\(Add pid x y) -> send pid (x + y))
148+ , matchIf (\(Divide _ _ y) -> y /= 0)
149+ (\(Divide pid x y) -> send pid (x / y))
150+ , match (\(Divide pid _ _) -> send pid DivByZero)
154+-- | Monitor or link to a remote node
155+monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
156+ -> ProcessId -- ^ Process to monitor/link to
157+ -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up
158+ -> Process (Maybe MonitorRef)
159+monitorOrLink mOrL pid mSignal = do
160+ result <- if mOrL then Just <$> monitor pid
161+ else link pid >> return Nothing
162+ -- Monitor is asynchronous, which usually does not matter but if we want a
163+ -- *specific* signal then it does. Therefore we wait until the MonitorRef is
164+ -- listed in the ProcessInfo and hope that this means the monitor has been set
166+ forM_ mSignal $ \signal -> do
169+ let waitForMOrL = do
170+ liftIO $ threadDelay 100000
171+ mpinfo <- getProcessInfo pid
173+ Nothing -> waitForMOrL
176+ unless (result == lookup self (infoMonitors pinfo)) waitForMOrL
178+ unless (elem self $ infoLinks pinfo) waitForMOrL
180+ liftIO $ putMVar signal ()
183+monitorTestProcess :: ProcessId -- Process to monitor/link to
184+ -> Bool -- 'True' for monitor, 'False' for link
185+ -> Bool -- Should we unmonitor?
186+ -> DiedReason -- Expected cause of death
187+ -> Maybe (MVar ()) -- Signal for 'monitor set up'
188+ -> MVar () -- Signal for successful termination
190+monitorTestProcess theirAddr mOrL un reason monitorSetup done =
191+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
193+ (True, Nothing) -> do
195+ liftIO $ putMVar done ()
196+ (True, Just ref) -> do
198+ liftIO $ putMVar done ()
201+ match (\(ProcessMonitorNotification ref' pid reason') -> do
203+ assertBool "Bad Monitor Signal"
204+ (Just ref' == ref && pid == theirAddr &&
205+ mOrL && reason == reason')
209+ (\(ProcessLinkException pid reason') -> do
210+ (liftIO $ assertBool "link exception unmatched" $
211+ pid == theirAddr && not mOrL && not un && reason == reason')
212+ liftIO $ putMVar done ()
215+--------------------------------------------------------------------------------
216+-- The tests proper --
217+--------------------------------------------------------------------------------
220+testPing :: TestTransport -> Assertion
221+testPing TestTransport{..} = do
222+ serverAddr <- newEmptyMVar
223+ clientDone <- newEmptyMVar
227+ localNode <- newLocalNode testTransport initRemoteTable
228+ addr <- forkProcess localNode ping
229+ putMVar serverAddr addr
233+ localNode <- newLocalNode testTransport initRemoteTable
234+ pingServer <- readMVar serverAddr
236+ let numPings = 10000
238+ runProcess localNode $ do
240+ replicateM_ numPings $ do
241+ send pingServer (Pong pid)
242+ p <- expectTimeout 3000000
244+ Just (Ping _) -> return ()
245+ Nothing -> die "Failed to receive Ping"
247+ putMVar clientDone ()
251+-- | Monitor a process on an unreachable node
252+testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
253+testMonitorUnreachable TestTransport{..} mOrL un = do
254+ deadProcess <- newEmptyMVar
255+ done <- newEmptyMVar
258+ localNode <- newLocalNode testTransport initRemoteTable
259+ addr <- forkProcess localNode expect
260+ closeLocalNode localNode
261+ putMVar deadProcess addr
264+ localNode <- newLocalNode testTransport initRemoteTable
265+ theirAddr <- readMVar deadProcess
266+ runProcess localNode $
267+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
271+-- | Monitor a process which terminates normally
272+testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion
273+testMonitorNormalTermination TestTransport{..} mOrL un = do
274+ monitorSetup <- newEmptyMVar
275+ monitoredProcess <- newEmptyMVar
276+ done <- newEmptyMVar
279+ localNode <- newLocalNode testTransport initRemoteTable
280+ addr <- forkProcess localNode $
281+ liftIO $ readMVar monitorSetup
282+ putMVar monitoredProcess addr
285+ localNode <- newLocalNode testTransport initRemoteTable
286+ theirAddr <- readMVar monitoredProcess
287+ runProcess localNode $
288+ monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
292+-- | Monitor a process which terminates abnormally
293+testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion
294+testMonitorAbnormalTermination TestTransport{..} mOrL un = do
295+ monitorSetup <- newEmptyMVar
296+ monitoredProcess <- newEmptyMVar
297+ done <- newEmptyMVar
299+ let err = userError "Abnormal termination"
302+ localNode <- newLocalNode testTransport initRemoteTable
303+ addr <- forkProcess localNode . liftIO $ do
304+ readMVar monitorSetup
306+ putMVar monitoredProcess addr
309+ localNode <- newLocalNode testTransport initRemoteTable
310+ theirAddr <- readMVar monitoredProcess
311+ runProcess localNode $
312+ monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
316+-- | Monitor a local process that is already dead
317+testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
318+testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
319+ processAddr <- newEmptyMVar
320+ localNode <- newLocalNode testTransport initRemoteTable
321+ done <- newEmptyMVar
324+ addr <- forkProcess localNode $ return ()
325+ putMVar processAddr addr
328+ theirAddr <- readMVar processAddr
329+ runProcess localNode $ do
331+ -- wait for the process to die
332+ expect :: Process ProcessMonitorNotification
333+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
337+-- | Monitor a remote process that is already dead
338+testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
339+testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do
340+ processDead <- newEmptyMVar
341+ processAddr <- newEmptyMVar
342+ done <- newEmptyMVar
345+ localNode <- newLocalNode testTransport initRemoteTable
346+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()
347+ putMVar processAddr addr
350+ localNode <- newLocalNode testTransport initRemoteTable
351+ theirAddr <- readMVar processAddr
352+ readMVar processDead
353+ runProcess localNode $ do
354+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
358+-- | Monitor a process that becomes disconnected
359+testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
360+testMonitorDisconnect TestTransport{..} mOrL un = do
361+ processAddr <- newEmptyMVar
362+ processAddr2 <- newEmptyMVar
363+ monitorSetup <- newEmptyMVar
364+ done <- newEmptyMVar
367+ localNode <- newLocalNode testTransport initRemoteTable
368+ addr <- forkProcess localNode $ expect
369+ addr2 <- forkProcess localNode $ return ()
370+ putMVar processAddr addr
371+ readMVar monitorSetup
372+ NT.closeEndPoint (localEndPoint localNode)
373+ putMVar processAddr2 addr2
376+ localNode <- newLocalNode testTransport initRemoteTable
377+ theirAddr <- readMVar processAddr
378+ forkProcess localNode $ do
379+ lc <- liftIO $ readMVar processAddr2
381+ runProcess localNode $ do
382+ monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
386+-- | Test the math server (i.e., receiveWait)
387+testMath :: TestTransport -> Assertion
388+testMath TestTransport{..} = do
389+ serverAddr <- newEmptyMVar
390+ clientDone <- newEmptyMVar
394+ localNode <- newLocalNode testTransport initRemoteTable
395+ addr <- forkProcess localNode math
396+ putMVar serverAddr addr
400+ localNode <- newLocalNode testTransport initRemoteTable
401+ mathServer <- readMVar serverAddr
403+ runProcess localNode $ do
405+ send mathServer (Add pid 1 2)
406+ three <- expect :: Process Double
407+ send mathServer (Divide pid 8 2)
408+ four <- expect :: Process Double
409+ send mathServer (Divide pid 8 0)
411+ liftIO $ putMVar clientDone (three, four, divByZ)
413+ res <- takeMVar clientDone
415+ (3, 4, DivByZero) -> return ()
416+ _ -> error $ "Something went horribly wrong"
418+-- | Send first message (i.e. connect) to an already terminated process
419+-- (without monitoring); then send another message to a second process on
420+-- the same remote node (we're checking that the remote node did not die)
421+testSendToTerminated :: TestTransport -> Assertion
422+testSendToTerminated TestTransport{..} = do
423+ serverAddr1 <- newEmptyMVar
424+ serverAddr2 <- newEmptyMVar
425+ clientDone <- newEmptyMVar
428+ terminated <- newEmptyMVar
429+ localNode <- newLocalNode testTransport initRemoteTable
430+ addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
431+ addr2 <- forkProcess localNode $ ping
433+ putMVar serverAddr1 addr1
434+ putMVar serverAddr2 addr2
437+ localNode <- newLocalNode testTransport initRemoteTable
438+ server1 <- readMVar serverAddr1
439+ server2 <- readMVar serverAddr2
440+ runProcess localNode $ do
443+ send server2 (Pong pid)
444+ expectPing clientDone
446+ verifyClient "Expected Ping from server" clientDone
448+-- | Test (non-zero) timeout
449+testTimeout :: TestTransport -> Assertion
450+testTimeout TestTransport{..} = do
451+ localNode <- newLocalNode testTransport initRemoteTable
452+ done <- newEmptyMVar
454+ runProcess localNode $ do
455+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
456+ liftIO $ putMVar done $ res == Nothing
458+ verifyClient "Expected receiveTimeout to timeout..." done
460+-- | Test zero timeout
461+testTimeout0 :: TestTransport -> Assertion
462+testTimeout0 TestTransport{..} = do
463+ serverAddr <- newEmptyMVar
464+ clientDone <- newEmptyMVar
467+ localNode <- newLocalNode testTransport initRemoteTable
468+ addr <- forkProcess localNode $ do
469+ -- Variation on the venerable ping server which uses a zero timeout
470+ partner <- fix $ \loop ->
471+ receiveTimeout 0 [match (\(Pong partner) -> return partner)]
472+ >>= maybe (liftIO (threadDelay 100000) >> loop) return
474+ send partner (Ping self)
475+ putMVar serverAddr addr
478+ localNode <- newLocalNode testTransport initRemoteTable
479+ server <- readMVar serverAddr
480+ runProcess localNode $ do
482+ -- Send a bunch of messages. A large number of messages that the server
483+ -- is not interested in, and then a single message that it wants
484+ replicateM_ 10000 $ send server "Irrelevant message"
485+ send server (Pong pid)
486+ expectPing clientDone
488+ verifyClient "Expected Ping from server" clientDone
490+-- | Test typed channels
491+testTypedChannels :: TestTransport -> Assertion
492+testTypedChannels TestTransport{..} = do
493+ serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
494+ clientDone <- newEmptyMVar
497+ localNode <- newLocalNode testTransport initRemoteTable
498+ forkProcess localNode $ do
499+ (serverSendPort, rport) <- newChan
500+ liftIO $ putMVar serverChannel serverSendPort
501+ (clientSendPort, i) <- receiveChan rport
502+ sendChan clientSendPort (even i)
506+ localNode <- newLocalNode testTransport initRemoteTable
507+ serverSendPort <- readMVar serverChannel
508+ runProcess localNode $ do
509+ (clientSendPort, rport) <- newChan
510+ sendChan serverSendPort (clientSendPort, 5)
511+ ch <- receiveChan rport
512+ liftIO $ putMVar clientDone $ ch == False
514+ verifyClient "Expected channel to send 'False'" clientDone
516+-- | Test merging receive ports
517+testMergeChannels :: TestTransport -> Assertion
518+testMergeChannels TestTransport{..} = do
519+ localNode <- newLocalNode testTransport initRemoteTable
520+ testFlat localNode True "aaabbbccc"
521+ testFlat localNode False "abcabcabc"
522+ testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
523+ testNested localNode True False "adgadgadgbehbehbehcficficfi"
524+ testNested localNode False True "abcabcabcdefdefdefghighighi"
525+ testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
526+ testBlocked localNode True
527+ testBlocked localNode False
529+ -- Single layer of merging
530+ testFlat :: LocalNode -> Bool -> String -> IO ()
531+ testFlat localNode biased expected = do
532+ done <- newEmptyMVar
533+ forkProcess localNode $ do
534+ rs <- mapM charChannel "abc"
535+ m <- mergePorts biased rs
536+ xs <- replicateM 9 $ receiveChan m
537+ liftIO $ putMVar done $ xs == expected
538+ verifyClient "Expected single layer merge to match expected ordering" done
540+ -- Two layers of merging
541+ testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
542+ testNested localNode biasedInner biasedOuter expected = do
543+ done <- newEmptyMVar
544+ forkProcess localNode $ do
545+ rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
546+ ms <- mapM (mergePorts biasedInner) rss
547+ m <- mergePorts biasedOuter ms
548+ xs <- replicateM (9 * 3) $ receiveChan m
549+ liftIO $ putMVar done $ xs == expected
550+ verifyClient "Expected nested channels to match expeted ordering" done
552+ -- Test that if no messages are (immediately) available, the scheduler makes no difference
553+ testBlocked :: LocalNode -> Bool -> IO ()
554+ testBlocked localNode biased = do
555+ vs <- replicateM 3 newEmptyMVar
556+ done <- newEmptyMVar
558+ forkProcess localNode $ do
559+ ss <- liftIO $ mapM readMVar vs
562+ mapM_ ((>> pause 10000) . uncurry sendChan)
588+ _ -> die "Something went horribly wrong"
590+ forkProcess localNode $ do
591+ (ss, rs) <- unzip <$> replicateM 3 newChan
592+ liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
593+ m <- mergePorts biased rs
594+ xs <- replicateM (6 * 3) $ receiveChan m
595+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
597+ verifyClient "Expected merged ports to match expected ordering" done
599+ mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
600+ mergePorts True = mergePortsBiased
601+ mergePorts False = mergePortsRR
603+ charChannel :: Char -> Process (ReceivePort Char)
605+ (sport, rport) <- newChan
606+ replicateM_ 3 $ sendChan sport c
607+ liftIO $ threadDelay 10000 -- Make sure messages have been sent
610+testTerminate :: TestTransport -> Assertion
611+testTerminate TestTransport{..} = do
612+ localNode <- newLocalNode testTransport initRemoteTable
613+ runProcess localNode $ do
614+ e <- try terminate :: Process (Either ProcessTerminationException ())
615+ if either show show e == show ProcessTerminationException
617+ else die "Unexpected result from terminate"
619+testMonitorNode :: TestTransport -> Assertion
620+testMonitorNode TestTransport{..} = do
621+ [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
622+ done <- newEmptyMVar
624+ closeLocalNode node1
626+ runProcess node2 $ do
627+ ref <- monitorNode (localNodeId node1)
629+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
630+ return $ ref == ref' && nid == localNodeId node1)
631+ ] >>= liftIO . putMVar done
633+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
635+testMonitorLiveNode :: TestTransport -> Assertion
636+testMonitorLiveNode TestTransport{..} = do
637+ [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
638+ ready <- newEmptyMVar
639+ readyr <- newEmptyMVar
640+ done <- newEmptyMVar
642+ p <- forkProcess node1 $ return ()
643+ forkProcess node2 $ do
644+ ref <- monitorNode (localNodeId node1)
645+ liftIO $ putMVar ready ()
646+ liftIO $ takeMVar readyr
649+ match (\(NodeMonitorNotification ref' nid _) ->
650+ (return $ ref == ref' && nid == localNodeId node1))
651+ ] >>= liftIO . putMVar done
654+ closeLocalNode node1
657+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
659+testMonitorChannel :: TestTransport -> Assertion
660+testMonitorChannel TestTransport{..} = do
661+ [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
662+ gotNotification <- newEmptyMVar
664+ pid <- forkProcess node1 $ do
665+ sport <- expect :: Process (SendPort ())
666+ ref <- monitorPort sport
668+ -- reason might be DiedUnknownId if the receive port is GCed before the
669+ -- monitor is established (TODO: not sure that this is reasonable)
670+ match (\(PortMonitorNotification ref' port' reason) ->
671+ return $ ref' == ref && port' == sendPortId sport &&
672+ (reason == DiedNormal || reason == DiedUnknownId))
673+ ] >>= liftIO . putMVar gotNotification
675+ runProcess node2 $ do
676+ (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
678+ liftIO $ threadDelay 100000
680+ verifyClient "Expected PortMonitorNotification" gotNotification
682+testRegistry :: TestTransport -> Assertion
683+testRegistry TestTransport{..} = do
684+ node <- newLocalNode testTransport initRemoteTable
685+ done <- newEmptyMVar
687+ pingServer <- forkProcess node ping
688+ deadProcess <- forkProcess node (return ())
690+ runProcess node $ do
691+ register "ping" pingServer
692+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
694+ nsend "ping" (Pong us)
696+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
698+ checkRegException "dead" Nothing deadProcess
699+ checkRegException "ping" (Just pingServer) deadProcess
700+ try (unregister "dead") >>= checkReg "dead" Nothing
701+ liftIO $ putMVar done ()
706+ checkRegException name pid dead =
707+ try (register name dead) >>= checkReg name pid
709+ checkReg name pid res =
711+ Left (ProcessRegistrationException name pid) -> return ()
712+ _ -> die $ "Unexpected Registration" ++ show res
714+testRegistryRemoteProcess :: TestTransport -> Assertion
715+testRegistryRemoteProcess TestTransport{..} = do
716+ node1 <- newLocalNode testTransport initRemoteTable
717+ node2 <- newLocalNode testTransport initRemoteTable
718+ done <- newEmptyMVar
720+ pingServer <- forkProcess node1 ping
722+ runProcess node2 $ do
723+ register "ping" pingServer
724+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
726+ nsend "ping" (Pong us)
728+ matchIf (\(Ping pid') -> pingServer == pid')
729+ (const $ liftIO $ putMVar done ())
734+testRemoteRegistry :: TestTransport -> Assertion
735+testRemoteRegistry TestTransport{..} = do
736+ node1 <- newLocalNode testTransport initRemoteTable
737+ node2 <- newLocalNode testTransport initRemoteTable
739+ pingServer <- forkProcess node1 ping
740+ deadProcess <- forkProcess node1 (return ())
742+ runProcess node2 $ do
743+ let nid1 = localNodeId node1
744+ registerRemoteAsync nid1 "ping" pingServer
746+ matchIf (\(RegisterReply label' _ (Just pid)) ->
747+ "ping" == label' && pid == pingServer)
748+ (\(RegisterReply _ _ _) -> return ()) ]
750+ pid <- verifyWhereIsRemote nid1 "ping"
751+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
754+ nsendRemote nid1 "ping" (Pong us)
756+ match (\(Ping pid') -> return $ pingServer == pid')
757+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
759+ -- test that if process was not registered Nothing is returned
761+ registerRemoteAsync nid1 "dead" deadProcess
762+ receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
763+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764+ ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
766+ registerRemoteAsync nid1 "ping" deadProcess
768+ matchIf (\(RegisterReply label' False mPid) ->
769+ "ping" == label' && isJust mPid)
770+ (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771+ ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
773+ unregisterRemoteAsync nid1 "dead"
775+ matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776+ (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777+ ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
779+testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
780+testRemoteRegistryRemoteProcess TestTransport{..} = do
781+ node1 <- newLocalNode testTransport initRemoteTable
782+ node2 <- newLocalNode testTransport initRemoteTable
783+ done <- newEmptyMVar
785+ pingServer <- forkProcess node2 ping
787+ runProcess node2 $ do
788+ let nid1 = localNodeId node1
789+ registerRemoteAsync nid1 "ping" pingServer
791+ matchIf (\(RegisterReply label' _ _) -> "ping" == label')
792+ (\(RegisterReply _ _ _) -> return ()) ]
793+ pid <- verifyWhereIsRemote nid1 "ping"
794+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
796+ nsendRemote nid1 "ping" (Pong us)
798+ match (\(Ping pid') -> return $ pingServer == pid')
799+ ] >>= liftIO . putMVar done
801+ verifyClient "Expected Ping with ping server's ProcessId" done
803+testSpawnLocal :: TestTransport -> Assertion
804+testSpawnLocal TestTransport{..} = do
805+ node <- newLocalNode testTransport initRemoteTable
806+ done <- newEmptyMVar
808+ runProcess node $ do
811+ pid <- spawnLocal $ do
813+ sendChan sport (1234 :: Int)
815+ sport <- spawnChannelLocal $
816+ \rport -> (receiveChan rport :: Process Int) >>= send us
819+ expect >>= liftIO . putMVar done
821+ res <- takeMVar done
822+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
824+testSpawnAsyncStrictness :: TestTransport -> Assertion
825+testSpawnAsyncStrictness TestTransport{..} = do
826+ node <- newLocalNode testTransport initRemoteTable
827+ done <- newEmptyMVar
829+ runProcess node $ do
832+ ev <- try $ spawnAsync here (error "boom")
834+ Right _ -> putMVar done (error "Exception didn't fire")
835+ Left (_::SomeException) -> putMVar done (return ())
837+ join $ takeMVar done
839+testReconnect :: TestTransport -> Assertion
840+testReconnect TestTransport{..} = do
841+ [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
842+ let nid1 = localNodeId node1
843+ processA <- newEmptyMVar
844+ [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
846+ forkProcess node1 $ do
848+ liftIO $ putMVar processA us
852+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
853+ putMVar sendTestOk ()
855+ forkProcess node2 $ do
857+ - Make sure there is no implicit reconnect on normal message sending
860+ them <- liftIO $ readMVar processA
861+ send them "message 1" >> liftIO (threadDelay 100000)
863+ -- Simulate network failure
864+ liftIO $ syncBreakConnection testBreakConnection node1 node2
867+ -- Should not arrive
868+ send them "message 2"
872+ send them "message 3"
874+ liftIO $ takeMVar sendTestOk
877+ - Test that there *is* implicit reconnect on node controller messages
881+ registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
883+ matchIf (\(RegisterReply label' _ _) -> "a" == label')
884+ (\(RegisterReply _ _ _) -> return ()) ]
886+ _ <- whereisRemote nid1 "a"
889+ -- Simulate network failure
890+ liftIO $ syncBreakConnection testBreakConnection node1 node2
892+ -- This will happen due to implicit reconnect
893+ registerRemoteAsync nid1 "b" us
895+ matchIf (\(RegisterReply label' _ _) -> "b" == label')
896+ (\(RegisterReply _ _ _) -> return ()) ]
899+ registerRemoteAsync nid1 "c" us
901+ matchIf (\(RegisterReply label' _ _) -> "c" == label')
902+ (\(RegisterReply _ _ _) -> return ()) ]
905+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
906+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
907+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
908+ verifyWhereIsRemote nid1 "c"
910+ liftIO $ putMVar registerTestOk ()
912+ takeMVar registerTestOk
914+-- | Tests that unreliable messages arrive sorted even when there are connection
916+testUSend :: (ProcessId -> Int -> Process ())
917+ -> TestTransport -> Int -> Assertion
918+testUSend usendPrim TestTransport{..} numMessages = do
919+ [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
920+ let nid1 = localNodeId node1
921+ nid2 = localNodeId node2
922+ processA <- newEmptyMVar
923+ usendTestOk <- newEmptyMVar
925+ forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do
927+ liftIO $ putMVar processA us
931+ let -- Collects messages from 'them' until the sender dies.
932+ -- Disconnection notifications are ignored.
933+ receiveMessages :: Process [Int]
934+ receiveMessages = receiveWait
935+ [ match $ \mn -> case mn of
936+ ProcessMonitorNotification _ _ DiedDisconnect -> do
940+ , match $ \i -> fmap (i :) receiveMessages
942+ msgs <- receiveMessages
943+ let -- Checks that the input list is sorted.
944+ isSorted :: [Int] -> Bool
945+ isSorted (x : xs@(y : _)) = x <= y && isSorted xs
947+ -- The list can't be null since there are no failures after sending
948+ -- the last message.
949+ liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
951+ forkProcess node2 $ do
952+ them <- liftIO $ readMVar processA
953+ getSelfPid >>= send them
954+ expect :: Process ()
955+ forM_ [1..numMessages] $ \i -> do
956+ liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
958+ liftIO (threadDelay 30000)
960+ res <- takeMVar usendTestOk
961+ assertBool "Unexpected failure after sending last msg" res
963+-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
965+testMatchAny :: TestTransport -> Assertion
966+testMatchAny TestTransport{..} = do
967+ proxyAddr <- newEmptyMVar
968+ clientDone <- newEmptyMVar
972+ localNode <- newLocalNode testTransport initRemoteTable
973+ mathServer <- forkProcess localNode math
974+ proxyServer <- forkProcess localNode $ forever $ do
975+ msg <- receiveWait [ matchAny return ]
976+ forward msg mathServer
977+ putMVar proxyAddr proxyServer
981+ localNode <- newLocalNode testTransport initRemoteTable
982+ mathServer <- readMVar proxyAddr
984+ runProcess localNode $ do
986+ send mathServer (Add pid 1 2)
987+ three <- expect :: Process Double
988+ send mathServer (Divide pid 8 2)
989+ four <- expect :: Process Double
990+ send mathServer (Divide pid 8 0)
992+ liftIO $ putMVar clientDone (three, four, divByZ)
994+ res <- takeMVar clientDone
996+ (3, 4, DivByZero) -> return ()
997+ _ -> error "Unexpected result"
999+-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
1000+-- in between, however we block 'Divide' requests ....
1001+testMatchAnyHandle :: TestTransport -> Assertion
1002+testMatchAnyHandle TestTransport{..} = do
1003+ proxyAddr <- newEmptyMVar
1004+ clientDone <- newEmptyMVar
1008+ localNode <- newLocalNode testTransport initRemoteTable
1009+ mathServer <- forkProcess localNode math
1010+ proxyServer <- forkProcess localNode $ forever $ do
1012+ matchAny (maybeForward mathServer)
1014+ putMVar proxyAddr proxyServer
1018+ localNode <- newLocalNode testTransport initRemoteTable
1019+ mathServer <- readMVar proxyAddr
1021+ runProcess localNode $ do
1023+ send mathServer (Add pid 1 2)
1024+ three <- expect :: Process Double
1025+ send mathServer (Divide pid 8 2)
1026+ res <- (expectTimeout 100000) :: Process (Maybe Double)
1027+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1029+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
1031+ where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1032+ maybeForward s msg =
1033+ handleMessage msg (\m@(Add _ _ _) -> send s m)
1035+testMatchAnyNoHandle :: TestTransport -> Assertion
1036+testMatchAnyNoHandle TestTransport{..} = do
1037+ addr <- newEmptyMVar
1038+ clientDone <- newEmptyMVar
1039+ serverDone <- newEmptyMVar
1043+ localNode <- newLocalNode testTransport initRemoteTable
1044+ server <- forkProcess localNode $ forever $ do
1047+ -- the condition has type `Add -> Bool`
1048+ (\(Add _ _ _) -> True)
1049+ -- the match `AbstractMessage -> Process ()` will succeed!
1051+ -- `String -> Process ()` does *not* match the input types however
1052+ r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
1054+ Nothing -> return ()
1055+ Just _ -> die "NONSENSE")
1057+ -- we *must* have removed the message from our mailbox though!!!
1058+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1060+ assertBool "Expected timeout!" $ res == Nothing
1061+ putMVar serverDone ()
1062+ putMVar addr server
1066+ localNode <- newLocalNode testTransport initRemoteTable
1067+ server <- readMVar addr
1069+ runProcess localNode $ do
1071+ send server (Add pid 1 2)
1072+ -- we only care about the client having sent a message, so we're done
1073+ liftIO $ putMVar clientDone ()
1075+ takeMVar clientDone
1076+ takeMVar serverDone
1078+-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
1079+-- unless the text body @/= "bar"@ - this case should time out rather than
1080+-- removing the message from the process mailbox.
1081+testMatchAnyIf :: TestTransport -> Assertion
1082+testMatchAnyIf TestTransport{..} = do
1083+ echoAddr <- newEmptyMVar
1084+ clientDone <- newEmptyMVar
1088+ localNode <- newLocalNode testTransport initRemoteTable
1089+ echoServer <- forkProcess localNode $ forever $ do
1091+ matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
1094+ putMVar echoAddr echoServer
1098+ localNode <- newLocalNode testTransport initRemoteTable
1099+ server <- readMVar echoAddr
1101+ runProcess localNode $ do
1103+ send server (pid, "foo")
1105+ -- provoking what would be the wrong ordering is informative here...
1107+ send server (pid, "bar")
1108+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1110+ send server (pid, "baz")
1113+ liftIO $ putMVar clientDone (foo, bar, baz)
1115+ res <- takeMVar clientDone
1116+ let res' = res == ("foo", Nothing, "baz")
1117+ assertBool "Expected timeout due to type mismatch" res'
1119+ where tryHandleMessage :: Message -> Process (Maybe ())
1120+ tryHandleMessage msg =
1121+ handleMessage msg (\(pid :: ProcessId, (m :: String))
1122+ -> do { send pid m; return () })
1124+testMatchMessageWithUnwrap :: TestTransport -> Assertion
1125+testMatchMessageWithUnwrap TestTransport{..} = do
1126+ echoAddr <- newEmptyMVar
1127+ clientDone <- newEmptyMVar
1131+ localNode <- newLocalNode testTransport initRemoteTable
1132+ echoServer <- forkProcess localNode $ forever $ do
1133+ msg <- receiveWait [
1134+ matchMessage (\(m :: Message) -> do
1137+ unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
1139+ (Just (p, msg')) -> forward msg' p
1140+ Nothing -> die "unable to unwrap the message"
1141+ putMVar echoAddr echoServer
1145+ localNode <- newLocalNode testTransport initRemoteTable
1146+ server <- readMVar echoAddr
1148+ runProcess localNode $ do
1150+ send server (pid, wrapMessage ("foo" :: String))
1152+ send server (pid, wrapMessage ("baz" :: String))
1154+ liftIO $ putMVar clientDone (foo, baz)
1156+ res <- takeMVar clientDone
1157+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1159+-- Test 'receiveChanTimeout'
1160+testReceiveChanTimeout :: TestTransport -> Assertion
1161+testReceiveChanTimeout TestTransport{..} = do
1162+ done <- newEmptyMVar
1163+ mvSender <- newEmptyMVar
1164+ sendPort <- newEmptyMVar
1167+ localNode <- newLocalNode testTransport initRemoteTable
1168+ runProcess localNode $ do
1169+ -- Create a typed channel
1170+ (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1171+ liftIO $ putMVar sendPort sp
1173+ -- Wait for a message with a delay. No message arrives, we should get
1174+ -- Nothing after the delay.
1175+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1177+ -- Let the sender know that it can send a message.
1178+ liftIO $ putMVar mvSender ()
1180+ -- Wait for a message with a delay again. Now a message arrives after
1182+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1183+ liftIO $ assertBool "Expected result to be 'True'" res
1185+ -- Wait for a message with zero timeout: non-blocking check. No message is
1186+ -- available, we get Nothing
1187+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1189+ -- Let the sender know that it can send a message.
1190+ liftIO $ putMVar mvSender ()
1192+ -- Again, but now there is a message available
1194+ liftIO $ threadDelay 100000
1195+ mb <- receiveChanTimeout 0 rp
1197+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1200+ liftIO $ putMVar done ()
1203+ localNode <- newLocalNode testTransport initRemoteTable
1204+ runProcess localNode $ do
1205+ sp <- liftIO $ readMVar sendPort
1207+ liftIO $ takeMVar mvSender
1208+ liftIO $ threadDelay 100000
1211+ liftIO $ takeMVar mvSender
1216+-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1217+testReceiveChanFeatures :: TestTransport -> Assertion
1218+testReceiveChanFeatures TestTransport{..} = do
1219+ done <- newEmptyMVar
1222+ localNode <- newLocalNode testTransport initRemoteTable
1223+ runProcess localNode $ do
1224+ (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1225+ (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1227+ -- Test Functor instance
1230+ sendChan spBool False
1232+ rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1234+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1235+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1237+ -- Test Applicative instance
1242+ let rp2 = pure (+) <*> rpInt <*> rpInt
1244+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1246+ -- Test Alternative instance
1249+ sendChan spBool True
1251+ let rp3 = (even <$> rpInt) <|> rpBool
1253+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1254+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
1256+ -- Test Monad instance
1258+ sendChan spBool True
1259+ sendChan spBool False
1262+ let rp4 :: ReceivePort Int
1263+ rp4 = do b <- rpBool
1268+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1269+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1271+ liftIO $ putMVar done ()
1275+testChanLifecycle :: TestTransport -> Assertion
1276+testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1277+ result <- newEmptyMVar
1278+ tchMV <- newEmptyMVar
1279+ localNode <- newLocalNode testTransport initRemoteTable
1280+ runProcess localNode $ do
1282+ pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283+ liftIO $ putMVar tchMV tCh
1284+ expect :: Process ()
1287+ expect :: Process ()
1289+ mRefPid <- monitor pid
1291+ cPid <- spawnLocal $ do
1292+ (sp', rp) <- liftIO $ takeMVar tchMV
1293+ -- say "picked up our test channel"
1295+ -- say "told pid to continue"
1296+ res <- receiveChanTimeout delay rp
1298+ Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299+ Just () -> do mr <- monitor pid
1301+ -- say "sending pid a second () will cause it to exit"
1304+ -- say "make sure we see a DOWN notification for pid having stopped"
1305+ receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1307+ -- now that pid has died, the send port should be useless...
1308+ liftIO $ putMVar tchMV (sp', rp)
1310+ -- let's verify that we do not see the message from our
1311+ -- parent process on the channel, once pid has died...
1312+ recv <- receiveChanTimeout delay rp
1313+ -- say $ "finished waiting for second (), writing result" ++ (show recv)
1314+ liftIO $ putMVar result $ isNothing recv
1316+ mRefCPid <- monitor cPid
1319+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1323+ -- say "seen first pid die..."
1325+ (sendPort, _) <- liftIO $ takeMVar tchMV
1326+ sendChan sendPort ()
1327+ -- say "sent () after owning pid died"
1329+ -- let cPid know we've written to the channel...
1333+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1337+ -- say "seen both pids die now..."
1339+ -- and wait on the result back in IO land...
1340+ testRes <- takeMVar result
1341+ -- runProcess localNode $ say "got result..."
1342+ assertBool "Expected sending on the channel to fail, but received data!" testRes
1345+testKillLocal :: TestTransport -> Assertion
1346+testKillLocal TestTransport{..} = do
1347+ localNode <- newLocalNode testTransport initRemoteTable
1349+ pid <- forkProcess localNode $ do
1350+ liftIO $ threadDelay 1000000
1352+ runProcess localNode $ do
1355+ kill pid "TestKill"
1358+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1359+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1361+ False -> die "Invalid ProcessMonitorNotification received"
1362+ _ -> die "Something went horribly wrong"
1364+testKillRemote :: TestTransport -> Assertion
1365+testKillRemote TestTransport{..} = do
1366+ node1 <- newLocalNode testTransport initRemoteTable
1367+ node2 <- newLocalNode testTransport initRemoteTable
1369+ pid <- forkProcess node1 $ do
1370+ liftIO $ threadDelay 1000000
1372+ runProcess node2 $ do
1375+ kill pid "TestKill"
1378+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1379+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1380+ (True, True, True) -> return ()
1382+ let a' = if a then "" else "Invalid ref"
1383+ let b' = if b then "" else "Invalid pid"
1384+ let c' = if c then "" else "Invalid message"
1385+ die $ unwords [a', b', c']
1386+ _ -> die "Received unexpected message"
1388+testCatchesExit :: TestTransport -> Assertion
1389+testCatchesExit TestTransport{..} = do
1390+ localNode <- newLocalNode testTransport initRemoteTable
1391+ done <- newEmptyMVar
1393+ _ <- forkProcess localNode $ do
1394+ (die ("foobar", 123 :: Int))
1396+ (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1397+ , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1398+ , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1399+ -> (liftIO $ putMVar done ()) >> return ()))
1404+testHandleMessageIf :: TestTransport -> Assertion
1405+testHandleMessageIf TestTransport{..} = do
1406+ localNode <- newLocalNode testTransport initRemoteTable
1407+ done <- newEmptyMVar
1408+ _ <- forkProcess localNode $ do
1410+ send self (5 :: Integer, 10 :: Integer)
1411+ msg <- receiveWait [ matchMessage return ]
1412+ handleMessageIf msg
1414+ (\() -> die "whoops") >>= maybe (return ())
1415+ (const $ die "Expected Mismatch")
1416+ handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1417+ (\input -> liftIO $ putMVar done input)
1420+ result <- takeMVar done
1421+ expectThat result $ equalTo (5, 10)
1423+testCatches :: TestTransport -> Assertion
1424+testCatches TestTransport{..} = do
1425+ localNode <- newLocalNode testTransport initRemoteTable
1426+ done <- newEmptyMVar
1428+ _ <- forkProcess localNode $ do
1429+ node <- getSelfNode
1430+ (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1432+ Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1437+testMaskRestoreScope :: TestTransport -> Assertion
1438+testMaskRestoreScope TestTransport{..} = do
1439+ localNode <- newLocalNode testTransport initRemoteTable
1440+ parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1441+ spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1443+ void $ runProcess localNode $ mask $ \unmask -> do
1444+ getSelfPid >>= liftIO . putMVar parentPid
1445+ void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1447+ parent <- liftIO $ takeMVar parentPid
1448+ child <- liftIO $ takeMVar spawnedPid
1449+ expectThat parent $ isNot $ equalTo child
1451+testDie :: TestTransport -> Assertion
1452+testDie TestTransport{..} = do
1453+ localNode <- newLocalNode testTransport initRemoteTable
1454+ done <- newEmptyMVar
1456+ _ <- forkProcess localNode $ do
1457+ (die ("foobar", 123 :: Int))
1458+ `catchExit` \_from reason -> do
1459+ -- TODO: should verify that 'from' has the right value
1460+ let res = reason == ("foobar", 123 :: Int)
1461+ liftIO $ putMVar done ()
1464+ else die "Something went horribly wrong"
1468+testPrettyExit :: TestTransport -> Assertion
1469+testPrettyExit TestTransport{..} = do
1470+ localNode <- newLocalNode testTransport initRemoteTable
1471+ done <- newEmptyMVar
1473+ _ <- forkProcess localNode $ do
1475+ `catch` \ex@(ProcessExitException from _) ->
1476+ let expected = "exit-from=" ++ (show from)
1478+ let res = (show ex) == expected
1479+ liftIO $ putMVar done ()
1482+ else die "Something went horribly wrong"
1486+testExitLocal :: TestTransport -> Assertion
1487+testExitLocal TestTransport{..} = do
1488+ localNode <- newLocalNode testTransport initRemoteTable
1489+ supervisedDone <- newEmptyMVar
1490+ supervisorDone <- newEmptyMVar
1491+ -- XXX: we guarantee that exception handler will be set up
1492+ -- regardless if forkProcess preserve masking state or not.
1493+ handlerSetUp <- newEmptyMVar
1495+ pid <- forkProcess localNode $ do
1496+ (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1497+ -- TODO: should verify that 'from' has the right value
1498+ res <- return $ reason == "TestExit"
1499+ liftIO $ putMVar supervisedDone ()
1502+ else die "Something went horribly wrong"
1504+ runProcess localNode $ do
1505+ liftIO $ takeMVar handlerSetUp
1507+ exit pid "TestExit"
1508+ -- This time the client catches the exception, so it dies normally
1511+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1512+ let res = ref == ref' && pid == pid'
1513+ liftIO $ putMVar supervisorDone ()
1516+ else die "Something went horribly wrong"
1517+ _ -> die "Something went horribly wrong"
1519+ takeMVar supervisedDone
1520+ takeMVar supervisorDone
1522+testExitRemote :: TestTransport -> Assertion
1523+testExitRemote TestTransport{..} = do
1524+ node1 <- newLocalNode testTransport initRemoteTable
1525+ node2 <- newLocalNode testTransport initRemoteTable
1526+ supervisedDone <- newEmptyMVar
1527+ supervisorDone <- newEmptyMVar
1529+ pid <- forkProcess node1 $ do
1530+ (receiveWait [] :: Process ()) -- block forever
1531+ `catchExit` \_from reason -> do
1532+ -- TODO: should verify that 'from' has the right value
1533+ res <- return $ reason == "TestExit"
1534+ liftIO $ putMVar supervisedDone ()
1537+ else die "Something went horribly wrong"
1539+ runProcess node2 $ do
1541+ exit pid "TestExit"
1544+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1545+ res' <- return $ ref == ref' && pid == pid'
1546+ liftIO $ putMVar supervisorDone ()
1549+ else die "Something went horribly wrong"
1550+ _ -> die "Something went horribly wrong"
1552+ takeMVar supervisedDone
1553+ takeMVar supervisorDone
1555+testRegistryMonitoring :: TestTransport -> Assertion
1556+testRegistryMonitoring TestTransport{..} = do
1557+ node1 <- newLocalNode testTransport initRemoteTable
1558+ node2 <- newLocalNode testTransport initRemoteTable
1560+ let nid = localNodeId node2
1561+ pid <- forkProcess node1 $ do
1563+ runUntilRegistered nid self
1564+ say $ (show self) ++ " registered as " ++ regName
1565+ expect :: Process ()
1566+ say $ (show self) ++ " exiting normally"
1568+ runProcess node2 $ do
1569+ register regName pid
1570+ say $ regName ++ " registered to " ++ show pid
1571+ res <- whereis regName
1573+ say $ " sent finish signal to " ++ show pid
1575+ liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
1578+ -- This delay isn't essential!
1579+ -- The test case passes perfectly fine without it (feel free to comment out
1580+ -- and see), however waiting a few seconds here, makes it much more likely
1581+ -- that in delayUntilMaybeUnregistered we will hit the match case right
1582+ -- away, and thus not be subjected to a 20 second delay. The value of 4
1583+ -- seconds appears to work optimally on osx and across several linux distros
1584+ -- running in virtual machines (which is essentially what we do in CI)
1585+ void $ receiveTimeout 4000000 [ matchAny return ]
1587+ -- This delay doesn't serve much purpose in the happy path, however if some
1588+ -- future patch breaks the cooperative behaviour of node controllers viz
1589+ -- remote process registration and notification taking place via ncEffectDied,
1590+ -- there would be the possibility of a race in the test case should we attempt
1591+ -- to evaluate `whereis regName` on node2 right away. In case the name is still
1592+ -- erroneously registered, observing the 20 second delay (or lack of), could at
1593+ -- least give a hint that something is wrong, and we give up our time slice
1594+ -- so that there's a higher change the registrations have been cleaned up
1596+ runProcess node2 $ delayUntilMaybeUnregistered nid pid
1598+ regHere <- newEmptyMVar
1599+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600+ res <- takeMVar regHere
1602+ Nothing -> return ()
1603+ Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1606+ runUntilRegistered nid us = do
1607+ whereisRemoteAsync nid regName
1609+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610+ (const $ return ())
1613+ delayUntilMaybeUnregistered nid p = do
1614+ whereisRemoteAsync nid regName
1615+ res <- receiveTimeout 20000000 {- 20 sec delay -} [
1616+ matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)
1617+ (const $ return ())
1620+ Just () -> return ()
1621+ Nothing -> delayUntilMaybeUnregistered nid p
1623+ regName = "testRegisterRemote"
1625+testUnsafeSend :: TestTransport -> Assertion
1626+testUnsafeSend TestTransport{..} = do
1627+ serverAddr <- newEmptyMVar
1628+ clientDone <- newEmptyMVar
1630+ localNode <- newLocalNode testTransport initRemoteTable
1631+ void $ forkProcess localNode $ do
1633+ liftIO $ putMVar serverAddr self
1634+ clientAddr <- expect
1635+ unsafeSend clientAddr ()
1637+ void $ forkProcess localNode $ do
1638+ serverPid <- liftIO $ takeMVar serverAddr
1639+ getSelfPid >>= unsafeSend serverPid
1640+ expect >>= liftIO . putMVar clientDone
1642+ takeMVar clientDone
1644+testUnsafeUSend :: TestTransport -> Assertion
1645+testUnsafeUSend TestTransport{..} = do
1646+ serverAddr <- newEmptyMVar
1647+ clientDone <- newEmptyMVar
1649+ localNode <- newLocalNode testTransport initRemoteTable
1650+ void $ forkProcess localNode $ do
1652+ liftIO $ putMVar serverAddr self
1653+ clientAddr <- expect
1654+ unsafeUSend clientAddr ()
1656+ void $ forkProcess localNode $ do
1657+ serverPid <- liftIO $ takeMVar serverAddr
1658+ getSelfPid >>= unsafeUSend serverPid
1659+ expect >>= liftIO . putMVar clientDone
1661+ takeMVar clientDone
1663+testUnsafeNSend :: TestTransport -> Assertion
1664+testUnsafeNSend TestTransport{..} = do
1665+ clientDone <- newEmptyMVar
1667+ localNode <- newLocalNode testTransport initRemoteTable
1669+ pid <- forkProcess localNode $ do
1670+ expect >>= liftIO . putMVar clientDone
1672+ void $ runProcess localNode $ do
1673+ register "foobar" pid
1674+ unsafeNSend "foobar" ()
1676+ takeMVar clientDone
1678+testUnsafeNSendRemote :: TestTransport -> Assertion
1679+testUnsafeNSendRemote TestTransport{..} = do
1680+ clientDone <- newEmptyMVar
1682+ localNode1 <- newLocalNode testTransport initRemoteTable
1683+ localNode2 <- newLocalNode testTransport initRemoteTable
1685+ _ <- forkProcess localNode1 $ do
1686+ getSelfPid >>= register "foobar"
1687+ liftIO $ putMVar clientDone ()
1688+ expect >>= liftIO . putMVar clientDone
1690+ takeMVar clientDone
1691+ void $ runProcess localNode2 $ do
1692+ unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1694+ takeMVar clientDone
1696+testUnsafeSendChan :: TestTransport -> Assertion
1697+testUnsafeSendChan TestTransport{..} = do
1698+ serverAddr <- newEmptyMVar
1699+ clientDone <- newEmptyMVar
1701+ localNode <- newLocalNode testTransport initRemoteTable
1702+ void $ forkProcess localNode $ do
1704+ liftIO $ putMVar serverAddr self
1706+ unsafeSendChan sp ()
1708+ void $ forkProcess localNode $ do
1709+ serverPid <- liftIO $ takeMVar serverAddr
1710+ (sp, rp) <- newChan
1711+ unsafeSend serverPid sp
1712+ receiveChan rp :: Process ()
1713+ liftIO $ putMVar clientDone ()
1715+ takeMVar clientDone
1717+testCallLocal :: TestTransport -> Assertion
1718+testCallLocal TestTransport{..} = do
1719+ node <- newLocalNode testTransport initRemoteTable
1721+ -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1722+ result <- newEmptyMVar
1723+ runProcess node $ do
1724+ r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1725+ liftIO $ putMVar result r
1727+ takeMVar result >>= assertBool "Expected 'True'"
1729+ -- Testing that when callLocal is interrupted, the worker is interrupted.
1730+ ibox <- newIORef False
1731+ runProcess node $ do
1732+ keeper <- getSelfPid
1734+ caller <- getSelfPid
1738+ onException (do send keeper caller
1740+ (do liftIO $ writeIORef ibox True))
1744+ expect :: Process ()
1746+ readIORef ibox >>= assertBool "Expected 'True'"
1748+ -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1749+ ibox2 <- newIORef False
1750+ runProcess node $ do
1751+ r <- try (callLocal $ error "e" >> return ())
1752+ liftIO $ writeIORef ibox2 $ case r of
1753+ Left (ErrorCall "e") -> True
1756+ readIORef ibox >>= assertBool "Expected 'True'"
1758+ -- Test that caller waits for the worker in correct situation
1759+ ibox3 <- newIORef False
1760+ result3 <- newEmptyMVar
1761+ runProcess node $ do
1762+ keeper <- getSelfPid
1765+ (do us <- getSelfPid
1769+ `finally` (liftIO $ writeIORef ibox3 True)
1770+ liftIO $ putMVar result3 =<< readIORef ibox3
1774+ takeMVar result3 >>= assertBool "Expected 'True'"
1776+ -- Test that caller waits for the worker in case when caller gets an exception
1777+ ibox4 <- newIORef False
1778+ result4 <- newEmptyMVar
1779+ runProcess node $ do
1780+ keeper <- getSelfPid
1782+ caller <- getSelfPid
1784+ ((do send keeper caller
1786+ `finally` (liftIO $ writeIORef ibox4 True))
1787+ `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1791+ takeMVar result4 >>= assertBool "Expected 'True'"
1792+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1794+tests :: TestTransport -> IO [Test]
1795+tests testtrans = return [
1796+ testGroup "Basic features" [
1797+ testCase "Ping" (testPing testtrans)
1798+ , testCase "Math" (testMath testtrans)
1799+ , testCase "Timeout" (testTimeout testtrans)
1800+ , testCase "Timeout0" (testTimeout0 testtrans)
1801+ , testCase "SendToTerminated" (testSendToTerminated testtrans)
1802+ , testCase "TypedChannnels" (testTypedChannels testtrans)
1803+ , testCase "Terminate" (testTerminate testtrans)
1804+ , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1805+ , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1806+ , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1807+ , testCase "SpawnLocal" (testSpawnLocal testtrans)
1808+ , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1809+ , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1810+ , testCase "MatchAny" (testMatchAny testtrans)
1811+ , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1812+ , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1813+ , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1814+ , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1815+ , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1816+ , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)
1818+ , testCase "KillLocal" (testKillLocal testtrans)
1819+ , testCase "KillRemote" (testKillRemote testtrans)
1820+ , testCase "Die" (testDie testtrans)
1821+ , testCase "PrettyExit" (testPrettyExit testtrans)
1822+ , testCase "CatchesExit" (testCatchesExit testtrans)
1823+ , testCase "Catches" (testCatches testtrans)
1824+ , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1825+ , testCase "ExitLocal" (testExitLocal testtrans)
1826+ , testCase "ExitRemote" (testExitRemote testtrans)
1827+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1828+ , testCase "TextCallLocal" (testCallLocal testtrans)
1829+ -- Unsafe Primitives
1830+ , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1831+ , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1832+ , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1833+ , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1834+ , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1836+ , testCase "USend" (testUSend usend testtrans 50)
1837+ , testCase "UForward"
1838+ (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1842+ , testGroup "Monitoring and Linking" [
1843+ -- Monitoring processes
1845+ -- The "missing" combinations in the list below don't make much sense, as
1846+ -- we cannot guarantee that the monitor reply or link exception will not
1847+ -- happen before the unmonitor or unlink
1848+ testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1849+ , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1850+ , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1851+ , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1852+ , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1853+ , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1854+ , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1855+ , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1856+ , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1857+ , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1858+ , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1859+ , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1860+ , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1861+ , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1862+ , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1863+ , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1864+ , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1865+ -- Monitoring nodes and channels
1866+ , testCase "MonitorNode" (testMonitorNode testtrans)
1867+ , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1868+ , testCase "MonitorChannel" (testMonitorChannel testtrans)
1872+ -- Tests that fail occasionally and should be revised
1873+ , testGroup "Flaky" [
1874+ testCase "Reconnect" (testReconnect testtrans)
1875+ , testCase "Registry" (testRegistry testtrans)
1876+ , testCase "MergeChannels" (testMergeChannels testtrans)
1877+ , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)