38b7a44 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Merge master

38b7a44Tim Watson8 years ago

.travis.yml+12−13

compare with master

unifiedsplit

@@ -5,19 +5,13 @@ sudo: false

5matrix:

6 include:

7 - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"

8− addons: {apt: {packages: [libgmp-dev]}}

9−

10− - env: ARGS="--stack-yaml stack-ghc-8.0.2.yaml"

11− addons: {apt: {packages: [libgmp-dev]}}

8+ addons: {apt: {packages: [libgmp-dev]}}

12−

13 - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"

9 - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"

14− addons: {apt: {packages: [libgmp-dev]}}

10+ addons: {apt: {packages: [libgmp-dev]}}

15−

16 - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"

11 - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"

17− addons: {apt: {packages: [libgmp-dev]}}

12+ addons: {apt: {packages: [libgmp-dev]}}

18−

13+ - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"

19− - env: ARGS=

20− addons: {apt: {packages: [libgmp-dev]}}

14+ addons: {apt: {packages: [libgmp-dev]}}

22cache:

16cache:

23 directories:

17 directories:

@@ -40,5 +34,10 @@ script:

40- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP

34- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP

41- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure

35- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure

42- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats

36- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats

43−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMx

37+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory

38+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP

44−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracing

39+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory

40+

41+notifications:

42+ slack:

43+ secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=

benchmarks/Channels.hs+6−5

@@ -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+23−10

@@ -34,7 +34,7 @@ library

34 exceptions >= 0.5,

35 HUnit >= 1.2 && < 1.7,

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

37− network >= 2.5 && < 2.7,

37+ network >= 2.5 && < 2.9,

38 random >= 1.0 && < 1.2,

39 rematch >= 0.1.2.1,

40 setenv >= 0.1.1.3,

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

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

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

63 distributed-process-tests,

64− network >= 2.3 && < 2.7,

64+ network >= 2.3 && < 2.9,

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

66 network-transport-inmemory >= 0.5,

67 test-framework >= 0.6 && < 0.9

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

76 if flag(tcp)

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

78 distributed-process-tests,

79− network >= 2.3 && < 2.7,

79+ network >= 2.3 && < 2.9,

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

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

82 test-framework >= 0.6 && < 0.9

@@ -93,7 +93,7 @@ Test-Suite TestClosure

93 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure

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

95 distributed-process-tests,

96− network >= 2.3 && < 2.7,

96+ network >= 2.3 && < 2.9,

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

98 network-transport-inmemory >= 0.5,

99 test-framework >= 0.6 && < 0.9

@@ -107,7 +107,7 @@ Test-Suite TestStats

107 CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats

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

109 distributed-process-tests,

110− network >= 2.3 && < 2.7,

110+ network >= 2.3 && < 2.9,

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

112 network-transport-inmemory >= 0.5,

113 test-framework >= 0.6 && < 0.9

@@ -115,14 +115,13 @@ Test-Suite TestStats

115 ghc-options: -Wall -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

116 HS-Source-Dirs: tests

117

118−

119−Test-Suite TestMx

118+Test-Suite TestMxInMemory

120 Type: exitcode-stdio-1.0

119 Type: exitcode-stdio-1.0

121 Main-Is: runInMemory.hs

120 Main-Is: runInMemory.hs

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

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

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

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

124 distributed-process-tests,

123 distributed-process-tests,

125− network >= 2.3 && < 2.7,

124+ network >= 2.3 && < 2.9,

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

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

127 network-transport-inmemory >= 0.5,

126 network-transport-inmemory >= 0.5,

128 test-framework >= 0.6 && < 0.9

127 test-framework >= 0.6 && < 0.9

@@ -130,16 +129,30 @@ Test-Suite TestMx

130 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

129 ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

131 HS-Source-Dirs: tests

130 HS-Source-Dirs: tests

132

131

133−Test-Suite TestTracing

132+Test-Suite TestTracingInMemory

134 Type: exitcode-stdio-1.0

133 Type: exitcode-stdio-1.0

135 Main-Is: runInMemory.hs

134 Main-Is: runInMemory.hs

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

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

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

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

138 distributed-process-tests,

137 distributed-process-tests,

139− network >= 2.3 && < 2.7,

138+ network >= 2.3 && < 2.9,

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

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

141 network-transport-inmemory >= 0.5,

140 network-transport-inmemory >= 0.5,

142 test-framework >= 0.6 && < 0.9

141 test-framework >= 0.6 && < 0.9

143 Extensions: CPP

142 Extensions: CPP

144 ghc-options: -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

143 ghc-options: -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

145 HS-Source-Dirs: tests

144 HS-Source-Dirs: tests

145+

146+Test-Suite TestMxInTCP

147+ Type: exitcode-stdio-1.0

148+ Main-Is: runInMemory.hs

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

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

151+ distributed-process-tests,

152+ network >= 2.3 && < 2.9,

153+ network-transport >= 0.4.1.0 && < 0.6,

154+ network-transport-inmemory >= 0.5,

155+ test-framework >= 0.6 && < 0.9

156+ Extensions: CPP

157+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

158+ HS-Source-Dirs: tests

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

@@ -42,9 +42,12 @@ import Control.Distributed.Process.Internal.Types

42 , createUnencodedMessage

43 )

44import Control.Distributed.Process.Node

45+import Control.Distributed.Process.Debug

46+import Control.Distributed.Process.Management.Internal.Types

47+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)

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

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

47−import Test.HUnit (Assertion, assertFailure)

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

48import Test.Framework (Test, testGroup)

51import Test.Framework (Test, testGroup)

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

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

50import Control.Rematch hiding (match)

53import Control.Rematch hiding (match)

@@ -80,12 +83,47 @@ ping = do

80 send partner (Ping self)

83 send partner (Ping self)

81 ping

84 ping

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

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

88+

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

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

91+ where

92+ checkPing (Ping _) = True

93+ checkPing _ = False

94+

83-- | Quick and dirty synchronous version of whereisRemoteAsync

95-- | Quick and dirty synchronous version of whereisRemoteAsync

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

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

85whereisRemote nid string = do

97whereisRemote nid string = do

86 whereisRemoteAsync nid string

98 whereisRemoteAsync nid string

99+ receiveWait [

87− WhereIsReply _ mPid <- expect

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

101+ ]

102+

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

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

105+

106+waitForExit :: ProcessId -> Process DiedReason

107+waitForExit pid = monitor pid >>= waitForDown

108+

109+waitForDown :: MonitorRef -> Process DiedReason

110+waitForDown ref =

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

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

113+

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

115+syncBreakConnection breakConnection nid0 nid1 = do

116+ m <- newEmptyMVar

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

118+ runProcess nid0 $ do

119+ them <- liftIO $ takeMVar m

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

121+ _ <- monitorNode (localNodeId nid1)

122+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

123+ (nodeAddress $ localNodeId nid1)

124+ NodeMonitorNotification _ _ _ <- expect

125+ kill pinger "finished"

88− return mPid

126+ return ()

127

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

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

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

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

@@ -160,12 +198,18 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =

160 unmonitor ref

198 unmonitor ref

161 liftIO $ putMVar done ()

199 liftIO $ putMVar done ()

162 (False, ref) -> do

200 (False, ref) -> do

201+ receiveWait [

163− ProcessMonitorNotification ref' pid reason' <- expect

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

203+ liftIO $ do

204+ assertBool "Bad Monitor Signal"

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

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

206+ mOrL && reason == reason')

165− liftIO $ putMVar done ()

207+ putMVar done ())

208+ ]

166 )

209 )

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

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

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

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

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

169 liftIO $ putMVar done ()

213 liftIO $ putMVar done ()

170 )

214 )

171

215

@@ -196,8 +240,10 @@ testPing TestTransport{..} = do

196 pid <- getSelfPid

240 pid <- getSelfPid

197 replicateM_ numPings $ do

241 replicateM_ numPings $ do

198 send pingServer (Pong pid)

242 send pingServer (Pong pid)

199− Ping _ <- expect

243+ p <- expect

244+ case p of

200− return ()

245+ Ping _ -> return ()

246+ _ -> die "Unexpected message"

201

247

202 putMVar clientDone ()

248 putMVar clientDone ()

203

249

@@ -284,7 +330,7 @@ testMonitorLocalDeadProcess TestTransport{..} mOrL un = do

284 runProcess localNode $ do

330 runProcess localNode $ do

285 monitor theirAddr

331 monitor theirAddr

286 -- wait for the process to die

332 -- wait for the process to die

287− ProcessMonitorNotification _ _ _ <- expect

333+ expect :: Process ProcessMonitorNotification

288 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

289

335

290 takeMVar done

336 takeMVar done

@@ -358,14 +404,17 @@ testMath TestTransport{..} = do

358 runProcess localNode $ do

404 runProcess localNode $ do

359 pid <- getSelfPid

405 pid <- getSelfPid

360 send mathServer (Add pid 1 2)

406 send mathServer (Add pid 1 2)

361− 3 <- expect :: Process Double

407+ three <- expect :: Process Double

362 send mathServer (Divide pid 8 2)

408 send mathServer (Divide pid 8 2)

363− 4 <- expect :: Process Double

409+ four <- expect :: Process Double

364 send mathServer (Divide pid 8 0)

410 send mathServer (Divide pid 8 0)

