d2b5d82 · distributed-process

git.iko.soy/distributed-process

on master help sign in

merge master

d2b5d82Tim Watson8 years ago

.travis.yml+11−6

compare with master

unifiedsplit

@@ -6,11 +6,11 @@ matrix:

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"

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

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

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

12−

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

13− - env: ARGS=

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

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

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

16cache:

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

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

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

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

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

38−- 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+26−12

@@ -31,9 +31,10 @@ library

31 bytestring >= 0.9 && < 0.12,

32 distributed-process >= 0.6.0 && < 0.8,

33 distributed-static,

34+ exceptions >= 0.5,

34 HUnit >= 1.2 && < 1.7,

35 HUnit >= 1.2 && < 1.7,

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

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

36− network >= 2.5 && < 2.7,

37+ network >= 2.5 && < 2.9,

37 random >= 1.0 && < 1.2,

38 random >= 1.0 && < 1.2,

38 rematch >= 0.1.2.1,

39 rematch >= 0.1.2.1,

39 setenv >= 0.1.1.3,

40 setenv >= 0.1.1.3,

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

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

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

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

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

62 distributed-process-tests,

63 distributed-process-tests,

63− network >= 2.3 && < 2.7,

64+ network >= 2.3 && < 2.9,

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

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

65 network-transport-inmemory >= 0.5,

66 network-transport-inmemory >= 0.5,

66 test-framework >= 0.6 && < 0.9

67 test-framework >= 0.6 && < 0.9

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

75 if flag(tcp)

76 if flag(tcp)

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

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

77 distributed-process-tests,

78 distributed-process-tests,

78− network >= 2.3 && < 2.7,

79+ network >= 2.3 && < 2.9,

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

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

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

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

81 test-framework >= 0.6 && < 0.9

82 test-framework >= 0.6 && < 0.9

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

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

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

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

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

94 distributed-process-tests,

95 distributed-process-tests,

95− network >= 2.3 && < 2.7,

96+ network >= 2.3 && < 2.9,

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

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

97 network-transport-inmemory >= 0.5,

98 network-transport-inmemory >= 0.5,

98 test-framework >= 0.6 && < 0.9

99 test-framework >= 0.6 && < 0.9

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

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

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

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

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

108 distributed-process-tests,

109 distributed-process-tests,

109− network >= 2.3 && < 2.7,

110+ network >= 2.3 && < 2.9,

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

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

111 network-transport-inmemory >= 0.5,

112 network-transport-inmemory >= 0.5,

112 test-framework >= 0.6 && < 0.9

113 test-framework >= 0.6 && < 0.9

@@ -114,31 +115,44 @@ Test-Suite TestStats

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

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

115 HS-Source-Dirs: tests

116 HS-Source-Dirs: tests

116

117

117−

118−Test-Suite TestMx

118+Test-Suite TestMxInMemory

119 Type: exitcode-stdio-1.0

120 Main-Is: runInMemory.hs

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

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

123 distributed-process-tests,

124− network >= 2.3 && < 2.7,

124+ network >= 2.3 && < 2.9,

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

126 network-transport-inmemory >= 0.5,

127 test-framework >= 0.6 && < 0.9

128 Extensions: CPP

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

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

130 HS-Source-Dirs: tests

131

132−Test-Suite TestTracing

132+Test-Suite TestTracingInMemory

133 Type: exitcode-stdio-1.0

134 Main-Is: runInMemory.hs

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

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

137 distributed-process-tests,

138− network >= 2.3 && < 2.7,

138+ network >= 2.3 && < 2.9,

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

140 network-transport-inmemory >= 0.5,

141 test-framework >= 0.6 && < 0.9

142 Extensions: CPP

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

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

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

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

144 HS-Source-Dirs: tests

158 HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+375−221

@@ -25,21 +25,29 @@ import Control.Concurrent.MVar

25 )

26import Control.Monad (replicateM_, replicateM, forever, void, unless, join)

27import Control.Exception (SomeException, throwIO, ErrorCall(..))

28−import qualified Control.Exception as Ex (catch)

28+import Control.Monad.Catch (try, catch, finally, mask, onException)

29−import Control.Applicative ((<$>), (<*>), pure, (<|>))

29+import Control.Applicative ((<|>))

30import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)

31−import Control.Distributed.Process

31+import Control.Distributed.Process hiding

32+ ( try

33+ , catch

34+ , finally

35+ , mask

36+ , onException

37+ )

32import Control.Distributed.Process.Internal.Types

38import Control.Distributed.Process.Internal.Types

33− ( NodeId(nodeAddress)

34− , LocalNode(localEndPoint)

39+ ( LocalNode(localEndPoint)

35 , ProcessExitException(..)

40 , ProcessExitException(..)

36 , nullProcessId

41 , nullProcessId

37 , createUnencodedMessage

42 , createUnencodedMessage

38 )

43 )

39import Control.Distributed.Process.Node

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)

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

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

42−import Test.HUnit (Assertion, assertFailure)

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

43import Test.Framework (Test, testGroup)

51import Test.Framework (Test, testGroup)

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

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

45import Control.Rematch hiding (match)

53import Control.Rematch hiding (match)

@@ -65,7 +73,7 @@ expectThat a matcher = case res of

65forkTry :: IO () -> IO ThreadId

73forkTry :: IO () -> IO ThreadId

66forkTry p = do

74forkTry p = do

67 tid <- myThreadId

75 tid <- myThreadId

68− forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))

76+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))

70-- | The ping server from the paper

78-- | The ping server from the paper

71ping :: Process ()

79ping :: Process ()

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

75 send partner (Ping self)

83 send partner (Ping self)

76 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+

78-- | Quick and dirty synchronous version of whereisRemoteAsync

95-- | Quick and dirty synchronous version of whereisRemoteAsync

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

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

80whereisRemote nid string = do

97whereisRemote nid string = do

81 whereisRemoteAsync nid string

98 whereisRemoteAsync nid string

99+ receiveWait [

82− 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"

83− return mPid

126+ return ()

127

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

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

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

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

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

155 unmonitor ref

198 unmonitor ref

156 liftIO $ putMVar done ()

199 liftIO $ putMVar done ()

157 (False, ref) -> do

200 (False, ref) -> do

201+ receiveWait [

158− ProcessMonitorNotification ref' pid reason' <- expect

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

203+ liftIO $ do

204+ assertBool "Bad Monitor Signal"

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

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

206+ mOrL && reason == reason')

160− liftIO $ putMVar done ()

207+ putMVar done ())

208+ ]

161 )

209 )

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

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

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

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

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

164 liftIO $ putMVar done ()

213 liftIO $ putMVar done ()

165 )

214 )

166

215

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

191 pid <- getSelfPid

240 pid <- getSelfPid

192 replicateM_ numPings $ do

241 replicateM_ numPings $ do

193 send pingServer (Pong pid)

242 send pingServer (Pong pid)

194− Ping _ <- expect

243+ p <- expect

244+ case p of

195− return ()

245+ Ping _ -> return ()

246+ _ -> die "Unexpected message"

196

247

197 putMVar clientDone ()

248 putMVar clientDone ()

198

249

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

279 runProcess localNode $ do

330 runProcess localNode $ do

280 monitor theirAddr

331 monitor theirAddr

281 -- wait for the process to die

332 -- wait for the process to die

282− ProcessMonitorNotification _ _ _ <- expect

333+ expect :: Process ProcessMonitorNotification

283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

284

335

285 takeMVar done

336 takeMVar done

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

353 runProcess localNode $ do

404 runProcess localNode $ do

354 pid <- getSelfPid

