1cf2a29 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Merge branch 'master' into reg-mx

1cf2a29Tim Watson8 years ago

benchmarks/Channels.hs+6−5

compare with master

unifiedsplit

@@ -4,7 +4,7 @@ import Control.Monad

4import Control.Applicative

5import Control.Distributed.Process

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)

9import qualified Data.ByteString.Lazy as BSL

@@ -36,7 +36,8 @@ initialProcess "CLIENT" = do

36main :: IO ()

37main = do

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

4import Control.Distributed.Process

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)

8import qualified Data.ByteString.Lazy as BSL

@@ -31,7 +31,9 @@ initialProcess "CLIENT" = do

31main :: IO ()

32main = do

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)

13import Control.Distributed.Process.Node

14import Control.Exception (catch, SomeException)

15−import Network.Transport.TCP (createTransport, defaultTCPParameters)

15+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)

16import System.Environment

17import System.Console.GetOpt

@@ -111,7 +111,7 @@ main = do

111 (opt, _) <- parseArgv argv

112 putStrLn $ "options: " ++ (show opt)

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

116 catch (void $ runProcess node $ initialProcess opt)

117 (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))

benchmarks/Spawns.hs+6−5

@@ -7,7 +7,7 @@ import Control.Monad

7import Control.Applicative

8import Control.Distributed.Process

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)

12import qualified Data.ByteString.Lazy as BSL

@@ -42,7 +42,8 @@ initialProcess "CLIENT" = do

42main :: IO ()

43main = do

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

7import Control.Distributed.Process

8import Control.Distributed.Process.Node

9−import Network.Transport.TCP (createTransport, defaultTCPParameters)

9+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

10import Data.Binary

11import qualified Data.ByteString.Lazy as BSL

12import Data.Typeable

@@ -67,7 +67,8 @@ initialProcess "CLIENT" = do

67main :: IO ()

68main = do

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,

34 HUnit >= 1.2 && < 1.7,

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,

38 rematch >= 0.1.2.1,

39 setenv >= 0.1.1.3,

@@ -60,7 +60,7 @@ Test-Suite TestCHInMemory

60 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH

61 Build-Depends: base >= 4.4 && < 5,

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,

65 network-transport-inmemory >= 0.5,

66 test-framework >= 0.6 && < 0.9

@@ -75,7 +75,7 @@ Test-Suite TestCHInTCP

75 if flag(tcp)

76 Build-Depends: base >= 4.4 && < 5,

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,

80 network-transport-tcp >= 0.5 && < 0.7,

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

93 Build-Depends: base >= 4.4 && < 5,

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,

97 network-transport-inmemory >= 0.5,

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

107 Build-Depends: base >= 4.4 && < 5,

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,

111 network-transport-inmemory >= 0.5,

112 test-framework >= 0.6 && < 0.9

@@ -148,7 +148,7 @@ Test-Suite TestMxInTCP

148 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx

149 Build-Depends: base >= 4.4 && < 5,

150 distributed-process-tests,

151− network >= 2.3 && < 2.7,

151+ network >= 2.3 && < 2.9,

152 network-transport >= 0.4.1.0 && < 0.6,

153 network-transport-inmemory >= 0.5,

154 test-framework >= 0.6 && < 0.9

@@ -162,7 +162,7 @@ Test-Suite TestTracingInTCP

162 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing

163 Build-Depends: base >= 4.4 && < 5,

164 distributed-process-tests,

165− network >= 2.3 && < 2.7,

165+ network >= 2.3 && < 2.9,

166 network-transport >= 0.4.1.0 && < 0.6,

167 network-transport-inmemory >= 0.5,

168 test-framework >= 0.6 && < 0.9

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+296−212

@@ -42,7 +42,7 @@ import Control.Distributed.Process.Management.Internal.Types

42import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)

43import Control.Distributed.Process.Serializable (Serializable)

45−import Test.HUnit (Assertion, assertFailure, assertBool)

45+import Test.HUnit (Assertion, assertBool, assertFailure)

46import Test.Framework (Test, testGroup)

47import Test.Framework.Providers.HUnit (testCase)

48import Control.Rematch hiding (match)

@@ -78,12 +78,47 @@ ping = do

78 send partner (Ping self)

79 ping

81+verifyClient :: String -> MVar Bool -> IO ()

82+verifyClient s b = takeMVar b >>= assertBool s

83+

84+expectPing :: MVar Bool -> Process ()

85+expectPing mv = expect >>= liftIO . putMVar mv . checkPing

86+ where

87+ checkPing (Ping _) = True

88+ checkPing _ = False

89+

81-- | Quick and dirty synchronous version of whereisRemoteAsync

90-- | Quick and dirty synchronous version of whereisRemoteAsync

82whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)

91whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)

83whereisRemote nid string = do

92whereisRemote nid string = do

84 whereisRemoteAsync nid string

93 whereisRemoteAsync nid string

94+ receiveWait [

85− WhereIsReply _ mPid <- expect

95+ match (\(WhereIsReply _ mPid) -> return mPid)

96+ ]

97+

98+verifyWhereIsRemote :: NodeId -> String -> Process ProcessId

99+verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return

100+

101+waitForExit :: ProcessId -> Process DiedReason

102+waitForExit pid = monitor pid >>= waitForDown

103+

104+waitForDown :: MonitorRef -> Process DiedReason

105+waitForDown ref =

106+ receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

107+ (\(ProcessMonitorNotification _ _ dr) -> return dr) ]

108+

109+syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()

110+syncBreakConnection breakConnection nid0 nid1 = do

111+ m <- newEmptyMVar

112+ _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m

113+ runProcess nid0 $ do

114+ them <- liftIO $ takeMVar m

115+ pinger <- spawnLocal $ forever $ send them ()

116+ _ <- monitorNode (localNodeId nid1)

117+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

118+ (nodeAddress $ localNodeId nid1)

119+ NodeMonitorNotification _ _ _ <- expect

120+ kill pinger "finished"

86− return mPid

121+ return ()

122

88data Add = Add ProcessId Double Double deriving (Typeable)

123data Add = Add ProcessId Double Double deriving (Typeable)

89data Divide = Divide ProcessId Double Double deriving (Typeable)

124data Divide = Divide ProcessId Double Double deriving (Typeable)

@@ -158,12 +193,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =

158 unmonitor ref

193 unmonitor ref

159 liftIO $ putMVar done ()

194 liftIO $ putMVar done ()

160 (False, ref) -> do

195 (False, ref) -> do

196+ receiveWait [

161− ProcessMonitorNotification ref' pid reason' <- expect

197+ match (\(ProcessMonitorNotification ref' pid reason') -> do

198+ liftIO $ do

199+ assertBool "Bad Monitor Signal"

162− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'

200+ (Just ref' == ref && pid == theirAddr &&

201+ mOrL && reason == reason')

163− liftIO $ putMVar done ()

202+ putMVar done ())

203+ ]

164 )

204 )

