git.iko.soy/distributed-process
on master help sign in
make it possible to verify against latest snapshot on stackage
bbb3a2eTim Watson
benchmarks/Channels.hs+6−5
compare with master
unifiedsplit
@@ -4,7 +4,7 @@ import Control.Monad
4import Control.Applicative
4import Control.Applicative
5import Control.Distributed.Process
5import Control.Distributed.Process
6import Control.Distributed.Process.Node
6import Control.Distributed.Process.Node
7−import Network.Transport.TCP (createTransport, defaultTCPParameters)
7+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
8import Data.Binary (encode, decode)
8import Data.Binary (encode, decode)
9import qualified Data.ByteString.Lazy as BSL
9import qualified Data.ByteString.Lazy as BSL
10
10
@@ -36,7 +36,8 @@ initialProcess "CLIENT" = do
36main :: IO ()
36main :: IO ()
37main = do
37main = do
38 [role, host, port] <- getArgs
38 [role, host, port] <- getArgs
39− Right transport <- createTransport
40− host port (\sn -> (host, port)) defaultTCPParameters
39+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
40+ case trans of
41− node <- newLocalNode transport initRemoteTable
41+ Right transport -> do node <- newLocalNode transport initRemoteTable
42− runProcess node $ initialProcess role
42+ runProcess node $ initialProcess role
43+ Left other -> error $ show other
benchmarks/Latency.hs+7−5
@@ -3,7 +3,7 @@ import Control.Monad
3import Control.Applicative
3import Control.Applicative
4import Control.Distributed.Process
4import Control.Distributed.Process
5import Control.Distributed.Process.Node
5import Control.Distributed.Process.Node
6−import Network.Transport.TCP (createTransport, defaultTCPParameters)
6+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
7import Data.Binary (encode, decode)
7import Data.Binary (encode, decode)
8import qualified Data.ByteString.Lazy as BSL
8import qualified Data.ByteString.Lazy as BSL
9
9
@@ -31,7 +31,9 @@ initialProcess "CLIENT" = do
31main :: IO ()
31main :: IO ()
32main = do
32main = do
33 [role, host, port] <- getArgs
33 [role, host, port] <- getArgs
34− Right transport <- createTransport
34+ trans <- createTransport
35− host port (\sn -> (host, sn)) defaultTCPParameters
35+ (defaultTCPAddr host port) defaultTCPParameters
36+ case trans of
36− node <- newLocalNode transport initRemoteTable
37+ Right transport -> do node <- newLocalNode transport initRemoteTable
37− runProcess node $ initialProcess role
38+ runProcess node $ initialProcess role
39+ Left other -> error $ show other
benchmarks/ProcessRing.hs+2−2
@@ -12,7 +12,7 @@ import Control.Monad
12import Control.Distributed.Process hiding (catch)
12import Control.Distributed.Process hiding (catch)
13import Control.Distributed.Process.Node
13import Control.Distributed.Process.Node
14import Control.Exception (catch, SomeException)
14import Control.Exception (catch, SomeException)
15−import Network.Transport.TCP (createTransport, defaultTCPParameters)
15+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
16import System.Environment
16import System.Environment
17import System.Console.GetOpt
17import System.Console.GetOpt
18
18
@@ -111,7 +111,7 @@ main = do
111 (opt, _) <- parseArgv argv
111 (opt, _) <- parseArgv argv
112 putStrLn $ "options: " ++ (show opt)
112 putStrLn $ "options: " ++ (show opt)
113 Right transport <- createTransport
113 Right transport <- createTransport
114− "127.0.0.1" "8090" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters
114+ (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters
115 node <- newLocalNode transport initRemoteTable
115 node <- newLocalNode transport initRemoteTable
116 catch (void $ runProcess node $ initialProcess opt)
116 catch (void $ runProcess node $ initialProcess opt)
117 (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
117 (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
benchmarks/Spawns.hs+6−5
@@ -7,7 +7,7 @@ import Control.Monad
7import Control.Applicative
7import Control.Applicative
8import Control.Distributed.Process
8import Control.Distributed.Process
9import Control.Distributed.Process.Node
9import Control.Distributed.Process.Node
10−import Network.Transport.TCP (createTransport, defaultTCPParameters)
10+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
11import Data.Binary (encode, decode)
11import Data.Binary (encode, decode)
12import qualified Data.ByteString.Lazy as BSL
12import qualified Data.ByteString.Lazy as BSL
13
13
@@ -42,7 +42,8 @@ initialProcess "CLIENT" = do
42main :: IO ()
42main :: IO ()
43main = do
43main = do
44 [role, host, port] <- getArgs
44 [role, host, port] <- getArgs
45− Right transport <- createTransport
46− host port (\sn -> (host, sn)) defaultTCPParameters
45+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
46+ case trans of
47− node <- newLocalNode transport initRemoteTable
47+ Right transport -> do node <- newLocalNode transport initRemoteTable
48− runProcess node $ initialProcess role
48+ runProcess node $ initialProcess role
49+ Left other -> error $ show other
benchmarks/Throughput.hs+6−5
@@ -6,7 +6,7 @@ import Control.Monad
6import Control.Applicative
6import Control.Applicative
7import Control.Distributed.Process
7import Control.Distributed.Process
8import Control.Distributed.Process.Node
8import Control.Distributed.Process.Node
9−import Network.Transport.TCP (createTransport, defaultTCPParameters)
9+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)
10import Data.Binary
10import Data.Binary
11import qualified Data.ByteString.Lazy as BSL
11import qualified Data.ByteString.Lazy as BSL
12import Data.Typeable
12import Data.Typeable
@@ -67,7 +67,8 @@ initialProcess "CLIENT" = do
67main :: IO ()
67main :: IO ()
68main = do
68main = do
69 [role, host, port] <- getArgs
69 [role, host, port] <- getArgs
70− Right transport <- createTransport
71− host port (\sn -> (host, sn)) defaultTCPParameters
70+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
71+ case trans of
72− node <- newLocalNode transport initRemoteTable
72+ Right transport -> do node <- newLocalNode transport initRemoteTable
73− runProcess node $ initialProcess role
73+ runProcess node $ initialProcess role
74+ Left other -> error $ show other
distributed-process-tests/distributed-process-tests.cabal+7−7
@@ -33,7 +33,7 @@ library
33 distributed-static,
33 distributed-static,
34 HUnit >= 1.2 && < 1.7,
34 HUnit >= 1.2 && < 1.7,
35 network-transport >= 0.4.1.0 && < 0.6,
35 network-transport >= 0.4.1.0 && < 0.6,
36− network >= 2.5 && < 2.7,
36+ network >= 2.5 && < 2.9,
37 random >= 1.0 && < 1.2,
37 random >= 1.0 && < 1.2,
38 rematch >= 0.1.2.1,
38 rematch >= 0.1.2.1,
39 setenv >= 0.1.1.3,
39 setenv >= 0.1.1.3,
@@ -60,7 +60,7 @@ Test-Suite TestCHInMemory
60 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
60 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
61 Build-Depends: base >= 4.4 && < 5,
61 Build-Depends: base >= 4.4 && < 5,
62 distributed-process-tests,
62 distributed-process-tests,
63− network >= 2.3 && < 2.7,
63+ network >= 2.3 && < 2.9,
64 network-transport >= 0.4.1.0 && < 0.6,
64 network-transport >= 0.4.1.0 && < 0.6,
65 network-transport-inmemory >= 0.5,
65 network-transport-inmemory >= 0.5,
66 test-framework >= 0.6 && < 0.9
66 test-framework >= 0.6 && < 0.9
@@ -75,7 +75,7 @@ Test-Suite TestCHInTCP
75 if flag(tcp)
75 if flag(tcp)
76 Build-Depends: base >= 4.4 && < 5,
76 Build-Depends: base >= 4.4 && < 5,
77 distributed-process-tests,
77 distributed-process-tests,
78− network >= 2.3 && < 2.7,
78+ network >= 2.3 && < 2.9,
79 network-transport >= 0.4.1.0 && < 0.6,
79 network-transport >= 0.4.1.0 && < 0.6,
80 network-transport-tcp >= 0.5 && < 0.7,
80 network-transport-tcp >= 0.5 && < 0.7,
81 test-framework >= 0.6 && < 0.9
81 test-framework >= 0.6 && < 0.9
@@ -92,7 +92,7 @@ Test-Suite TestClosure
92 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure
92 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure
93 Build-Depends: base >= 4.4 && < 5,
93 Build-Depends: base >= 4.4 && < 5,
94 distributed-process-tests,
94 distributed-process-tests,
95− network >= 2.3 && < 2.7,
95+ network >= 2.3 && < 2.9,
96 network-transport >= 0.4.1.0 && < 0.6,
96 network-transport >= 0.4.1.0 && < 0.6,
97 network-transport-inmemory >= 0.5,
97 network-transport-inmemory >= 0.5,
98 test-framework >= 0.6 && < 0.9
98 test-framework >= 0.6 && < 0.9
@@ -106,7 +106,7 @@ Test-Suite TestStats
106 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats
106 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats
107 Build-Depends: base >= 4.4 && < 5,
107 Build-Depends: base >= 4.4 && < 5,
108 distributed-process-tests,
108 distributed-process-tests,
109− network >= 2.3 && < 2.7,
109+ network >= 2.3 && < 2.9,
110 network-transport >= 0.4.1.0 && < 0.6,
110 network-transport >= 0.4.1.0 && < 0.6,
111 network-transport-inmemory >= 0.5,
111 network-transport-inmemory >= 0.5,
112 test-framework >= 0.6 && < 0.9
112 test-framework >= 0.6 && < 0.9
@@ -121,7 +121,7 @@ Test-Suite TestMx
121 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
121 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
122 Build-Depends: base >= 4.4 && < 5,
122 Build-Depends: base >= 4.4 && < 5,
123 distributed-process-tests,
123 distributed-process-tests,
124− network >= 2.3 && < 2.7,
124+ network >= 2.3 && < 2.9,
125 network-transport >= 0.4.1.0 && < 0.6,
125 network-transport >= 0.4.1.0 && < 0.6,
126 network-transport-inmemory >= 0.5,
126 network-transport-inmemory >= 0.5,
127 test-framework >= 0.6 && < 0.9
127 test-framework >= 0.6 && < 0.9
@@ -135,7 +135,7 @@ Test-Suite TestTracing
135 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing
135 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing
136 Build-Depends: base >= 4.4 && < 5,
136 Build-Depends: base >= 4.4 && < 5,
137 distributed-process-tests,
137 distributed-process-tests,
138− network >= 2.3 && < 2.7,
138+ network >= 2.3 && < 2.9,
139 network-transport >= 0.4.1.0 && < 0.6,
139 network-transport >= 0.4.1.0 && < 0.6,
140 network-transport-inmemory >= 0.5,
140 network-transport-inmemory >= 0.5,
141 test-framework >= 0.6 && < 0.9
141 test-framework >= 0.6 && < 0.9
distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+296−212
@@ -39,7 +39,7 @@ import Control.Distributed.Process.Internal.Types
39import Control.Distributed.Process.Node
39import Control.Distributed.Process.Node
40import Control.Distributed.Process.Serializable (Serializable)
40import Control.Distributed.Process.Serializable (Serializable)
41
41
42−import Test.HUnit (Assertion, assertFailure)
42+import Test.HUnit (Assertion, assertBool, assertFailure)
43import Test.Framework (Test, testGroup)
43import Test.Framework (Test, testGroup)
44import Test.Framework.Providers.HUnit (testCase)
44import Test.Framework.Providers.HUnit (testCase)
45import Control.Rematch hiding (match)
45import Control.Rematch hiding (match)
@@ -75,12 +75,47 @@ ping = do
75 send partner (Ping self)
75 send partner (Ping self)
76 ping
76 ping
77
77
78+verifyClient :: String -> MVar Bool -> IO ()
79+verifyClient s b = takeMVar b >>= assertBool s
80+
81+expectPing :: MVar Bool -> Process ()
82+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
83+ where
84+ checkPing (Ping _) = True
85+ checkPing _ = False
86+
78-- | Quick and dirty synchronous version of whereisRemoteAsync
87-- | Quick and dirty synchronous version of whereisRemoteAsync
79whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
88whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
80whereisRemote nid string = do
89whereisRemote nid string = do
81 whereisRemoteAsync nid string
90 whereisRemoteAsync nid string
91+ receiveWait [
82− WhereIsReply _ mPid <- expect
92+ match (\(WhereIsReply _ mPid) -> return mPid)
93+ ]
94+
95+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
96+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
97+
98+waitForExit :: ProcessId -> Process DiedReason
99+waitForExit pid = monitor pid >>= waitForDown
100+
101+waitForDown :: MonitorRef -> Process DiedReason
102+waitForDown ref =
103+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
104+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
105+
106+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
107+syncBreakConnection breakConnection nid0 nid1 = do
108+ m <- newEmptyMVar
109+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
110+ runProcess nid0 $ do
111+ them <- liftIO $ takeMVar m
112+ pinger <- spawnLocal $ forever $ send them ()
113+ _ <- monitorNode (localNodeId nid1)
114+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
115+ (nodeAddress $ localNodeId nid1)
116+ NodeMonitorNotification _ _ _ <- expect
117+ kill pinger "finished"
83− return mPid
118+ return ()
84
119
85data Add = Add ProcessId Double Double deriving (Typeable)
120data Add = Add ProcessId Double Double deriving (Typeable)
86data Divide = Divide ProcessId Double Double deriving (Typeable)
121data Divide = Divide ProcessId Double Double deriving (Typeable)
@@ -155,12 +190,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
155 unmonitor ref
190 unmonitor ref
156 liftIO $ putMVar done ()
191 liftIO $ putMVar done ()
157 (False, ref) -> do
192 (False, ref) -> do
193+ receiveWait [
158− ProcessMonitorNotification ref' pid reason' <- expect
194+ match (\(ProcessMonitorNotification ref' pid reason') -> do
195+ liftIO $ do
196+ assertBool "Bad Monitor Signal"
159− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
197+ (Just ref' == ref && pid == theirAddr &&
198+ mOrL && reason == reason')
160− liftIO $ putMVar done ()
199+ putMVar done ())
200+ ]
161 )
201 )
162 (\(ProcessLinkException pid reason') -> do
202 (\(ProcessLinkException pid reason') -> do
203+ (liftIO $ assertBool "link exception unmatched" $
163− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
204+ pid == theirAddr && not mOrL && not un && reason == reason')
164 liftIO $ putMVar done ()
205 liftIO $ putMVar done ()
165 )
206 )
166
207
@@ -191,8 +232,10 @@ testPing TestTransport{..} = do
191 pid <- getSelfPid
232 pid <- getSelfPid
192 replicateM_ numPings $ do
233 replicateM_ numPings $ do
193 send pingServer (Pong pid)
234 send pingServer (Pong pid)
194− Ping _ <- expect
235+ p <- expect
236+ case p of
195− return ()
237+ Ping _ -> return ()
238+ _ -> die "Unexpected message"
196
239
197 putMVar clientDone ()
240 putMVar clientDone ()
198
241
@@ -279,7 +322,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
279 runProcess localNode $ do
322 runProcess localNode $ do
280 monitor theirAddr
323 monitor theirAddr
281 -- wait for the process to die
324 -- wait for the process to die
282− ProcessMonitorNotification _ _ _ <- expect
325+ expect :: Process ProcessMonitorNotification
283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
326 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
284
327
285 takeMVar done
328 takeMVar done
@@ -353,14 +396,17 @@ testMath TestTransport{..} = do
353 runProcess localNode $ do
396 runProcess localNode $ do
354 pid <- getSelfPid
397 pid <- getSelfPid
355 send mathServer (Add pid 1 2)
398 send mathServer (Add pid 1 2)
356− 3 <- expect :: Process Double
399+ three <- expect :: Process Double
357 send mathServer (Divide pid 8 2)
400 send mathServer (Divide pid 8 2)
358− 4 <- expect :: Process Double
401+ four <- expect :: Process Double
359 send mathServer (Divide pid 8 0)
402 send mathServer (Divide pid 8 0)
360− DivByZero <- expect
403+ divByZ <- expect
361− liftIO $ putMVar clientDone ()
404+ liftIO $ putMVar clientDone (three, four, divByZ)
362
405
363− takeMVar clientDone
406+ res <- takeMVar clientDone
407+ case res of
408+ (3, 4, DivByZero) -> return ()
409+ _ -> error $ "Something went horribly wrong"
364
410
365-- | Send first message (i.e. connect) to an already terminated process
411-- | Send first message (i.e. connect) to an already terminated process
366-- (without monitoring); then send another message to a second process on
412-- (without monitoring); then send another message to a second process on
@@ -388,11 +434,9 @@ testSendToTerminated TestTransport{..} = do
388 pid <- getSelfPid
434 pid <- getSelfPid
389 send server1 "Hi"
435 send server1 "Hi"
390 send server2 (Pong pid)
436 send server2 (Pong pid)
391− Ping pid' <- expect
392− True <- return $ pid' == server2
393− liftIO $ putMVar clientDone ()
437+ expectPing clientDone
394
438
395− takeMVar clientDone
439+ verifyClient "Expected Ping from server" clientDone
396
440
397-- | Test (non-zero) timeout
441-- | Test (non-zero) timeout
398testTimeout :: TestTransport -> Assertion
442testTimeout :: TestTransport -> Assertion
@@ -401,10 +445,10 @@ testTimeout TestTransport{..} = do
401 done <- newEmptyMVar
445 done <- newEmptyMVar
402
446
403 runProcess localNode $ do
447 runProcess localNode $ do
404− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
448+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
405− liftIO $ putMVar done ()
449+ liftIO $ putMVar done $ res == Nothing
406
450
407− takeMVar done
451+ verifyClient "Expected receiveTimeout to timeout..." done
408
452
409-- | Test zero timeout
453-- | Test zero timeout
410testTimeout0 :: TestTransport -> Assertion
454testTimeout0 :: TestTransport -> Assertion
@@ -432,10 +476,9 @@ testTimeout0 TestTransport{..} = do
432 -- is not interested in, and then a single message that it wants
476 -- is not interested in, and then a single message that it wants
433 replicateM_ 10000 $ send server "Irrelevant message"
477 replicateM_ 10000 $ send server "Irrelevant message"
434 send server (Pong pid)
478 send server (Pong pid)
435− Ping _ <- expect
436− liftIO $ putMVar clientDone ()
479+ expectPing clientDone
437
480
438− takeMVar clientDone
481+ verifyClient "Expected Ping from server" clientDone
439
482
440-- | Test typed channels
483-- | Test typed channels
441testTypedChannels :: TestTransport -> Assertion
484testTypedChannels :: TestTransport -> Assertion
@@ -458,10 +501,10 @@ testTypedChannels TestTransport{..} = do
458 runProcess localNode $ do
501 runProcess localNode $ do
459 (clientSendPort, rport) <- newChan
502 (clientSendPort, rport) <- newChan
460 sendChan serverSendPort (clientSendPort, 5)
503 sendChan serverSendPort (clientSendPort, 5)
461− False <- receiveChan rport
504+ ch <- receiveChan rport
462− liftIO $ putMVar clientDone ()
505+ liftIO $ putMVar clientDone $ ch == False
463
506
464− takeMVar clientDone
507+ verifyClient "Expected channel to send 'False'" clientDone
465
508
466-- | Test merging receive ports
509-- | Test merging receive ports
467testMergeChannels :: TestTransport -> Assertion
510testMergeChannels :: TestTransport -> Assertion
@@ -484,9 +527,8 @@ testMergeChannels TestTransport{..} = do
484 rs <- mapM charChannel "abc"
527 rs <- mapM charChannel "abc"
485 m <- mergePorts biased rs
528 m <- mergePorts biased rs
486 xs <- replicateM 9 $ receiveChan m
529 xs <- replicateM 9 $ receiveChan m
487− True <- return $ xs == expected
488− liftIO $ putMVar done ()
530+ liftIO $ putMVar done $ xs == expected
489− takeMVar done
531+ verifyClient "Expected single layer merge to match expected ordering" done
490
532
491 -- Two layers of merging
533 -- Two layers of merging
492 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
534 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
@@ -497,9 +539,8 @@ testMergeChannels TestTransport{..} = do
497 ms <- mapM (mergePorts biasedInner) rss
539 ms <- mapM (mergePorts biasedInner) rss
498 m <- mergePorts biasedOuter ms
540 m <- mergePorts biasedOuter ms
499 xs <- replicateM (9 * 3) $ receiveChan m
541 xs <- replicateM (9 * 3) $ receiveChan m
500− True <- return $ xs == expected
542+ liftIO $ putMVar done $ xs == expected
501− liftIO $ putMVar done ()
543+ verifyClient "Expected nested channels to match expeted ordering" done
502− takeMVar done
503
544
504 -- Test that if no messages are (immediately) available, the scheduler makes no difference
545 -- Test that if no messages are (immediately) available, the scheduler makes no difference
505 testBlocked :: LocalNode -> Bool -> IO ()
546 testBlocked :: LocalNode -> Bool -> IO ()
@@ -508,43 +549,45 @@ testMergeChannels TestTransport{..} = do
508 done <- newEmptyMVar
549 done <- newEmptyMVar
509
550
510 forkProcess localNode $ do
551 forkProcess localNode $ do
511− [sa, sb, sc] <- liftIO $ mapM readMVar vs
552+ ss <- liftIO $ mapM readMVar vs
553+ case ss of
554+ [sa, sb, sc] ->
512− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
555+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
513− [ -- a, b, c
556+ [ -- a, b, c
514− (sa, 'a')
557+ (sa, 'a')
515− , (sb, 'b')
558+ , (sb, 'b')
516− , (sc, 'c')
559+ , (sc, 'c')
517− -- a, c, b
560+ -- a, c, b
518− , (sa, 'a')
561+ , (sa, 'a')
519− , (sc, 'c')
562+ , (sc, 'c')
520− , (sb, 'b')
563+ , (sb, 'b')
521− -- b, a, c
564+ -- b, a, c
522− , (sb, 'b')
565+ , (sb, 'b')
523− , (sa, 'a')
566+ , (sa, 'a')
524− , (sc, 'c')
567+ , (sc, 'c')
525− -- b, c, a
568+ -- b, c, a
526− , (sb, 'b')
569+ , (sb, 'b')
527− , (sc, 'c')
570+ , (sc, 'c')
528− , (sa, 'a')
571+ , (sa, 'a')
529− -- c, a, b
572+ -- c, a, b
530− , (sc, 'c')
573+ , (sc, 'c')
531− , (sa, 'a')
574+ , (sa, 'a')
532− , (sb, 'b')
575+ , (sb, 'b')
533− -- c, b, a
576+ -- c, b, a
534− , (sc, 'c')
577+ , (sc, 'c')
535− , (sb, 'b')
578+ , (sb, 'b')
536− , (sa, 'a')
579+ , (sa, 'a')
537− ]
580+ ]
581+ _ -> die "Something went horribly wrong"
538
582
539 forkProcess localNode $ do
583 forkProcess localNode $ do
540 (ss, rs) <- unzip <$> replicateM 3 newChan
584 (ss, rs) <- unzip <$> replicateM 3 newChan
541 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
585 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
542 m <- mergePorts biased rs
586 m <- mergePorts biased rs
543 xs <- replicateM (6 * 3) $ receiveChan m
587 xs <- replicateM (6 * 3) $ receiveChan m
544− True <- return $ xs == "abcacbbacbcacabcba"
545− liftIO $ putMVar done ()
588+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
546
589
547− takeMVar done
590+ verifyClient "Expected merged ports to match expected ordering" done
548
591
549 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
592 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
550 mergePorts True = mergePortsBiased
593 mergePorts True = mergePortsBiased
@@ -562,8 +605,9 @@ testTerminate TestTransport{..} = do
562 localNode <- newLocalNode testTransport initRemoteTable
605 localNode <- newLocalNode testTransport initRemoteTable
563 runProcess localNode $ do
606 runProcess localNode $ do
564 e <- try terminate :: Process (Either ProcessTerminationException ())
607 e <- try terminate :: Process (Either ProcessTerminationException ())
565− True <- return $ either show show e == show ProcessTerminationException
608+ if either show show e == show ProcessTerminationException
566− return ()
609+ then return ()
610+ else die "Unexpected result from terminate"
567
611
568testMonitorNode :: TestTransport -> Assertion
612testMonitorNode :: TestTransport -> Assertion
569testMonitorNode TestTransport{..} = do
613testMonitorNode TestTransport{..} = do
@@ -574,11 +618,12 @@ testMonitorNode TestTransport{..} = do
574
618
575 runProcess node2 $ do
619 runProcess node2 $ do
576 ref <- monitorNode (localNodeId node1)
620 ref <- monitorNode (localNodeId node1)
621+ receiveWait [
577− NodeMonitorNotification ref' nid DiedDisconnect <- expect
622+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
578− True <- return $ ref == ref' && nid == localNodeId node1
623+ return $ ref == ref' && nid == localNodeId node1)
579− liftIO $ putMVar done ()
624+ ] >>= liftIO . putMVar done
580
625
581− takeMVar done
626+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
582
627
583testMonitorLiveNode :: TestTransport -> Assertion
628testMonitorLiveNode :: TestTransport -> Assertion
584testMonitorLiveNode TestTransport{..} = do
629testMonitorLiveNode TestTransport{..} = do
@@ -593,15 +638,16 @@ testMonitorLiveNode TestTransport{..} = do
593 liftIO $ putMVar ready ()
638 liftIO $ putMVar ready ()
594 liftIO $ takeMVar readyr
639 liftIO $ takeMVar readyr
595 send p ()
640 send p ()
641+ receiveWait [
596− NodeMonitorNotification ref' nid _ <- expect
642+ match (\(NodeMonitorNotification ref' nid _) ->
597− True <- return $ ref == ref' && nid == localNodeId node1
643+ (return $ ref == ref' && nid == localNodeId node1))
598− liftIO $ putMVar done ()
644+ ] >>= liftIO . putMVar done
599
645
600 takeMVar ready
646 takeMVar ready
601 closeLocalNode node1
647 closeLocalNode node1
602 putMVar readyr ()
648 putMVar readyr ()
603
649
604− takeMVar done
650+ verifyClient "Expected NodeMonitorNotification for LIVE node" done
605
651
606testMonitorChannel :: TestTransport -> Assertion
652testMonitorChannel :: TestTransport -> Assertion
607testMonitorChannel TestTransport{..} = do
653testMonitorChannel TestTransport{..} = do
@@ -611,18 +657,20 @@ testMonitorChannel TestTransport{..} = do
611 pid <- forkProcess node1 $ do
657 pid <- forkProcess node1 $ do
612 sport <- expect :: Process (SendPort ())
658 sport <- expect :: Process (SendPort ())
613 ref <- monitorPort sport
659 ref <- monitorPort sport
614− PortMonitorNotification ref' port' reason <- expect
660+ receiveWait [
615− -- reason might be DiedUnknownId if the receive port is GCed before the
661+ -- reason might be DiedUnknownId if the receive port is GCed before the
616− -- monitor is established (TODO: not sure that this is reasonable)
662+ -- monitor is established (TODO: not sure that this is reasonable)
663+ match (\(PortMonitorNotification ref' port' reason) ->
664+ return $ ref' == ref && port' == sendPortId sport &&
617− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
665+ (reason == DiedNormal || reason == DiedUnknownId))
618− liftIO $ putMVar gotNotification ()
666+ ] >>= liftIO . putMVar gotNotification
619
667
620 runProcess node2 $ do
668 runProcess node2 $ do
621 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
669 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
622 send pid sport
670 send pid sport
623 liftIO $ threadDelay 100000
671 liftIO $ threadDelay 100000
624
672
625− takeMVar gotNotification
673+ verifyClient "Expected PortMonitorNotification" gotNotification
626
674
627testRegistry :: TestTransport -> Assertion
675testRegistry :: TestTransport -> Assertion
628testRegistry TestTransport{..} = do
676testRegistry TestTransport{..} = do
@@ -634,20 +682,28 @@ testRegistry TestTransport{..} = do
634
682
635 runProcess node $ do
683 runProcess node $ do
636 register "ping" pingServer
684 register "ping" pingServer
637− Just pid <- whereis "ping"
685+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
638− True <- return $ pingServer == pid
639 us <- getSelfPid
686 us <- getSelfPid
640 nsend "ping" (Pong us)
687 nsend "ping" (Pong us)
641− Ping pid' <- expect
688+ receiveWait [
642− True <- return $ pingServer == pid'
689+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
643− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess
690+ ]
644− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess
691+ checkRegException "dead" Nothing deadProcess
645− True <- return $ x == pingServer
692+ checkRegException "ping" (Just pingServer) deadProcess
646− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"
693+ try (unregister "dead") >>= checkReg "dead" Nothing
647 liftIO $ putMVar done ()
694 liftIO $ putMVar done ()
648
695
649 takeMVar done
696 takeMVar done
650
697
698+ where
699+ checkRegException name pid dead =
700+ try (register name dead) >>= checkReg name pid
701+
702+ checkReg name pid res =
703+ case res of
704+ Left (ProcessRegistrationException name pid) -> return ()
705+ _ -> die $ "Unexpected Registration" ++ show res
706+
651testRegistryRemoteProcess :: TestTransport -> Assertion
707testRegistryRemoteProcess :: TestTransport -> Assertion
652testRegistryRemoteProcess TestTransport{..} = do
708testRegistryRemoteProcess TestTransport{..} = do
653 node1 <- newLocalNode testTransport initRemoteTable
709 node1 <- newLocalNode testTransport initRemoteTable
@@ -658,13 +714,13 @@ testRegistryRemoteProcess TestTransport{..} = do
658
714
659 runProcess node2 $ do
715 runProcess node2 $ do
660 register "ping" pingServer
716 register "ping" pingServer
661− Just pid <- whereis "ping"
717+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
662− True <- return $ pingServer == pid
663 us <- getSelfPid
718 us <- getSelfPid
664 nsend "ping" (Pong us)
719 nsend "ping" (Pong us)
665− Ping pid' <- expect
720+ receiveWait [
666− True <- return $ pingServer == pid'
721+ matchIf (\(Ping pid') -> pingServer == pid')
667− liftIO $ putMVar done ()
722+ (const $ liftIO $ putMVar done ())
723+ ]
668
724
669 takeMVar done
725 takeMVar done
670
726
@@ -685,12 +741,13 @@ testRemoteRegistry TestTransport{..} = do
685 "ping" == label' && pid == pingServer)
741 "ping" == label' && pid == pingServer)
686 (\(RegisterReply _ _ _) -> return ()) ]
742 (\(RegisterReply _ _ _) -> return ()) ]
687
743
688− Just pid <- whereisRemote nid1 "ping"
744+ pid <- verifyWhereIsRemote nid1 "ping"
689− True <- return $ pingServer == pid
745+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
690 us <- getSelfPid
746 us <- getSelfPid
691 nsendRemote nid1 "ping" (Pong us)
747 nsendRemote nid1 "ping" (Pong us)
692− Ping pid' <- expect
748+ receiveWait [
693− True <- return $ pingServer == pid'
749+ match (\(Ping pid') -> return $ pingServer == pid')
750+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
694
751
695 -- test that if process was not registered Nothing is returned
752 -- test that if process was not registered Nothing is returned
696 -- in owner field.
753 -- in owner field.
@@ -726,15 +783,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do
726 receiveWait [
783 receiveWait [
727 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
784 matchIf (\(RegisterReply label' _ _) -> "ping" == label')
728 (\(RegisterReply _ _ _) -> return ()) ]
785 (\(RegisterReply _ _ _) -> return ()) ]
729− Just pid <- whereisRemote nid1 "ping"
786+ pid <- verifyWhereIsRemote nid1 "ping"
730− True <- return $ pingServer == pid
787+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
731 us <- getSelfPid
788 us <- getSelfPid
732 nsendRemote nid1 "ping" (Pong us)
789 nsendRemote nid1 "ping" (Pong us)
733− Ping pid' <- expect
790+ receiveWait [
734− True <- return $ pingServer == pid'
791+ match (\(Ping pid') -> return $ pingServer == pid')
735− liftIO $ putMVar done ()
792+ ] >>= liftIO . putMVar done
736
793
737− takeMVar done
794+ verifyClient "Expected Ping with ping server's ProcessId" done
738
795
739testSpawnLocal :: TestTransport -> Assertion
796testSpawnLocal :: TestTransport -> Assertion
740testSpawnLocal TestTransport{..} = do
797testSpawnLocal TestTransport{..} = do
@@ -748,15 +805,14 @@ testSpawnLocal TestTransport{..} = do
748 sport <- expect
805 sport <- expect
749 sendChan sport (1234 :: Int)
806 sendChan sport (1234 :: Int)
750
807
751− sport <- spawnChannelLocal $ \rport -> do
808+ sport <- spawnChannelLocal $
752− (1234 :: Int) <- receiveChan rport
809+ \rport -> (receiveChan rport :: Process Int) >>= send us
753− send us ()
754
810
755 send pid sport
811 send pid sport
756− () <- expect
757− liftIO $ putMVar done ()
812+ expect >>= liftIO . putMVar done
758
813
759− takeMVar done
814+ res <- takeMVar done
815+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
760
816
761testSpawnAsyncStrictness :: TestTransport -> Assertion
817testSpawnAsyncStrictness :: TestTransport -> Assertion
762testSpawnAsyncStrictness TestTransport{..} = do
818testSpawnAsyncStrictness TestTransport{..} = do
@@ -785,8 +841,9 @@ testReconnect TestTransport{..} = do
785 liftIO $ putMVar processA us
841 liftIO $ putMVar processA us
786 msg1 <- expect
842 msg1 <- expect
787 msg2 <- expect
843 msg2 <- expect
844+ liftIO $ do
788− True <- return $ msg1 == "message 1" && msg2 == "message 3"
845+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
789− liftIO $ putMVar sendTestOk ()
846+ putMVar sendTestOk ()
790
847
791 forkProcess node2 $ do
848 forkProcess node2 $ do
792 {-
849 {-
@@ -819,7 +876,7 @@ testReconnect TestTransport{..} = do
819 matchIf (\(RegisterReply label' _ _) -> "a" == label')
876 matchIf (\(RegisterReply label' _ _) -> "a" == label')
820 (\(RegisterReply _ _ _) -> return ()) ]
877 (\(RegisterReply _ _ _) -> return ()) ]
821
878
822− Just _ <- whereisRemote nid1 "a"
879+ _ <- whereisRemote nid1 "a"
823
880
824
881
825 -- Simulate network failure
882 -- Simulate network failure
@@ -838,9 +895,10 @@ testReconnect TestTransport{..} = do
838 (\(RegisterReply _ _ _) -> return ()) ]
895 (\(RegisterReply _ _ _) -> return ()) ]
839
896
840 -- Check
897 -- Check
841− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
898+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
899+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
842− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
900+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
843− Just _ <- whereisRemote nid1 "c"
901+ verifyWhereIsRemote nid1 "c"
844
902
845 liftIO $ putMVar registerTestOk ()
903 liftIO $ putMVar registerTestOk ()
846
904
@@ -881,13 +939,14 @@ testUSend usendPrim TestTransport{..} numMessages = do
881 isSorted _ = True
939 isSorted _ = True
882 -- The list can't be null since there are no failures after sending
940 -- The list can't be null since there are no failures after sending
883 -- the last message.
941 -- the last message.
942+ liftIO $ do
884− True <- return $ isSorted msgs && not (null msgs)
943+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)
885− liftIO $ putMVar usendTestOk ()
944+ putMVar usendTestOk ()
886
945
887 forkProcess node2 $ do
946 forkProcess node2 $ do
888 them <- liftIO $ readMVar processA
947 them <- liftIO $ readMVar processA
889 getSelfPid >>= send them
948 getSelfPid >>= send them
890− () <- expect
949+ expect :: Process ()
891 forM_ [1..numMessages] $ \i -> do
950 forM_ [1..numMessages] $ \i -> do
892 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
951 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
893 usendPrim them i
952 usendPrim them i
@@ -919,14 +978,17 @@ testMatchAny TestTransport{..} = do
919 runProcess localNode $ do
978 runProcess localNode $ do
920 pid <- getSelfPid
979 pid <- getSelfPid
921 send mathServer (Add pid 1 2)
980 send mathServer (Add pid 1 2)
922− 3 <- expect :: Process Double
981+ three <- expect :: Process Double
923 send mathServer (Divide pid 8 2)
982 send mathServer (Divide pid 8 2)
924− 4 <- expect :: Process Double
983+ four <- expect :: Process Double
925 send mathServer (Divide pid 8 0)
984 send mathServer (Divide pid 8 0)
926− DivByZero <- expect
985+ divByZ <- expect
927− liftIO $ putMVar clientDone ()
986+ liftIO $ putMVar clientDone (three, four, divByZ)
928
987
929− takeMVar clientDone
988+ res <- takeMVar clientDone
989+ case res of
990+ (3, 4, DivByZero) -> return ()
991+ _ -> error "Unexpected result"
930
992
931-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
993-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
932-- in between, however we block 'Divide' requests ....
994-- in between, however we block 'Divide' requests ....
@@ -953,12 +1015,13 @@ testMatchAnyHandle TestTransport{..} = do
953 runProcess localNode $ do
1015 runProcess localNode $ do
954 pid <- getSelfPid
1016 pid <- getSelfPid
955 send mathServer (Add pid 1 2)
1017 send mathServer (Add pid 1 2)
956− 3 <- expect :: Process Double
1018+ three <- expect :: Process Double
957 send mathServer (Divide pid 8 2)
1019 send mathServer (Divide pid 8 2)
958− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1020+ res <- (expectTimeout 100000) :: Process (Maybe Double)
959− liftIO $ putMVar clientDone ()
1021+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1022+
1023+ verifyClient "Expected Nothing (i.e. timeout)" clientDone
960
1024
961− takeMVar clientDone
962 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1025 where maybeForward :: ProcessId -> Message -> Process (Maybe ())
963 maybeForward s msg =
1026 maybeForward s msg =
964 handleMessage msg (\m@(Add _ _ _) -> send s m)
1027 handleMessage msg (\m@(Add _ _ _) -> send s m)
@@ -986,8 +1049,10 @@ testMatchAnyNoHandle TestTransport{..} = do
986 Just _ -> die "NONSENSE")
1049 Just _ -> die "NONSENSE")
987 ]
1050 ]
988 -- we *must* have removed the message from our mailbox though!!!
1051 -- we *must* have removed the message from our mailbox though!!!
989− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1052+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1053+ liftIO $ do
1054+ assertBool "Expected timeout!" $ res == Nothing
990− liftIO $ putMVar serverDone ()
1055+ putMVar serverDone ()
991 putMVar addr server
1056 putMVar addr server
992
1057
993 -- Client
1058 -- Client
@@ -1030,14 +1095,21 @@ testMatchAnyIf TestTransport{..} = do
1030 runProcess localNode $ do
1095 runProcess localNode $ do
1031 pid <- getSelfPid
1096 pid <- getSelfPid
1032 send server (pid, "foo")
1097 send server (pid, "foo")
1033− "foo" <- expect
1098+ foo <- expect
1034− send server (pid, "baz")
1099+ -- provoking what would be the wrong ordering is informative here...
1035− "baz" <- expect
1100+
1036 send server (pid, "bar")
1101 send server (pid, "bar")
1037− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)
1102+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1103+
1104+ send server (pid, "baz")
1105+ baz <- expect
1106+
1038− liftIO $ putMVar clientDone ()
1107+ liftIO $ putMVar clientDone (foo, bar, baz)
1108+
1109+ res <- takeMVar clientDone
1110+ let res' = res == ("foo", Nothing, "baz")
1111+ assertBool "Expected timeout due to type mismatch" res'
1039
1112
1040− takeMVar clientDone
1041 where tryHandleMessage :: Message -> Process (Maybe ())
1113 where tryHandleMessage :: Message -> Process (Maybe ())
1042 tryHandleMessage msg =
1114 tryHandleMessage msg =
1043 handleMessage msg (\(pid :: ProcessId, (m :: String))
1115 handleMessage msg (\(pid :: ProcessId, (m :: String))
@@ -1070,12 +1142,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do
1070 runProcess localNode $ do
1142 runProcess localNode $ do
1071 pid <- getSelfPid
1143 pid <- getSelfPid
1072 send server (pid, wrapMessage ("foo" :: String))
1144 send server (pid, wrapMessage ("foo" :: String))
1073− "foo" <- expect
1145+ foo <- expect
1074 send server (pid, wrapMessage ("baz" :: String))
1146 send server (pid, wrapMessage ("baz" :: String))
1075− "baz" <- expect
1147+ baz <- expect
1076− liftIO $ putMVar clientDone ()
1148+ liftIO $ putMVar clientDone (foo, baz)
1077
1149
1078− takeMVar clientDone
1150+ res <- takeMVar clientDone
1151+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1079
1152
1080-- Test 'receiveChanTimeout'
1153-- Test 'receiveChanTimeout'
1081testReceiveChanTimeout :: TestTransport -> Assertion
1154testReceiveChanTimeout :: TestTransport -> Assertion
@@ -1093,18 +1166,19 @@ testReceiveChanTimeout TestTransport{..} = do
1093
1166
1094 -- Wait for a message with a delay. No message arrives, we should get
1167 -- Wait for a message with a delay. No message arrives, we should get
1095 -- Nothing after the delay.
1168 -- Nothing after the delay.
1096− Nothing <- receiveChanTimeout 100000 rp
1169+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1097
1170
1098 -- Let the sender know that it can send a message.
1171 -- Let the sender know that it can send a message.
1099 liftIO $ putMVar mvSender ()
1172 liftIO $ putMVar mvSender ()
1100
1173
1101 -- Wait for a message with a delay again. Now a message arrives after
1174 -- Wait for a message with a delay again. Now a message arrives after
1102 -- 0.1 seconds
1175 -- 0.1 seconds
1103− Just True <- receiveChanTimeout 20000000 rp
1176+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1177+ liftIO $ assertBool "Expected result to be 'True'" res
1104
1178
1105 -- Wait for a message with zero timeout: non-blocking check. No message is
1179 -- Wait for a message with zero timeout: non-blocking check. No message is
1106 -- available, we get Nothing
1180 -- available, we get Nothing
1107− Nothing <- receiveChanTimeout 0 rp
1181+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1108
1182
1109 -- Let the sender know that it can send a message.
1183 -- Let the sender know that it can send a message.
1110 liftIO $ putMVar mvSender ()
1184 liftIO $ putMVar mvSender ()
@@ -1114,7 +1188,7 @@ testReceiveChanTimeout TestTransport{..} = do
1114 liftIO $ threadDelay 100000
1188 liftIO $ threadDelay 100000
1115 mb <- receiveChanTimeout 0 rp
1189 mb <- receiveChanTimeout 0 rp
1116 case mb of
1190 case mb of
1117− Just b -> do False <- return b; return ()
1191+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1118 _ -> loop
1192 _ -> loop
1119
1193
1120 liftIO $ putMVar done ()
1194 liftIO $ putMVar done ()
@@ -1151,8 +1225,8 @@ testReceiveChanFeatures TestTransport{..} = do
1151
1225
1152 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1226 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1153
1227
1154− True <- receiveChan rp1
1228+ receiveChan rp1 >>= liftIO . assertBool "Expected True"
1155− False <- receiveChan rp1
1229+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1156
1230
1157 -- Test Applicative instance
1231 -- Test Applicative instance
1158
1232
@@ -1161,7 +1235,7 @@ testReceiveChanFeatures TestTransport{..} = do
1161
1235
1162 let rp2 = pure (+) <*> rpInt <*> rpInt
1236 let rp2 = pure (+) <*> rpInt <*> rpInt
1163
1237
1164− 7 <- receiveChan rp2
1238+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1165
1239
1166 -- Test Alternative instance
1240 -- Test Alternative instance
1167
1241
@@ -1170,8 +1244,8 @@ testReceiveChanFeatures TestTransport{..} = do
1170
1244
1171 let rp3 = (even <$> rpInt) <|> rpBool
1245 let rp3 = (even <$> rpInt) <|> rpBool
1172
1246
1173− False <- receiveChan rp3
1247+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1174− True <- receiveChan rp3
1248+ receiveChan rp3 >>= liftIO . assertBool "Expected True"
1175
1249
1176 -- Test Monad instance
1250 -- Test Monad instance
1177
1251
@@ -1185,8 +1259,8 @@ testReceiveChanFeatures TestTransport{..} = do
1185 then rpInt
1259 then rpInt
1186 else return 7
1260 else return 7
1187
1261
1188− 5 <- receiveChan rp4
1262+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1189− 7 <- receiveChan rp4
1263+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1190
1264
1191 liftIO $ putMVar done ()
1265 liftIO $ putMVar done ()
1192
1266
@@ -1195,7 +1269,6 @@ testReceiveChanFeatures TestTransport{..} = do
1195testKillLocal :: TestTransport -> Assertion
1269testKillLocal :: TestTransport -> Assertion
1196testKillLocal TestTransport{..} = do
1270testKillLocal TestTransport{..} = do
1197 localNode <- newLocalNode testTransport initRemoteTable
1271 localNode <- newLocalNode testTransport initRemoteTable
1198− done <- newEmptyMVar
1199
1272
1200 pid <- forkProcess localNode $ do
1273 pid <- forkProcess localNode $ do
1201 liftIO $ threadDelay 1000000
1274 liftIO $ threadDelay 1000000
@@ -1204,17 +1277,18 @@ testKillLocal TestTransport{..} = do
1204 ref <- monitor pid
1277 ref <- monitor pid
1205 us <- getSelfPid
1278 us <- getSelfPid
1206 kill pid "TestKill"
1279 kill pid "TestKill"
1207− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
1280+ mn <- expect
1281+ case mn of
1282+ ProcessMonitorNotification ref' pid' (DiedException ex) ->
1208− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"
1283+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1209− liftIO $ putMVar done ()
1284+ True -> return ()
1210−
1285+ False -> die "Invalid ProcessMonitorNotification received"
1211− takeMVar done
1286+ _ -> die "Something went horribly wrong"
1212
1287
1213testKillRemote :: TestTransport -> Assertion
1288testKillRemote :: TestTransport -> Assertion
1214testKillRemote TestTransport{..} = do
1289testKillRemote TestTransport{..} = do
1215 node1 <- newLocalNode testTransport initRemoteTable
1290 node1 <- newLocalNode testTransport initRemoteTable
1216 node2 <- newLocalNode testTransport initRemoteTable
1291 node2 <- newLocalNode testTransport initRemoteTable
1217− done <- newEmptyMVar
1218
1292
1219 pid <- forkProcess node1 $ do
1293 pid <- forkProcess node1 $ do
1220 liftIO $ threadDelay 1000000
1294 liftIO $ threadDelay 1000000
@@ -1223,11 +1297,17 @@ testKillRemote TestTransport{..} = do
1223 ref <- monitor pid
1297 ref <- monitor pid
1224 us <- getSelfPid
1298 us <- getSelfPid
1225 kill pid "TestKill"
1299 kill pid "TestKill"
1300+ mn <- expect
1301+ case mn of
1226− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect
1302+ ProcessMonitorNotification ref' pid' (DiedException reason) ->
1227− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"
1303+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1228− liftIO $ putMVar done ()
1304+ (True, True, True) -> return ()
1229−
1305+ (a, b, c) -> do
1230− takeMVar done
1306+ let a' = if a then "" else "Invalid ref"
1307+ let b' = if b then "" else "Invalid pid"
1308+ let c' = if c then "" else "Invalid message"
1309+ die $ unwords [a', b', c']
1310+ _ -> die "Received unexpected message"
1231
1311
1232testCatchesExit :: TestTransport -> Assertion
1312testCatchesExit :: TestTransport -> Assertion
1233testCatchesExit TestTransport{..} = do
1313testCatchesExit TestTransport{..} = do
@@ -1253,7 +1333,10 @@ testHandleMessageIf TestTransport{..} = do
1253 self <- getSelfPid
1333 self <- getSelfPid
1254 send self (5 :: Integer, 10 :: Integer)
1334 send self (5 :: Integer, 10 :: Integer)
1255 msg <- receiveWait [ matchMessage return ]
1335 msg <- receiveWait [ matchMessage return ]
1256− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")
1336+ handleMessageIf msg
1337+ (\() -> True)
1338+ (\() -> die "whoops") >>= maybe (return ())
1339+ (const $ die "Expected Mismatch")
1257 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1340 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1258 (\input -> liftIO $ putMVar done input)
1341 (\input -> liftIO $ putMVar done input)
1259 return ()
1342 return ()
@@ -1298,8 +1381,11 @@ testDie TestTransport{..} = do
1298 (die ("foobar", 123 :: Int))
1381 (die ("foobar", 123 :: Int))
1299 `catchExit` \_from reason -> do
1382 `catchExit` \_from reason -> do
1300 -- TODO: should verify that 'from' has the right value
1383 -- TODO: should verify that 'from' has the right value
1301− True <- return $ reason == ("foobar", 123 :: Int)
1384+ let res = reason == ("foobar", 123 :: Int)
1302 liftIO $ putMVar done ()
1385 liftIO $ putMVar done ()
1386+ if res
1387+ then return ()
1388+ else die "Something went horribly wrong"
1303
1389
1304 takeMVar done
1390 takeMVar done
1305
1391
@@ -1313,8 +1399,11 @@ testPrettyExit TestTransport{..} = do
1313 `catch` \ex@(ProcessExitException from _) ->
1399 `catch` \ex@(ProcessExitException from _) ->
1314 let expected = "exit-from=" ++ (show from)
1400 let expected = "exit-from=" ++ (show from)
1315 in do
1401 in do
1316− True <- return $ (show ex) == expected
1402+ let res = (show ex) == expected
1317 liftIO $ putMVar done ()
1403 liftIO $ putMVar done ()
1404+ if res
1405+ then return ()
1406+ else die "Something went horribly wrong"
1318
1407
1319 takeMVar done
1408 takeMVar done
1320
1409
@@ -1330,17 +1419,26 @@ testExitLocal TestTransport{..} = do
1330 pid <- forkProcess localNode $ do
1419 pid <- forkProcess localNode $ do
1331 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1420 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1332 -- TODO: should verify that 'from' has the right value
1421 -- TODO: should verify that 'from' has the right value
1333− True <- return $ reason == "TestExit"
1422+ res <- return $ reason == "TestExit"
1334 liftIO $ putMVar supervisedDone ()
1423 liftIO $ putMVar supervisedDone ()
1424+ if res
1425+ then return ()
1426+ else die "Something went horribly wrong"
1335
1427
1336 runProcess localNode $ do
1428 runProcess localNode $ do
1337 liftIO $ takeMVar handlerSetUp
1429 liftIO $ takeMVar handlerSetUp
1338 ref <- monitor pid
1430 ref <- monitor pid
1339 exit pid "TestExit"
1431 exit pid "TestExit"
1340 -- This time the client catches the exception, so it dies normally
1432 -- This time the client catches the exception, so it dies normally
1433+ mn <- expect
1434+ case mn of
1341− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1435+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1342− True <- return $ ref == ref' && pid == pid'
1436+ let res = ref == ref' && pid == pid'
1343− liftIO $ putMVar supervisorDone ()
1437+ liftIO $ putMVar supervisorDone ()
1438+ if res
1439+ then return ()
1440+ else die "Something went horribly wrong"
1441+ _ -> die "Something went horribly wrong"
1344
1442
1345 takeMVar supervisedDone
1443 takeMVar supervisedDone
1346 takeMVar supervisorDone
1444 takeMVar supervisorDone
@@ -1356,15 +1454,24 @@ testExitRemote TestTransport{..} = do
1356 (receiveWait [] :: Process ()) -- block forever
1454 (receiveWait [] :: Process ()) -- block forever
1357 `catchExit` \_from reason -> do
1455 `catchExit` \_from reason -> do
1358 -- TODO: should verify that 'from' has the right value
1456 -- TODO: should verify that 'from' has the right value
1359− True <- return $ reason == "TestExit"
1457+ res <- return $ reason == "TestExit"
1360 liftIO $ putMVar supervisedDone ()
1458 liftIO $ putMVar supervisedDone ()
1459+ if res
1460+ then return ()
1461+ else die "Something went horribly wrong"
1361
1462
1362 runProcess node2 $ do
1463 runProcess node2 $ do
1363 ref <- monitor pid
1464 ref <- monitor pid
1364 exit pid "TestExit"
1465 exit pid "TestExit"
1466+ mn <- expect
1467+ case mn of
1365− ProcessMonitorNotification ref' pid' DiedNormal <- expect
1468+ ProcessMonitorNotification ref' pid' DiedNormal -> do
1366− True <- return $ ref == ref' && pid == pid'
1469+ res' <- return $ ref == ref' && pid == pid'
1367− liftIO $ putMVar supervisorDone ()
1470+ liftIO $ putMVar supervisorDone ()
1471+ if res'
1472+ then return ()
1473+ else die "Something went horribly wrong"
1474+ _ -> die "Something went horribly wrong"
1368
1475
1369 takeMVar supervisedDone
1476 takeMVar supervisedDone
1370 takeMVar supervisorDone
1477 takeMVar supervisorDone
@@ -1384,8 +1491,7 @@ testUnsafeSend TestTransport{..} = do
1384 void $ forkProcess localNode $ do
1491 void $ forkProcess localNode $ do
1385 serverPid <- liftIO $ takeMVar serverAddr
1492 serverPid <- liftIO $ takeMVar serverAddr
1386 getSelfPid >>= unsafeSend serverPid
1493 getSelfPid >>= unsafeSend serverPid
1387− () <- expect
1388− liftIO $ putMVar clientDone ()
1494+ expect >>= liftIO . putMVar clientDone
1389
1495
1390 takeMVar clientDone
1496 takeMVar clientDone
1391
1497
@@ -1404,8 +1510,7 @@ testUnsafeUSend TestTransport{..} = do
1404 void $ forkProcess localNode $ do
1510 void $ forkProcess localNode $ do
1405 serverPid <- liftIO $ takeMVar serverAddr
1511 serverPid <- liftIO $ takeMVar serverAddr
1406 getSelfPid >>= unsafeUSend serverPid
1512 getSelfPid >>= unsafeUSend serverPid
1407− () <- expect
1408− liftIO $ putMVar clientDone ()
1513+ expect >>= liftIO . putMVar clientDone
1409
1514
1410 takeMVar clientDone
1515 takeMVar clientDone
1411
1516
@@ -1416,8 +1521,7 @@ testUnsafeNSend TestTransport{..} = do
1416 localNode <- newLocalNode testTransport initRemoteTable
1521 localNode <- newLocalNode testTransport initRemoteTable
1417
1522
1418 pid <- forkProcess localNode $ do
1523 pid <- forkProcess localNode $ do
1419− () <- expect
1420− liftIO $ putMVar clientDone ()
1524+ expect >>= liftIO . putMVar clientDone
1421
1525
1422 void $ runProcess localNode $ do
1526 void $ runProcess localNode $ do
1423 register "foobar" pid
1527 register "foobar" pid
@@ -1435,8 +1539,7 @@ testUnsafeNSendRemote TestTransport{..} = do
1435 _ <- forkProcess localNode1 $ do
1539 _ <- forkProcess localNode1 $ do
1436 getSelfPid >>= register "foobar"
1540 getSelfPid >>= register "foobar"
1437 liftIO $ putMVar clientDone ()
1541 liftIO $ putMVar clientDone ()
1438− () <- expect
1439− liftIO $ putMVar clientDone ()
1542+ expect >>= liftIO . putMVar clientDone
1440
1543
1441 takeMVar clientDone
1544 takeMVar clientDone
1442 void $ runProcess localNode2 $ do
1545 void $ runProcess localNode2 $ do
@@ -1460,7 +1563,7 @@ testUnsafeSendChan TestTransport{..} = do
1460 serverPid <- liftIO $ takeMVar serverAddr
1563 serverPid <- liftIO $ takeMVar serverAddr
1461 (sp, rp) <- newChan
1564 (sp, rp) <- newChan
1462 unsafeSend serverPid sp
1565 unsafeSend serverPid sp
1463− () <- receiveChan rp
1566+ receiveChan rp :: Process ()
1464 liftIO $ putMVar clientDone ()
1567 liftIO $ putMVar clientDone ()
1465
1568
1466 takeMVar clientDone
1569 takeMVar clientDone
@@ -1474,8 +1577,8 @@ testCallLocal TestTransport{..} = do
1474 runProcess node $ do
1577 runProcess node $ do
1475 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1578 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1476 liftIO $ putMVar result r
1579 liftIO $ putMVar result r
1580+
1477− True <- takeMVar result
1581+ takeMVar result >>= assertBool "Expected 'True'"
1478− return ()
1479
1582
1480 -- Testing that when callLocal is interrupted, the worker is interrupted.
1583 -- Testing that when callLocal is interrupted, the worker is interrupted.
1481 ibox <- newIORef False
1584 ibox <- newIORef False
@@ -1492,10 +1595,9 @@ testCallLocal TestTransport{..} = do
1492 (send keeper ())
1595 (send keeper ())
1493 caller <- expect
1596 caller <- expect
1494 exit caller "test"
1597 exit caller "test"
1495− () <- expect
1598+ expect :: Process ()
1496− return ()
1599+
1497− True <- readIORef ibox
1600+ readIORef ibox >>= assertBool "Expected 'True'"
1498− return ()
1499
1601
1500 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1602 -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1501 ibox2 <- newIORef False
1603 ibox2 <- newIORef False
@@ -1504,8 +1606,8 @@ testCallLocal TestTransport{..} = do
1504 liftIO $ writeIORef ibox2 $ case r of
1606 liftIO $ writeIORef ibox2 $ case r of
1505 Left (ErrorCall "e") -> True
1607 Left (ErrorCall "e") -> True
1506 _ -> False
1608 _ -> False
1609+
1507− True <- readIORef ibox
1610+ readIORef ibox >>= assertBool "Expected 'True'"
1508− return ()
1509
1611
1510 -- Test that caller waits for the worker in correct situation
1612 -- Test that caller waits for the worker in correct situation
1511 ibox3 <- newIORef False
1613 ibox3 <- newIORef False
@@ -1522,8 +1624,8 @@ testCallLocal TestTransport{..} = do
1522 liftIO $ putMVar result3 =<< readIORef ibox3
1624 liftIO $ putMVar result3 =<< readIORef ibox3
1523 worker <- expect
1625 worker <- expect
1524 send worker ()
1626 send worker ()
1627+
1525− True <- takeMVar result3
1628+ takeMVar result3 >>= assertBool "Expected 'True'"
1526− return ()
1527
1629
1528 -- Test that caller waits for the worker in case when caller gets an exception
1630 -- Test that caller waits for the worker in case when caller gets an exception
1529 ibox4 <- newIORef False
1631 ibox4 <- newIORef False
@@ -1539,13 +1641,9 @@ testCallLocal TestTransport{..} = do
1539 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1641 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1540 caller <- expect
1642 caller <- expect
1541 exit caller "hi!"
1643 exit caller "hi!"
1542− True <- takeMVar result4
1543− return ()
1544− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1545−
1546−
1547−
1548
1644
1645+ takeMVar result4 >>= assertBool "Expected 'True'"
1646+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1549
1647
1550tests :: TestTransport -> IO [Test]
1648tests :: TestTransport -> IO [Test]
1551tests testtrans = return [
1649tests testtrans = return [
@@ -1631,17 +1729,3 @@ tests testtrans = return [
1631 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1729 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1632 ]
1730 ]
1633 ]
1731 ]
1634−
1635−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1636−syncBreakConnection breakConnection nid0 nid1 = do
1637− m <- newEmptyMVar
1638− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1639− runProcess nid0 $ do
1640− them <- liftIO $ takeMVar m
1641− pinger <- spawnLocal $ forever $ send them ()
1642− _ <- monitorNode (localNodeId nid1)
1643− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1644− (nodeAddress $ localNodeId nid1)
1645− NodeMonitorNotification _ _ _ <- expect
1646− kill pinger "finished"
1647− return ()
distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+83−44
@@ -169,8 +169,11 @@ testUnclosure TestTransport{..} rtable = do
169 node <- newLocalNode testTransport rtable
169 node <- newLocalNode testTransport rtable
170 done <- newEmptyMVar
170 done <- newEmptyMVar
171 forkProcess node $ do
171 forkProcess node $ do
172− 120 <- join . unClosure $ factorialClosure 5
172+ i <- join . unClosure $ factorialClosure 5
173 liftIO $ putMVar done ()
173 liftIO $ putMVar done ()
174+ if i == 720
175+ then return ()
176+ else error "Something went horribly wrong"
174 takeMVar done
177 takeMVar done
175
178
176testBind :: TestTransport -> RemoteTable -> Assertion
179testBind :: TestTransport -> RemoteTable -> Assertion
@@ -180,8 +183,11 @@ testBind TestTransport{..} rtable = do
180 runProcess node $ do
183 runProcess node $ do
181 us <- getSelfPid
184 us <- getSelfPid
182 join . unClosure $ sendFac 6 us
185 join . unClosure $ sendFac 6 us
183− (720 :: Int) <- expect
186+ (i :: Int) <- expect
184 liftIO $ putMVar done ()
187 liftIO $ putMVar done ()
188+ if i == 720
189+ then return ()
190+ else error "Something went horribly wrong"
185 takeMVar done
191 takeMVar done
186
192
187testSendPureClosure :: TestTransport -> RemoteTable -> Assertion
193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion
@@ -194,7 +200,7 @@ testSendPureClosure TestTransport{..} rtable = do
194 addr <- forkProcess node $ do
200 addr <- forkProcess node $ do
195 cl <- expect
201 cl <- expect
196 fn <- unClosure cl :: Process (Int -> Int)
202 fn <- unClosure cl :: Process (Int -> Int)
197− 13 <- return $ fn 6
203+ (_ :: Int) <- return $ fn 6
198 liftIO $ putMVar serverDone ()
204 liftIO $ putMVar serverDone ()
199 putMVar serverAddr addr
205 putMVar serverAddr addr
200
206
@@ -218,8 +224,11 @@ testSendIOClosure TestTransport{..} rtable = do
218 liftIO $ do
224 liftIO $ do
219 someMVar <- newEmptyMVar
225 someMVar <- newEmptyMVar
220 io someMVar
226 io someMVar
221− 5 <- readMVar someMVar
227+ i <- readMVar someMVar
222 putMVar serverDone ()
228 putMVar serverDone ()
229+ if i == 5
230+ then return ()
231+ else error "Something went horribly wrong"
223 putMVar serverAddr addr
232 putMVar serverAddr addr
224
233
225 forkIO $ do
234 forkIO $ do
@@ -248,8 +257,10 @@ testSendProcClosure TestTransport{..} rtable = do
248 runProcess node $ do
257 runProcess node $ do
249 pid <- getSelfPid
258 pid <- getSelfPid
250 send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
259 send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
251− 5 <- expect :: Process Int
260+ i <- expect :: Process Int
261+ if i == 5
252− liftIO $ putMVar clientDone ()
262+ then liftIO $ putMVar clientDone ()
263+ else error "Something went horribly wrong"
253
264
254 takeMVar clientDone
265 takeMVar clientDone
255
266
@@ -269,8 +280,9 @@ testSpawn TestTransport{..} rtable = do
269 pid <- getSelfPid
280 pid <- getSelfPid
270 pid' <- spawn nid (sendPidClosure pid)
281 pid' <- spawn nid (sendPidClosure pid)
271 pid'' <- expect
282 pid'' <- expect
272− True <- return $ pid' == pid''
283+ if pid' == pid''
273− liftIO $ putMVar clientDone ()
284+ then liftIO $ putMVar clientDone ()
285+ else error "Something went horribly wrong"
274
286
275 takeMVar clientDone
287 takeMVar clientDone
276
288
@@ -294,8 +306,9 @@ testSpawnRace TestTransport{..} rtable = do
294 spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid
306 spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid
295 pid' <- expect :: Process ProcessId
307 pid' <- expect :: Process ProcessId
296 pid'' <- expect :: Process ProcessId
308 pid'' <- expect :: Process ProcessId
297− True <- return $ pid' == pid''
309+ if pid' == pid''
298− return ()
310+ then return ()
311+ else error "Something went horribly wrong"
299
312
300 where
313 where
301
314
@@ -332,8 +345,10 @@ testCall TestTransport{..} rtable = do
332 node <- newLocalNode testTransport rtable
345 node <- newLocalNode testTransport rtable
333 nid <- readMVar serverNodeAddr
346 nid <- readMVar serverNodeAddr
334 runProcess node $ do
347 runProcess node $ do
335− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
348+ (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
349+ if a == 120
336− liftIO $ putMVar clientDone ()
350+ then liftIO $ putMVar clientDone ()
351+ else error "something went horribly wrong"
337
352
338 takeMVar clientDone
353 takeMVar clientDone
339
354
@@ -350,8 +365,10 @@ testCallBind TestTransport{..} rtable = do
350 node <- newLocalNode testTransport rtable
365 node <- newLocalNode testTransport rtable
351 nid <- readMVar serverNodeAddr
366 nid <- readMVar serverNodeAddr
352 runProcess node $ do
367 runProcess node $ do
353− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
368+ (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
369+ if a == 120
354− liftIO $ putMVar clientDone ()
370+ then liftIO $ putMVar clientDone ()
371+ else error "Something went horribly wrong"
355
372
356 takeMVar clientDone
373 takeMVar clientDone
357
374
@@ -362,9 +379,11 @@ testSeq TestTransport{..} rtable = do
362 runProcess node $ do
379 runProcess node $ do
363 us <- getSelfPid
380 us <- getSelfPid
364 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
381 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
365− 120 :: Int <- expect
382+ a :: Int <- expect
366− 720 :: Int <- expect
383+ b :: Int <- expect
384+ if a == 120 && b == 720
367− liftIO $ putMVar done ()
385+ then liftIO $ putMVar done ()
386+ else error "Something went horribly wrong"
368 takeMVar done
387 takeMVar done
369
388
370-- Test 'spawnSupervised'
389-- Test 'spawnSupervised'
@@ -393,25 +412,33 @@ testSpawnSupervised TestTransport{..} rtable = do
393 throw supervisorDeath
412 throw supervisorDeath
394
413
395 forkProcess node2 $ do
414 forkProcess node2 $ do
396− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
415+ res <- liftIO $ mapM readMVar [superPid, childPid]
416+ case res of
417+ [super, child] -> do
397− ref <- monitor child
418+ ref <- monitor child
398− self <- getSelfPid
419+ self <- getSelfPid
399− let waitForMOrL = do
420+ let waitForMOrL = do
400− liftIO $ threadDelay 10000
421+ liftIO $ threadDelay 10000
401− mpinfo <- getProcessInfo child
422+ mpinfo <- getProcessInfo child
402− case mpinfo of
423+ case mpinfo of
403− Nothing -> waitForMOrL
424+ Nothing -> waitForMOrL
404− Just pinfo ->
425+ Just pinfo ->
405− unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL
426+ unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL
406− waitForMOrL
427+ waitForMOrL
407− liftIO $ putMVar linkUp ()
428+ liftIO $ putMVar linkUp ()
408− -- because monitor message was sent before message to process
429+ -- because monitor message was sent before message to process
409− -- we hope that it will be processed before
430+ -- we hope that it will be processed before
431+ res' <- expect
432+ case res' of
410− ProcessMonitorNotification ref' pid' (DiedException e) <- expect
433+ (ProcessMonitorNotification ref' pid' (DiedException e)) ->
411− True <- return $ ref' == ref
412− && pid' == child
434+ if (ref' == ref && pid' == child &&
435+ e == show (ProcessLinkException super
413− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
436+ (DiedException (show supervisorDeath))))
414− liftIO $ putMVar thirdProcessDone ()
437+ then liftIO $ putMVar thirdProcessDone ()
438+ else error "Something went horribly wrong"
439+ _ -> error "Something went horribly wrong"
440+
441+ _ -> die $ "Something went horribly wrong"
415
442
416 takeMVar thirdProcessDone
443 takeMVar thirdProcessDone
417 where
444 where
@@ -426,8 +453,10 @@ testSpawnInvalid TestTransport{..} rtable = do
426 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
453 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
427 ProcessMonitorNotification ref' pid' _reason <- expect
454 ProcessMonitorNotification ref' pid' _reason <- expect
428 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
455 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
429− True <- return $ ref' == ref && pid == pid'
456+ res <- return $ ref' == ref && pid == pid'
457+ if res == True
430− liftIO $ putMVar done ()
458+ then liftIO $ putMVar done ()
459+ else error "Something went horribly wrong"
431 takeMVar done
460 takeMVar done
432
461
433testClosureExpect :: TestTransport -> RemoteTable -> Assertion
462testClosureExpect :: TestTransport -> RemoteTable -> Assertion
@@ -439,8 +468,10 @@ testClosureExpect TestTransport{..} rtable = do
439 us <- getSelfPid
468 us <- getSelfPid
440 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
469 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
441 send them (1234 :: Int)
470 send them (1234 :: Int)
442− (1234 :: Int) <- expect
471+ (res :: Int) <- expect
472+ if res == 1234
443− liftIO $ putMVar done ()
473+ then liftIO $ putMVar done ()
474+ else error "Something went horribly wrong"
444 takeMVar done
475 takeMVar done
445
476
446testSpawnChannel :: TestTransport -> RemoteTable -> Assertion
477testSpawnChannel :: TestTransport -> RemoteTable -> Assertion
@@ -465,8 +496,10 @@ testTDict TestTransport{..} rtable = do
465 done <- newEmptyMVar
496 done <- newEmptyMVar
466 [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
497 [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
467 forkProcess node1 $ do
498 forkProcess node1 $ do
468− True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
499+ res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
500+ if res == True
469− liftIO $ putMVar done ()
501+ then liftIO $ putMVar done ()
502+ else error "Something went horribly wrong..."
470 takeMVar done
503 takeMVar done
471
504
472testFib :: TestTransport -> RemoteTable -> Assertion
505testFib :: TestTransport -> RemoteTable -> Assertion
@@ -477,8 +510,11 @@ testFib TestTransport{..} rtable = do
477 forkProcess (head nodes) $ do
510 forkProcess (head nodes) $ do
478 (sport, rport) <- newChan
511 (sport, rport) <- newChan
479 spawnLocal $ dfib (map localNodeId nodes, sport, 10)
512 spawnLocal $ dfib (map localNodeId nodes, sport, 10)
480− 55 <- receiveChan rport :: Process Integer
513+ ff <- receiveChan rport :: Process Integer
481 liftIO $ putMVar done ()
514 liftIO $ putMVar done ()
515+ if ff /= 55
516+ then die $ "Something went horribly wrong"
517+ else return ()
482
518
483 takeMVar done
519 takeMVar done
484
520
@@ -503,9 +539,12 @@ testSpawnReconnect testtrans@TestTransport{..} rtable = do
503 liftIO $ threadDelay 100000
539 liftIO $ threadDelay 100000
504
540
505 count <- liftIO $ takeMVar iv
541 count <- liftIO $ takeMVar iv
506− True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
542+ res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
507
543
508 liftIO $ putMVar done ()
544 liftIO $ putMVar done ()
545+ if res /= True
546+ then error "Something went horribly wrong"
547+ else return ()
509
548
510 takeMVar done
549 takeMVar done
511
550
distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+11−7
@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)
29
29
30testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
30testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
31testLocalDeadProcessInfo result = do
31testLocalDeadProcessInfo result = do
32− pid <- spawnLocal $ do "finish" <- expect; return ()
32+ pid <- spawnLocal $ do (_ :: String) <- expect; return ()
33 mref <- monitor pid
33 mref <- monitor pid
34 send pid "finish"
34 send pid "finish"
35 _ <- receiveWait [
35 _ <- receiveWait [
@@ -52,8 +52,10 @@ testLocalLiveProcessInfo result = do
52 link self
52 link self
53 mRef <- monitor self
53 mRef <- monitor self
54 stash mon mRef
54 stash mon mRef
55− "die" <- expect
55+ res <- expect
56+ case res of
56− return ()
57+ "die" -> return ()
58+ _ -> die $ "unexpected message received: " ++ res
57
59
58 monRef <- liftIO $ takeMVar mon
60 monRef <- liftIO $ takeMVar mon
59
61
@@ -84,9 +86,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do
84 -- our send op shouldn't overtake link or monitor requests AFAICT
86 -- our send op shouldn't overtake link or monitor requests AFAICT
85 -- so a little table tennis should get us synchronised properly
87 -- so a little table tennis should get us synchronised properly
86 send serverPid (self, "ping")
88 send serverPid (self, "ping")
87− "pong" <- expect
89+ pong <- expect
88 pInfo <- getProcessInfo serverPid
90 pInfo <- getProcessInfo serverPid
89− stash result $ pInfo /= Nothing
91+ stash result $ pong == "pong" && pInfo /= Nothing
90 where
92 where
91 launchRemote :: MVar ProcessId -> IO ()
93 launchRemote :: MVar ProcessId -> IO ()
92 launchRemote locMV = do
94 launchRemote locMV = do
@@ -97,8 +99,10 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do
97 _ <- receiveWait [
99 _ <- receiveWait [
98 match (\(pid, "ping") -> send pid "pong")
100 match (\(pid, "ping") -> send pid "pong")
99 ]
101 ]
100− "stop" <- expect
102+ res <- expect
103+ case res of
101− return ()
104+ "stop" -> return ()
105+ _ -> die $ "unexpected message received: " ++ res
102 return ()
106 return ()
103
107
104 withActiveRemote :: LocalNode
108 withActiveRemote :: LocalNode
distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+23−11
@@ -125,9 +125,11 @@ testTraceSending result = do
125 (\ev ->
125 (\ev ->
126 case ev of
126 case ev of
127 (MxSent to from msg) -> do
127 (MxSent to from msg) -> do
128− (Just s) <- unwrapMessage msg :: Process (Maybe String)
128+ mS <- unwrapMessage msg :: Process (Maybe String)
129+ case mS of
129− stash res (to == pid && from == self && s == "hello there")
130+ (Just s) -> do stash res (to == pid && from == self && s == "hello there")
130− stash res (to == pid && from == self)
131+ stash res (to == pid && from == self)
132+ _ -> die "failed state invariant, message type unmatched..."
131 _ ->
133 _ ->
132 return ()) $ do
134 return ()) $ do
133 send pid "hello there"
135 send pid "hello there"
@@ -246,12 +248,8 @@ testRemoteTraceRelay TestTransport{..} result =
246 -- Here we set up that relay, and then wait for a signal
248 -- Here we set up that relay, and then wait for a signal
247 -- that the tracer (on node1) has seen the expected
249 -- that the tracer (on node1) has seen the expected
248 -- MxSpawned message, at which point we're finished
250 -- MxSpawned message, at which point we're finished
249− (Just log') <- whereis "logger"
250− pid <- liftIO $ forkProcess node2 $ do
251− logRelay <- spawnLocal $ relay log'
252− reregister "logger" logRelay
253− getSelfNode >>= stash mvNid >> (expect :: Process ())
254
251
252+ pid <- splinchLogger node2 mvNid
255 nid <- liftIO $ takeMVar mvNid
253 nid <- liftIO $ takeMVar mvNid
256 mref <- monitor pid
254 mref <- monitor pid
257 observedPid <- liftIO $ newEmptyMVar
255 observedPid <- liftIO $ newEmptyMVar
@@ -291,6 +289,17 @@ testRemoteTraceRelay TestTransport{..} result =
291 -- and just to be polite...
289 -- and just to be polite...
292 liftIO $ closeLocalNode node2
290 liftIO $ closeLocalNode node2
293
291
292+ where
293+ splinchLogger n2 mv = do
294+ mLog <- whereis "logger"
295+ case mLog of
296+ Nothing -> die "no logger registered"
297+ Just log' -> do liftIO $ forkProcess n2 $ do
298+ logRelay <- spawnLocal $ relay log'
299+ reregister "logger" logRelay
300+ getSelfNode >>= stash mv >> (expect :: Process ())
301+
302+
294-- | Sets the value of an environment variable while executing the given IO
303-- | Sets the value of an environment variable while executing the given IO
295-- computation and restores the preceeding value upon completion.
304-- computation and restores the preceeding value upon completion.
296withEnv :: String -> String -> IO a -> IO a
305withEnv :: String -> String -> IO a -> IO a
@@ -319,9 +328,12 @@ testSystemLoggerMsg t action interestingMessage =
319 -- Wait for the trace message.
328 -- Wait for the trace message.
320 receiveWait [ matchIf interestingMessage' $ const $ return () ]
329 receiveWait [ matchIf interestingMessage' $ const $ return () ]
321 -- Only one interesting message should arrive.
330 -- Only one interesting message should arrive.
322− Nothing <- receiveTimeout 100000
331+ expectedTimeout <- receiveTimeout
332+ 100000
323− [ matchIf interestingMessage' $ const $ return () ]
333+ [ matchIf interestingMessage' $ const $ return () ]
334+ case expectedTimeout of
324− return ()
335+ Nothing -> return ()
336+ Just _ -> die "Unexpected message arrived..."
325
337
326
338
327-- | Tests that one and only one trace message is produced when a message is
339-- | Tests that one and only one trace message is produced when a message is
distributed-process-tests/tests/runTCP.hs+2−2
@@ -10,6 +10,7 @@ import Network.Transport.TCP
10 ( createTransportExposeInternals
10 ( createTransportExposeInternals
11 , TransportInternals(socketBetween)
11 , TransportInternals(socketBetween)
12 , defaultTCPParameters
12 , defaultTCPParameters
13+ , defaultTCPAddr
13 , TCPParameters(..)
14 , TCPParameters(..)
14 )
15 )
15import Test.Framework (defaultMainWithArgs)
16import Test.Framework (defaultMainWithArgs)
@@ -24,8 +25,7 @@ main = do
24 hSetBuffering stdout LineBuffering
25 hSetBuffering stdout LineBuffering
25 hSetBuffering stderr LineBuffering
26 hSetBuffering stderr LineBuffering
26 Right (transport, internals) <-
27 Right (transport, internals) <-
27− createTransportExposeInternals "127.0.0.1" "8080"
28+ createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")
28− (\sn -> ("127.0.0.1", sn))
29 defaultTCPParameters { transportConnectTimeout = Just 3000000 }
29 defaultTCPParameters { transportConnectTimeout = Just 3000000 }
30 ts <- tests TestTransport
30 ts <- tests TestTransport
31 { testTransport = transport
31 { testTransport = transport
src/Control/Distributed/Process/Internal/Primitives.hs+5−2
@@ -400,8 +400,11 @@ newtype Match b = Match { unMatch :: MatchOn Message (Process b) }
400receiveWait :: [Match b] -> Process b
400receiveWait :: [Match b] -> Process b
401receiveWait ms = do
401receiveWait ms = do
402 queue <- processQueue <$> ask
402 queue <- processQueue <$> ask
403− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
403+ mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)
404+ case mProc of
404− proc
405+ Just proc' -> proc'
406+ Nothing -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "
407+ ++ "in the absence of a timeout value."
405
408
406-- | Like 'receiveWait' but with a timeout.
409-- | Like 'receiveWait' but with a timeout.
407--
410--
src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+8−2
@@ -33,6 +33,7 @@ import Control.Distributed.Process.Internal.Primitives
33 ( whereis
33 ( whereis
34 , newChan
34 , newChan
35 , receiveChan
35 , receiveChan
36+ , die
36 )
37 )
37import Control.Distributed.Process.Management.Internal.Trace.Types
38import Control.Distributed.Process.Management.Internal.Trace.Types
38 ( TraceArg(..)
39 ( TraceArg(..)
@@ -168,6 +169,11 @@ withRegisteredTracer act = do
168 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
169 currentTracer <- receiveChan rp
170 currentTracer <- receiveChan rp
170 case currentTracer of
171 case currentTracer of
171− Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
172+ Nothing -> do mTP <- whereis "tracer.initial"
173+ -- NB: this should NOT ever happen, but forcing pattern matches
174+ -- is not considered cool in later versions of MonadFail
175+ case mTP of
176+ Just p' -> act p'
177+ Nothing -> die $ "System Invariant Violation: Tracer Process "
178+ ++ "Name Not Found (whereis tracer.initial)"
172 (Just p) -> act p
179 (Just p) -> act p
173−
stack-ghc-7.10.3.yaml+4−1
@@ -3,12 +3,15 @@ resolver: nightly-2016-03-08
3packages:
3packages:
4- '.'
4- '.'
5- distributed-process-tests/
5- distributed-process-tests/
6+- location:
7+ git: https://github.com/haskell-distributed/network-transport-tcp.git
8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd
9+ extra-dep: true
6
10
7extra-deps:
11extra-deps:
8- rank1dynamic-0.4.0
12- rank1dynamic-0.4.0
9- distributed-static-0.3.8
13- distributed-static-0.3.8
10- network-transport-0.5.2
14- network-transport-0.5.2
11−- network-transport-tcp-0.6.0
12- network-transport-inmemory-0.5.2
15- network-transport-inmemory-0.5.2
13- rematch-0.2.0.0
16- rematch-0.2.0.0
14
17
stack-ghc-8.0.2.yaml+8−2
@@ -1,14 +1,20 @@
1−resolver: lts-9.0
1+resolver: lts-9.21
2+
3+# added -location for network-transport-tcp-0.6.0
4+# since c7fd79 broke the client facing API for createTransport :/
2
5
3packages:
6packages:
4- '.'
7- '.'
5- distributed-process-tests/
8- distributed-process-tests/
9+- location:
10+ git: https://github.com/haskell-distributed/network-transport-tcp.git
11+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd
12+ extra-dep: true
6
13
7extra-deps:
14extra-deps:
8- rank1dynamic-0.4.0
15- rank1dynamic-0.4.0
9- distributed-static-0.3.8
16- distributed-static-0.3.8
10- network-transport-0.5.2
17- network-transport-0.5.2
11−- network-transport-tcp-0.6.0
12- network-transport-inmemory-0.5.2
18- network-transport-inmemory-0.5.2
13- rematch-0.2.0.0
19- rematch-0.2.0.0
14
20
stack-nightly.yamlnew file+26
@@ -0,0 +1,26 @@
1+resolver: nightly-2018-11-10
2+
3+packages:
4+- '.'
5+- distributed-process-tests/
6+- location:
7+ git: https://github.com/haskell-distributed/distributed-static.git
8+ commit: c51e6aadd3a44c044e96a8e986c11d3a94b45b11
9+ extra-dep: true
10+- location:
11+ git: https://github.com/haskell-distributed/network-transport-tcp.git
12+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd
13+ extra-dep: true
14+- location:
15+ git: https://github.com/haskell-distributed/network-transport-inmemory.git
16+ commit: b7a10ffc07a77f4fe6affbf8abe535b11933a01a
17+ extra-dep: true
18+
19+extra-deps:
20+- rank1dynamic-0.4.0
21+- network-transport-0.5.2
22+- rematch-0.2.0.0
23+
24+flags:
25+ distributed-process-tests:
26+ tcp: true
stack.yaml+4−1
@@ -3,12 +3,15 @@ resolver: nightly-2017-08-20
3packages:
3packages:
4- '.'
4- '.'
5- distributed-process-tests/
5- distributed-process-tests/
6+- location:
7+ git: https://github.com/haskell-distributed/network-transport-tcp.git
8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd
9+ extra-dep: true
6
10
7extra-deps:
11extra-deps:
8- rank1dynamic-0.4.0
12- rank1dynamic-0.4.0
9- distributed-static-0.3.8
13- distributed-static-0.3.8
10- network-transport-0.5.2
14- network-transport-0.5.2
11−- network-transport-tcp-0.6.0
12- network-transport-inmemory-0.5.2
15- network-transport-inmemory-0.5.2
13- rematch-0.2.0.0
16- rematch-0.2.0.0
14
17