405 pid <- getSelfPid

355 send mathServer (Add pid 1 2)

406 send mathServer (Add pid 1 2)

356− 3 <- expect :: Process Double

407+ three <- expect :: Process Double

357 send mathServer (Divide pid 8 2)

408 send mathServer (Divide pid 8 2)

358− 4 <- expect :: Process Double

409+ four <- expect :: Process Double

359 send mathServer (Divide pid 8 0)

410 send mathServer (Divide pid 8 0)

360− DivByZero <- expect

411+ divByZ <- expect

361− liftIO $ putMVar clientDone ()

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

362

413

363− takeMVar clientDone

414+ res <- takeMVar clientDone

415+ case res of

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

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

364

418

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

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

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

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

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

388 pid <- getSelfPid

442 pid <- getSelfPid

389 send server1 "Hi"

443 send server1 "Hi"

390 send server2 (Pong pid)

444 send server2 (Pong pid)

391− Ping pid' <- expect

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

393− liftIO $ putMVar clientDone ()

445+ expectPing clientDone

394

446

395− takeMVar clientDone

447+ verifyClient "Expected Ping from server" clientDone

396

448

397-- | Test (non-zero) timeout

449-- | Test (non-zero) timeout

398testTimeout :: TestTransport -> Assertion

450testTimeout :: TestTransport -> Assertion

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

401 done <- newEmptyMVar

453 done <- newEmptyMVar

402

454

403 runProcess localNode $ do

455 runProcess localNode $ do

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

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

405− liftIO $ putMVar done ()

457+ liftIO $ putMVar done $ res == Nothing

406

458

407− takeMVar done

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

408

460

409-- | Test zero timeout

461-- | Test zero timeout

410testTimeout0 :: TestTransport -> Assertion

462testTimeout0 :: TestTransport -> Assertion

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

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

433 replicateM_ 10000 $ send server "Irrelevant message"

485 replicateM_ 10000 $ send server "Irrelevant message"

434 send server (Pong pid)

486 send server (Pong pid)

435− Ping _ <- expect

436− liftIO $ putMVar clientDone ()

487+ expectPing clientDone

437

488

438− takeMVar clientDone

489+ verifyClient "Expected Ping from server" clientDone

439

490

440-- | Test typed channels

491-- | Test typed channels

441testTypedChannels :: TestTransport -> Assertion

492testTypedChannels :: TestTransport -> Assertion

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

458 runProcess localNode $ do

509 runProcess localNode $ do

459 (clientSendPort, rport) <- newChan

510 (clientSendPort, rport) <- newChan

460 sendChan serverSendPort (clientSendPort, 5)

511 sendChan serverSendPort (clientSendPort, 5)

461− False <- receiveChan rport

512+ ch <- receiveChan rport

462− liftIO $ putMVar clientDone ()

513+ liftIO $ putMVar clientDone $ ch == False

463

514

464− takeMVar clientDone

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

465

516

466-- | Test merging receive ports

517-- | Test merging receive ports

467testMergeChannels :: TestTransport -> Assertion

518testMergeChannels :: TestTransport -> Assertion

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

484 rs <- mapM charChannel "abc"

535 rs <- mapM charChannel "abc"

485 m <- mergePorts biased rs

536 m <- mergePorts biased rs

486 xs <- replicateM 9 $ receiveChan m

537 xs <- replicateM 9 $ receiveChan m

487− True <- return $ xs == expected

488− liftIO $ putMVar done ()

538+ liftIO $ putMVar done $ xs == expected

489− takeMVar done

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

490

540

491 -- Two layers of merging

541 -- Two layers of merging

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

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

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

497 ms <- mapM (mergePorts biasedInner) rss

547 ms <- mapM (mergePorts biasedInner) rss

498 m <- mergePorts biasedOuter ms

548 m <- mergePorts biasedOuter ms

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

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

500− True <- return $ xs == expected

550+ liftIO $ putMVar done $ xs == expected

501− liftIO $ putMVar done ()

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

502− takeMVar done

503

552

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

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

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

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

508 done <- newEmptyMVar

557 done <- newEmptyMVar

509

558

510 forkProcess localNode $ do

559 forkProcess localNode $ do

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

560+ ss <- liftIO $ mapM readMVar vs

561+ case ss of

562+ [sa, sb, sc] ->

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

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

513− [ -- a, b, c

564+ [ -- a, b, c

514− (sa, 'a')

565+ (sa, 'a')

515− , (sb, 'b')

566+ , (sb, 'b')

516− , (sc, 'c')

567+ , (sc, 'c')

517− -- a, c, b

568+ -- a, c, b

518− , (sa, 'a')

569+ , (sa, 'a')

519− , (sc, 'c')

570+ , (sc, 'c')

520− , (sb, 'b')

571+ , (sb, 'b')

521− -- b, a, c

572+ -- b, a, c

522− , (sb, 'b')

573+ , (sb, 'b')

523− , (sa, 'a')

574+ , (sa, 'a')

524− , (sc, 'c')

575+ , (sc, 'c')

525− -- b, c, a

576+ -- b, c, a

526− , (sb, 'b')

577+ , (sb, 'b')

527− , (sc, 'c')

578+ , (sc, 'c')

528− , (sa, 'a')

579+ , (sa, 'a')

529− -- c, a, b

580+ -- c, a, b

530− , (sc, 'c')

581+ , (sc, 'c')

531− , (sa, 'a')

582+ , (sa, 'a')

532− , (sb, 'b')

583+ , (sb, 'b')

533− -- c, b, a

584+ -- c, b, a

534− , (sc, 'c')

585+ , (sc, 'c')

535− , (sb, 'b')

586+ , (sb, 'b')

536− , (sa, 'a')

587+ , (sa, 'a')

537− ]

588+ ]

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

538

590

539 forkProcess localNode $ do

591 forkProcess localNode $ do

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

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

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

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

542 m <- mergePorts biased rs

594 m <- mergePorts biased rs

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

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

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

545− liftIO $ putMVar done ()

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

546

597

547− takeMVar done

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

548

599

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

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

550 mergePorts True = mergePortsBiased

601 mergePorts True = mergePortsBiased

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

562 localNode <- newLocalNode testTransport initRemoteTable

613 localNode <- newLocalNode testTransport initRemoteTable

563 runProcess localNode $ do

614 runProcess localNode $ do

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

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

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

616+ if either show show e == show ProcessTerminationException

566− return ()

617+ then return ()

618+ else die "Unexpected result from terminate"

567

619

568testMonitorNode :: TestTransport -> Assertion

620testMonitorNode :: TestTransport -> Assertion

569testMonitorNode TestTransport{..} = do

621testMonitorNode TestTransport{..} = do

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

574

626

575 runProcess node2 $ do

627 runProcess node2 $ do

576 ref <- monitorNode (localNodeId node1)

628 ref <- monitorNode (localNodeId node1)

629+ receiveWait [

577− NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

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

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

579− liftIO $ putMVar done ()

632+ ] >>= liftIO . putMVar done

580

633

581− takeMVar done

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

582

635

583testMonitorLiveNode :: TestTransport -> Assertion

636testMonitorLiveNode :: TestTransport -> Assertion

584testMonitorLiveNode TestTransport{..} = do

637testMonitorLiveNode TestTransport{..} = do

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

593 liftIO $ putMVar ready ()

646 liftIO $ putMVar ready ()

594 liftIO $ takeMVar readyr

647 liftIO $ takeMVar readyr

595 send p ()

648 send p ()

649+ receiveWait [

596− NodeMonitorNotification ref' nid _ <- expect

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

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

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

598− liftIO $ putMVar done ()

652+ ] >>= liftIO . putMVar done