165 (\(ProcessLinkException pid reason') -> do

205 (\(ProcessLinkException pid reason') -> do

206+ (liftIO $ assertBool "link exception unmatched" $

166− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'

207+ pid == theirAddr && not mOrL && not un && reason == reason')

167 liftIO $ putMVar done ()

208 liftIO $ putMVar done ()

168 )

209 )

169

210

@@ -194,8 +235,10 @@ testPing TestTransport{..} = do

194 pid <- getSelfPid

235 pid <- getSelfPid

195 replicateM_ numPings $ do

236 replicateM_ numPings $ do

196 send pingServer (Pong pid)

237 send pingServer (Pong pid)

197− Ping _ <- expect

238+ p <- expect

239+ case p of

198− return ()

240+ Ping _ -> return ()

241+ _ -> die "Unexpected message"

199

242

200 putMVar clientDone ()

243 putMVar clientDone ()

201

244

@@ -282,7 +325,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do

282 runProcess localNode $ do

325 runProcess localNode $ do

283 monitor theirAddr

326 monitor theirAddr

284 -- wait for the process to die

327 -- wait for the process to die

285− ProcessMonitorNotification _ _ _ <- expect

328+ expect :: Process ProcessMonitorNotification

286 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

329 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

287

330

288 takeMVar done

331 takeMVar done

@@ -356,14 +399,17 @@ testMath TestTransport{..} = do

356 runProcess localNode $ do

399 runProcess localNode $ do

357 pid <- getSelfPid

400 pid <- getSelfPid

358 send mathServer (Add pid 1 2)

401 send mathServer (Add pid 1 2)

359− 3 <- expect :: Process Double

402+ three <- expect :: Process Double

360 send mathServer (Divide pid 8 2)

403 send mathServer (Divide pid 8 2)

361− 4 <- expect :: Process Double

404+ four <- expect :: Process Double

362 send mathServer (Divide pid 8 0)

405 send mathServer (Divide pid 8 0)

363− DivByZero <- expect

406+ divByZ <- expect

364− liftIO $ putMVar clientDone ()

407+ liftIO $ putMVar clientDone (three, four, divByZ)

365

408

366− takeMVar clientDone

409+ res <- takeMVar clientDone

410+ case res of

411+ (3, 4, DivByZero) -> return ()

412+ _ -> error $ "Something went horribly wrong"

367

413

368-- | Send first message (i.e. connect) to an already terminated process

414-- | Send first message (i.e. connect) to an already terminated process

369-- (without monitoring); then send another message to a second process on

415-- (without monitoring); then send another message to a second process on

@@ -391,11 +437,9 @@ testSendToTerminated TestTransport{..} = do

391 pid <- getSelfPid

437 pid <- getSelfPid

392 send server1 "Hi"

438 send server1 "Hi"

393 send server2 (Pong pid)

439 send server2 (Pong pid)

394− Ping pid' <- expect

395− True <- return $ pid' == server2

396− liftIO $ putMVar clientDone ()

440+ expectPing clientDone

397

441

398− takeMVar clientDone

442+ verifyClient "Expected Ping from server" clientDone

399

443

400-- | Test (non-zero) timeout

444-- | Test (non-zero) timeout

401testTimeout :: TestTransport -> Assertion

445testTimeout :: TestTransport -> Assertion

@@ -404,10 +448,10 @@ testTimeout TestTransport{..} = do

404 done <- newEmptyMVar

448 done <- newEmptyMVar

405

449

406 runProcess localNode $ do

450 runProcess localNode $ do

407− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]

451+ res <- receiveTimeout 1000000 [match (\Add{} -> return ())]

408− liftIO $ putMVar done ()

452+ liftIO $ putMVar done $ res == Nothing

409

453

410− takeMVar done

454+ verifyClient "Expected receiveTimeout to timeout..." done

411

455

412-- | Test zero timeout

456-- | Test zero timeout

413testTimeout0 :: TestTransport -> Assertion

457testTimeout0 :: TestTransport -> Assertion

@@ -435,10 +479,9 @@ testTimeout0 TestTransport{..} = do

435 -- is not interested in, and then a single message that it wants

479 -- is not interested in, and then a single message that it wants

436 replicateM_ 10000 $ send server "Irrelevant message"

480 replicateM_ 10000 $ send server "Irrelevant message"

437 send server (Pong pid)

481 send server (Pong pid)

438− Ping _ <- expect

439− liftIO $ putMVar clientDone ()

482+ expectPing clientDone

440

483

441− takeMVar clientDone

484+ verifyClient "Expected Ping from server" clientDone

442

485

443-- | Test typed channels

486-- | Test typed channels

444testTypedChannels :: TestTransport -> Assertion

487testTypedChannels :: TestTransport -> Assertion

@@ -461,10 +504,10 @@ testTypedChannels TestTransport{..} = do

461 runProcess localNode $ do

504 runProcess localNode $ do

462 (clientSendPort, rport) <- newChan

505 (clientSendPort, rport) <- newChan

463 sendChan serverSendPort (clientSendPort, 5)

506 sendChan serverSendPort (clientSendPort, 5)

464− False <- receiveChan rport

507+ ch <- receiveChan rport

465− liftIO $ putMVar clientDone ()

508+ liftIO $ putMVar clientDone $ ch == False

466

509

467− takeMVar clientDone

510+ verifyClient "Expected channel to send 'False'" clientDone

468

511

469-- | Test merging receive ports

512-- | Test merging receive ports

470testMergeChannels :: TestTransport -> Assertion

513testMergeChannels :: TestTransport -> Assertion

@@ -487,9 +530,8 @@ testMergeChannels TestTransport{..} = do

487 rs <- mapM charChannel "abc"

530 rs <- mapM charChannel "abc"

488 m <- mergePorts biased rs

531 m <- mergePorts biased rs

489 xs <- replicateM 9 $ receiveChan m

532 xs <- replicateM 9 $ receiveChan m

490− True <- return $ xs == expected

491− liftIO $ putMVar done ()

533+ liftIO $ putMVar done $ xs == expected

492− takeMVar done

534+ verifyClient "Expected single layer merge to match expected ordering" done

493

535

494 -- Two layers of merging

536 -- Two layers of merging

495 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()

537 testNested :: LocalNode -> Bool -> Bool -> String -> IO ()

@@ -500,9 +542,8 @@ testMergeChannels TestTransport{..} = do

500 ms <- mapM (mergePorts biasedInner) rss

542 ms <- mapM (mergePorts biasedInner) rss

501 m <- mergePorts biasedOuter ms

543 m <- mergePorts biasedOuter ms

502 xs <- replicateM (9 * 3) $ receiveChan m

544 xs <- replicateM (9 * 3) $ receiveChan m

503− True <- return $ xs == expected

545+ liftIO $ putMVar done $ xs == expected

504− liftIO $ putMVar done ()

546+ verifyClient "Expected nested channels to match expeted ordering" done

505− takeMVar done

506

547

507 -- Test that if no messages are (immediately) available, the scheduler makes no difference

548 -- Test that if no messages are (immediately) available, the scheduler makes no difference

508 testBlocked :: LocalNode -> Bool -> IO ()

549 testBlocked :: LocalNode -> Bool -> IO ()

@@ -511,43 +552,45 @@ testMergeChannels TestTransport{..} = do

511 done <- newEmptyMVar

552 done <- newEmptyMVar

512

553

513 forkProcess localNode $ do

554 forkProcess localNode $ do

514− [sa, sb, sc] <- liftIO $ mapM readMVar vs

555+ ss <- liftIO $ mapM readMVar vs

556+ case ss of

557+ [sa, sb, sc] ->

515− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)

558+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)