365− DivByZero <- expect

411+ divByZ <- expect

366− liftIO $ putMVar clientDone ()

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

367

413

368− takeMVar clientDone

414+ res <- takeMVar clientDone

415+ case res of

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

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

369

418

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

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

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

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

@@ -393,11 +442,9 @@ testSendToTerminated TestTransport{..} = do

393 pid <- getSelfPid

442 pid <- getSelfPid

394 send server1 "Hi"

443 send server1 "Hi"

395 send server2 (Pong pid)

444 send server2 (Pong pid)

396− Ping pid' <- expect

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

398− liftIO $ putMVar clientDone ()

445+ expectPing clientDone

399

446

400− takeMVar clientDone

447+ verifyClient "Expected Ping from server" clientDone

401

448

402-- | Test (non-zero) timeout

449-- | Test (non-zero) timeout

403testTimeout :: TestTransport -> Assertion

450testTimeout :: TestTransport -> Assertion

@@ -406,10 +453,10 @@ testTimeout TestTransport{..} = do

406 done <- newEmptyMVar

453 done <- newEmptyMVar

407

454

408 runProcess localNode $ do

455 runProcess localNode $ do

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

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

410− liftIO $ putMVar done ()

457+ liftIO $ putMVar done $ res == Nothing

411

458

412− takeMVar done

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

413

460

414-- | Test zero timeout

461-- | Test zero timeout

415testTimeout0 :: TestTransport -> Assertion

462testTimeout0 :: TestTransport -> Assertion

@@ -437,10 +484,9 @@ testTimeout0 TestTransport{..} = do

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

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

438 replicateM_ 10000 $ send server "Irrelevant message"

485 replicateM_ 10000 $ send server "Irrelevant message"

439 send server (Pong pid)

486 send server (Pong pid)

440− Ping _ <- expect

441− liftIO $ putMVar clientDone ()

487+ expectPing clientDone

442

488

443− takeMVar clientDone

489+ verifyClient "Expected Ping from server" clientDone

444

490

445-- | Test typed channels

491-- | Test typed channels

446testTypedChannels :: TestTransport -> Assertion

492testTypedChannels :: TestTransport -> Assertion

@@ -463,10 +509,10 @@ testTypedChannels TestTransport{..} = do

463 runProcess localNode $ do

509 runProcess localNode $ do

464 (clientSendPort, rport) <- newChan

510 (clientSendPort, rport) <- newChan

465 sendChan serverSendPort (clientSendPort, 5)

511 sendChan serverSendPort (clientSendPort, 5)

466− False <- receiveChan rport

512+ ch <- receiveChan rport

467− liftIO $ putMVar clientDone ()

513+ liftIO $ putMVar clientDone $ ch == False

468

514

469− takeMVar clientDone

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

470

516

471-- | Test merging receive ports

517-- | Test merging receive ports

472testMergeChannels :: TestTransport -> Assertion

518testMergeChannels :: TestTransport -> Assertion

@@ -489,9 +535,8 @@ testMergeChannels TestTransport{..} = do

489 rs <- mapM charChannel "abc"

535 rs <- mapM charChannel "abc"

490 m <- mergePorts biased rs

536 m <- mergePorts biased rs

491 xs <- replicateM 9 $ receiveChan m

537 xs <- replicateM 9 $ receiveChan m

492− True <- return $ xs == expected

493− liftIO $ putMVar done ()

538+ liftIO $ putMVar done $ xs == expected

494− takeMVar done

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

495

540

496 -- Two layers of merging

541 -- Two layers of merging

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

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

@@ -502,9 +547,8 @@ testMergeChannels TestTransport{..} = do

502 ms <- mapM (mergePorts biasedInner) rss

547 ms <- mapM (mergePorts biasedInner) rss

503 m <- mergePorts biasedOuter ms

548 m <- mergePorts biasedOuter ms

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

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

505− True <- return $ xs == expected

550+ liftIO $ putMVar done $ xs == expected

506− liftIO $ putMVar done ()

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

507− takeMVar done

508

552

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

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

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

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

@@ -513,43 +557,45 @@ testMergeChannels TestTransport{..} = do

513 done <- newEmptyMVar

557 done <- newEmptyMVar

514

558

515 forkProcess localNode $ do

559 forkProcess localNode $ do

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

560+ ss <- liftIO $ mapM readMVar vs

561+ case ss of

562+ [sa, sb, sc] ->

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

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

518− [ -- a, b, c

564+ [ -- a, b, c

519− (sa, 'a')

565+ (sa, 'a')

520− , (sb, 'b')

566+ , (sb, 'b')

521− , (sc, 'c')

567+ , (sc, 'c')

522− -- a, c, b

568+ -- a, c, b

523− , (sa, 'a')

569+ , (sa, 'a')

524− , (sc, 'c')

570+ , (sc, 'c')

525− , (sb, 'b')

571+ , (sb, 'b')

526− -- b, a, c

572+ -- b, a, c

527− , (sb, 'b')

573+ , (sb, 'b')

528− , (sa, 'a')

574+ , (sa, 'a')

529− , (sc, 'c')

575+ , (sc, 'c')

530− -- b, c, a

576+ -- b, c, a

531− , (sb, 'b')

577+ , (sb, 'b')

532− , (sc, 'c')

578+ , (sc, 'c')

533− , (sa, 'a')

579+ , (sa, 'a')

534− -- c, a, b

580+ -- c, a, b

535− , (sc, 'c')

581+ , (sc, 'c')

536− , (sa, 'a')

582+ , (sa, 'a')

537− , (sb, 'b')

583+ , (sb, 'b')

538− -- c, b, a

584+ -- c, b, a

539− , (sc, 'c')

585+ , (sc, 'c')

540− , (sb, 'b')

586+ , (sb, 'b')

541− , (sa, 'a')

587+ , (sa, 'a')

542− ]

588+ ]

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

543

590

544 forkProcess localNode $ do

591 forkProcess localNode $ do

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

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

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

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

547 m <- mergePorts biased rs

594 m <- mergePorts biased rs

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

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

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

550− liftIO $ putMVar done ()

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

551

597

552− takeMVar done

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

553

599

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

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

555 mergePorts True = mergePortsBiased

601 mergePorts True = mergePortsBiased

@@ -567,8 +613,9 @@ testTerminate TestTransport{..} = do

567 localNode <- newLocalNode testTransport initRemoteTable

613 localNode <- newLocalNode testTransport initRemoteTable

568 runProcess localNode $ do

614 runProcess localNode $ do

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

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

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

616+ if either show show e == show ProcessTerminationException

571− return ()

617+ then return ()

618+ else die "Unexpected result from terminate"

572

619

573testMonitorNode :: TestTransport -> Assertion

620testMonitorNode :: TestTransport -> Assertion

574testMonitorNode TestTransport{..} = do

621testMonitorNode TestTransport{..} = do

@@ -579,11 +626,12 @@ testMonitorNode TestTransport{..} = do

579

626

580 runProcess node2 $ do

627 runProcess node2 $ do

581 ref <- monitorNode (localNodeId node1)

628 ref <- monitorNode (localNodeId node1)

629+ receiveWait [

582− NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

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

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

584− liftIO $ putMVar done ()

632+ ] >>= liftIO . putMVar done

585

633

586− takeMVar done

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

587

635

588testMonitorLiveNode :: TestTransport -> Assertion

636testMonitorLiveNode :: TestTransport -> Assertion

589testMonitorLiveNode TestTransport{..} = do

637testMonitorLiveNode TestTransport{..} = do

@@ -598,15 +646,16 @@ testMonitorLiveNode TestTransport{..} = do

598 liftIO $ putMVar ready ()

646 liftIO $ putMVar ready ()

599 liftIO $ takeMVar readyr

647 liftIO $ takeMVar readyr

600 send p ()

648 send p ()

649+ receiveWait [

601− NodeMonitorNotification ref' nid _ <- expect

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

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

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

603− liftIO $ putMVar done ()

652+ ] >>= liftIO . putMVar done

604

653

605 takeMVar ready

654 takeMVar ready

606 closeLocalNode node1

655 closeLocalNode node1

607 putMVar readyr ()

656 putMVar readyr ()

608

657

609− takeMVar done

658+ verifyClient "Expected NodeMonitorNotification for LIVE node" done

610

659

611testMonitorChannel :: TestTransport -> Assertion

660testMonitorChannel :: TestTransport -> Assertion

612testMonitorChannel TestTransport{..} = do

661testMonitorChannel TestTransport{..} = do

@@ -616,18 +665,20 @@ testMonitorChannel TestTransport{..} = do

616 pid <- forkProcess node1 $ do

665 pid <- forkProcess node1 $ do

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

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

618 ref <- monitorPort sport

667 ref <- monitorPort sport

619− PortMonitorNotification ref' port' reason <- expect

668+ receiveWait [

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

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

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

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

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

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

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

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

623− liftIO $ putMVar gotNotification ()

674+ ] >>= liftIO . putMVar gotNotification

624

675

625 runProcess node2 $ do

676 runProcess node2 $ do

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

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

627 send pid sport

678 send pid sport

628 liftIO $ threadDelay 100000

679 liftIO $ threadDelay 100000

629

680

630− takeMVar gotNotification

681+ verifyClient "Expected PortMonitorNotification" gotNotification

631

682

632testRegistry :: TestTransport -> Assertion