599

653

600 takeMVar ready

654 takeMVar ready

601 closeLocalNode node1

655 closeLocalNode node1

602 putMVar readyr ()

656 putMVar readyr ()

603

657

604− takeMVar done

658+ verifyClient "Expected NodeMonitorNotification for LIVE node" done

605

659

606testMonitorChannel :: TestTransport -> Assertion

660testMonitorChannel :: TestTransport -> Assertion

607testMonitorChannel TestTransport{..} = do

661testMonitorChannel TestTransport{..} = do

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

611 pid <- forkProcess node1 $ do

665 pid <- forkProcess node1 $ do

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

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

613 ref <- monitorPort sport

667 ref <- monitorPort sport

614− PortMonitorNotification ref' port' reason <- expect

668+ receiveWait [

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

616− -- 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 &&

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

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

618− liftIO $ putMVar gotNotification ()

674+ ] >>= liftIO . putMVar gotNotification

619

675

620 runProcess node2 $ do

676 runProcess node2 $ do

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

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

622 send pid sport

678 send pid sport

623 liftIO $ threadDelay 100000

679 liftIO $ threadDelay 100000

624

680

625− takeMVar gotNotification

681+ verifyClient "Expected PortMonitorNotification" gotNotification

626

682

627testRegistry :: TestTransport -> Assertion

683testRegistry :: TestTransport -> Assertion

628testRegistry TestTransport{..} = do

684testRegistry TestTransport{..} = do

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

634

690

635 runProcess node $ do

691 runProcess node $ do

636 register "ping" pingServer

692 register "ping" pingServer

637− Just pid <- whereis "ping"

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

638− True <- return $ pingServer == pid

639 us <- getSelfPid

694 us <- getSelfPid

640 nsend "ping" (Pong us)

695 nsend "ping" (Pong us)

641− Ping pid' <- expect

696+ receiveWait [

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

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

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

698+ ]

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

699+ checkRegException "dead" Nothing deadProcess

645− True <- return $ x == pingServer

700+ checkRegException "ping" (Just pingServer) deadProcess

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

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

647 liftIO $ putMVar done ()

702 liftIO $ putMVar done ()

648

703

649 takeMVar done

704 takeMVar done

650

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+

651testRegistryRemoteProcess :: TestTransport -> Assertion

715testRegistryRemoteProcess :: TestTransport -> Assertion

652testRegistryRemoteProcess TestTransport{..} = do

716testRegistryRemoteProcess TestTransport{..} = do

653 node1 <- newLocalNode testTransport initRemoteTable

717 node1 <- newLocalNode testTransport initRemoteTable

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

658

722

659 runProcess node2 $ do

723 runProcess node2 $ do

660 register "ping" pingServer

724 register "ping" pingServer

661− Just pid <- whereis "ping"

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

662− True <- return $ pingServer == pid

663 us <- getSelfPid

726 us <- getSelfPid

664 nsend "ping" (Pong us)

727 nsend "ping" (Pong us)

665− Ping pid' <- expect

728+ receiveWait [

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

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

667− liftIO $ putMVar done ()

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

731+ ]

668

732

669 takeMVar done

733 takeMVar done

670

734

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

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

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

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

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

687

751

688− Just pid <- whereisRemote nid1 "ping"

752+ pid <- verifyWhereIsRemote nid1 "ping"

689− True <- return $ pingServer == pid

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

690 us <- getSelfPid

754 us <- getSelfPid

691 nsendRemote nid1 "ping" (Pong us)

755 nsendRemote nid1 "ping" (Pong us)

692− Ping pid' <- expect