516− [ -- a, b, c

559+ [ -- a, b, c

517− (sa, 'a')

560+ (sa, 'a')

518− , (sb, 'b')

561+ , (sb, 'b')

519− , (sc, 'c')

562+ , (sc, 'c')

520− -- a, c, b

563+ -- a, c, b

521− , (sa, 'a')

564+ , (sa, 'a')

522− , (sc, 'c')

565+ , (sc, 'c')

523− , (sb, 'b')

566+ , (sb, 'b')

524− -- b, a, c

567+ -- b, a, c

525− , (sb, 'b')

568+ , (sb, 'b')

526− , (sa, 'a')

569+ , (sa, 'a')

527− , (sc, 'c')

570+ , (sc, 'c')

528− -- b, c, a

571+ -- b, c, a

529− , (sb, 'b')

572+ , (sb, 'b')

530− , (sc, 'c')

573+ , (sc, 'c')

531− , (sa, 'a')

574+ , (sa, 'a')

532− -- c, a, b

575+ -- c, a, b

533− , (sc, 'c')

576+ , (sc, 'c')

534− , (sa, 'a')

577+ , (sa, 'a')

535− , (sb, 'b')

578+ , (sb, 'b')

536− -- c, b, a

579+ -- c, b, a

537− , (sc, 'c')

580+ , (sc, 'c')

538− , (sb, 'b')

581+ , (sb, 'b')

539− , (sa, 'a')

582+ , (sa, 'a')

540− ]

583+ ]

584+ _ -> die "Something went horribly wrong"

541

585

542 forkProcess localNode $ do

586 forkProcess localNode $ do

543 (ss, rs) <- unzip <$> replicateM 3 newChan

587 (ss, rs) <- unzip <$> replicateM 3 newChan

544 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

588 liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

545 m <- mergePorts biased rs

589 m <- mergePorts biased rs

546 xs <- replicateM (6 * 3) $ receiveChan m

590 xs <- replicateM (6 * 3) $ receiveChan m

547− True <- return $ xs == "abcacbbacbcacabcba"

548− liftIO $ putMVar done ()

591+ liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"

549

592

550− takeMVar done

593+ verifyClient "Expected merged ports to match expected ordering" done

551

594

552 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)

595 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)

553 mergePorts True = mergePortsBiased

596 mergePorts True = mergePortsBiased

@@ -565,8 +608,9 @@ testTerminate TestTransport{..} = do

565 localNode <- newLocalNode testTransport initRemoteTable

608 localNode <- newLocalNode testTransport initRemoteTable

566 runProcess localNode $ do

609 runProcess localNode $ do

567 e <- try terminate :: Process (Either ProcessTerminationException ())

610 e <- try terminate :: Process (Either ProcessTerminationException ())

568− True <- return $ either show show e == show ProcessTerminationException

611+ if either show show e == show ProcessTerminationException

569− return ()

612+ then return ()

613+ else die "Unexpected result from terminate"

570

614

571testMonitorNode :: TestTransport -> Assertion

615testMonitorNode :: TestTransport -> Assertion

572testMonitorNode TestTransport{..} = do

616testMonitorNode TestTransport{..} = do

@@ -577,11 +621,12 @@ testMonitorNode TestTransport{..} = do

577

621

578 runProcess node2 $ do

622 runProcess node2 $ do

579 ref <- monitorNode (localNodeId node1)

623 ref <- monitorNode (localNodeId node1)

624+ receiveWait [

580− NodeMonitorNotification ref' nid DiedDisconnect <- expect

625+ match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->

581− True <- return $ ref == ref' && nid == localNodeId node1

626+ return $ ref == ref' && nid == localNodeId node1)

582− liftIO $ putMVar done ()

627+ ] >>= liftIO . putMVar done

583

628

584− takeMVar done

629+ verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done

585

630

586testMonitorLiveNode :: TestTransport -> Assertion

631testMonitorLiveNode :: TestTransport -> Assertion

587testMonitorLiveNode TestTransport{..} = do

632testMonitorLiveNode TestTransport{..} = do

@@ -596,15 +641,16 @@ testMonitorLiveNode TestTransport{..} = do

596 liftIO $ putMVar ready ()

641 liftIO $ putMVar ready ()

597 liftIO $ takeMVar readyr

642 liftIO $ takeMVar readyr

598 send p ()

643 send p ()

644+ receiveWait [

599− NodeMonitorNotification ref' nid _ <- expect

645+ match (\(NodeMonitorNotification ref' nid _) ->

600− True <- return $ ref == ref' && nid == localNodeId node1

646+ (return $ ref == ref' && nid == localNodeId node1))

601− liftIO $ putMVar done ()

647+ ] >>= liftIO . putMVar done

602

648

603 takeMVar ready

649 takeMVar ready

604 closeLocalNode node1

650 closeLocalNode node1

605 putMVar readyr ()

651 putMVar readyr ()

606

652

607− takeMVar done

653+ verifyClient "Expected NodeMonitorNotification for LIVE node" done

608

654

609testMonitorChannel :: TestTransport -> Assertion

655testMonitorChannel :: TestTransport -> Assertion

610testMonitorChannel TestTransport{..} = do

656testMonitorChannel TestTransport{..} = do

@@ -614,18 +660,20 @@ testMonitorChannel TestTransport{..} = do

614 pid <- forkProcess node1 $ do

660 pid <- forkProcess node1 $ do

615 sport <- expect :: Process (SendPort ())

661 sport <- expect :: Process (SendPort ())

616 ref <- monitorPort sport

662 ref <- monitorPort sport

617− PortMonitorNotification ref' port' reason <- expect

663+ receiveWait [

618− -- reason might be DiedUnknownId if the receive port is GCed before the

664+ -- reason might be DiedUnknownId if the receive port is GCed before the

619− -- monitor is established (TODO: not sure that this is reasonable)

665+ -- monitor is established (TODO: not sure that this is reasonable)

666+ match (\(PortMonitorNotification ref' port' reason) ->

667+ return $ ref' == ref && port' == sendPortId sport &&

620− return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)

668+ (reason == DiedNormal || reason == DiedUnknownId))

621− liftIO $ putMVar gotNotification ()

669+ ] >>= liftIO . putMVar gotNotification

622

670

623 runProcess node2 $ do

671 runProcess node2 $ do

624 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())

672 (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())

625 send pid sport

673 send pid sport

626 liftIO $ threadDelay 100000

674 liftIO $ threadDelay 100000

627

675

628− takeMVar gotNotification

676+ verifyClient "Expected PortMonitorNotification" gotNotification

629

677

630testRegistry :: TestTransport -> Assertion

678testRegistry :: TestTransport -> Assertion

631testRegistry TestTransport{..} = do

679testRegistry TestTransport{..} = do

@@ -637,20 +685,28 @@ testRegistry TestTransport{..} = do

637

685

638 runProcess node $ do

686 runProcess node $ do

639 register "ping" pingServer

687 register "ping" pingServer

640− Just pid <- whereis "ping"

688+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

641− True <- return $ pingServer == pid

642 us <- getSelfPid

689 us <- getSelfPid

643 nsend "ping" (Pong us)

690 nsend "ping" (Pong us)

644− Ping pid' <- expect

691+ receiveWait [

645− True <- return $ pingServer == pid'

692+ matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())

646− Left (ProcessRegistrationException "dead" Nothing) <- try $ register "dead" deadProcess

693+ ]

