@@ -1,1879 +0,0 @@
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)