756+ receiveWait [

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

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

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

694

759

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

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

696 -- in owner field.

761 -- in owner field.

@@ -700,8 +765,8 @@ testRemoteRegistry TestTransport{..} = do

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

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

701 registerRemoteAsync nid1 "ping" deadProcess

766 registerRemoteAsync nid1 "ping" deadProcess

702 receiveWait [

767 receiveWait [

703− matchIf (\(RegisterReply label' False (Just pid)) ->

768+ matchIf (\(RegisterReply label' False (Just pid'')) ->

704− "ping" == label' && pid == pingServer)

769+ "ping" == label' && pid'' == pingServer)

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

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

706 unregisterRemoteAsync nid1 "dead"

771 unregisterRemoteAsync nid1 "dead"

707 receiveWait [

772 receiveWait [

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

726 receiveWait [

791 receiveWait [

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

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

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

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

729− Just pid <- whereisRemote nid1 "ping"

794+ pid <- verifyWhereIsRemote nid1 "ping"

730− True <- return $ pingServer == pid

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

731 us <- getSelfPid

796 us <- getSelfPid

732 nsendRemote nid1 "ping" (Pong us)

797 nsendRemote nid1 "ping" (Pong us)

733− Ping pid' <- expect

798+ receiveWait [

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

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

735− liftIO $ putMVar done ()

800+ ] >>= liftIO . putMVar done

736

801

737− takeMVar done

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

738

803

739testSpawnLocal :: TestTransport -> Assertion

804testSpawnLocal :: TestTransport -> Assertion

740testSpawnLocal TestTransport{..} = do

805testSpawnLocal TestTransport{..} = do

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

748 sport <- expect

813 sport <- expect

749 sendChan sport (1234 :: Int)

814 sendChan sport (1234 :: Int)

750

815

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

816+ sport <- spawnChannelLocal $

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

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

753− send us ()

754

818

755 send pid sport

819 send pid sport

756− () <- expect

757− liftIO $ putMVar done ()

820+ expect >>= liftIO . putMVar done

758

821

759− takeMVar done

822+ res <- takeMVar done

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

760

824

761testSpawnAsyncStrictness :: TestTransport -> Assertion

825testSpawnAsyncStrictness :: TestTransport -> Assertion

762testSpawnAsyncStrictness TestTransport{..} = do

826testSpawnAsyncStrictness TestTransport{..} = do

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

785 liftIO $ putMVar processA us

849 liftIO $ putMVar processA us

786 msg1 <- expect

850 msg1 <- expect

787 msg2 <- expect

851 msg2 <- expect

852+ liftIO $ do

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

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

789− liftIO $ putMVar sendTestOk ()

854+ putMVar sendTestOk ()

790

855

791 forkProcess node2 $ do

856 forkProcess node2 $ do

792 {-

857 {-

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

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

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

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

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

821

886

822− Just _ <- whereisRemote nid1 "a"

887+ _ <- whereisRemote nid1 "a"

823

888

824

889

825 -- Simulate network failure

890 -- Simulate network failure

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

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

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

839

904

840 -- Check

905 -- Check

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

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

843− Just _ <- whereisRemote nid1 "c"

909+ verifyWhereIsRemote nid1 "c"

844

910

845 liftIO $ putMVar registerTestOk ()

911 liftIO $ putMVar registerTestOk ()

846

912

@@ -881,19 +947,19 @@ testUSend usendPrim TestTransport{..} numMessages = do

881 isSorted _ = True

947 isSorted _ = True

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

883 -- the last message.

949 -- the last message.

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

950+ liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)

885− liftIO $ putMVar usendTestOk ()

886

951

887 forkProcess node2 $ do

952 forkProcess node2 $ do

888 them <- liftIO $ readMVar processA

953 them <- liftIO $ readMVar processA

889 getSelfPid >>= send them

954 getSelfPid >>= send them

890− () <- expect

955+ expect :: Process ()

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

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

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

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

893 usendPrim them i

958 usendPrim them i

894 liftIO (threadDelay 30000)

959 liftIO (threadDelay 30000)

895

960

896− takeMVar usendTestOk

961+ res <- takeMVar usendTestOk

962+ assertBool "Unexpected failure after sending last msg" res

897

963

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

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

899-- in between

965-- in between

@@ -919,14 +985,17 @@ testMatchAny TestTransport{..} = do

919 runProcess localNode $ do

985 runProcess localNode $ do

920 pid <- getSelfPid

986 pid <- getSelfPid

921 send mathServer (Add pid 1 2)

987 send mathServer (Add pid 1 2)

922− 3 <- expect :: Process Double

988+ three <- expect :: Process Double

923 send mathServer (Divide pid 8 2)

989 send mathServer (Divide pid 8 2)

924− 4 <- expect :: Process Double

990+ four <- expect :: Process Double

925 send mathServer (Divide pid 8 0)

991 send mathServer (Divide pid 8 0)

926− DivByZero <- expect

992+ divByZ <- expect

927− liftIO $ putMVar clientDone ()

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

928

994

929− takeMVar clientDone

995+ res <- takeMVar clientDone

996+ case res of

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

998+ _ -> error "Unexpected result"

930

999

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

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

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

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

@@ -953,12 +1022,13 @@ testMatchAnyHandle TestTransport{..} = do

953 runProcess localNode $ do

1022 runProcess localNode $ do

954 pid <- getSelfPid

1023 pid <- getSelfPid

955 send mathServer (Add pid 1 2)

1024 send mathServer (Add pid 1 2)

956− 3 <- expect :: Process Double

1025+ three <- expect :: Process Double

957 send mathServer (Divide pid 8 2)

1026 send mathServer (Divide pid 8 2)

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

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

959− liftIO $ putMVar clientDone ()

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

1029+

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

960

1031

961− takeMVar clientDone

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

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

963 maybeForward s msg =

1033 maybeForward s msg =

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

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

@@ -986,8 +1056,10 @@ testMatchAnyNoHandle TestTransport{..} = do

986 Just _ -> die "NONSENSE")

1056 Just _ -> die "NONSENSE")

987 ]

1057 ]

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

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

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

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

1060+ liftIO $ do

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

990− liftIO $ putMVar serverDone ()

1062+ putMVar serverDone ()

991 putMVar addr server

1063 putMVar addr server

992

1064

993 -- Client

1065 -- Client

@@ -1030,14 +1102,21 @@ testMatchAnyIf TestTransport{..} = do

1030 runProcess localNode $ do

1102 runProcess localNode $ do

1031 pid <- getSelfPid

1103 pid <- getSelfPid

1032 send server (pid, "foo")

1104 send server (pid, "foo")

1033− "foo" <- expect

1105+ foo <- expect

1034− send server (pid, "baz")

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

1035− "baz" <- expect

1107+

1036 send server (pid, "bar")

1108 send server (pid, "bar")

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

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

1110+

1111+ send server (pid, "baz")

1112+ baz <- expect

1113+

1038− liftIO $ putMVar clientDone ()

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

1115+

1116+ res <- takeMVar clientDone

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

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

1039

1119

1040− takeMVar clientDone

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

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

1042 tryHandleMessage msg =

1121 tryHandleMessage msg =

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

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

@@ -1070,12 +1149,13 @@ testMatchMessageWithUnwrap TestTransport{..} = do

1070 runProcess localNode $ do

1149 runProcess localNode $ do

1071 pid <- getSelfPid

1150 pid <- getSelfPid

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

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

1073− "foo" <- expect

1152+ foo <- expect

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

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

1075− "baz" <- expect

1154+ baz <- expect

1076− liftIO $ putMVar clientDone ()

1155+ liftIO $ putMVar clientDone (foo, baz)

1077

1156

1078− takeMVar clientDone

1157+ res <- takeMVar clientDone

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

1079

1159

1080-- Test 'receiveChanTimeout'

1160-- Test 'receiveChanTimeout'

1081testReceiveChanTimeout :: TestTransport -> Assertion

1161testReceiveChanTimeout :: TestTransport -> Assertion

@@ -1093,18 +1173,19 @@ testReceiveChanTimeout TestTransport{..} = do

1093

1173

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

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

1095 -- Nothing after the delay.

1175 -- Nothing after the delay.

1096− Nothing <- receiveChanTimeout 100000 rp

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

1097

1177

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

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

1099 liftIO $ putMVar mvSender ()

1179 liftIO $ putMVar mvSender ()

1100

1180

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

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

1102 -- 0.1 seconds

1182 -- 0.1 seconds

1103− Just True <- receiveChanTimeout 20000000 rp

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

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

1104

1185

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

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

1106 -- available, we get Nothing

1187 -- available, we get Nothing

1107− Nothing <- receiveChanTimeout 0 rp

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

1108

1189

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

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

1110 liftIO $ putMVar mvSender ()

1191 liftIO $ putMVar mvSender ()

@@ -1114,7 +1195,7 @@ testReceiveChanTimeout TestTransport{..} = do

1114 liftIO $ threadDelay 100000

1195 liftIO $ threadDelay 100000

1115 mb <- receiveChanTimeout 0 rp

1196 mb <- receiveChanTimeout 0 rp

1116 case mb of

1197 case mb of

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

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

1118 _ -> loop

1199 _ -> loop

1119

1200

1120 liftIO $ putMVar done ()

1201 liftIO $ putMVar done ()

@@ -1151,8 +1232,8 @@ testReceiveChanFeatures TestTransport{..} = do

1151

1232

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

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

1153

1234

1154− True <- receiveChan rp1

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

1155− False <- receiveChan rp1

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

1156

1237

1157 -- Test Applicative instance

1238 -- Test Applicative instance

1158

1239

@@ -1161,7 +1242,7 @@ testReceiveChanFeatures TestTransport{..} = do

1161

1242

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

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

1163

1244

1164− 7 <- receiveChan rp2

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

1165

1246

1166 -- Test Alternative instance

1247 -- Test Alternative instance

1167

1248

@@ -1170,8 +1251,8 @@ testReceiveChanFeatures TestTransport{..} = do

1170

1251

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

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

1172

1253

1173− False <- receiveChan rp3

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

1174− True <- receiveChan rp3

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

1175

1256

1176 -- Test Monad instance

1257 -- Test Monad instance

1177

1258

@@ -1185,8 +1266,8 @@ testReceiveChanFeatures TestTransport{..} = do

1185 then rpInt

1266 then rpInt

1186 else return 7

1267 else return 7

1187

1268

1188− 5 <- receiveChan rp4

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

1189− 7 <- receiveChan rp4

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

1190

1271

1191 liftIO $ putMVar done ()

1272 liftIO $ putMVar done ()

1192

1273

@@ -1195,7 +1276,6 @@ testReceiveChanFeatures TestTransport{..} = do

1195testKillLocal :: TestTransport -> Assertion

1276testKillLocal :: TestTransport -> Assertion

1196testKillLocal TestTransport{..} = do

1277testKillLocal TestTransport{..} = do

1197 localNode <- newLocalNode testTransport initRemoteTable

1278 localNode <- newLocalNode testTransport initRemoteTable

1198− done <- newEmptyMVar

1199

1279

1200 pid <- forkProcess localNode $ do

1280 pid <- forkProcess localNode $ do

1201 liftIO $ threadDelay 1000000

1281 liftIO $ threadDelay 1000000

@@ -1204,17 +1284,18 @@ testKillLocal TestTransport{..} = do

1204 ref <- monitor pid

1284 ref <- monitor pid

1205 us <- getSelfPid

1285 us <- getSelfPid

1206 kill pid "TestKill"

1286 kill pid "TestKill"

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

1287+ mn <- expect

1288+ case mn of

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

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

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

1209− liftIO $ putMVar done ()

1291+ True -> return ()

1210−

1292+ False -> die "Invalid ProcessMonitorNotification received"

1211− takeMVar done

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

1212

1294

1213testKillRemote :: TestTransport -> Assertion

1295testKillRemote :: TestTransport -> Assertion

1214testKillRemote TestTransport{..} = do

1296testKillRemote TestTransport{..} = do

1215 node1 <- newLocalNode testTransport initRemoteTable

1297 node1 <- newLocalNode testTransport initRemoteTable

1216 node2 <- newLocalNode testTransport initRemoteTable

1298 node2 <- newLocalNode testTransport initRemoteTable

1217− done <- newEmptyMVar

1218

1299

1219 pid <- forkProcess node1 $ do

1300 pid <- forkProcess node1 $ do

1220 liftIO $ threadDelay 1000000

1301 liftIO $ threadDelay 1000000

@@ -1223,11 +1304,17 @@ testKillRemote TestTransport{..} = do

1223 ref <- monitor pid

1304 ref <- monitor pid

1224 us <- getSelfPid

1305 us <- getSelfPid

1225 kill pid "TestKill"

1306 kill pid "TestKill"

1307+ mn <- expect

1308+ case mn of

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

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

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

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

1228− liftIO $ putMVar done ()

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

1229−

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

1230− takeMVar done

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

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

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

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

1317+ _ -> die "Received unexpected message"

1231

1318

1232testCatchesExit :: TestTransport -> Assertion

1319testCatchesExit :: TestTransport -> Assertion

1233testCatchesExit TestTransport{..} = do

1320testCatchesExit TestTransport{..} = do

@@ -1253,7 +1340,10 @@ testHandleMessageIf TestTransport{..} = do

1253 self <- getSelfPid

1340 self <- getSelfPid

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

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

1255 msg <- receiveWait [ matchMessage return ]

1342 msg <- receiveWait [ matchMessage return ]

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

1343+ handleMessageIf msg

1344+ (\() -> True)

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

1346+ (const $ die "Expected Mismatch")

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

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

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

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

1259 return ()

1349 return ()

@@ -1298,8 +1388,11 @@ testDie TestTransport{..} = do

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

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

1299 `catchExit` \_from reason -> do

1389 `catchExit` \_from reason -> do

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

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

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

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

1302 liftIO $ putMVar done ()

1392 liftIO $ putMVar done ()

1393+ if res

1394+ then return ()

1395+ else die "Something went horribly wrong"

1303

1396

1304 takeMVar done

1397 takeMVar done

1305

1398

@@ -1313,8 +1406,11 @@ testPrettyExit TestTransport{..} = do

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

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

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

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

1315 in do

1408 in do

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

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

1317 liftIO $ putMVar done ()

1410 liftIO $ putMVar done ()

1411+ if res

1412+ then return ()

1413+ else die "Something went horribly wrong"

1318

1414

1319 takeMVar done

1415 takeMVar done

1320

1416

@@ -1330,17 +1426,26 @@ testExitLocal TestTransport{..} = do

1330 pid <- forkProcess localNode $ do

1426 pid <- forkProcess localNode $ do

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

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

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

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

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

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

1334 liftIO $ putMVar supervisedDone ()

1430 liftIO $ putMVar supervisedDone ()

1431+ if res

1432+ then return ()

1433+ else die "Something went horribly wrong"

1335

1434

1336 runProcess localNode $ do

1435 runProcess localNode $ do

1337 liftIO $ takeMVar handlerSetUp

1436 liftIO $ takeMVar handlerSetUp

1338 ref <- monitor pid

1437 ref <- monitor pid

1339 exit pid "TestExit"

1438 exit pid "TestExit"

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

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

1440+ mn <- expect

1441+ case mn of

1341− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1442+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1343− liftIO $ putMVar supervisorDone ()

1444+ liftIO $ putMVar supervisorDone ()

1445+ if res

1446+ then return ()

1447+ else die "Something went horribly wrong"

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

1344

1449

1345 takeMVar supervisedDone

1450 takeMVar supervisedDone

1346 takeMVar supervisorDone

1451 takeMVar supervisorDone

@@ -1356,19 +1461,90 @@ testExitRemote TestTransport{..} = do

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

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

1357 `catchExit` \_from reason -> do

1462 `catchExit` \_from reason -> do

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

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

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

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

1360 liftIO $ putMVar supervisedDone ()

1465 liftIO $ putMVar supervisedDone ()

1466+ if res

1467+ then return ()

1468+ else die "Something went horribly wrong"

1361

1469

1362 runProcess node2 $ do

1470 runProcess node2 $ do

1363 ref <- monitor pid

1471 ref <- monitor pid

1364 exit pid "TestExit"

1472 exit pid "TestExit"

1473+ mn <- expect

1474+ case mn of

1365− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1475+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1367− liftIO $ putMVar supervisorDone ()

1477+ liftIO $ putMVar supervisorDone ()

1478+ if res'

1479+ then return ()

1480+ else die "Something went horribly wrong"

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

1368

1482

1369 takeMVar supervisedDone

1483 takeMVar supervisedDone

1370 takeMVar supervisorDone

1484 takeMVar supervisorDone

1371

1485

1486+testRegistryMonitoring :: TestTransport -> Assertion

1487+testRegistryMonitoring TestTransport{..} = do

1488+ node1 <- newLocalNode testTransport initRemoteTable

1489+ node2 <- newLocalNode testTransport initRemoteTable

1490+ waitH <- newEmptyMVar

1491+

1492+ let nid = localNodeId node2

1493+ pid <- forkProcess node1 $ do

1494+ getSelfPid >>= runUntilRegistered nid

1495+ liftIO $ takeMVar waitH

1496+

1497+ runProcess node2 $ do

1498+ register regName pid

1499+ res <- whereis regName

1500+ us <- getSelfPid

1501+ liftIO $ do

1502+ putMVar waitH ()

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

1504+

1505+ -- This delay isn't essential!

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

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

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

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

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

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

1512+ void $ receiveTimeout 4000000 [ matchAny return ]

1513+

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

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

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

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

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

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

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

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

1522+ -- in either case.

1523+ runProcess node2 $ delayUntilMaybeUnregistered nid pid

1524+

1525+ regHere <- newEmptyMVar

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

1527+ res <- takeMVar regHere

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

1529+

1530+ where

1531+ runUntilRegistered nid us = do

1532+ whereisRemoteAsync nid regName

1533+ receiveWait [

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

1535+ (const $ return ())

1536+ ]

1537+

1538+ delayUntilMaybeUnregistered nid p = do

1539+ whereisRemoteAsync nid regName

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

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

1542+ (const $ return ())

1543+ ]

1544+ return ()

1545+

1546+ regName = "testRegisterRemote"

1547+

1372testUnsafeSend :: TestTransport -> Assertion

1548testUnsafeSend :: TestTransport -> Assertion

1373testUnsafeSend TestTransport{..} = do

1549testUnsafeSend TestTransport{..} = do

1374 serverAddr <- newEmptyMVar

1550 serverAddr <- newEmptyMVar

@@ -1384,8 +1560,7 @@ testUnsafeSend TestTransport{..} = do

1384 void $ forkProcess localNode $ do

1560 void $ forkProcess localNode $ do

1385 serverPid <- liftIO $ takeMVar serverAddr

1561 serverPid <- liftIO $ takeMVar serverAddr

1386 getSelfPid >>= unsafeSend serverPid

1562 getSelfPid >>= unsafeSend serverPid

1387− () <- expect

1388− liftIO $ putMVar clientDone ()

1563+ expect >>= liftIO . putMVar clientDone

1389

1564

1390 takeMVar clientDone

1565 takeMVar clientDone

1391

1566

@@ -1404,8 +1579,7 @@ testUnsafeUSend TestTransport{..} = do

1404 void $ forkProcess localNode $ do

1579 void $ forkProcess localNode $ do

1405 serverPid <- liftIO $ takeMVar serverAddr

1580 serverPid <- liftIO $ takeMVar serverAddr

1406 getSelfPid >>= unsafeUSend serverPid

1581 getSelfPid >>= unsafeUSend serverPid

1407− () <- expect

1408− liftIO $ putMVar clientDone ()

1582+ expect >>= liftIO . putMVar clientDone

1409

1583

1410 takeMVar clientDone

1584 takeMVar clientDone

1411

1585

@@ -1416,8 +1590,7 @@ testUnsafeNSend TestTransport{..} = do

1416 localNode <- newLocalNode testTransport initRemoteTable

1590 localNode <- newLocalNode testTransport initRemoteTable

1417

1591

1418 pid <- forkProcess localNode $ do

1592 pid <- forkProcess localNode $ do

1419− () <- expect

1420− liftIO $ putMVar clientDone ()

1593+ expect >>= liftIO . putMVar clientDone

1421

1594

1422 void $ runProcess localNode $ do

1595 void $ runProcess localNode $ do

1423 register "foobar" pid

1596 register "foobar" pid

@@ -1435,8 +1608,7 @@ testUnsafeNSendRemote TestTransport{..} = do

1435 _ <- forkProcess localNode1 $ do

1608 _ <- forkProcess localNode1 $ do

1436 getSelfPid >>= register "foobar"

1609 getSelfPid >>= register "foobar"

1437 liftIO $ putMVar clientDone ()

1610 liftIO $ putMVar clientDone ()

1438− () <- expect

1439− liftIO $ putMVar clientDone ()

1611+ expect >>= liftIO . putMVar clientDone

1440

1612

1441 takeMVar clientDone

1613 takeMVar clientDone

1442 void $ runProcess localNode2 $ do

1614 void $ runProcess localNode2 $ do

@@ -1460,7 +1632,7 @@ testUnsafeSendChan TestTransport{..} = do

1460 serverPid <- liftIO $ takeMVar serverAddr

1632 serverPid <- liftIO $ takeMVar serverAddr

1461 (sp, rp) <- newChan

1633 (sp, rp) <- newChan

1462 unsafeSend serverPid sp

1634 unsafeSend serverPid sp

1463− () <- receiveChan rp

1635+ receiveChan rp :: Process ()

1464 liftIO $ putMVar clientDone ()

1636 liftIO $ putMVar clientDone ()

1465

1637

1466 takeMVar clientDone

1638 takeMVar clientDone

@@ -1474,8 +1646,8 @@ testCallLocal TestTransport{..} = do

1474 runProcess node $ do

1646 runProcess node $ do

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

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

1476 liftIO $ putMVar result r

1648 liftIO $ putMVar result r

1649+

1477− True <- takeMVar result

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

1478− return ()

1479

1651

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

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

1481 ibox <- newIORef False

1653 ibox <- newIORef False

@@ -1492,10 +1664,9 @@ testCallLocal TestTransport{..} = do

1492 (send keeper ())

1664 (send keeper ())

1493 caller <- expect

1665 caller <- expect

1494 exit caller "test"

1666 exit caller "test"

1495− () <- expect

1667+ expect :: Process ()

1496− return ()

1668+

1497− True <- readIORef ibox

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

1498− return ()

1499

1670

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

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

1501 ibox2 <- newIORef False

1672 ibox2 <- newIORef False

@@ -1504,8 +1675,8 @@ testCallLocal TestTransport{..} = do

1504 liftIO $ writeIORef ibox2 $ case r of

1675 liftIO $ writeIORef ibox2 $ case r of

1505 Left (ErrorCall "e") -> True

1676 Left (ErrorCall "e") -> True

1506 _ -> False

1677 _ -> False

1678+

1507− True <- readIORef ibox

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

1508− return ()

1509

1680

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

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

1511 ibox3 <- newIORef False

1682 ibox3 <- newIORef False

@@ -1522,8 +1693,8 @@ testCallLocal TestTransport{..} = do

1522 liftIO $ putMVar result3 =<< readIORef ibox3

1693 liftIO $ putMVar result3 =<< readIORef ibox3

1523 worker <- expect

1694 worker <- expect

1524 send worker ()

1695 send worker ()

1696+

1525− True <- takeMVar result3

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

1526− return ()

1527

1698

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

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

1529 ibox4 <- newIORef False

1700 ibox4 <- newIORef False

@@ -1539,13 +1710,9 @@ testCallLocal TestTransport{..} = do

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

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

1540 caller <- expect

1711 caller <- expect

1541 exit caller "hi!"

1712 exit caller "hi!"

1542− True <- takeMVar result4

1543− return ()

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

1545−

1546−

1547−

1548

1713

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

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

1549

1716

1550tests :: TestTransport -> IO [Test]

1717tests :: TestTransport -> IO [Test]

1551tests testtrans = return [

1718tests testtrans = return [

@@ -1579,6 +1746,7 @@ tests testtrans = return [

1579 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1746 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1580 , testCase "ExitLocal" (testExitLocal testtrans)

1747 , testCase "ExitLocal" (testExitLocal testtrans)

1581 , testCase "ExitRemote" (testExitRemote testtrans)

1748 , testCase "ExitRemote" (testExitRemote testtrans)

1749+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1582 , testCase "TextCallLocal" (testCallLocal testtrans)

1750 , testCase "TextCallLocal" (testCallLocal testtrans)

1583 -- Unsafe Primitives

1751 -- Unsafe Primitives

1584 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1752 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

@@ -1631,17 +1799,3 @@ tests testtrans = return [

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

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

1632 ]

1800 ]

1633 ]

1801 ]

1634−

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

1636−syncBreakConnection breakConnection nid0 nid1 = do

1637− m <- newEmptyMVar

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

1639− runProcess nid0 $ do

1640− them <- liftIO $ takeMVar m

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

1642− _ <- monitorNode (localNodeId nid1)

1643− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1644− (nodeAddress $ localNodeId nid1)

1645− NodeMonitorNotification _ _ _ <- expect

1646− kill pinger "finished"

1647− return ()

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+84−45

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

@@ -486,7 +522,7 @@ testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion

486testSpawnReconnect testtrans@TestTransport{..} rtable = do

522testSpawnReconnect testtrans@TestTransport{..} rtable = do

487 [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

523 [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

488 let nid1 = localNodeId node1

524 let nid1 = localNodeId node1

489− nid2 = localNodeId node2

525+ -- nid2 = localNodeId node2

490 done <- newEmptyMVar

526 done <- newEmptyMVar

491 iv <- newMVar (0 :: Int)

527 iv <- newMVar (0 :: Int)

492

528

@@ -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+167−20

@@ -4,7 +4,6 @@ module Control.Distributed.Process.Tests.Mx (tests) where

4import Control.Distributed.Process.Tests.Internal.Utils

5import Network.Transport.Test (TestTransport(..))

7−import Control.Concurrent (threadDelay)

8import Control.Distributed.Process

7import Control.Distributed.Process

9import Control.Distributed.Process.Node

8import Control.Distributed.Process.Node

10import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe

9import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe

@@ -27,12 +26,12 @@ import Control.Distributed.Process.Management

27 , mxUpdateLocal

26 , mxUpdateLocal

28 , mxNotify

27 , mxNotify

29 , mxBroadcast

28 , mxBroadcast

30− , mxGetId

31 )

29 )

32−import Control.Monad (void)

30+import Control.Monad (void, unless)

31+import Control.Rematch (equalTo)

33import Data.Binary

32import Data.Binary

34import Data.List (find, sort)

33import Data.List (find, sort)

35−import Data.Maybe (isJust)

34+import Data.Maybe (isJust, isNothing)

36import Data.Typeable

35import Data.Typeable

37import GHC.Generics

36import GHC.Generics

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

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

@@ -50,6 +49,16 @@ data Publish = Publish

51instance Binary Publish where

50instance Binary Publish where

52+awaitExit :: ProcessId -> Process ()

53+awaitExit pid =

54+ withMonitorRef pid $ \ref -> do

55+ receiveWait

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

57+ (\_ -> return ())

58+ ]

59+ where

60+ withMonitorRef pid = bracket (monitor pid) unmonitor

61+

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

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

54testAgentBroadcast result = do

63testAgentBroadcast result = do

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

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

@@ -67,13 +76,13 @@ testAgentBroadcast result = do

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

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

68 stash result =<< receiveChan resultRP

77 stash result =<< receiveChan resultRP

70− kill publisher "finished"

79+ kill publisher "finished" >> awaitExit publisher

71− kill consumer "finished"

80+ kill consumer "finished" >> awaitExit consumer

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

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

74testAgentDualInput result = do

83testAgentDualInput result = do

75 (sp, rp) <- newChan

84 (sp, rp) <- newChan

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

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

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

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

78 mxSetLocal . (+i) =<< mxGetLocal

87 mxSetLocal . (+i) =<< mxGetLocal

79 i' <- mxGetLocal

88 i' <- mxGetLocal

@@ -90,6 +99,7 @@ testAgentDualInput result = do

90 mxNotify (5 :: Int)

99 mxNotify (5 :: Int)

100

92 stash result =<< receiveChanTimeout 10000000 rp

101 stash result =<< receiveChanTimeout 10000000 rp

102+ awaitExit s

103

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

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

95testAgentPrioritisation result = do

105testAgentPrioritisation result = do

@@ -101,8 +111,8 @@ testAgentPrioritisation result = do

101

111

102 let name = "prioritising-agent"

112 let name = "prioritising-agent"

103 (sp, rp) <- newChan

113 (sp, rp) <- newChan

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

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

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

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

106 mxUpdateLocal ((s:))

116 mxUpdateLocal ((s:))

107 st <- mxGetLocal

117 st <- mxGetLocal

108 case length st of

118 case length st of

@@ -118,22 +128,25 @@ testAgentPrioritisation result = do

118 nsend name "fifth"

128 nsend name "fifth"

119

129

120 stash result . sort =<< receiveChan rp

130 stash result . sort =<< receiveChan rp

131+ awaitExit s

121

132

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

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

123testAgentMailboxHandling result = do

134testAgentMailboxHandling result = do

124 (sp, rp) <- newChan

135 (sp, rp) <- newChan

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

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

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

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

127 ]

138 ]

128

139

129− nsend "listener-agent" ()

140+ nsend "mailbox-agent" ()

130

141

131 stash result =<< receiveChanTimeout 1000000 rp

142 stash result =<< receiveChanTimeout 1000000 rp

132− kill agent "finished"

143+ kill agent "finished" >> awaitExit agent

133

144

134testAgentEventHandling :: TestResult Bool -> Process ()

145testAgentEventHandling :: TestResult Bool -> Process ()

135testAgentEventHandling result = do

146testAgentEventHandling result = do

136 let initState = [] :: [MxEvent]

147 let initState = [] :: [MxEvent]

148+

149+ (rc, rs) <- newChan

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

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

138 (mxSink $ \ev -> do

151 (mxSink $ \ev -> do

139 st <- mxGetLocal

152 st <- mxGetLocal

@@ -142,7 +155,7 @@ testAgentEventHandling result = do

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

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

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

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

144 _ -> return ()

157 _ -> return ()

145− act >> mxReady),

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

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

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

147 st <- mxGetLocal

160 st <- mxGetLocal

148 let found =

161 let found =

@@ -162,16 +175,26 @@ testAgentEventHandling result = do

162 mxReady)

175 mxReady)

163 ]

176 ]

164

177

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

179+ faff 2000000 rs

180+

165 _ <- monitor agentPid

181 _ <- monitor agentPid

166 (sp, rp) <- newChan

182 (sp, rp) <- newChan

183+

167− pid <- spawnLocal $ sendChan sp ()

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

168− () <- receiveChan rp

169

185

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

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

171− -- higher probably that the agent has seen

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

172 monitor pid

188 monitor pid

189+

190+ send pid ()

191+ () <- receiveChan rp

192+

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

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

174

194

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

196+ faff 2000000 rs

197+

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

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

176 mxNotify (MxSpawned pid, replyTo)

199 mxNotify (MxSpawned pid, replyTo)

177 mxNotify (MxProcessDied pid DiedNormal, replyTo)

200 mxNotify (MxProcessDied pid DiedNormal, replyTo)

@@ -180,6 +203,121 @@ testAgentEventHandling result = do

180 seenDead <- receiveChan reply

203 seenDead <- receiveChan reply

181

204

182 stash result $ seenAlive && seenDead

205 stash result $ seenAlive && seenDead

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

207+ where

208+ faff delay port = do

209+ res <- receiveChanTimeout delay port

210+ unless (isNothing res) $ do

211+ pause delay

212+ faff delay port

213+

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

215+testMxRegEvents result = do

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

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

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

219+ ensure (stash result ()) $ do

220+ let label = "testMxRegEvents"

221+ let agentLabel = "mxRegEvents-agent"

222+ let delay = 1000000

223+ (regChan, regSink) <- newChan

224+ (unRegChan, unRegSink) <- newChan

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

226+ mxSink $ \ev -> do

227+ case ev of

228+ MxRegistered pid label'

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

230+ MxUnRegistered pid label'

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

232+ _ -> return ()

233+ mxReady

234+ ]