647− Left (ProcessRegistrationException "ping" (Just x)) <- try $ register "ping" deadProcess

694+ checkRegException "dead" Nothing deadProcess

648− True <- return $ x == pingServer

695+ checkRegException "ping" (Just pingServer) deadProcess

649− Left (ProcessRegistrationException "dead" Nothing) <- try $ unregister "dead"

696+ try (unregister "dead") >>= checkReg "dead" Nothing

650 liftIO $ putMVar done ()

697 liftIO $ putMVar done ()

651

698

652 takeMVar done

699 takeMVar done

653

700

701+ where

702+ checkRegException name pid dead =

703+ try (register name dead) >>= checkReg name pid

704+

705+ checkReg name pid res =

706+ case res of

707+ Left (ProcessRegistrationException name pid) -> return ()

708+ _ -> die $ "Unexpected Registration" ++ show res

709+

654testRegistryRemoteProcess :: TestTransport -> Assertion

710testRegistryRemoteProcess :: TestTransport -> Assertion

655testRegistryRemoteProcess TestTransport{..} = do

711testRegistryRemoteProcess TestTransport{..} = do

656 node1 <- newLocalNode testTransport initRemoteTable

712 node1 <- newLocalNode testTransport initRemoteTable

@@ -661,13 +717,13 @@ testRegistryRemoteProcess TestTransport{..} = do

661

717

662 runProcess node2 $ do

718 runProcess node2 $ do

663 register "ping" pingServer

719 register "ping" pingServer

664− Just pid <- whereis "ping"

720+ whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

665− True <- return $ pingServer == pid

666 us <- getSelfPid

721 us <- getSelfPid

667 nsend "ping" (Pong us)

722 nsend "ping" (Pong us)

668− Ping pid' <- expect

723+ receiveWait [

669− True <- return $ pingServer == pid'

724+ matchIf (\(Ping pid') -> pingServer == pid')

670− liftIO $ putMVar done ()

725+ (const $ liftIO $ putMVar done ())

726+ ]

671

727

672 takeMVar done

728 takeMVar done

673

729

@@ -688,12 +744,13 @@ testRemoteRegistry TestTransport{..} = do

688 "ping" == label' && pid == pingServer)

744 "ping" == label' && pid == pingServer)

689 (\(RegisterReply _ _ _) -> return ()) ]

745 (\(RegisterReply _ _ _) -> return ()) ]

690

746

691− Just pid <- whereisRemote nid1 "ping"

747+ pid <- verifyWhereIsRemote nid1 "ping"

692− True <- return $ pingServer == pid

748+ liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid

693 us <- getSelfPid

749 us <- getSelfPid

694 nsendRemote nid1 "ping" (Pong us)

750 nsendRemote nid1 "ping" (Pong us)

695− Ping pid' <- expect

751+ receiveWait [

696− True <- return $ pingServer == pid'

752+ match (\(Ping pid') -> return $ pingServer == pid')

753+ ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"

697

754

698 -- test that if process was not registered Nothing is returned

755 -- test that if process was not registered Nothing is returned

699 -- in owner field.

756 -- in owner field.

@@ -729,15 +786,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do

729 receiveWait [

786 receiveWait [

730 matchIf (\(RegisterReply label' _ _) -> "ping" == label')

787 matchIf (\(RegisterReply label' _ _) -> "ping" == label')

731 (\(RegisterReply _ _ _) -> return ()) ]

788 (\(RegisterReply _ _ _) -> return ()) ]

732− Just pid <- whereisRemote nid1 "ping"

789+ pid <- verifyWhereIsRemote nid1 "ping"

733− True <- return $ pingServer == pid

790+ liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid

734 us <- getSelfPid

791 us <- getSelfPid

735 nsendRemote nid1 "ping" (Pong us)

792 nsendRemote nid1 "ping" (Pong us)

736− Ping pid' <- expect

793+ receiveWait [

737− True <- return $ pingServer == pid'

794+ match (\(Ping pid') -> return $ pingServer == pid')

738− liftIO $ putMVar done ()

795+ ] >>= liftIO . putMVar done

739

796

740− takeMVar done

797+ verifyClient "Expected Ping with ping server's ProcessId" done

741

798

742testSpawnLocal :: TestTransport -> Assertion

799testSpawnLocal :: TestTransport -> Assertion

743testSpawnLocal TestTransport{..} = do

800testSpawnLocal TestTransport{..} = do

@@ -751,15 +808,14 @@ testSpawnLocal TestTransport{..} = do

751 sport <- expect

808 sport <- expect

752 sendChan sport (1234 :: Int)

809 sendChan sport (1234 :: Int)

753

810

754− sport <- spawnChannelLocal $ \rport -> do

811+ sport <- spawnChannelLocal $

755− (1234 :: Int) <- receiveChan rport

812+ \rport -> (receiveChan rport :: Process Int) >>= send us

756− send us ()

757

813

758 send pid sport

814 send pid sport

759− () <- expect

760− liftIO $ putMVar done ()

815+ expect >>= liftIO . putMVar done

761

816

762− takeMVar done

817+ res <- takeMVar done

818+ assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)

763

819

764testSpawnAsyncStrictness :: TestTransport -> Assertion

820testSpawnAsyncStrictness :: TestTransport -> Assertion

765testSpawnAsyncStrictness TestTransport{..} = do

821testSpawnAsyncStrictness TestTransport{..} = do

@@ -788,8 +844,9 @@ testReconnect TestTransport{..} = do

788 liftIO $ putMVar processA us

844 liftIO $ putMVar processA us

789 msg1 <- expect

845 msg1 <- expect

790 msg2 <- expect

846 msg2 <- expect

847+ liftIO $ do

791− True <- return $ msg1 == "message 1" && msg2 == "message 3"

848+ assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"

792− liftIO $ putMVar sendTestOk ()

849+ putMVar sendTestOk ()

793

850

794 forkProcess node2 $ do

851 forkProcess node2 $ do

795 {-

852 {-

@@ -822,7 +879,7 @@ testReconnect TestTransport{..} = do

822 matchIf (\(RegisterReply label' _ _) -> "a" == label')

879 matchIf (\(RegisterReply label' _ _) -> "a" == label')

823 (\(RegisterReply _ _ _) -> return ()) ]

880 (\(RegisterReply _ _ _) -> return ()) ]

824

881

825− Just _ <- whereisRemote nid1 "a"

882+ _ <- whereisRemote nid1 "a"

826

883

827

884

828 -- Simulate network failure

885 -- Simulate network failure

@@ -841,9 +898,10 @@ testReconnect TestTransport{..} = do

841 (\(RegisterReply _ _ _) -> return ()) ]

898 (\(RegisterReply _ _ _) -> return ()) ]

842

899

843 -- Check

900 -- Check

844− Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected

901+ mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected

902+ liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing

845− Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect

903+ verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect

846− Just _ <- whereisRemote nid1 "c"

904+ verifyWhereIsRemote nid1 "c"

847

905

848 liftIO $ putMVar registerTestOk ()

906 liftIO $ putMVar registerTestOk ()

849

907

@@ -884,13 +942,14 @@ testUSend usendPrim TestTransport{..} numMessages = do

884 isSorted _ = True

942 isSorted _ = True

885 -- The list can't be null since there are no failures after sending

943 -- The list can't be null since there are no failures after sending

886 -- the last message.

944 -- the last message.

945+ liftIO $ do

887− True <- return $ isSorted msgs && not (null msgs)

946+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)

888− liftIO $ putMVar usendTestOk ()

947+ putMVar usendTestOk ()

889

948

890 forkProcess node2 $ do

949 forkProcess node2 $ do

891 them <- liftIO $ readMVar processA

950 them <- liftIO $ readMVar processA

892 getSelfPid >>= send them

951 getSelfPid >>= send them

893− () <- expect

952+ expect :: Process ()

894 forM_ [1..numMessages] $ \i -> do

953 forM_ [1..numMessages] $ \i -> do

895 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)

954 liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)

896 usendPrim them i

955 usendPrim them i

@@ -922,14 +981,17 @@ testMatchAny TestTransport{..} = do

922 runProcess localNode $ do

981 runProcess localNode $ do

923 pid <- getSelfPid

982 pid <- getSelfPid

924 send mathServer (Add pid 1 2)

983 send mathServer (Add pid 1 2)

925− 3 <- expect :: Process Double

984+ three <- expect :: Process Double

926 send mathServer (Divide pid 8 2)

985 send mathServer (Divide pid 8 2)

927− 4 <- expect :: Process Double

986+ four <- expect :: Process Double

928 send mathServer (Divide pid 8 0)

987 send mathServer (Divide pid 8 0)

929− DivByZero <- expect

988+ divByZ <- expect

930− liftIO $ putMVar clientDone ()

989+ liftIO $ putMVar clientDone (three, four, divByZ)

931

990

932− takeMVar clientDone

991+ res <- takeMVar clientDone

992+ case res of

993+ (3, 4, DivByZero) -> return ()

994+ _ -> error "Unexpected result"

933

995

934-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

996-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

935-- in between, however we block 'Divide' requests ....

997-- in between, however we block 'Divide' requests ....

@@ -956,12 +1018,13 @@ testMatchAnyHandle TestTransport{..} = do

956 runProcess localNode $ do

1018 runProcess localNode $ do

957 pid <- getSelfPid

1019 pid <- getSelfPid

958 send mathServer (Add pid 1 2)

1020 send mathServer (Add pid 1 2)

959− 3 <- expect :: Process Double

1021+ three <- expect :: Process Double

960 send mathServer (Divide pid 8 2)

1022 send mathServer (Divide pid 8 2)

961− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)