683testRegistry :: TestTransport -> Assertion

633testRegistry TestTransport{..} = do

684testRegistry TestTransport{..} = do

@@ -639,20 +690,28 @@ testRegistry TestTransport{..} = do

639

690

640 runProcess node $ do

691 runProcess node $ do

641 register "ping" pingServer

692 register "ping" pingServer

642− Just pid <- whereis "ping"

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

643− True <- return $ pingServer == pid

644 us <- getSelfPid

694 us <- getSelfPid

645 nsend "ping" (Pong us)

695 nsend "ping" (Pong us)

646− Ping pid' <- expect

696+ receiveWait [

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

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

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

698+ ]

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

699+ checkRegException "dead" Nothing deadProcess

650− True <- return $ x == pingServer

700+ checkRegException "ping" (Just pingServer) deadProcess

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

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

652 liftIO $ putMVar done ()

702 liftIO $ putMVar done ()

653

703

654 takeMVar done

704 takeMVar done

655

705

706+ where

707+ checkRegException name pid dead =

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

709+

710+ checkReg name pid res =

711+ case res of

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

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

714+

656testRegistryRemoteProcess :: TestTransport -> Assertion

715testRegistryRemoteProcess :: TestTransport -> Assertion

657testRegistryRemoteProcess TestTransport{..} = do

716testRegistryRemoteProcess TestTransport{..} = do

658 node1 <- newLocalNode testTransport initRemoteTable

717 node1 <- newLocalNode testTransport initRemoteTable

@@ -663,13 +722,13 @@ testRegistryRemoteProcess TestTransport{..} = do

663

722

664 runProcess node2 $ do

723 runProcess node2 $ do

665 register "ping" pingServer

724 register "ping" pingServer

666− Just pid <- whereis "ping"

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

667− True <- return $ pingServer == pid

668 us <- getSelfPid

726 us <- getSelfPid

669 nsend "ping" (Pong us)

727 nsend "ping" (Pong us)

670− Ping pid' <- expect

728+ receiveWait [

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

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

672− liftIO $ putMVar done ()

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

731+ ]

673

732

674 takeMVar done

733 takeMVar done

675

734

@@ -690,12 +749,13 @@ testRemoteRegistry TestTransport{..} = do

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

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

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

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

692

751

693− Just pid <- whereisRemote nid1 "ping"

752+ pid <- verifyWhereIsRemote nid1 "ping"

694− True <- return $ pingServer == pid

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

695 us <- getSelfPid

754 us <- getSelfPid

696 nsendRemote nid1 "ping" (Pong us)

755 nsendRemote nid1 "ping" (Pong us)

697− Ping pid' <- expect