235+

236+ p1 <- spawnLocal expect

237+ p2 <- spawnLocal expect

238+

239+ register label p1

240+ reg1 <- receiveChanTimeout delay regSink

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

242+

243+ unregister label

244+ unreg1 <- receiveChanTimeout delay unRegSink

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

246+

247+ register label p2

248+ reg2 <- receiveChanTimeout delay regSink

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

250+

251+ reregister label p1

252+ unreg2 <- receiveChanTimeout delay unRegSink

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

254+

255+ reg3 <- receiveChanTimeout delay regSink

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

257+

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

259+ awaitExit agent

260+

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

262+testMxRegMon remoteNode result = do

263+ ensure (stash result ()) $ do

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

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

266+ let label1 = "aaaaa"

267+ let label2 = "bbbbb"

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

269+ let agentLabel = "mxRegMon-agent"

270+ let delay = 1000000

271+ (regChan, regSink) <- newChan

272+ (unRegChan, unRegSink) <- newChan

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

274+ mxSink $ \ev -> do

275+ case ev of

276+ MxRegistered pid label

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

278+ MxUnRegistered pid label

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

280+ _ -> return ()

281+ mxReady

282+ ]

283+

284+ (sp, rp) <- newChan

285+ liftIO $ forkProcess remoteNode $ do