1023+ res <- (expectTimeout 100000) :: Process (Maybe Double)

962− liftIO $ putMVar clientDone ()

1024+ liftIO $ putMVar clientDone $ three == 3 && res == Nothing

1025+

1026+ verifyClient "Expected Nothing (i.e. timeout)" clientDone

963

1027

964− takeMVar clientDone

965 where maybeForward :: ProcessId -> Message -> Process (Maybe ())

1028 where maybeForward :: ProcessId -> Message -> Process (Maybe ())

966 maybeForward s msg =

1029 maybeForward s msg =

967 handleMessage msg (\m@(Add _ _ _) -> send s m)

1030 handleMessage msg (\m@(Add _ _ _) -> send s m)

@@ -989,8 +1052,10 @@ testMatchAnyNoHandle TestTransport{..} = do

989 Just _ -> die "NONSENSE")

1052 Just _ -> die "NONSENSE")

990 ]

1053 ]

991 -- we *must* have removed the message from our mailbox though!!!

1054 -- we *must* have removed the message from our mailbox though!!!

992− Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]

1055+ res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]

1056+ liftIO $ do

1057+ assertBool "Expected timeout!" $ res == Nothing

993− liftIO $ putMVar serverDone ()

1058+ putMVar serverDone ()

994 putMVar addr server

1059 putMVar addr server

995

1060

996 -- Client

1061 -- Client

@@ -1033,14 +1098,21 @@ testMatchAnyIf TestTransport{..} = do

1033 runProcess localNode $ do

1098 runProcess localNode $ do

1034 pid <- getSelfPid

1099 pid <- getSelfPid

1035 send server (pid, "foo")

1100 send server (pid, "foo")

1036− "foo" <- expect

1101+ foo <- expect

1037− send server (pid, "baz")

1102+ -- provoking what would be the wrong ordering is informative here...

1038− "baz" <- expect

1103+

1039 send server (pid, "bar")

1104 send server (pid, "bar")

1040− Nothing <- (expectTimeout 100000) :: Process (Maybe Double)

1105+ bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?

1106+

1107+ send server (pid, "baz")

1108+ baz <- expect

1109+

1041− liftIO $ putMVar clientDone ()

1110+ liftIO $ putMVar clientDone (foo, bar, baz)

1111+

1112+ res <- takeMVar clientDone

1113+ let res' = res == ("foo", Nothing, "baz")

1114+ assertBool "Expected timeout due to type mismatch" res'

1042

1115

1043− takeMVar clientDone

1044 where tryHandleMessage :: Message -> Process (Maybe ())

1116 where tryHandleMessage :: Message -> Process (Maybe ())

1045 tryHandleMessage msg =

1117 tryHandleMessage msg =