756+ receiveWait [

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

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

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

699

759

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

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

701 -- in owner field.

761 -- in owner field.

@@ -731,15 +791,15 @@ testRemoteRegistryRemoteProcess TestTransport{..} = do

731 receiveWait [

791 receiveWait [

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

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

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

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

734− Just pid <- whereisRemote nid1 "ping"

794+ pid <- verifyWhereIsRemote nid1 "ping"

735− True <- return $ pingServer == pid

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

736 us <- getSelfPid

796 us <- getSelfPid

737 nsendRemote nid1 "ping" (Pong us)

797 nsendRemote nid1 "ping" (Pong us)

738− Ping pid' <- expect

798+ receiveWait [

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

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

740− liftIO $ putMVar done ()

800+ ] >>= liftIO . putMVar done

741

801

742− takeMVar done

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

743

803

744testSpawnLocal :: TestTransport -> Assertion

804testSpawnLocal :: TestTransport -> Assertion

745testSpawnLocal TestTransport{..} = do

805testSpawnLocal TestTransport{..} = do

@@ -753,15 +813,14 @@ testSpawnLocal TestTransport{..} = do

753 sport <- expect

813 sport <- expect

754 sendChan sport (1234 :: Int)

814 sendChan sport (1234 :: Int)

755

815

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

816+ sport <- spawnChannelLocal $

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

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

758− send us ()

759

818

760 send pid sport

819 send pid sport

761− () <- expect

762− liftIO $ putMVar done ()

820+ expect >>= liftIO . putMVar done

763

821

764− takeMVar done

822+ res <- takeMVar done

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

765

824

766testSpawnAsyncStrictness :: TestTransport -> Assertion

825testSpawnAsyncStrictness :: TestTransport -> Assertion

767testSpawnAsyncStrictness TestTransport{..} = do

826testSpawnAsyncStrictness TestTransport{..} = do

@@ -790,8 +849,9 @@ testReconnect TestTransport{..} = do

790 liftIO $ putMVar processA us

849 liftIO $ putMVar processA us

791 msg1 <- expect

850 msg1 <- expect

792 msg2 <- expect

851 msg2 <- expect

852+ liftIO $ do

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

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

794− liftIO $ putMVar sendTestOk ()

854+ putMVar sendTestOk ()

795

855

796 forkProcess node2 $ do

856 forkProcess node2 $ do

797 {-

857 {-

@@ -824,7 +884,7 @@ testReconnect TestTransport{..} = do

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

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

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

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

826

886

827− Just _ <- whereisRemote nid1 "a"

887+ _ <- whereisRemote nid1 "a"

828

888

829

889

830 -- Simulate network failure

890 -- Simulate network failure

@@ -843,9 +903,10 @@ testReconnect TestTransport{..} = do

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

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

844

904

845 -- Check

905 -- Check

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

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

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

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

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

848− Just _ <- whereisRemote nid1 "c"

909+ verifyWhereIsRemote nid1 "c"

849

910

850 liftIO $ putMVar registerTestOk ()

911 liftIO $ putMVar registerTestOk ()

851

912

@@ -886,13 +947,14 @@ testUSend usendPrim TestTransport{..} numMessages = do

886 isSorted _ = True

947 isSorted _ = True

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

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

888 -- the last message.

949 -- the last message.

950+ liftIO $ do

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

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

890− liftIO $ putMVar usendTestOk ()

952+ putMVar usendTestOk ()

891

953

892 forkProcess node2 $ do

954 forkProcess node2 $ do

893 them <- liftIO $ readMVar processA

955 them <- liftIO $ readMVar processA

894 getSelfPid >>= send them

956 getSelfPid >>= send them

895− () <- expect

957+ expect :: Process ()

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

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

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

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

898 usendPrim them i

960 usendPrim them i

@@ -924,14 +986,17 @@ testMatchAny TestTransport{..} = do

924 runProcess localNode $ do

986 runProcess localNode $ do

925 pid <- getSelfPid

987 pid <- getSelfPid

926 send mathServer (Add pid 1 2)

988 send mathServer (Add pid 1 2)

927− 3 <- expect :: Process Double

989+ three <- expect :: Process Double

928 send mathServer (Divide pid 8 2)

990 send mathServer (Divide pid 8 2)

929− 4 <- expect :: Process Double

991+ four <- expect :: Process Double

930 send mathServer (Divide pid 8 0)

992 send mathServer (Divide pid 8 0)

931− DivByZero <- expect

993+ divByZ <- expect

932− liftIO $ putMVar clientDone ()

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

933

995

934− takeMVar clientDone

996+ res <- takeMVar clientDone

997+ case res of

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

999+ _ -> error "Unexpected result"

935

1000

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

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

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

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

@@ -958,12 +1023,13 @@ testMatchAnyHandle TestTransport{..} = do

958 runProcess localNode $ do

1023 runProcess localNode $ do

959 pid <- getSelfPid

1024 pid <- getSelfPid

960 send mathServer (Add pid 1 2)

1025 send mathServer (Add pid 1 2)

961− 3 <- expect :: Process Double

1026+ three <- expect :: Process Double

962 send mathServer (Divide pid 8 2)

1027 send mathServer (Divide pid 8 2)

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

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

964− liftIO $ putMVar clientDone ()

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

1030+

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

965

1032

966− takeMVar clientDone

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

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

968 maybeForward s msg =

1034 maybeForward s msg =

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

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

@@ -991,8 +1057,10 @@ testMatchAnyNoHandle TestTransport{..} = do

991 Just _ -> die "NONSENSE")

1057 Just _ -> die "NONSENSE")

992 ]

1058 ]

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

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

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

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

1061+ liftIO $ do

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

995− liftIO $ putMVar serverDone ()

1063+ putMVar serverDone ()

996 putMVar addr server

1064 putMVar addr server

997

1065

998 -- Client

1066 -- Client

@@ -1035,14 +1103,21 @@ testMatchAnyIf TestTransport{..} = do

1035 runProcess localNode $ do

1103 runProcess localNode $ do

1036 pid <- getSelfPid

1104 pid <- getSelfPid

1037 send server (pid, "foo")

1105 send server (pid, "foo")

1038− "foo" <- expect

1106+ foo <- expect

1039− send server (pid, "baz")

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

1040− "baz" <- expect

1108+

1041 send server (pid, "bar")

1109 send server (pid, "bar")

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

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

1111+

1112+ send server (pid, "baz")

1113+ baz <- expect

1114+

1043− liftIO $ putMVar clientDone ()

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

1116+

1117+ res <- takeMVar clientDone

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

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

1044

1120

1045− takeMVar clientDone

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

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

1047 tryHandleMessage msg =

1122 tryHandleMessage msg =

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

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

@@ -1075,12 +1150,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do

1075 runProcess localNode $ do

1150 runProcess localNode $ do

1076 pid <- getSelfPid

1151 pid <- getSelfPid

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

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

1078− "foo" <- expect

1153+ foo <- expect

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

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

1080− "baz" <- expect

1155+ baz <- expect

1081− liftIO $ putMVar clientDone ()

1156+ liftIO $ putMVar clientDone (foo, baz)

1082

1157

1083− takeMVar clientDone

1158+ res <- takeMVar clientDone

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

1084

1160

1085-- Test 'receiveChanTimeout'

1161-- Test 'receiveChanTimeout'

1086testReceiveChanTimeout :: TestTransport -> Assertion

1162testReceiveChanTimeout :: TestTransport -> Assertion

@@ -1098,18 +1174,19 @@ testReceiveChanTimeout TestTransport{..} = do

1098

1174

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

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

1100 -- Nothing after the delay.

1176 -- Nothing after the delay.

1101− Nothing <- receiveChanTimeout 100000 rp

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

1102

1178

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

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

1104 liftIO $ putMVar mvSender ()

1180 liftIO $ putMVar mvSender ()

1105

1181

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

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

1107 -- 0.1 seconds

1183 -- 0.1 seconds

1108− Just True <- receiveChanTimeout 20000000 rp

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

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

1109

1186

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

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

1111 -- available, we get Nothing

1188 -- available, we get Nothing

1112− Nothing <- receiveChanTimeout 0 rp

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

1113

1190

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

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

1115 liftIO $ putMVar mvSender ()

1192 liftIO $ putMVar mvSender ()

@@ -1119,7 +1196,7 @@ testReceiveChanTimeout TestTransport{..} = do

1119 liftIO $ threadDelay 100000

1196 liftIO $ threadDelay 100000

1120 mb <- receiveChanTimeout 0 rp

1197 mb <- receiveChanTimeout 0 rp

1121 case mb of

1198 case mb of

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

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

1123 _ -> loop

1200 _ -> loop

1124

1201

1125 liftIO $ putMVar done ()

1202 liftIO $ putMVar done ()

@@ -1156,8 +1233,8 @@ testReceiveChanFeatures TestTransport{..} = do

1156

1233

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

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

1158

1235

1159− True <- receiveChan rp1

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

1160− False <- receiveChan rp1

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

1161

1238

1162 -- Test Applicative instance

1239 -- Test Applicative instance

1163

1240

@@ -1166,7 +1243,7 @@ testReceiveChanFeatures TestTransport{..} = do

1166

1243

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

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

1168

1245

1169− 7 <- receiveChan rp2

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

1170

1247

1171 -- Test Alternative instance

1248 -- Test Alternative instance

1172

1249

@@ -1175,8 +1252,8 @@ testReceiveChanFeatures TestTransport{..} = do

1175

1252

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

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

1177

1254

1178− False <- receiveChan rp3

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

1179− True <- receiveChan rp3

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

1180

1257

1181 -- Test Monad instance

1258 -- Test Monad instance

1182

1259

@@ -1190,8 +1267,8 @@ testReceiveChanFeatures TestTransport{..} = do

1190 then rpInt

1267 then rpInt

1191 else return 7

1268 else return 7

1192

1269

1193− 5 <- receiveChan rp4

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

1194− 7 <- receiveChan rp4

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

1195

1272

1196 liftIO $ putMVar done ()

1273 liftIO $ putMVar done ()

1197

1274

@@ -1200,7 +1277,6 @@ testReceiveChanFeatures TestTransport{..} = do

1200testKillLocal :: TestTransport -> Assertion

1277testKillLocal :: TestTransport -> Assertion

1201testKillLocal TestTransport{..} = do

1278testKillLocal TestTransport{..} = do

1202 localNode <- newLocalNode testTransport initRemoteTable

1279 localNode <- newLocalNode testTransport initRemoteTable

1203− done <- newEmptyMVar

1204

1280

1205 pid <- forkProcess localNode $ do

1281 pid <- forkProcess localNode $ do

1206 liftIO $ threadDelay 1000000

1282 liftIO $ threadDelay 1000000

@@ -1209,17 +1285,18 @@ testKillLocal TestTransport{..} = do

1209 ref <- monitor pid

1285 ref <- monitor pid

1210 us <- getSelfPid

1286 us <- getSelfPid

1211 kill pid "TestKill"

1287 kill pid "TestKill"

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

1288+ mn <- expect

1289+ case mn of

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

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

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

1214− liftIO $ putMVar done ()

1292+ True -> return ()

1215−

1293+ False -> die "Invalid ProcessMonitorNotification received"

1216− takeMVar done

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

1217

1295

1218testKillRemote :: TestTransport -> Assertion

1296testKillRemote :: TestTransport -> Assertion

1219testKillRemote TestTransport{..} = do

1297testKillRemote TestTransport{..} = do

1220 node1 <- newLocalNode testTransport initRemoteTable

1298 node1 <- newLocalNode testTransport initRemoteTable

1221 node2 <- newLocalNode testTransport initRemoteTable

1299 node2 <- newLocalNode testTransport initRemoteTable

1222− done <- newEmptyMVar

1223

1300

1224 pid <- forkProcess node1 $ do

1301 pid <- forkProcess node1 $ do

1225 liftIO $ threadDelay 1000000

1302 liftIO $ threadDelay 1000000

@@ -1228,11 +1305,17 @@ testKillRemote TestTransport{..} = do

1228 ref <- monitor pid

1305 ref <- monitor pid

1229 us <- getSelfPid

1306 us <- getSelfPid

1230 kill pid "TestKill"

1307 kill pid "TestKill"

1308+ mn <- expect

1309+ case mn of

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

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

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

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

1233− liftIO $ putMVar done ()

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

1234−

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

1235− takeMVar done

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

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

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

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

1318+ _ -> die "Received unexpected message"

1236

1319

1237testCatchesExit :: TestTransport -> Assertion

1320testCatchesExit :: TestTransport -> Assertion

1238testCatchesExit TestTransport{..} = do

1321testCatchesExit TestTransport{..} = do

@@ -1258,7 +1341,10 @@ testHandleMessageIf TestTransport{..} = do

1258 self <- getSelfPid

1341 self <- getSelfPid

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

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

1260 msg <- receiveWait [ matchMessage return ]

1343 msg <- receiveWait [ matchMessage return ]

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

1344+ handleMessageIf msg

1345+ (\() -> True)

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

1347+ (const $ die "Expected Mismatch")

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

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

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

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

1264 return ()

1350 return ()

@@ -1303,8 +1389,11 @@ testDie TestTransport{..} = do

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

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

1304 `catchExit` \_from reason -> do

1390 `catchExit` \_from reason -> do

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

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

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

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

1307 liftIO $ putMVar done ()

1393 liftIO $ putMVar done ()

1394+ if res

1395+ then return ()

1396+ else die "Something went horribly wrong"

1308

1397

1309 takeMVar done

1398 takeMVar done

1310

1399

@@ -1318,8 +1407,11 @@ testPrettyExit TestTransport{..} = do

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

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

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

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

1320 in do

1409 in do

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

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

1322 liftIO $ putMVar done ()

1411 liftIO $ putMVar done ()

1412+ if res

1413+ then return ()

1414+ else die "Something went horribly wrong"

1323

1415

1324 takeMVar done

1416 takeMVar done

1325

1417

@@ -1335,17 +1427,26 @@ testExitLocal TestTransport{..} = do

1335 pid <- forkProcess localNode $ do

1427 pid <- forkProcess localNode $ do

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

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

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

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

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

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

1339 liftIO $ putMVar supervisedDone ()

1431 liftIO $ putMVar supervisedDone ()

1432+ if res

1433+ then return ()

1434+ else die "Something went horribly wrong"

1340

1435

1341 runProcess localNode $ do

1436 runProcess localNode $ do

1342 liftIO $ takeMVar handlerSetUp

1437 liftIO $ takeMVar handlerSetUp

1343 ref <- monitor pid

1438 ref <- monitor pid

1344 exit pid "TestExit"

1439 exit pid "TestExit"

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

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

1441+ mn <- expect

1442+ case mn of

1346− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1443+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1348− liftIO $ putMVar supervisorDone ()

1445+ liftIO $ putMVar supervisorDone ()

1446+ if res

1447+ then return ()

1448+ else die "Something went horribly wrong"

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

1349

1450

1350 takeMVar supervisedDone

1451 takeMVar supervisedDone

1351 takeMVar supervisorDone

1452 takeMVar supervisorDone

@@ -1361,19 +1462,90 @@ testExitRemote TestTransport{..} = do

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

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

1362 `catchExit` \_from reason -> do

1463 `catchExit` \_from reason -> do

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

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

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

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

1365 liftIO $ putMVar supervisedDone ()

1466 liftIO $ putMVar supervisedDone ()

1467+ if res

1468+ then return ()

1469+ else die "Something went horribly wrong"

1366

1470

1367 runProcess node2 $ do

1471 runProcess node2 $ do

1368 ref <- monitor pid

1472 ref <- monitor pid

1369 exit pid "TestExit"

1473 exit pid "TestExit"

1474+ mn <- expect

1475+ case mn of

1370− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1476+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1372− liftIO $ putMVar supervisorDone ()

1478+ liftIO $ putMVar supervisorDone ()

1479+ if res'

1480+ then return ()

1481+ else die "Something went horribly wrong"

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

1373

1483

1374 takeMVar supervisedDone

1484 takeMVar supervisedDone

1375 takeMVar supervisorDone

1485 takeMVar supervisorDone

1376

1486

1487+testRegistryMonitoring :: TestTransport -> Assertion

1488+testRegistryMonitoring TestTransport{..} = do

1489+ node1 <- newLocalNode testTransport initRemoteTable

1490+ node2 <- newLocalNode testTransport initRemoteTable

1491+ waitH <- newEmptyMVar

1492+

1493+ let nid = localNodeId node2

1494+ pid <- forkProcess node1 $ do

1495+ getSelfPid >>= runUntilRegistered nid

1496+ liftIO $ takeMVar waitH

1497+

1498+ runProcess node2 $ do

1499+ register regName pid

1500+ res <- whereis regName

1501+ us <- getSelfPid

1502+ liftIO $ do

1503+ putMVar waitH ()

1504+ assertBool "expected (Just pid)" $ res == (Just pid)

1505+

1506+ -- This delay isn't essential!

1507+ -- The test case passes perfectly fine without it (feel free to comment out

1508+ -- and see), however waiting a few seconds here, makes it much more likely

1509+ -- that in delayUntilMaybeUnregistered we will hit the match case right

1510+ -- away, and thus not be subjected to a 20 second delay. The value of 4

1511+ -- seconds appears to work optimally on osx and across several linux distros

1512+ -- running in virtual machines (which is essentially what we do in CI)

1513+ void $ receiveTimeout 4000000 [ matchAny return ]

1514+

1515+ -- This delay doesn't serve much purpose in the happy path, however if some

1516+ -- future patch breaks the cooperative behaviour of node controllers viz

1517+ -- remote process registration and notification taking place via ncEffectDied,

1518+ -- there would be the possibility of a race in the test case should we attempt

1519+ -- to evaluate `whereis regName` on node2 right away. In case the name is still

1520+ -- erroneously registered, observing the 20 second delay (or lack of), could at

1521+ -- least give a hint that something is wrong, and we give up our time slice

1522+ -- so that there's a higher change the registrations have been cleaned up

1523+ -- in either case.

1524+ runProcess node2 $ delayUntilMaybeUnregistered nid pid

1525+

1526+ regHere <- newEmptyMVar

1527+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere

1528+ res <- takeMVar regHere

1529+ assertBool "expected Nothing, but process still registered" (res == Nothing)

1530+

1531+ where

1532+ runUntilRegistered nid us = do

1533+ whereisRemoteAsync nid regName

1534+ receiveWait [

1535+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)

1536+ (const $ return ())

1537+ ]