286+ getSelfPid >>= sendChan sp

287+ expect :: Process ()

288+

289+ p1 <- receiveChan rp

290+

291+ register label1 p1

292+ reg1 <- receiveChanTimeout delay regSink

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

294+

295+ register label2 p1

296+ reg2 <- receiveChanTimeout delay regSink

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

298+

299+ n1 <- whereis label1

300+ n1 `shouldBe` equalTo (Just p1)

301+

302+ n2 <- whereis label2

303+ n2 `shouldBe` equalTo (Just p1)

304+

305+ kill p1 "goodbye"

306+

307+ unreg1 <- receiveChanTimeout delay unRegSink

308+ unreg2 <- receiveChanTimeout delay unRegSink

309+

310+ let evts = [unreg1, unreg2]

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

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

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

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

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

316+

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

318+

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

320+ensure = flip finally

183

321

184

322

185testMxUnsafeSendEvents :: LocalNode -> Process ()

323testMxUnsafeSendEvents :: LocalNode -> Process ()

@@ -265,8 +403,17 @@ tests TestTransport{..} = do

265 node1 (sort ["first", "second",

403 node1 (sort ["first", "second",

266 "third", "fourth",

404 "third", "fourth",

267 "fifth"]) testAgentPrioritisation)

405 "fifth"]) testAgentPrioritisation)