1046 handleMessage msg (\(pid :: ProcessId, (m :: String))

1118 handleMessage msg (\(pid :: ProcessId, (m :: String))

@@ -1073,12 +1145,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do

1073 runProcess localNode $ do

1145 runProcess localNode $ do

1074 pid <- getSelfPid

1146 pid <- getSelfPid

1075 send server (pid, wrapMessage ("foo" :: String))

1147 send server (pid, wrapMessage ("foo" :: String))

1076− "foo" <- expect

1148+ foo <- expect

1077 send server (pid, wrapMessage ("baz" :: String))

1149 send server (pid, wrapMessage ("baz" :: String))

1078− "baz" <- expect

1150+ baz <- expect

1079− liftIO $ putMVar clientDone ()

1151+ liftIO $ putMVar clientDone (foo, baz)

1080

1152

1081− takeMVar clientDone

1153+ res <- takeMVar clientDone

1154+ assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")

1082

1155

1083-- Test 'receiveChanTimeout'

1156-- Test 'receiveChanTimeout'

1084testReceiveChanTimeout :: TestTransport -> Assertion

1157testReceiveChanTimeout :: TestTransport -> Assertion

@@ -1096,18 +1169,19 @@ testReceiveChanTimeout TestTransport{..} = do

1096

1169

1097 -- Wait for a message with a delay. No message arrives, we should get

1170 -- Wait for a message with a delay. No message arrives, we should get

1098 -- Nothing after the delay.

1171 -- Nothing after the delay.

1099− Nothing <- receiveChanTimeout 100000 rp

1172+ receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1100

1173

1101 -- Let the sender know that it can send a message.

1174 -- Let the sender know that it can send a message.

1102 liftIO $ putMVar mvSender ()

1175 liftIO $ putMVar mvSender ()

1103

1176

1104 -- Wait for a message with a delay again. Now a message arrives after

1177 -- Wait for a message with a delay again. Now a message arrives after

1105 -- 0.1 seconds

1178 -- 0.1 seconds

1106− Just True <- receiveChanTimeout 20000000 rp

1179+ res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return

1180+ liftIO $ assertBool "Expected result to be 'True'" res

1107

1181

1108 -- Wait for a message with zero timeout: non-blocking check. No message is

1182 -- Wait for a message with zero timeout: non-blocking check. No message is

1109 -- available, we get Nothing

1183 -- available, we get Nothing

1110− Nothing <- receiveChanTimeout 0 rp

1184+ receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1111

1185

1112 -- Let the sender know that it can send a message.

1186 -- Let the sender know that it can send a message.

1113 liftIO $ putMVar mvSender ()

1187 liftIO $ putMVar mvSender ()

@@ -1117,7 +1191,7 @@ testReceiveChanTimeout TestTransport{..} = do

1117 liftIO $ threadDelay 100000

1191 liftIO $ threadDelay 100000

1118 mb <- receiveChanTimeout 0 rp

1192 mb <- receiveChanTimeout 0 rp

1119 case mb of

1193 case mb of

1120− Just b -> do False <- return b; return ()

1194+ Just b -> do liftIO $ assertBool "Unexpected Message" $ not b

1121 _ -> loop

1195 _ -> loop

1122

1196

1123 liftIO $ putMVar done ()

1197 liftIO $ putMVar done ()

@@ -1154,8 +1228,8 @@ testReceiveChanFeatures TestTransport{..} = do

1154

1228

1155 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]

1229 rp1 <- mergePortsBiased [even <$> rpInt, rpBool]

1156

1230

1157− True <- receiveChan rp1

1231+ receiveChan rp1 >>= liftIO . assertBool "Expected True"

1158− False <- receiveChan rp1

1232+ receiveChan rp1 >>= liftIO . assertBool "Expected False" . not

1159

1233

1160 -- Test Applicative instance

1234 -- Test Applicative instance

1161

1235

@@ -1164,7 +1238,7 @@ testReceiveChanFeatures TestTransport{..} = do

1164

1238

1165 let rp2 = pure (+) <*> rpInt <*> rpInt

1239 let rp2 = pure (+) <*> rpInt <*> rpInt

1166

1240

1167− 7 <- receiveChan rp2

1241+ receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)

1168

1242

1169 -- Test Alternative instance

1243 -- Test Alternative instance

1170

1244

@@ -1173,8 +1247,8 @@ testReceiveChanFeatures TestTransport{..} = do

1173

1247

1174 let rp3 = (even <$> rpInt) <|> rpBool

1248 let rp3 = (even <$> rpInt) <|> rpBool

1175

1249

1176− False <- receiveChan rp3

1250+ receiveChan rp3 >>= liftIO . assertBool "Expected False" . not

1177− True <- receiveChan rp3

1251+ receiveChan rp3 >>= liftIO . assertBool "Expected True"

1178

1252

1179 -- Test Monad instance

1253 -- Test Monad instance

1180

1254

@@ -1188,8 +1262,8 @@ testReceiveChanFeatures TestTransport{..} = do

1188 then rpInt

1262 then rpInt

1189 else return 7

1263 else return 7

1190

1264

1191− 5 <- receiveChan rp4

1265+ receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)

1192− 7 <- receiveChan rp4

1266+ receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)

1193

1267

1194 liftIO $ putMVar done ()

1268 liftIO $ putMVar done ()

1195

1269

@@ -1198,7 +1272,6 @@ testReceiveChanFeatures TestTransport{..} = do

1198testKillLocal :: TestTransport -> Assertion

1272testKillLocal :: TestTransport -> Assertion

1199testKillLocal TestTransport{..} = do

1273testKillLocal TestTransport{..} = do

1200 localNode <- newLocalNode testTransport initRemoteTable

1274 localNode <- newLocalNode testTransport initRemoteTable

1201− done <- newEmptyMVar

1202

1275

1203 pid <- forkProcess localNode $ do

1276 pid <- forkProcess localNode $ do

1204 liftIO $ threadDelay 1000000

1277 liftIO $ threadDelay 1000000

@@ -1207,17 +1280,18 @@ testKillLocal TestTransport{..} = do

1207 ref <- monitor pid

1280 ref <- monitor pid

1208 us <- getSelfPid

1281 us <- getSelfPid

1209 kill pid "TestKill"

1282 kill pid "TestKill"

1210− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

1283+ mn <- expect

1284+ case mn of

1285+ ProcessMonitorNotification ref' pid' (DiedException ex) ->

1211− True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"

1286+ case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of

1212− liftIO $ putMVar done ()

1287+ True -> return ()

1213−

1288+ False -> die "Invalid ProcessMonitorNotification received"

1214− takeMVar done

1289+ _ -> die "Something went horribly wrong"

1215

1290

1216testKillRemote :: TestTransport -> Assertion

1291testKillRemote :: TestTransport -> Assertion

1217testKillRemote TestTransport{..} = do

1292testKillRemote TestTransport{..} = do

1218 node1 <- newLocalNode testTransport initRemoteTable

1293 node1 <- newLocalNode testTransport initRemoteTable

1219 node2 <- newLocalNode testTransport initRemoteTable

1294 node2 <- newLocalNode testTransport initRemoteTable

1220− done <- newEmptyMVar

1221

1295

1222 pid <- forkProcess node1 $ do

1296 pid <- forkProcess node1 $ do

1223 liftIO $ threadDelay 1000000

1297 liftIO $ threadDelay 1000000

@@ -1226,11 +1300,17 @@ testKillRemote TestTransport{..} = do

1226 ref <- monitor pid

1300 ref <- monitor pid

1227 us <- getSelfPid

1301 us <- getSelfPid

1228 kill pid "TestKill"

1302 kill pid "TestKill"

1303+ mn <- expect

1304+ case mn of

1229− ProcessMonitorNotification ref' pid' (DiedException reason) <- expect

1305+ ProcessMonitorNotification ref' pid' (DiedException reason) ->

1230− True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"

1306+ case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of

1231− liftIO $ putMVar done ()

1307+ (True, True, True) -> return ()

1232−

1308+ (a, b, c) -> do

1233− takeMVar done

1309+ let a' = if a then "" else "Invalid ref"

1310+ let b' = if b then "" else "Invalid pid"

1311+ let c' = if c then "" else "Invalid message"

1312+ die $ unwords [a', b', c']

1313+ _ -> die "Received unexpected message"

1234

1314

1235testCatchesExit :: TestTransport -> Assertion

1315testCatchesExit :: TestTransport -> Assertion

1236testCatchesExit TestTransport{..} = do

1316testCatchesExit TestTransport{..} = do

@@ -1256,7 +1336,10 @@ testHandleMessageIf TestTransport{..} = do

1256 self <- getSelfPid

1336 self <- getSelfPid

1257 send self (5 :: Integer, 10 :: Integer)

1337 send self (5 :: Integer, 10 :: Integer)

1258 msg <- receiveWait [ matchMessage return ]

1338 msg <- receiveWait [ matchMessage return ]

1259− Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")

1339+ handleMessageIf msg

1340+ (\() -> True)

1341+ (\() -> die "whoops") >>= maybe (return ())

1342+ (const $ die "Expected Mismatch")

1260 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)

1343 handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)

1261 (\input -> liftIO $ putMVar done input)