1538+

1539+ delayUntilMaybeUnregistered nid p = do

1540+ whereisRemoteAsync nid regName

1541+ receiveTimeout 20000000 {- 20 sec delay -} [

1542+ matchIf (\(WhereIsReply n p) -> n == regName && p == Nothing)

1543+ (const $ return ())

1544+ ]

1545+ return ()

1546+

1547+ regName = "testRegisterRemote"

1548+

1377testUnsafeSend :: TestTransport -> Assertion

1549testUnsafeSend :: TestTransport -> Assertion

1378testUnsafeSend TestTransport{..} = do

1550testUnsafeSend TestTransport{..} = do

1379 serverAddr <- newEmptyMVar

1551 serverAddr <- newEmptyMVar

@@ -1389,8 +1561,7 @@ testUnsafeSend TestTransport{..} = do

1389 void $ forkProcess localNode $ do

1561 void $ forkProcess localNode $ do

1390 serverPid <- liftIO $ takeMVar serverAddr

1562 serverPid <- liftIO $ takeMVar serverAddr

1391 getSelfPid >>= unsafeSend serverPid

1563 getSelfPid >>= unsafeSend serverPid

1392− () <- expect

1393− liftIO $ putMVar clientDone ()

1564+ expect >>= liftIO . putMVar clientDone

1394

1565

1395 takeMVar clientDone

1566 takeMVar clientDone

1396

1567

@@ -1409,8 +1580,7 @@ testUnsafeUSend TestTransport{..} = do

1409 void $ forkProcess localNode $ do

1580 void $ forkProcess localNode $ do

1410 serverPid <- liftIO $ takeMVar serverAddr

1581 serverPid <- liftIO $ takeMVar serverAddr

1411 getSelfPid >>= unsafeUSend serverPid

1582 getSelfPid >>= unsafeUSend serverPid

1412− () <- expect

1413− liftIO $ putMVar clientDone ()

1583+ expect >>= liftIO . putMVar clientDone

1414

1584

1415 takeMVar clientDone

1585 takeMVar clientDone

1416

1586

@@ -1421,8 +1591,7 @@ testUnsafeNSend TestTransport{..} = do

1421 localNode <- newLocalNode testTransport initRemoteTable

1591 localNode <- newLocalNode testTransport initRemoteTable

1422

1592

1423 pid <- forkProcess localNode $ do

1593 pid <- forkProcess localNode $ do

1424− () <- expect

1425− liftIO $ putMVar clientDone ()

1594+ expect >>= liftIO . putMVar clientDone

1426

1595

1427 void $ runProcess localNode $ do

1596 void $ runProcess localNode $ do

1428 register "foobar" pid

1597 register "foobar" pid

@@ -1440,8 +1609,7 @@ testUnsafeNSendRemote TestTransport{..} = do

1440 _ <- forkProcess localNode1 $ do

1609 _ <- forkProcess localNode1 $ do

1441 getSelfPid >>= register "foobar"

1610 getSelfPid >>= register "foobar"

1442 liftIO $ putMVar clientDone ()

1611 liftIO $ putMVar clientDone ()

1443− () <- expect

1444− liftIO $ putMVar clientDone ()

1612+ expect >>= liftIO . putMVar clientDone

1445

1613

1446 takeMVar clientDone

1614 takeMVar clientDone

1447 void $ runProcess localNode2 $ do

1615 void $ runProcess localNode2 $ do

@@ -1465,7 +1633,7 @@ testUnsafeSendChan TestTransport{..} = do

1465 serverPid <- liftIO $ takeMVar serverAddr

1633 serverPid <- liftIO $ takeMVar serverAddr

1466 (sp, rp) <- newChan

1634 (sp, rp) <- newChan

1467 unsafeSend serverPid sp

1635 unsafeSend serverPid sp

1468− () <- receiveChan rp

1636+ receiveChan rp :: Process ()

1469 liftIO $ putMVar clientDone ()

1637 liftIO $ putMVar clientDone ()

1470

1638

1471 takeMVar clientDone

1639 takeMVar clientDone

@@ -1479,8 +1647,8 @@ testCallLocal TestTransport{..} = do

1479 runProcess node $ do

1647 runProcess node $ do

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

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

1481 liftIO $ putMVar result r

1649 liftIO $ putMVar result r

1650+

1482− True <- takeMVar result

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

1483− return ()

1484

1652

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

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

1486 ibox <- newIORef False

1654 ibox <- newIORef False

@@ -1497,10 +1665,9 @@ testCallLocal TestTransport{..} = do

1497 (send keeper ())

1665 (send keeper ())

1498 caller <- expect

1666 caller <- expect

1499 exit caller "test"

1667 exit caller "test"

1500− () <- expect

1668+ expect :: Process ()

1501− return ()

1669+

1502− True <- readIORef ibox

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

1503− return ()

1504

1671

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

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

1506 ibox2 <- newIORef False

1673 ibox2 <- newIORef False

@@ -1509,8 +1676,8 @@ testCallLocal TestTransport{..} = do

1509 liftIO $ writeIORef ibox2 $ case r of

1676 liftIO $ writeIORef ibox2 $ case r of

1510 Left (ErrorCall "e") -> True

1677 Left (ErrorCall "e") -> True

1511 _ -> False

1678 _ -> False

1679+

1512− True <- readIORef ibox

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

1513− return ()

1514

1681

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

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

1516 ibox3 <- newIORef False

1683 ibox3 <- newIORef False

@@ -1527,8 +1694,8 @@ testCallLocal TestTransport{..} = do

1527 liftIO $ putMVar result3 =<< readIORef ibox3

1694 liftIO $ putMVar result3 =<< readIORef ibox3

1528 worker <- expect

1695 worker <- expect

1529 send worker ()

1696 send worker ()

1697+

1530− True <- takeMVar result3

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

1531− return ()

1532

1699

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

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

1534 ibox4 <- newIORef False

1701 ibox4 <- newIORef False

@@ -1544,13 +1711,9 @@ testCallLocal TestTransport{..} = do

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

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

1545 caller <- expect

1712 caller <- expect

1546 exit caller "hi!"

1713 exit caller "hi!"

1547− True <- takeMVar result4

1548− return ()

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

1550−

1551−

1552−

1553

1714

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

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

1554

1717

1555tests :: TestTransport -> IO [Test]

1718tests :: TestTransport -> IO [Test]