268− testGroup "Mx Events" [

269− testCase "Monitor Events"

270− (runProcess node1 (testMxUnsafeSendEvents node2))

271 ]

406 ]

407+ , testGroup "Mx Events" [

408+ testCase "Name Registration Events"

409+ (delayedAssertion

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

411+ node1 () testMxRegEvents)

412+ , testCase "Post Death Name UnRegistration Events"

413+ (delayedAssertion

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

415+ node1 () (testMxRegMon node2))

416+ , testCase "Monitor Events"

417+ (runProcess node1 (testMxUnsafeSendEvents node2))

272− ]]

418+ ]

419+ ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs+7−8

@@ -10,13 +10,12 @@ import Network.Transport.Test (TestTransport(..))

11import Network.Transport (Transport)

12import Control.Distributed.Process

13−import Control.Distributed.Process.Closure

14import Control.Distributed.Process.Node

13import Control.Distributed.Process.Node

16import Control.Monad

15import Control.Monad

18import Test.HUnit (Assertion, (@?=))

17import Test.HUnit (Assertion, (@?=))

19−import Test.Framework (Test, defaultMain)

18+import Test.Framework (Test)

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

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

22-- Tests:

21-- Tests:

@@ -43,7 +42,7 @@ recTest2 :: ReceivePort ()