1344 (\input -> liftIO $ putMVar done input)

1262 return ()

1345 return ()

@@ -1301,8 +1384,11 @@ testDie TestTransport{..} = do

1301 (die ("foobar", 123 :: Int))

1384 (die ("foobar", 123 :: Int))

1302 `catchExit` \_from reason -> do

1385 `catchExit` \_from reason -> do

1303 -- TODO: should verify that 'from' has the right value

1386 -- TODO: should verify that 'from' has the right value

1304− True <- return $ reason == ("foobar", 123 :: Int)

1387+ let res = reason == ("foobar", 123 :: Int)

1305 liftIO $ putMVar done ()

1388 liftIO $ putMVar done ()

1389+ if res

1390+ then return ()

1391+ else die "Something went horribly wrong"

1306

1392

1307 takeMVar done

1393 takeMVar done

1308

1394

@@ -1316,8 +1402,11 @@ testPrettyExit TestTransport{..} = do

1316 `catch` \ex@(ProcessExitException from _) ->

1402 `catch` \ex@(ProcessExitException from _) ->

1317 let expected = "exit-from=" ++ (show from)

1403 let expected = "exit-from=" ++ (show from)

1318 in do

1404 in do

1319− True <- return $ (show ex) == expected

1405+ let res = (show ex) == expected

1320 liftIO $ putMVar done ()

1406 liftIO $ putMVar done ()

1407+ if res

1408+ then return ()

1409+ else die "Something went horribly wrong"

1321

1410

1322 takeMVar done

1411 takeMVar done

1323

1412

@@ -1333,17 +1422,26 @@ testExitLocal TestTransport{..} = do

1333 pid <- forkProcess localNode $ do

1422 pid <- forkProcess localNode $ do

1334 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do

1423 (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do

1335 -- TODO: should verify that 'from' has the right value

1424 -- TODO: should verify that 'from' has the right value

1336− True <- return $ reason == "TestExit"

1425+ res <- return $ reason == "TestExit"

1337 liftIO $ putMVar supervisedDone ()

1426 liftIO $ putMVar supervisedDone ()

1427+ if res

1428+ then return ()

1429+ else die "Something went horribly wrong"

1338

1430

1339 runProcess localNode $ do

1431 runProcess localNode $ do

1340 liftIO $ takeMVar handlerSetUp

1432 liftIO $ takeMVar handlerSetUp

1341 ref <- monitor pid

1433 ref <- monitor pid

1342 exit pid "TestExit"

1434 exit pid "TestExit"

1343 -- This time the client catches the exception, so it dies normally

1435 -- This time the client catches the exception, so it dies normally

1436+ mn <- expect

1437+ case mn of

1344− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1438+ ProcessMonitorNotification ref' pid' DiedNormal -> do

1345− True <- return $ ref == ref' && pid == pid'

1439+ let res = ref == ref' && pid == pid'

1346− liftIO $ putMVar supervisorDone ()

1440+ liftIO $ putMVar supervisorDone ()

1441+ if res

1442+ then return ()

1443+ else die "Something went horribly wrong"

1444+ _ -> die "Something went horribly wrong"

1347

1445

1348 takeMVar supervisedDone

1446 takeMVar supervisedDone

1349 takeMVar supervisorDone

1447 takeMVar supervisorDone

@@ -1359,15 +1457,24 @@ testExitRemote TestTransport{..} = do

1359 (receiveWait [] :: Process ()) -- block forever

1457 (receiveWait [] :: Process ()) -- block forever

1360 `catchExit` \_from reason -> do

1458 `catchExit` \_from reason -> do

1361 -- TODO: should verify that 'from' has the right value

1459 -- TODO: should verify that 'from' has the right value

1362− True <- return $ reason == "TestExit"

1460+ res <- return $ reason == "TestExit"

1363 liftIO $ putMVar supervisedDone ()

1461 liftIO $ putMVar supervisedDone ()

1462+ if res

1463+ then return ()

1464+ else die "Something went horribly wrong"

1364

1465

1365 runProcess node2 $ do

1466 runProcess node2 $ do

1366 ref <- monitor pid

1467 ref <- monitor pid

1367 exit pid "TestExit"

1468 exit pid "TestExit"

1469+ mn <- expect

1470+ case mn of

1368− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1471+ ProcessMonitorNotification ref' pid' DiedNormal -> do

1369− True <- return $ ref == ref' && pid == pid'

1472+ res' <- return $ ref == ref' && pid == pid'

1370− liftIO $ putMVar supervisorDone ()

1473+ liftIO $ putMVar supervisorDone ()

1474+ if res'

1475+ then return ()

1476+ else die "Something went horribly wrong"

1477+ _ -> die "Something went horribly wrong"

1371

1478

1372 takeMVar supervisedDone

1479 takeMVar supervisedDone

1373 takeMVar supervisorDone

1480 takeMVar supervisorDone

@@ -1497,8 +1604,7 @@ testUnsafeSend TestTransport{..} = do

1497 void $ forkProcess localNode $ do

1604 void $ forkProcess localNode $ do

1498 serverPid <- liftIO $ takeMVar serverAddr

1605 serverPid <- liftIO $ takeMVar serverAddr

1499 getSelfPid >>= unsafeSend serverPid

1606 getSelfPid >>= unsafeSend serverPid

1500− () <- expect

1501− liftIO $ putMVar clientDone ()

1607+ expect >>= liftIO . putMVar clientDone

1502

1608

1503 takeMVar clientDone

1609 takeMVar clientDone

1504

1610

@@ -1517,8 +1623,7 @@ testUnsafeUSend TestTransport{..} = do

1517 void $ forkProcess localNode $ do

1623 void $ forkProcess localNode $ do

1518 serverPid <- liftIO $ takeMVar serverAddr

1624 serverPid <- liftIO $ takeMVar serverAddr

1519 getSelfPid >>= unsafeUSend serverPid

1625 getSelfPid >>= unsafeUSend serverPid

1520− () <- expect

1521− liftIO $ putMVar clientDone ()

1626+ expect >>= liftIO . putMVar clientDone

1522

1627

1523 takeMVar clientDone

1628 takeMVar clientDone

1524

1629

@@ -1529,8 +1634,7 @@ testUnsafeNSend TestTransport{..} = do

1529 localNode <- newLocalNode testTransport initRemoteTable

1634 localNode <- newLocalNode testTransport initRemoteTable

1530

1635

1531 pid <- forkProcess localNode $ do

1636 pid <- forkProcess localNode $ do

1532− () <- expect

1533− liftIO $ putMVar clientDone ()

1637+ expect >>= liftIO . putMVar clientDone

1534

1638

1535 void $ runProcess localNode $ do

1639 void $ runProcess localNode $ do

1536 register "foobar" pid

1640 register "foobar" pid

@@ -1548,8 +1652,7 @@ testUnsafeNSendRemote TestTransport{..} = do

1548 _ <- forkProcess localNode1 $ do

1652 _ <- forkProcess localNode1 $ do

1549 getSelfPid >>= register "foobar"

1653 getSelfPid >>= register "foobar"

1550 liftIO $ putMVar clientDone ()

1654 liftIO $ putMVar clientDone ()

1551− () <- expect

1552− liftIO $ putMVar clientDone ()

1655+ expect >>= liftIO . putMVar clientDone

1553

1656

1554 takeMVar clientDone

1657 takeMVar clientDone

1555 void $ runProcess localNode2 $ do

1658 void $ runProcess localNode2 $ do

@@ -1573,7 +1676,7 @@ testUnsafeSendChan TestTransport{..} = do

1573 serverPid <- liftIO $ takeMVar serverAddr

1676 serverPid <- liftIO $ takeMVar serverAddr

1574 (sp, rp) <- newChan

1677 (sp, rp) <- newChan

1575 unsafeSend serverPid sp

1678 unsafeSend serverPid sp

1576− () <- receiveChan rp

1679+ receiveChan rp :: Process ()

1577 liftIO $ putMVar clientDone ()

1680 liftIO $ putMVar clientDone ()

1578

1681

1579 takeMVar clientDone

1682 takeMVar clientDone

@@ -1587,8 +1690,8 @@ testCallLocal TestTransport{..} = do

1587 runProcess node $ do

1690 runProcess node $ do

1588 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid

1691 r <- (/=) <$> getSelfPid <*> callLocal getSelfPid

1589 liftIO $ putMVar result r

1692 liftIO $ putMVar result r

1693+

1590− True <- takeMVar result

1694+ takeMVar result >>= assertBool "Expected 'True'"

1591− return ()

1592

1695

1593 -- Testing that when callLocal is interrupted, the worker is interrupted.

1696 -- Testing that when callLocal is interrupted, the worker is interrupted.

1594 ibox <- newIORef False

1697 ibox <- newIORef False

@@ -1605,10 +1708,9 @@ testCallLocal TestTransport{..} = do

1605 (send keeper ())

1708 (send keeper ())

1606 caller <- expect

1709 caller <- expect

1607 exit caller "test"

1710 exit caller "test"

1608− () <- expect

1711+ expect :: Process ()

1609− return ()

1712+

1610− True <- readIORef ibox

1713+ readIORef ibox >>= assertBool "Expected 'True'"

1611− return ()

1612

1714

1613 -- Testing that when the worker raises an exception, the exception is propagated to the parent.

1715 -- Testing that when the worker raises an exception, the exception is propagated to the parent.

1614 ibox2 <- newIORef False

1716 ibox2 <- newIORef False

@@ -1617,8 +1719,8 @@ testCallLocal TestTransport{..} = do

1617 liftIO $ writeIORef ibox2 $ case r of

1719 liftIO $ writeIORef ibox2 $ case r of

1618 Left (ErrorCall "e") -> True

1720 Left (ErrorCall "e") -> True

1619 _ -> False

1721 _ -> False

1722+

1620− True <- readIORef ibox

1723+ readIORef ibox >>= assertBool "Expected 'True'"

1621− return ()

1622

1724

1623 -- Test that caller waits for the worker in correct situation

1725 -- Test that caller waits for the worker in correct situation

1624 ibox3 <- newIORef False

1726 ibox3 <- newIORef False

@@ -1635,8 +1737,8 @@ testCallLocal TestTransport{..} = do

1635 liftIO $ putMVar result3 =<< readIORef ibox3

1737 liftIO $ putMVar result3 =<< readIORef ibox3

1636 worker <- expect

1738 worker <- expect

1637 send worker ()

1739 send worker ()

1740+

1638− True <- takeMVar result3

1741+ takeMVar result3 >>= assertBool "Expected 'True'"

1639− return ()

1640

1742

1641 -- Test that caller waits for the worker in case when caller gets an exception

1743 -- Test that caller waits for the worker in case when caller gets an exception

1642 ibox4 <- newIORef False

1744 ibox4 <- newIORef False

@@ -1652,13 +1754,9 @@ testCallLocal TestTransport{..} = do

1652 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)