1556tests testtrans = return [

1719tests testtrans = return [

@@ -1584,6 +1747,7 @@ tests testtrans = return [

1584 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1747 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1585 , testCase "ExitLocal" (testExitLocal testtrans)

1748 , testCase "ExitLocal" (testExitLocal testtrans)

1586 , testCase "ExitRemote" (testExitRemote testtrans)

1749 , testCase "ExitRemote" (testExitRemote testtrans)

1750+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1587 , testCase "TextCallLocal" (testCallLocal testtrans)

1751 , testCase "TextCallLocal" (testCallLocal testtrans)

1588 -- Unsafe Primitives

1752 -- Unsafe Primitives

1589 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1753 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

@@ -1636,17 +1800,3 @@ tests testtrans = return [

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

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

1637 ]

1801 ]

1638 ]

1802 ]

1639−

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

1641−syncBreakConnection breakConnection nid0 nid1 = do

1642− m <- newEmptyMVar

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

1644− runProcess nid0 $ do

1645− them <- liftIO $ takeMVar m

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

1647− _ <- monitorNode (localNodeId nid1)

1648− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1649− (nodeAddress $ localNodeId nid1)

1650− NodeMonitorNotification _ _ _ <- expect

1651− kill pinger "finished"

1652− 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/Internal/Utils.hs+11−3

@@ -20,6 +20,7 @@ module Control.Distributed.Process.Tests.Internal.Utils

20 -- ping !

21 , Ping(Ping)

22 , ping

23+ , pause

23 , shouldBe

24 , shouldBe

24 , shouldMatch

25 , shouldMatch

25 , shouldContain

26 , shouldContain

@@ -78,10 +79,10 @@ import Control.Distributed.Process.Node

78import Control.Distributed.Process.Serializable()

79import Control.Distributed.Process.Serializable()

80import Control.Exception (AsyncException(ThreadKilled), SomeException)

81import Control.Exception (AsyncException(ThreadKilled), SomeException)

81−import Control.Monad (forever)

82+import Control.Monad (forever, void)

82import Control.Monad.STM (atomically)

83import Control.Monad.STM (atomically)

83import Control.Rematch hiding (match)

84import Control.Rematch hiding (match)

84−import Control.Rematch.Run

85+import Control.Rematch.Run

85import Data.Binary

86import Data.Binary

86import Data.Typeable (Typeable)

87import Data.Typeable (Typeable)

@@ -107,10 +108,18 @@ data TestProcessControl = Stop | Go | Report ProcessId

107

108

108instance Binary TestProcessControl where

109instance Binary TestProcessControl where

109

110

111+data Private = Private

112+ deriving (Typeable, Generic)

113+instance Binary Private where

114+

110-- | Does exactly what it says on the tin, doing so in the @Process@ monad.

115-- | Does exactly what it says on the tin, doing so in the @Process@ monad.

111noop :: Process ()

116noop :: Process ()

112noop = return ()

117noop = return ()

113

118

119+pause :: Int -> Process ()

120+pause delay =

121+ void $ receiveTimeout delay [ match (\Private -> return ()) ]

122+

114synchronisedAssertion :: Eq a

123synchronisedAssertion :: Eq a

115 => String

124 => String

116 -> LocalNode

125 -> LocalNode

@@ -229,4 +238,3 @@ tryForkProcess :: LocalNode -> Process () -> IO ProcessId

229tryForkProcess node p = do

238tryForkProcess node p = do

230 tid <- liftIO myThreadId

239 tid <- liftIO myThreadId

231 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

240 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

232−

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+190−38

@@ -21,10 +21,11 @@ import Control.Distributed.Process.Management

21 , mxNotify

22 , mxBroadcast

23 )

24−import Control.Monad (void)

24+import Control.Monad (void, unless)

25+import Control.Rematch (equalTo)

25import Data.Binary

26import Data.Binary

26import Data.List (find, sort)

27import Data.List (find, sort)

27−import Data.Maybe (isJust)

28+import Data.Maybe (isJust, isNothing)

28import Data.Typeable

29import Data.Typeable

29import GHC.Generics

30import GHC.Generics

30#if ! MIN_VERSION_base(4,6,0)

31#if ! MIN_VERSION_base(4,6,0)

@@ -42,6 +43,16 @@ data Publish = Publish

43instance Binary Publish where

44instance Binary Publish where

46+awaitExit :: ProcessId -> Process ()

47+awaitExit pid =

48+ withMonitorRef pid $ \ref -> do

49+ receiveWait

50+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == ref)

51+ (\_ -> return ())

52+ ]

53+ where

54+ withMonitorRef pid = bracket (monitor pid) unmonitor

55+

45testAgentBroadcast :: TestResult () -> Process ()

56testAgentBroadcast :: TestResult () -> Process ()

46testAgentBroadcast result = do

57testAgentBroadcast result = do

47 (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())

58 (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())

@@ -59,13 +70,13 @@ testAgentBroadcast result = do

59 -- and the consumer will see that and send the result to our typed channel.

70 -- and the consumer will see that and send the result to our typed channel.

60 stash result =<< receiveChan resultRP

71 stash result =<< receiveChan resultRP

62− kill publisher "finished"

73+ kill publisher "finished" >> awaitExit publisher

63− kill consumer "finished"

74+ kill consumer "finished" >> awaitExit consumer

65testAgentDualInput :: TestResult (Maybe Int) -> Process ()

76testAgentDualInput :: TestResult (Maybe Int) -> Process ()

66testAgentDualInput result = do

77testAgentDualInput result = do

67 (sp, rp) <- newChan

78 (sp, rp) <- newChan