43 -> SendPort String

42 -> SendPort String

44 -> ReceivePort String -> ReceivePort String

43 -> ReceivePort String -> ReceivePort String

45 -> Process ()

44 -> Process ()

46−recTest2 wait sync r1 r2 = do

45+recTest2 wait sync r1 _ = do

47 forever $ do

46 forever $ do

48 receiveChan wait

47 receiveChan wait

49 r <- receiveWait

48 r <- receiveWait

@@ -56,7 +55,7 @@ recTest3 :: ReceivePort ()

56 -> SendPort String

55 -> SendPort String

57 -> ReceivePort String -> ReceivePort String

56 -> ReceivePort String -> ReceivePort String

58 -> Process ()

57 -> Process ()

59−recTest3 wait sync r1 r2 = do

58+recTest3 wait sync r1 _ = do

60 forever $ do

59 forever $ do

61 receiveChan wait

60 receiveChan wait

62 r <- receiveWait

61 r <- receiveWait

@@ -69,7 +68,7 @@ recTest4 :: ReceivePort ()

69 -> SendPort String

68 -> SendPort String

70 -> ReceivePort String -> ReceivePort String

69 -> ReceivePort String -> ReceivePort String

71 -> Process ()

70 -> Process ()

72−recTest4 wait sync r1 r2 = do

71+recTest4 wait sync r1 _ = do

73 forever $ do

72 forever $ do

74 receiveChan wait

73 receiveChan wait

75 r <- receiveWait

74 r <- receiveWait

@@ -83,11 +82,11 @@ master :: Process ()

83master = do

82master = do

84 (waits,waitr) <- newChan

83 (waits,waitr) <- newChan

85 (syncs,syncr) <- newChan

84 (syncs,syncr) <- newChan

86− let go expect = do

85+ let go expected = do

87 sendChan waits ()

86 sendChan waits ()

88 r <- receiveChan syncr

87 r <- receiveChan syncr

89− liftIO $ print (r,expect, r == expect)

88+ liftIO $ print (r, expected, r == expected)

90− liftIO $ r @?= expect

89+ liftIO $ r @?= expected

92 liftIO $ putStrLn "---- Test 1 ----"

91 liftIO $ putStrLn "---- Test 1 ----"

93 (s1,r1) <- newChan

92 (s1,r1) <- newChan

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/runInMemory.hs−1

@@ -8,7 +8,6 @@ import Network.Transport.Test (TestTransport(..))

8import Network.Transport.InMemory

9import Test.Framework (defaultMainWithArgs)

11−import Control.Concurrent (threadDelay)

12import System.Environment (getArgs)

11import System.Environment (getArgs)

14main :: IO ()

13main :: IO ()

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+1−1

@@ -21,7 +21,7 @@ Description: This is an implementation of Cloud Haskell, as described in

22 You will probably also want to install a Cloud Haskell backend such

23 as distributed-process-simplelocalnet.

24−Tested-With: GHC==7.6.3 GHC==7.8.4 GHC==7.10.3 GHC==8.0.1

24+Tested-With: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 GHC==8.4.4

25Category: Control

26extra-source-files: ChangeLog

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

@@ -114,6 +115,7 @@ newtype MxAgent s a =

114 } deriving ( Functor

115 } deriving ( Functor

115 , Monad

116 , Monad

116 , MonadIO

117 , MonadIO

118+ , MonadFix

117 , ST.MonadState (MxAgentState s)

119 , ST.MonadState (MxAgentState s)

118 , Typeable

120 , Typeable

119 , Applicative

121 , 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+5−1

@@ -3,14 +3,18 @@ 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

17+- exceptions-0.8.2.1 # test dependency

15flags:

19flags:

16 distributed-process-tests:

20 distributed-process-tests:

stack-ghc-8.0.2.yaml+8−2

@@ -1,16 +1,22 @@

1−resolver: lts-9.0

1+resolver: 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

19+# - exceptions-0.8.2.1 # test dependency

15flags:

21flags:

16 distributed-process-tests:

22 distributed-process-tests:

stack-ghc-8.2.2.yamlnew file+21

@@ -0,0 +1,21 @@

1+resolver: lts-11.22

3+packages:

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

10+

11+extra-deps:

12+- rank1dynamic-0.4.0

13+- distributed-static-0.3.8

14+- network-transport-0.5.2

15+- network-transport-inmemory-0.5.2

16+- rematch-0.2.0.0

17+# - exceptions-0.8.2.1 # test dependency

18+

19+flags:

20+ distributed-process-tests:

21+ tcp: true

stack-ghc-8.4.4.yamlnew file+20

@@ -0,0 +1,20 @@

1+resolver: lts-12.18

3+packages:

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

10+

11+extra-deps:

12+- rank1dynamic-0.4.0

13+- distributed-static-0.3.8

14+- network-transport-0.5.2

15+- network-transport-inmemory-0.5.2

16+- rematch-0.2.0.0

17+

18+flags:

19+ distributed-process-tests:

20+ tcp: true

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

@@ -1,14 +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

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