1754 `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)

1653 caller <- expect

1755 caller <- expect

1654 exit caller "hi!"

1756 exit caller "hi!"

1655− True <- takeMVar result4

1656− return ()

1657− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.

1658−

1659−

1660−

1661

1757

1758+ takeMVar result4 >>= assertBool "Expected 'True'"

1759+ -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.

1662

1760

1663tests :: TestTransport -> IO [Test]

1761tests :: TestTransport -> IO [Test]

1664tests testtrans = return [

1762tests testtrans = return [

@@ -1745,17 +1843,3 @@ tests testtrans = return [

1745 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)

1843 , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)

1746 ]

1844 ]

1747 ]

1845 ]

1748−

1749−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()

1750−syncBreakConnection breakConnection nid0 nid1 = do

1751− m <- newEmptyMVar

1752− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m

1753− runProcess nid0 $ do

1754− them <- liftIO $ takeMVar m

1755− pinger <- spawnLocal $ forever $ send them ()

1756− _ <- monitorNode (localNodeId nid1)

1757− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1758− (nodeAddress $ localNodeId nid1)

1759− NodeMonitorNotification _ _ _ <- expect

1760− kill pinger "finished"

1761− 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

170 done <- newEmptyMVar

171 forkProcess node $ do

172− 120 <- join . unClosure $ factorialClosure 5

172+ i <- join . unClosure $ factorialClosure 5

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)

30testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()

31testLocalDeadProcessInfo result = do

32− pid <- spawnLocal $ do "finish" <- expect; return ()

32+ pid <- spawnLocal $ do (_ :: String) <- expect; return ()

33 mref <- monitor pid

34 send pid "finish"

35 _ <- receiveWait [

@@ -52,8 +52,10 @@ testLocalLiveProcessInfo result = do

52 link self

53 mRef <- monitor self

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

58 monRef <- liftIO $ takeMVar mon

60 monRef <- liftIO $ takeMVar mon

@@ -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 ->

126 case ev of

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

11 , TransportInternals(socketBetween)

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 }

30 ts <- tests TestTransport

31 { testTransport = transport

src/Control/Distributed/Process/Internal/Primitives.hs+5−2

@@ -401,8 +401,11 @@ newtype Match b = Match { unMatch :: MatchOn Message (Process b) }

401receiveWait :: [Match b] -> Process b

402receiveWait ms = do

403 queue <- processQueue <$> ask

404− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)

404+ mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)

405+ case mProc of

405− proc

406+ Just proc' -> proc'

407+ Nothing -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "

408+ ++ "in the absence of a timeout value."

406

409

407-- | Like 'receiveWait' but with a timeout.

410-- | Like 'receiveWait' but with a timeout.

408--

411--

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+8−2

@@ -33,6 +33,7 @@ import Control.Distributed.Process.Internal.Primitives

33 ( whereis

34 , newChan

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:

4- '.'

5- distributed-process-tests/

6+- location:

7+ git: https://github.com/haskell-distributed/network-transport-tcp.git

8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9+ extra-dep: true

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

stack-ghc-8.0.2.yaml+8−2

@@ -1,14 +1,20 @@

1−resolver: lts-9.0

1+resolver: lts-9.21

3+# added -location for network-transport-tcp-0.6.0

4+# since c7fd79 broke the client facing API for createTransport :/

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

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

stack-nightly.yamlnew file+26

@@ -0,0 +1,26 @@

1+resolver: nightly-2018-11-10

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:

4- '.'

5- distributed-process-tests/

6+- location:

7+ git: https://github.com/haskell-distributed/network-transport-tcp.git

8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9+ extra-dep: true

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