68− _ <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [

79+ s <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [

69 mxSink $ (\(i :: Int) -> do

80 mxSink $ (\(i :: Int) -> do

70 mxSetLocal . (+i) =<< mxGetLocal

81 mxSetLocal . (+i) =<< mxGetLocal

71 i' <- mxGetLocal

82 i' <- mxGetLocal

@@ -82,6 +93,7 @@ testAgentDualInput result = do

82 mxNotify (5 :: Int)

93 mxNotify (5 :: Int)

84 stash result =<< receiveChanTimeout 10000000 rp

95 stash result =<< receiveChanTimeout 10000000 rp

96+ awaitExit s

86testAgentPrioritisation :: TestResult [String] -> Process ()

98testAgentPrioritisation :: TestResult [String] -> Process ()

87testAgentPrioritisation result = do

99testAgentPrioritisation result = do

@@ -93,8 +105,8 @@ testAgentPrioritisation result = do

105

94 let name = "prioritising-agent"

106 let name = "prioritising-agent"

95 (sp, rp) <- newChan

107 (sp, rp) <- newChan

96− void $ mxAgent (MxAgentId name) ["first"] [

108+ s <- mxAgent (MxAgentId name) ["first"] [

97− mxSink (\(s :: String) -> do

109+ mxSink (\(s :: String) -> do

98 mxUpdateLocal ((s:))

110 mxUpdateLocal ((s:))

99 st <- mxGetLocal

111 st <- mxGetLocal

100 case length st of

112 case length st of

@@ -110,22 +122,25 @@ testAgentPrioritisation result = do

110 nsend name "fifth"

122 nsend name "fifth"

111

123

112 stash result . sort =<< receiveChan rp

124 stash result . sort =<< receiveChan rp

125+ awaitExit s

113

126

114testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()

127testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()

115testAgentMailboxHandling result = do

128testAgentMailboxHandling result = do

116 (sp, rp) <- newChan

129 (sp, rp) <- newChan

117− agent <- mxAgent (MxAgentId "listener-agent") () [

130+ agent <- mxAgent (MxAgentId "mailbox-agent") () [

118 mxSink $ \() -> (liftMX $ sendChan sp ()) >> mxReady

131 mxSink $ \() -> (liftMX $ sendChan sp ()) >> mxReady

119 ]

132 ]

120

133

121− nsend "listener-agent" ()

134+ nsend "mailbox-agent" ()

122

135

123 stash result =<< receiveChanTimeout 1000000 rp

136 stash result =<< receiveChanTimeout 1000000 rp

124− kill agent "finished"

137+ kill agent "finished" >> awaitExit agent

125

138

126testAgentEventHandling :: TestResult Bool -> Process ()

139testAgentEventHandling :: TestResult Bool -> Process ()

127testAgentEventHandling result = do

140testAgentEventHandling result = do

128 let initState = [] :: [MxEvent]

141 let initState = [] :: [MxEvent]

142+

143+ (rc, rs) <- newChan

129 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

144 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

130 (mxSink $ \ev -> do

145 (mxSink $ \ev -> do

131 st <- mxGetLocal

146 st <- mxGetLocal

@@ -134,7 +149,7 @@ testAgentEventHandling result = do

134 (MxSpawned _) -> mxSetLocal (ev:st)

149 (MxSpawned _) -> mxSetLocal (ev:st)

135 (MxProcessDied _ _) -> mxSetLocal (ev:st)

150 (MxProcessDied _ _) -> mxSetLocal (ev:st)

136 _ -> return ()

151 _ -> return ()

137− act >> mxReady),

152+ act >> (liftMX $ sendChan rc ()) >> mxReady),

138 (mxSink $ \(ev, sp :: SendPort Bool) -> do

153 (mxSink $ \(ev, sp :: SendPort Bool) -> do

139 st <- mxGetLocal

154 st <- mxGetLocal

140 let found =

155 let found =

@@ -154,16 +169,26 @@ testAgentEventHandling result = do

154 mxReady)

169 mxReady)

155 ]

170 ]

156

171

172+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

173+ faff 2000000 rs

174+

157 _ <- monitor agentPid

175 _ <- monitor agentPid

158 (sp, rp) <- newChan

176 (sp, rp) <- newChan

177+

159− pid <- spawnLocal $ sendChan sp ()

178+ pid <- spawnLocal $ expect >>= sendChan sp

160− () <- receiveChan rp

161

179

162 -- By waiting for a monitor notification, we have a

180 -- By waiting for a monitor notification, we have a

163− -- higher probably that the agent has seen

181+ -- higher probably that the agent has seen the spawn and died events

164 monitor pid

182 monitor pid

183+

184+ send pid ()

185+ () <- receiveChan rp

186+

165 receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]

187 receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]

166

188

189+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

190+ faff 2000000 rs

191+

167 (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

192 (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

168 mxNotify (MxSpawned pid, replyTo)

193 mxNotify (MxSpawned pid, replyTo)

169 mxNotify (MxProcessDied pid DiedNormal, replyTo)

194 mxNotify (MxProcessDied pid DiedNormal, replyTo)

@@ -172,32 +197,159 @@ testAgentEventHandling result = do

172 seenDead <- receiveChan reply

197 seenDead <- receiveChan reply

173

198

174 stash result $ seenAlive && seenDead

199 stash result $ seenAlive && seenDead

200+ kill agentPid "test-complete" >> awaitExit agentPid

201+ where

202+ faff delay port = do

203+ res <- receiveChanTimeout delay port

204+ unless (isNothing res) $ do

205+ pause delay

206+ faff delay port

207+

208+testMxRegEvents :: TestResult () -> Process ()

209+testMxRegEvents result = do

210+ {- This test only deals with the local case, to ensure that we are being

211+ notified in the expected order - the remote cases related to the

212+ behaviour of the node controller are contained in the CH test suite. -}

213+ ensure (stash result ()) $ do

214+ let label = "testMxRegEvents"

215+ let agentLabel = "mxRegEvents-agent"

216+ let delay = 1000000

217+ (regChan, regSink) <- newChan

218+ (unRegChan, unRegSink) <- newChan

219+ agent <- mxAgent (MxAgentId agentLabel) () [

220+ mxSink $ \ev -> do

221+ case ev of

222+ MxRegistered pid label'

223+ | label' == label -> liftMX $ sendChan regChan (label', pid)

224+ MxUnRegistered pid label'

225+ | label' == label -> liftMX $ sendChan unRegChan (label', pid)

226+ _ -> return ()

227+ mxReady

228+ ]

229+

230+ p1 <- spawnLocal expect

231+ p2 <- spawnLocal expect

232+

233+ register label p1

234+ reg1 <- receiveChanTimeout delay regSink

235+ reg1 `shouldBe` equalTo (Just (label, p1))

236+

237+ unregister label

238+ unreg1 <- receiveChanTimeout delay unRegSink

239+ unreg1 `shouldBe` equalTo (Just (label, p1))

240+

241+ register label p2

242+ reg2 <- receiveChanTimeout delay regSink

243+ reg2 `shouldBe` equalTo (Just (label, p2))

244+

245+ reregister label p1

246+ unreg2 <- receiveChanTimeout delay unRegSink

247+ unreg2 `shouldBe` equalTo (Just (label, p2))

248+

249+ reg3 <- receiveChanTimeout delay regSink

250+ reg3 `shouldBe` equalTo (Just (label, p1))

251+

252+ mapM_ (flip kill $ "test-complete") [agent, p1, p2]

253+ awaitExit agent

254+

255+testMxRegMon :: LocalNode -> TestResult () -> Process ()

256+testMxRegMon remoteNode result = do

257+ ensure (stash result ()) $ do

258+ -- ensure that when a registered process dies, we get a notification that

259+ -- it has been unregistered as well as seeing the name get removed

260+ let label1 = "aaaaa"

261+ let label2 = "bbbbb"

262+ let isValid l = l == label1 || l == label2

263+ let agentLabel = "mxRegMon-agent"

264+ let delay = 1000000

265+ (regChan, regSink) <- newChan

266+ (unRegChan, unRegSink) <- newChan

267+ agent <- mxAgent (MxAgentId agentLabel) () [

268+ mxSink $ \ev -> do

269+ case ev of

270+ MxRegistered pid label

271+ | isValid label -> liftMX $ sendChan regChan (label, pid)

272+ MxUnRegistered pid label

273+ | isValid label -> liftMX $ sendChan unRegChan (label, pid)

274+ _ -> return ()

275+ mxReady

276+ ]

277+

278+ (sp, rp) <- newChan

279+ liftIO $ forkProcess remoteNode $ do

280+ getSelfPid >>= sendChan sp

281+ expect :: Process ()

282+

283+ p1 <- receiveChan rp

284+

285+ register label1 p1

286+ reg1 <- receiveChanTimeout delay regSink

287+ reg1 `shouldBe` equalTo (Just (label1, p1))

288+

289+ register label2 p1

290+ reg2 <- receiveChanTimeout delay regSink

291+ reg2 `shouldBe` equalTo (Just (label2, p1))

292+

293+ n1 <- whereis label1

294+ n1 `shouldBe` equalTo (Just p1)

295+

296+ n2 <- whereis label2

297+ n2 `shouldBe` equalTo (Just p1)

298+

299+ kill p1 "goodbye"

300+

301+ unreg1 <- receiveChanTimeout delay unRegSink

302+ unreg2 <- receiveChanTimeout delay unRegSink

303+

304+ let evts = [unreg1, unreg2]

305+ -- we can't rely on the order of the values in the node controller's

306+ -- map (it's either racy to do so, or no such guarantee exists for Data.Map),

307+ -- so we simply verify that we received the un-registration events we expect

308+ evts `shouldContain` (Just (label1, p1))

309+ evts `shouldContain` (Just (label2, p1))

310+

311+ kill agent "test-complete" >> awaitExit agent

312+

313+ensure :: Process () -> Process () -> Process ()

314+ensure = flip finally

175

315

176tests :: TestTransport -> IO [Test]

316tests :: TestTransport -> IO [Test]

177tests TestTransport{..} = do

317tests TestTransport{..} = do

178 node1 <- newLocalNode testTransport initRemoteTable

318 node1 <- newLocalNode testTransport initRemoteTable

319+ node2 <- newLocalNode testTransport initRemoteTable

179 return [

320 return [

180− testGroup "Mx Agents" [

321+ testGroup "Mx Agents" [

181− testCase "Event Handling"

322+ testCase "Event Handling"

182− (delayedAssertion

323+ (delayedAssertion

183− "expected True, but events where not as expected"

324+ "expected True, but events where not as expected"

184− node1 True testAgentEventHandling)

325+ node1 True testAgentEventHandling)

185− , testCase "Inter-Agent Broadcast"

326+ , testCase "Inter-Agent Broadcast"

186− (delayedAssertion

327+ (delayedAssertion

187− "expected (), but no broadcast was received"

328+ "expected (), but no broadcast was received"

188− node1 () testAgentBroadcast)

329+ node1 () testAgentBroadcast)

189− , testCase "Agent Mailbox Handling"

330+ , testCase "Agent Mailbox Handling"

190− (delayedAssertion

331+ (delayedAssertion

191− "expected (Just ()), but no regular (mailbox) input was handled"

332+ "expected (Just ()), but no regular (mailbox) input was handled"

192− node1 (Just ()) testAgentMailboxHandling)

333+ node1 (Just ()) testAgentMailboxHandling)

193− , testCase "Agent Dual Input Handling"

334+ , testCase "Agent Dual Input Handling"

194− (delayedAssertion

335+ (delayedAssertion

195− "expected sum = 15, but the result was Nothing"

336+ "expected sum = 15, but the result was Nothing"

196− node1 (Just 15 :: Maybe Int) testAgentDualInput)

337+ node1 (Just 15 :: Maybe Int) testAgentDualInput)

197− , testCase "Agent Input Prioritisation"

338+ , testCase "Agent Input Prioritisation"

198− (delayedAssertion

339+ (delayedAssertion

199− "expected [first, second, third, fourth, fifth], but result diverged"

340+ "expected [first, second, third, fourth, fifth], but result diverged"

200− node1 (sort ["first", "second",

341+ node1 (sort ["first", "second",

201− "third", "fourth",

342+ "third", "fourth",

202− "fifth"]) testAgentPrioritisation)

343+ "fifth"]) testAgentPrioritisation)

344+ ]

345+ , testGroup "Mx Events" [

346+ testCase "Name Registration Events"

347+ (delayedAssertion

348+ "expected registration events to map to the correct ProcessId"

349+ node1 () testMxRegEvents)

350+ , testCase "Post Death Name UnRegistration Events"

351+ (delayedAssertion

352+ "expected process deaths to result in unregistration events"

353+ node1 () (testMxRegMon node2))

203− ]]

354+ ]

355+ ]

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

distributed-process.cabal+2−2

@@ -45,7 +45,7 @@ Library

45 binary >= 0.6.3 && < 0.10,

46 hashable >= 1.2.0.5 && < 1.3,

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

48− stm >= 2.4 && < 2.5,

48+ stm >= 2.4 && < 2.6,

49 transformers >= 0.2 && < 0.6,

50 mtl >= 2.0 && < 2.4,

51 data-accessor >= 0.2 && < 0.3,

@@ -55,7 +55,7 @@ Library

55 rank1dynamic >= 0.1 && < 0.5,

56 syb >= 0.3 && < 0.8,

57 exceptions >= 0.5,

58− containers >= 0.5 && < 0.6,

58+ containers >= 0.5 && < 0.7,

59 deepseq >= 1.3.0.1 && < 1.6

60 Exposed-modules: Control.Distributed.Process,

61 Control.Distributed.Process.Closure,

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

@@ -76,6 +76,7 @@ module Control.Distributed.Process.Internal.Primitives

76 , unlink

77 , monitor

78 , unmonitor

79+ , unmonitorAsync

79 , withMonitor

80 , withMonitor

80 , withMonitor_

81 , withMonitor_

81 -- * Logging

82 -- * Logging

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

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

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

401receiveWait ms = do

402receiveWait ms = do

402 queue <- processQueue <$> ask

403 queue <- processQueue <$> ask

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

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

405+ case mProc of

404− proc

406+ Just proc' -> proc'

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

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

405

409

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

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

407--

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−

src/Control/Distributed/Process/Management/Internal/Types.hs+2

@@ -30,6 +30,7 @@ import qualified Control.Monad.State as ST

30 ( MonadState

31 , StateT

32 )

33+import Control.Monad.Fix (MonadFix)

33import Data.Binary

34import Data.Binary

34import Data.Typeable (Typeable)

35import Data.Typeable (Typeable)

35import GHC.Generics

36import GHC.Generics

@@ -112,6 +113,7 @@ newtype MxAgent s a =

112 } deriving ( Functor

113 } deriving ( Functor

113 , Monad

114 , Monad

114 , MonadIO

115 , MonadIO

116+ , MonadFix

115 , ST.MonadState (MxAgentState s)

117 , ST.MonadState (MxAgentState s)

116 , Typeable

118 , Typeable

117 , Applicative

119 , Applicative

src/Control/Distributed/Process/Node.hs+23−9

@@ -28,9 +28,12 @@ import Data.Binary (decode)

28import Data.Map (Map)

29import qualified Data.Map as Map

30 ( empty

31+ , delete

31 , toList

32 , toList

32 , fromList

33 , fromList

33− , filter

34+ , insert

35+ , lookup

36+ , partition

34 , partitionWithKey

37 , partitionWithKey

35 , elems

38 , elems

36 , size

39 , size

@@ -183,6 +186,9 @@ import Control.Distributed.Process.Internal.Types

183import Control.Distributed.Process.Management.Internal.Agent

186import Control.Distributed.Process.Management.Internal.Agent

184 ( mxAgentController

187 ( mxAgentController

185 )

188 )

189+import Control.Distributed.Process.Management.Internal.Types

190+ ( MxEvent(..)

191+ )

186import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace

192import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace

187 ( remoteTable

193 ( remoteTable

188 )

194 )

@@ -195,9 +201,6 @@ import Control.Distributed.Process.Management.Internal.Trace.Types

195 , traceLogFmt

201 , traceLogFmt

196 , enableTrace

202 , enableTrace

197 )

203 )

198−import Control.Distributed.Process.Management.Internal.Types

199− ( MxEvent(..)

200− )

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

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

202import Control.Distributed.Process.Internal.Messaging

205import Control.Distributed.Process.Internal.Messaging

203 ( sendBinary

206 ( sendBinary

@@ -210,6 +213,9 @@ import Control.Distributed.Process.Internal.Primitives

210 , match

213 , match

211 , sendChan

214 , sendChan

212 , unwrapMessage

215 , unwrapMessage

216+ , monitor

217+ , unmonitorAsync

218+ , getSelfNode

213 , SayMessage(..)

219 , SayMessage(..)

214 )

220 )

215import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

221import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

@@ -903,7 +909,11 @@ ncEffectDied ident reason = do

903

909

904 modify' $ (links ^= unaffectedLinks') . (monitors ^= unaffectedMons')

910 modify' $ (links ^= unaffectedLinks') . (monitors ^= unaffectedMons')

905

911

912+ -- we now consider all labels for this identifier unregistered

906− modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)

913+ let toDrop pid = not $ ident `impliesDeathOf` ProcessIdentifier pid

914+ (keepNames, dropNames) <- Map.partition toDrop <$> gets (^. registeredHere)

915+ mapM_ (\(p, l) -> liftIO $ trace node (MxUnRegistered l p)) (Map.toList dropNames)

916+ modify' $ registeredHere ^= keepNames

907

917

908 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

918 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

909 mapM (\(pid,nidlist) ->

919 mapM (\(pid,nidlist) ->

@@ -955,7 +965,11 @@ ncEffectRegister from label atnode mPid reregistration = do

955 do modify' $ registeredHereFor label ^= mPid

965 do modify' $ registeredHereFor label ^= mPid

956 updateRemote node currentVal mPid

966 updateRemote node currentVal mPid

957 case mPid of

967 case mPid of

968+ (Just p) -> do

969+ if reregistration

970+ then liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

971+ else return ()

958− (Just p) -> liftIO $ trace node (MxRegistered p label)

972+ liftIO $ trace node (MxRegistered p label)

959 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

973 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

960 newVal <- gets (^. registeredHereFor label)

974 newVal <- gets (^. registeredHereFor label)

961 ncSendToProcess from $ unsafeCreateUnencodedMessage $

975 ncSendToProcess from $ unsafeCreateUnencodedMessage $

@@ -1070,7 +1084,7 @@ ncEffectGetInfo from pid =

1070 case mProc of

1084 case mProc of

1071 Nothing -> dispatch (isLocal node (ProcessIdentifier from))

1085 Nothing -> dispatch (isLocal node (ProcessIdentifier from))

1072 from (ProcessInfoNone DiedUnknownId)

1086 from (ProcessInfoNone DiedUnknownId)

1073− Just proc -> do

1087+ Just proc -> do

1074 itsLinks <- Set.map fst . BiMultiMap.lookupBy1st them <$>

1088 itsLinks <- Set.map fst . BiMultiMap.lookupBy1st them <$>

1075 gets (^. links)

1089 gets (^. links)

1076 itsMons <- BiMultiMap.lookupBy1st them <$> gets (^. monitors)

1090 itsMons <- BiMultiMap.lookupBy1st them <$> gets (^. monitors)

@@ -1084,8 +1098,8 @@ ncEffectGetInfo from pid =

1084 infoNode = (processNodeId pid)

1098 infoNode = (processNodeId pid)

1085 , infoRegisteredNames = reg

1099 , infoRegisteredNames = reg

1086 , infoMessageQueueLength = size

1100 , infoMessageQueueLength = size

1087− , infoMonitors = Set.toList itsMons

1101+ , infoMonitors = Set.toList itsMons

1088− , infoLinks = Set.toList itsLinks

1102+ , infoLinks = Set.toList itsLinks

1089 }

1103 }

1090 where dispatch :: (Serializable a)

1104 where dispatch :: (Serializable a)

1091 => Bool

1105 => Bool

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

14- exceptions-0.8.2.1 # test dependency

17- exceptions-0.8.2.1 # test dependency

stack-ghc-8.0.2.yaml+6−1

@@ -1,14 +1,19 @@

1resolver: lts-9.21

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

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

3packages:

5packages:

4- '.'

6- '.'

5- distributed-process-tests/

7- distributed-process-tests/

8+- location:

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

10+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11+ extra-dep: true

7extra-deps:

13extra-deps:

8- rank1dynamic-0.4.0

14- rank1dynamic-0.4.0

9- distributed-static-0.3.8

15- distributed-static-0.3.8

10- network-transport-0.5.2

16- network-transport-0.5.2

11−- network-transport-tcp-0.6.0

12- network-transport-inmemory-0.5.2

17- network-transport-inmemory-0.5.2

13- rematch-0.2.0.0

18- rematch-0.2.0.0

14# - exceptions-0.8.2.1 # test dependency

19# - exceptions-0.8.2.1 # test dependency

stack-ghc-8.2.2.yaml+4

@@ -3,6 +3,10 @@ resolver: lts-11.22

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

stack-ghc-8.4.4.yaml+5−1

@@ -1,8 +1,12 @@

1−resolver: lts-12.17

1+resolver: lts-12.18

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

stack-nightly.yamlnew file+26

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

1+resolver: nightly

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: d58250e2388b86a1865ac4139373cbdc106e72e1

13+ extra-dep: true

14+- location:

15+ git: https://github.com/haskell-distributed/network-transport-inmemory.git

16+ commit: 0ce97924f15a8c1570b2355151834305c9bd2a28

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+5−2

@@ -1,16 +1,19 @@

1−resolver: nightly-2017-08-20

1+resolver: lts-12.18 # Use GHC 8.4.4

3# TODO: we can enable nightly-2018-11-11 once PR #319 is merged

5packages:

6- '.'

7- distributed-process-tests/

8+- location:

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

10+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11+ extra-dep: true

9extra-deps:

13extra-deps:

10- rank1dynamic-0.4.0

14- rank1dynamic-0.4.0

11- distributed-static-0.3.8

15- distributed-static-0.3.8

12- network-transport-0.5.2

16- network-transport-0.5.2

13−- network-transport-tcp-0.6.0

14- network-transport-inmemory-0.5.2

17- network-transport-inmemory-0.5.2

15- rematch-0.2.0.0

18- rematch-0.2.0.0