master..ecdd703 · distributed-process

git.iko.soy/distributed-process

on ecdd703 help sign in

.travis.yml+56−24

since splitsnapshots

unifiedsplit

@@ -4,40 +4,72 @@ sudo: false

5matrix:

6 include:

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

7+ - env: CABAL_INSTALL_VER=1.22 GHCVER=7.6.3 BUILD=cabal

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

8+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3], sources: [hvr-ghc]}}

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

10+ - env: ARGS="--stack-yaml stack-ghc-7.8.4.yaml" BUILD=stack

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

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

12+

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

13+ - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml" BUILD=stack

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

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

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

15+

16+ - env: ARGS= BUILD=stack GHCVER=8.0.1

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

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

16cache:

19cache:

17 directories:

20 directories:

18 - $HOME/.stack

21 - $HOME/.stack

22+ - $HOME/.cabal/packages

20before_install:

24before_install:

25+# cabal case:

26+# workaround for https://ghc.haskell.org/trac/ghc/ticket/9221

27+# taken from https://github.com/hvr/multi-ghc-travis/blob/0fa68f78c2b1b059f904c9abc85510a3bb4f57e2/README.md

28+- case "$BUILD" in

29+ stack)

21−- export PATH=$HOME/.local/bin:$PATH;

30+ export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH;

22− mkdir -p ~/.local/bin;

31+ mkdir -p ~/.local/bin;

23− travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';

32+ travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';

24− stack --version

33+ stack --version

34+ ;;

35+ cabal)

36+ export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABAL_INSTALL_VER/bin:$HOME/.cabal/bin:$PATH;

37+ ghc --version;

38+ cabal --version;

39+ travis_retry cabal update;

40+ sed -i 's/^jobs:/-- jobs:/' $HOME/.cabal/config

41+ ;;

42+ esac

26install:

44install:

45+- case "$BUILD" in

46+ stack)

27−- stack $ARGS setup --no-terminal;

47+ stack $ARGS setup --no-terminal;

28− stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;

48+ stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;

49+ ;;

50+ cabal)

51+ cabal install --jobs=2 --enable-tests --only-dependencies -ftcp . distributed-process-tests/

52+ ;;

53+ esac

30script:

55script:

56+- case "$BUILD" in

57+ stack)

31−- export ARG='--test-arguments'

58+ export ARG='--test-arguments'

32− export TEST_PACKAGE="distributed-process-tests:"

59+ export TEST_PACKAGE="distributed-process-tests:"

60+ ;;

61+ cabal)

62+ cabal install --jobs=2 --enable-tests -ftcp .

63+ cd distributed-process-tests;

64+ cabal configure -ftcp --enable-tests;

65+ cabal build --jobs=2;

66+ export ARG='--test-options'

67+ export TEST_PACKAGE=""

68+ ;;

69+ esac

33−- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory

70+- $BUILD ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory

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

71+- $BUILD ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP

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

72+- $BUILD ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure

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

73+- $BUILD ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats

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

74+- $BUILD ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMx

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

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

75+- $BUILD ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracing

40−

41−notifications:

42− slack:

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

ChangeLog−44

@@ -1,47 +1,3 @@

1−[Unrealeased]

2−

3−*

4−

5−2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4

6−

7−* Added support for exceptions >= 0.10

8−

9−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3

10−

11−* Drop support for ghc-7.8.* and earlier.

12−

13−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2

14−

15−* Fixed build errors with ghc-8.2.1.

16−

17−2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1

18−

19−* Relax upper bounds in dependencies to build with ghc-8.2.1.

20−

21−2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0

22−

23−* Change type of message sent by `say` from a 3-tuple to a proper

24−type (`SayMessage`) with a proper `UTCTime`. (#291)

25−* Expose the MonitorRef in the withMonitor call.

26−* Have unmonitor remove the monitor message in the inbox. (#268)

27−* Remove Mx Data Tables. This API isn't used, is easy to replace with various

28−other packages. (#276)

29−* Add Ord instance to SpawnRef.

30−

31−2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6

32−

33−* Remove monitors from remote nodes when a process dies. (#295)

34−

35−2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5

36−

37−* Use only one connection to communicate between NCs. (#296, #297)

38−* Improve documentation of CQueue.

39−* Implement bidirectional multimaps for links and monitors. (#293, #294)

40−* Fix various warnings. (#292)

41−* Fix some of the intermittent failures in tests.

42−* Improve error messages when node controllers receive invalid requests.

43−(#290)

44−

452016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4

12016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4

47* Fixup build errors.

3* Fixup build errors.

benchmarks/Channels.hs+4−6

@@ -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, defaultTCPAddr, defaultTCPParameters)

7+import Network.Transport.TCP (createTransport, defaultTCPParameters)

8import Data.Binary (encode, decode)

9import qualified Data.ByteString.Lazy as BSL

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

36main :: IO ()

37main = do

38 [role, host, port] <- getArgs

39− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

39+ Right transport <- createTransport host port defaultTCPParameters

40− case trans of

41− Right transport -> do node <- newLocalNode transport initRemoteTable

40+ node <- newLocalNode transport initRemoteTable

42− runProcess node $ initialProcess role

41+ runProcess node $ initialProcess role

43− Left other -> error $ show other

benchmarks/Latency.hs+4−7

@@ -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, defaultTCPAddr, defaultTCPParameters)

6+import Network.Transport.TCP (createTransport, defaultTCPParameters)

7import Data.Binary (encode, decode)

8import qualified Data.ByteString.Lazy as BSL

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

31main :: IO ()

32main = do

33 [role, host, port] <- getArgs

34− trans <- createTransport

35− (defaultTCPAddr host port) defaultTCPParameters

34+ Right transport <- createTransport host port defaultTCPParameters

36− case trans of

37− Right transport -> do node <- newLocalNode transport initRemoteTable

35+ node <- newLocalNode transport initRemoteTable

38− runProcess node $ initialProcess role

36+ runProcess node $ initialProcess role

39− Left other -> error $ show other

benchmarks/ProcessRing.hs+2−3

@@ -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, defaultTCPAddr, defaultTCPParameters)

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

16import System.Environment

17import System.Console.GetOpt

@@ -110,8 +110,7 @@ main = do

110 argv <- getArgs

111 (opt, _) <- parseArgv argv

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

113− Right transport <- createTransport

113+ Right transport <- createTransport "127.0.0.1" "8090" defaultTCPParameters

114− (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters

115 node <- newLocalNode transport initRemoteTable

114 node <- newLocalNode transport initRemoteTable

116 catch (void $ runProcess node $ initialProcess opt)

115 catch (void $ runProcess node $ initialProcess opt)

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

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

benchmarks/Spawns.hs+4−6

@@ -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, defaultTCPAddr, defaultTCPParameters)

10+import Network.Transport.TCP (createTransport, defaultTCPParameters)

11import Data.Binary (encode, decode)

12import qualified Data.ByteString.Lazy as BSL

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

42main :: IO ()

43main = do

44 [role, host, port] <- getArgs

45− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

45+ Right transport <- createTransport host port defaultTCPParameters

46− case trans of

47− Right transport -> do node <- newLocalNode transport initRemoteTable

46+ node <- newLocalNode transport initRemoteTable

48− runProcess node $ initialProcess role

47+ runProcess node $ initialProcess role

49− Left other -> error $ show other

benchmarks/Throughput.hs+4−6

@@ -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, defaultTCPAddr)

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

10import Data.Binary

11import qualified Data.ByteString.Lazy as BSL

12import Data.Typeable

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

67main :: IO ()

68main = do

69 [role, host, port] <- getArgs

70− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

70+ Right transport <- createTransport host port defaultTCPParameters

71− case trans of

72− Right transport -> do node <- newLocalNode transport initRemoteTable

71+ node <- newLocalNode transport initRemoteTable

73− runProcess node $ initialProcess role

72+ runProcess node $ initialProcess role

74− Left other -> error $ show other

distributed-process-tests/distributed-process-tests.cabal+26−39

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

1name: distributed-process-tests

2−version: 0.4.11

2+version: 0.4.6

3synopsis: Tests and test support tools for distributed-process.

4homepage: http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests

5description: Tests and test suite for Cloud Haskell libraries.

6license: BSD3

7license-file: LICENSE

8Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9−Maintainer: Tim Watson <watson.timothy@gmail.com>

9+Maintainer: Facundo Domínguez <facundo.dominguez@tweag.io>

10copyright: Well-Typed LLP

11category: Control, Cloud Haskell

12build-type: Simple

@@ -26,15 +26,14 @@ library

26 Control.Distributed.Process.Tests.Tracing

27 Control.Distributed.Process.Tests.Internal.Utils

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

29− ansi-terminal >= 0.5,

29+ ansi-terminal >= 0.5 && < 0.7,

30 binary >= 0.5 && < 0.9,

31 bytestring >= 0.9 && < 0.12,

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

32+ distributed-process >= 0.6.0 && < 0.7,

33 distributed-static,

34− exceptions >= 0.5,

35− HUnit >= 1.2 && < 1.7,

34+ HUnit >= 1.2 && < 1.4,

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

35+ network-transport >= 0.4.1.0 && < 0.5,

37− network >= 2.5 && < 2.9,

36+ network >= 2.5 && < 2.7,

38 random >= 1.0 && < 1.2,

37 random >= 1.0 && < 1.2,

39 rematch >= 0.1.2.1,

38 rematch >= 0.1.2.1,

40 setenv >= 0.1.1.3,

39 setenv >= 0.1.1.3,

@@ -49,6 +48,7 @@ library

49 DeriveDataTypeable,

48 DeriveDataTypeable,

50 DeriveGeneric,

49 DeriveGeneric,

51 GeneralizedNewtypeDeriving,

50 GeneralizedNewtypeDeriving,

51+ OverlappingInstances,

52 RankNTypes,

53 RecordWildCards,

54 ScopedTypeVariables

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

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

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

63 distributed-process-tests,

64− network >= 2.3 && < 2.9,

64+ network >= 2.3 && < 2.7,

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

65+ network-transport >= 0.4.1.0 && < 0.5,

66 network-transport-inmemory >= 0.5,

67 test-framework >= 0.6 && < 0.9

68 Extensions: CPP

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

76 if flag(tcp)

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

78 distributed-process-tests,

79− network >= 2.3 && < 2.9,

79+ network >= 2.3 && < 2.7,

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

80+ network-transport >= 0.4.1.0 && < 0.5,

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

81+ network-transport-tcp >= 0.5 && < 0.6,

82 test-framework >= 0.6 && < 0.9

83 else

84 Buildable: False

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

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

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

95 distributed-process-tests,

96− network >= 2.3 && < 2.9,

96+ network >= 2.3 && < 2.7,

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

97+ network-transport >= 0.4.1.0 && < 0.5,

98 network-transport-inmemory >= 0.5,

99 test-framework >= 0.6 && < 0.9

100 Extensions: CPP

@@ -107,52 +107,39 @@ Test-Suite TestStats

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

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

109 distributed-process-tests,

110− network >= 2.3 && < 2.9,

110+ network >= 2.3 && < 2.7,

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

111+ network-transport >= 0.4.1.0 && < 0.5,

112 network-transport-inmemory >= 0.5,

113 test-framework >= 0.6 && < 0.9

114 Extensions: CPP

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

116 HS-Source-Dirs: tests

117

118+

118−Test-Suite TestMxInMemory

119+Test-Suite TestMx

119 Type: exitcode-stdio-1.0

120 Type: exitcode-stdio-1.0

120 Main-Is: runInMemory.hs

121 Main-Is: runInMemory.hs

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

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

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

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

123 distributed-process-tests,

124 distributed-process-tests,

124− network >= 2.3 && < 2.9,

125+ network >= 2.3 && < 2.7,

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

126+ network-transport >= 0.4.1.0 && < 0.5,

126 network-transport-inmemory >= 0.5,

127 network-transport-inmemory >= 0.5,

127 test-framework >= 0.6 && < 0.9

128 test-framework >= 0.6 && < 0.9

128 Extensions: CPP

129 Extensions: CPP

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

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

130 HS-Source-Dirs: tests

131 HS-Source-Dirs: tests

131

132

132−Test-Suite TestTracingInMemory

133+Test-Suite TestTracing

133 Type: exitcode-stdio-1.0

134 Type: exitcode-stdio-1.0

134 Main-Is: runInMemory.hs

135 Main-Is: runInMemory.hs

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

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

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

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

137 distributed-process-tests,

138 distributed-process-tests,

138− network >= 2.3 && < 2.9,

139+ network >= 2.3 && < 2.7,

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

140+ network-transport >= 0.4.1.0 && < 0.5,

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,

141 network-transport-inmemory >= 0.5,

155 test-framework >= 0.6 && < 0.9

142 test-framework >= 0.6 && < 0.9

156 Extensions: CPP

143 Extensions: CPP

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

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

158 HS-Source-Dirs: tests

145 HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+240−487

@@ -25,32 +25,24 @@ import Control.Concurrent.MVar

25 )

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

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

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

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

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

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

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

31−import Control.Distributed.Process hiding

31+import Control.Distributed.Process

32− ( try

33− , catch

34− , finally

35− , mask

36− , onException

37− )

38import Control.Distributed.Process.Internal.Types

32import Control.Distributed.Process.Internal.Types

33+ ( NodeId(nodeAddress)

39− ( LocalNode(localEndPoint)

34+ , LocalNode(localEndPoint)

40 , ProcessExitException(..)

35 , ProcessExitException(..)

41 , nullProcessId

36 , nullProcessId

42 , createUnencodedMessage

37 , createUnencodedMessage

43 )

38 )

44import Control.Distributed.Process.Node

39import Control.Distributed.Process.Node

45−import Control.Distributed.Process.Debug

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

47−import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)

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

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

49−import Data.Maybe (isNothing, isJust)

41+

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

42+import Test.HUnit (Assertion, assertFailure)

51import Test.Framework (Test, testGroup)

43import Test.Framework (Test, testGroup)

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

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

53−import Control.Rematch hiding (match, isNothing, isJust)

45+import Control.Rematch hiding (match)

54import Control.Rematch.Run (Match(..))

46import Control.Rematch.Run (Match(..))

56newtype Ping = Ping ProcessId

48newtype Ping = Ping ProcessId

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

73forkTry :: IO () -> IO ThreadId

65forkTry :: IO () -> IO ThreadId

74forkTry p = do

66forkTry p = do

75 tid <- myThreadId

67 tid <- myThreadId

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

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

78-- | The ping server from the paper

70-- | The ping server from the paper

79ping :: Process ()

71ping :: Process ()

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

83 send partner (Ping self)

75 send partner (Ping self)

84 ping

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

94-- | Quick and dirty synchronous version of whereisRemoteAsync

78-- | Quick and dirty synchronous version of whereisRemoteAsync

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

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

96whereisRemote nid string = do

80whereisRemote nid string = do

97 whereisRemoteAsync nid string

81 whereisRemoteAsync nid string

98− receiveWait [

99− match (\(WhereIsReply _ mPid) -> return mPid)

82+ WhereIsReply _ mPid <- expect

100− ]

101−

102−verifyWhereIsRemote :: NodeId -> String -> Process ProcessId

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

104−

105−waitForExit :: ProcessId -> Process DiedReason

106−waitForExit pid = monitor pid >>= waitForDown

107−

108−waitForDown :: MonitorRef -> Process DiedReason

109−waitForDown ref =

110− receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

111− (\(ProcessMonitorNotification _ _ dr) -> return dr) ]

112−

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

114−syncBreakConnection breakConnection nid0 nid1 = do

115− m <- newEmptyMVar

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

117− runProcess nid0 $ do

118− them <- liftIO $ takeMVar m

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

120− _ <- monitorNode (localNodeId nid1)

121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

122− (nodeAddress $ localNodeId nid1)

123− NodeMonitorNotification _ _ _ <- expect

124− kill pinger "finished"

125− return ()

83+ return mPid

126

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

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

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

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

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

197 unmonitor ref

155 unmonitor ref

198 liftIO $ putMVar done ()

156 liftIO $ putMVar done ()

199 (False, ref) -> do

157 (False, ref) -> do

200− receiveWait [

201− match (\(ProcessMonitorNotification ref' pid reason') -> do

158+ ProcessMonitorNotification ref' pid reason' <- expect

202− liftIO $ do

203− assertBool "Bad Monitor Signal"

204− (Just ref' == ref && pid == theirAddr &&

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

205− mOrL && reason == reason')

206− putMVar done ())

160+ liftIO $ putMVar done ()

207− ]

208 )

161 )

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

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

210− (liftIO $ assertBool "link exception unmatched" $

211− pid == theirAddr && not mOrL && not un && reason == reason')

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

212 liftIO $ putMVar done ()

164 liftIO $ putMVar done ()

213 )

165 )

214

166

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

239 pid <- getSelfPid

191 pid <- getSelfPid

240 replicateM_ numPings $ do

192 replicateM_ numPings $ do

241 send pingServer (Pong pid)

193 send pingServer (Pong pid)

242− p <- expectTimeout 3000000

194+ Ping _ <- expect

243− case p of

244− Just (Ping _) -> return ()

195+ return ()

245− Nothing -> die "Failed to receive Ping"

246

196

247 putMVar clientDone ()

197 putMVar clientDone ()

248

198

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

329 runProcess localNode $ do

279 runProcess localNode $ do

330 monitor theirAddr

280 monitor theirAddr

331 -- wait for the process to die

281 -- wait for the process to die

332− expect :: Process ProcessMonitorNotification

282+ ProcessMonitorNotification _ _ _ <- expect

333 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334

284

335 takeMVar done

285 takeMVar done

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

403 runProcess localNode $ do

353 runProcess localNode $ do

404 pid <- getSelfPid

354 pid <- getSelfPid

405 send mathServer (Add pid 1 2)

355 send mathServer (Add pid 1 2)

406− three <- expect :: Process Double

356+ 3 <- expect :: Process Double

407 send mathServer (Divide pid 8 2)

357 send mathServer (Divide pid 8 2)

408− four <- expect :: Process Double

358+ 4 <- expect :: Process Double

409 send mathServer (Divide pid 8 0)

359 send mathServer (Divide pid 8 0)

410− divByZ <- expect

360+ DivByZero <- expect

411− liftIO $ putMVar clientDone (three, four, divByZ)

361+ liftIO $ putMVar clientDone ()

412

362

413− res <- takeMVar clientDone

363+ takeMVar clientDone

414− case res of

415− (3, 4, DivByZero) -> return ()

416− _ -> error $ "Something went horribly wrong"

417

364

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

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

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

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

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

441 pid <- getSelfPid

388 pid <- getSelfPid

442 send server1 "Hi"

389 send server1 "Hi"

443 send server2 (Pong pid)

390 send server2 (Pong pid)

391+ Ping pid' <- expect

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

444− expectPing clientDone

393+ liftIO $ putMVar clientDone ()

445

394

446− verifyClient "Expected Ping from server" clientDone

395+ takeMVar clientDone

447

396

448-- | Test (non-zero) timeout

397-- | Test (non-zero) timeout

449testTimeout :: TestTransport -> Assertion

398testTimeout :: TestTransport -> Assertion

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

452 done <- newEmptyMVar

401 done <- newEmptyMVar

453

402

454 runProcess localNode $ do

403 runProcess localNode $ do

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

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

456− liftIO $ putMVar done $ res == Nothing

405+ liftIO $ putMVar done ()

457

406

458− verifyClient "Expected receiveTimeout to timeout..." done

407+ takeMVar done

459

408

460-- | Test zero timeout

409-- | Test zero timeout

461testTimeout0 :: TestTransport -> Assertion

410testTimeout0 :: TestTransport -> Assertion

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

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

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

484 replicateM_ 10000 $ send server "Irrelevant message"

433 replicateM_ 10000 $ send server "Irrelevant message"

485 send server (Pong pid)

434 send server (Pong pid)

435+ Ping _ <- expect

486− expectPing clientDone

436+ liftIO $ putMVar clientDone ()

487

437

488− verifyClient "Expected Ping from server" clientDone

438+ takeMVar clientDone

489

439

490-- | Test typed channels

440-- | Test typed channels

491testTypedChannels :: TestTransport -> Assertion

441testTypedChannels :: TestTransport -> Assertion

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

508 runProcess localNode $ do

458 runProcess localNode $ do

509 (clientSendPort, rport) <- newChan

459 (clientSendPort, rport) <- newChan

510 sendChan serverSendPort (clientSendPort, 5)

460 sendChan serverSendPort (clientSendPort, 5)

511− ch <- receiveChan rport

461+ False <- receiveChan rport

512− liftIO $ putMVar clientDone $ ch == False

462+ liftIO $ putMVar clientDone ()

513

463

514− verifyClient "Expected channel to send 'False'" clientDone

464+ takeMVar clientDone

515

465

516-- | Test merging receive ports

466-- | Test merging receive ports

517testMergeChannels :: TestTransport -> Assertion

467testMergeChannels :: TestTransport -> Assertion

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

534 rs <- mapM charChannel "abc"

484 rs <- mapM charChannel "abc"

535 m <- mergePorts biased rs

485 m <- mergePorts biased rs

536 xs <- replicateM 9 $ receiveChan m

486 xs <- replicateM 9 $ receiveChan m

537− liftIO $ putMVar done $ xs == expected

487+ True <- return $ xs == expected

538− verifyClient "Expected single layer merge to match expected ordering" done

488+ liftIO $ putMVar done ()

489+ takeMVar done

539

490

540 -- Two layers of merging

491 -- Two layers of merging

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

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

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

546 ms <- mapM (mergePorts biasedInner) rss

497 ms <- mapM (mergePorts biasedInner) rss

547 m <- mergePorts biasedOuter ms

498 m <- mergePorts biasedOuter ms

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

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

549− liftIO $ putMVar done $ xs == expected

500+ True <- return $ xs == expected

550− verifyClient "Expected nested channels to match expeted ordering" done

501+ liftIO $ putMVar done ()

502+ takeMVar done

551

503

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

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

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

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

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

556 done <- newEmptyMVar

508 done <- newEmptyMVar

557

509

558 forkProcess localNode $ do

510 forkProcess localNode $ do

559− ss <- liftIO $ mapM readMVar vs

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

560− case ss of

561− [sa, sb, sc] ->

562− mapM_ ((>> pause 10000) . uncurry sendChan)

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

563− [ -- a, b, c

513+ [ -- a, b, c

564− (sa, 'a')

514+ (sa, 'a')

565− , (sb, 'b')

515+ , (sb, 'b')

566− , (sc, 'c')

516+ , (sc, 'c')

567− -- a, c, b

517+ -- a, c, b

568− , (sa, 'a')

518+ , (sa, 'a')

569− , (sc, 'c')

519+ , (sc, 'c')

570− , (sb, 'b')

520+ , (sb, 'b')

571− -- b, a, c

521+ -- b, a, c

572− , (sb, 'b')

522+ , (sb, 'b')

573− , (sa, 'a')

523+ , (sa, 'a')

574− , (sc, 'c')

524+ , (sc, 'c')

575− -- b, c, a

525+ -- b, c, a

576− , (sb, 'b')

526+ , (sb, 'b')

577− , (sc, 'c')

527+ , (sc, 'c')

578− , (sa, 'a')

528+ , (sa, 'a')

579− -- c, a, b

529+ -- c, a, b

580− , (sc, 'c')

530+ , (sc, 'c')

581− , (sa, 'a')

531+ , (sa, 'a')

582− , (sb, 'b')

532+ , (sb, 'b')

583− -- c, b, a

533+ -- c, b, a

584− , (sc, 'c')

534+ , (sc, 'c')

585− , (sb, 'b')

535+ , (sb, 'b')

586− , (sa, 'a')

536+ , (sa, 'a')

587− ]

537+ ]

588− _ -> die "Something went horribly wrong"

589

538

590 forkProcess localNode $ do

539 forkProcess localNode $ do

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

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

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

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

593 m <- mergePorts biased rs

542 m <- mergePorts biased rs

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

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

595− liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"

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

545+ liftIO $ putMVar done ()

596

546

597− verifyClient "Expected merged ports to match expected ordering" done

547+ takeMVar done

598

548

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

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

600 mergePorts True = mergePortsBiased

550 mergePorts True = mergePortsBiased

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

612 localNode <- newLocalNode testTransport initRemoteTable

562 localNode <- newLocalNode testTransport initRemoteTable

613 runProcess localNode $ do

563 runProcess localNode $ do

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

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

615− if either show show e == show ProcessTerminationException

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

616− then return ()

566+ return ()

617− else die "Unexpected result from terminate"

618

567

619testMonitorNode :: TestTransport -> Assertion

568testMonitorNode :: TestTransport -> Assertion

620testMonitorNode TestTransport{..} = do

569testMonitorNode TestTransport{..} = do

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

625

574

626 runProcess node2 $ do

575 runProcess node2 $ do

627 ref <- monitorNode (localNodeId node1)

576 ref <- monitorNode (localNodeId node1)

628− receiveWait [

629− match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->

577+ NodeMonitorNotification ref' nid DiedDisconnect <- expect

630− return $ ref == ref' && nid == localNodeId node1)

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

631− ] >>= liftIO . putMVar done

579+ liftIO $ putMVar done ()

632

580

633− verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done

581+ takeMVar done

634

582

635testMonitorLiveNode :: TestTransport -> Assertion

583testMonitorLiveNode :: TestTransport -> Assertion

636testMonitorLiveNode TestTransport{..} = do

584testMonitorLiveNode TestTransport{..} = do

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

645 liftIO $ putMVar ready ()

593 liftIO $ putMVar ready ()

646 liftIO $ takeMVar readyr

594 liftIO $ takeMVar readyr

647 send p ()

595 send p ()

648− receiveWait [

649− match (\(NodeMonitorNotification ref' nid _) ->

596+ NodeMonitorNotification ref' nid _ <- expect

650− (return $ ref == ref' && nid == localNodeId node1))

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

651− ] >>= liftIO . putMVar done

598+ liftIO $ putMVar done ()

652

599

653 takeMVar ready

600 takeMVar ready

654 closeLocalNode node1

601 closeLocalNode node1

655 putMVar readyr ()

602 putMVar readyr ()

656

603

657− verifyClient "Expected NodeMonitorNotification for LIVE node" done

604+ takeMVar done

658

605

659testMonitorChannel :: TestTransport -> Assertion

606testMonitorChannel :: TestTransport -> Assertion

660testMonitorChannel TestTransport{..} = do

607testMonitorChannel TestTransport{..} = do

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

664 pid <- forkProcess node1 $ do

611 pid <- forkProcess node1 $ do

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

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

666 ref <- monitorPort sport

613 ref <- monitorPort sport

667− receiveWait [

614+ PortMonitorNotification ref' port' reason <- expect

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

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

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

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

670− match (\(PortMonitorNotification ref' port' reason) ->

671− return $ ref' == ref && port' == sendPortId sport &&

672− (reason == DiedNormal || reason == DiedUnknownId))

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

673− ] >>= liftIO . putMVar gotNotification

618+ liftIO $ putMVar gotNotification ()

674

619

675 runProcess node2 $ do

620 runProcess node2 $ do

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

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

677 send pid sport

622 send pid sport

678 liftIO $ threadDelay 100000

623 liftIO $ threadDelay 100000

679

624

680− verifyClient "Expected PortMonitorNotification" gotNotification

625+ takeMVar gotNotification

681

626

682testRegistry :: TestTransport -> Assertion

627testRegistry :: TestTransport -> Assertion

683testRegistry TestTransport{..} = do

628testRegistry TestTransport{..} = do

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

689

634

690 runProcess node $ do

635 runProcess node $ do

691 register "ping" pingServer

636 register "ping" pingServer

692− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

637+ Just pid <- whereis "ping"

638+ True <- return $ pingServer == pid

693 us <- getSelfPid

639 us <- getSelfPid

694 nsend "ping" (Pong us)

640 nsend "ping" (Pong us)

695− receiveWait [

641+ Ping pid' <- expect

696− matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())

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

697− ]

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

698− checkRegException "dead" Nothing deadProcess

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

699− checkRegException "ping" (Just pingServer) deadProcess

645+ True <- return $ x == pingServer

700− try (unregister "dead") >>= checkReg "dead" Nothing

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

701 liftIO $ putMVar done ()

647 liftIO $ putMVar done ()

702

648

703 takeMVar done

649 takeMVar done

704

650

705− where

706− checkRegException name pid dead =

707− try (register name dead) >>= checkReg name pid

708−

709− checkReg name pid res =

710− case res of

711− Left (ProcessRegistrationException name pid) -> return ()

712− _ -> die $ "Unexpected Registration" ++ show res

713−

714testRegistryRemoteProcess :: TestTransport -> Assertion

651testRegistryRemoteProcess :: TestTransport -> Assertion

715testRegistryRemoteProcess TestTransport{..} = do

652testRegistryRemoteProcess TestTransport{..} = do

716 node1 <- newLocalNode testTransport initRemoteTable

653 node1 <- newLocalNode testTransport initRemoteTable

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

721

658

722 runProcess node2 $ do

659 runProcess node2 $ do

723 register "ping" pingServer

660 register "ping" pingServer

724− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

661+ Just pid <- whereis "ping"

662+ True <- return $ pingServer == pid

725 us <- getSelfPid

663 us <- getSelfPid

726 nsend "ping" (Pong us)

664 nsend "ping" (Pong us)

727− receiveWait [

665+ Ping pid' <- expect

728− matchIf (\(Ping pid') -> pingServer == pid')

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

729− (const $ liftIO $ putMVar done ())

667+ liftIO $ putMVar done ()

730− ]

731

668

732 takeMVar done

669 takeMVar done

733

670

@@ -735,6 +672,7 @@ testRemoteRegistry :: TestTransport -> Assertion

735testRemoteRegistry TestTransport{..} = do

672testRemoteRegistry TestTransport{..} = do

736 node1 <- newLocalNode testTransport initRemoteTable

673 node1 <- newLocalNode testTransport initRemoteTable

737 node2 <- newLocalNode testTransport initRemoteTable

674 node2 <- newLocalNode testTransport initRemoteTable

675+ done <- newEmptyMVar

738

676

739 pingServer <- forkProcess node1 ping

677 pingServer <- forkProcess node1 ping

740 deadProcess <- forkProcess node1 (return ())

678 deadProcess <- forkProcess node1 (return ())

@@ -747,34 +685,32 @@ testRemoteRegistry TestTransport{..} = do

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

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

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

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

749

687

750− pid <- verifyWhereIsRemote nid1 "ping"

688+ Just pid <- whereisRemote nid1 "ping"

751− liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid

689+ True <- return $ pingServer == pid

752−

753 us <- getSelfPid

690 us <- getSelfPid

754 nsendRemote nid1 "ping" (Pong us)

691 nsendRemote nid1 "ping" (Pong us)

755− receiveWait [

692+ Ping pid' <- expect

756− match (\(Ping pid') -> return $ pingServer == pid')

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

757− ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"

758

694

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

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

760 -- in owner field.

696 -- in owner field.

761 registerRemoteAsync nid1 "dead" deadProcess

697 registerRemoteAsync nid1 "dead" deadProcess

698+ receiveWait [

762− receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')

699+ matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')

763− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))

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

764− ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"

765−

766 registerRemoteAsync nid1 "ping" deadProcess

701 registerRemoteAsync nid1 "ping" deadProcess

767 receiveWait [

702 receiveWait [

768− matchIf (\(RegisterReply label' False mPid) ->

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

769− "ping" == label' && isJust mPid)

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

770− (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))

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

771− ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"

772−

773 unregisterRemoteAsync nid1 "dead"

706 unregisterRemoteAsync nid1 "dead"

774 receiveWait [

707 receiveWait [

775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')

708+ matchIf (\(RegisterReply label' False Nothing) ->

709+ "dead" == label' && pid == pingServer)

776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))

710+ (\(RegisterReply _ _ _) -> return ()) ]

777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"

711+ liftIO $ putMVar done ()

712+

713+ takeMVar done

778

714

779testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

715testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

780testRemoteRegistryRemoteProcess TestTransport{..} = do

716testRemoteRegistryRemoteProcess TestTransport{..} = do

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

790 receiveWait [

726 receiveWait [

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

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

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

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

793− pid <- verifyWhereIsRemote nid1 "ping"

729+ Just pid <- whereisRemote nid1 "ping"

794− liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid

730+ True <- return $ pingServer == pid

795 us <- getSelfPid

731 us <- getSelfPid

796 nsendRemote nid1 "ping" (Pong us)

732 nsendRemote nid1 "ping" (Pong us)

797− receiveWait [

733+ Ping pid' <- expect

798− match (\(Ping pid') -> return $ pingServer == pid')

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

799− ] >>= liftIO . putMVar done

735+ liftIO $ putMVar done ()

800

736

801− verifyClient "Expected Ping with ping server's ProcessId" done

737+ takeMVar done

802

738

803testSpawnLocal :: TestTransport -> Assertion

739testSpawnLocal :: TestTransport -> Assertion

804testSpawnLocal TestTransport{..} = do

740testSpawnLocal TestTransport{..} = do

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

812 sport <- expect

748 sport <- expect

813 sendChan sport (1234 :: Int)

749 sendChan sport (1234 :: Int)

814

750

815− sport <- spawnChannelLocal $

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

816− \rport -> (receiveChan rport :: Process Int) >>= send us

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

753+ send us ()

817

754

818 send pid sport

755 send pid sport

756+ () <- expect

819− expect >>= liftIO . putMVar done

757+ liftIO $ putMVar done ()

820

758

821− res <- takeMVar done

759+ takeMVar done

822− assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)

823

760

824testSpawnAsyncStrictness :: TestTransport -> Assertion

761testSpawnAsyncStrictness :: TestTransport -> Assertion

825testSpawnAsyncStrictness TestTransport{..} = do

762testSpawnAsyncStrictness TestTransport{..} = do

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

848 liftIO $ putMVar processA us

785 liftIO $ putMVar processA us

849 msg1 <- expect

786 msg1 <- expect

850 msg2 <- expect

787 msg2 <- expect

851− liftIO $ do

852− assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"

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

853− putMVar sendTestOk ()

789+ liftIO $ putMVar sendTestOk ()

854

790

855 forkProcess node2 $ do

791 forkProcess node2 $ do

856 {-

792 {-

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

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

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

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

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

885

821

886− _ <- whereisRemote nid1 "a"

822+ Just _ <- whereisRemote nid1 "a"

887

823

888

824

889 -- Simulate network failure

825 -- Simulate network failure

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

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

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

903

839

904 -- Check

840 -- Check

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

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

906− liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing

907− verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect

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

908− verifyWhereIsRemote nid1 "c"

843+ Just _ <- whereisRemote nid1 "c"

909

844

910 liftIO $ putMVar registerTestOk ()

845 liftIO $ putMVar registerTestOk ()

911

846

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

946 isSorted _ = True

881 isSorted _ = True

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

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

948 -- the last message.

883 -- the last message.

949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)

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

885+ liftIO $ putMVar usendTestOk ()

950

886

951 forkProcess node2 $ do

887 forkProcess node2 $ do

952 them <- liftIO $ readMVar processA

888 them <- liftIO $ readMVar processA

953 getSelfPid >>= send them

889 getSelfPid >>= send them

954− expect :: Process ()

890+ () <- expect

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

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

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

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

957 usendPrim them i

893 usendPrim them i

958 liftIO (threadDelay 30000)

894 liftIO (threadDelay 30000)

959

895

960− res <- takeMVar usendTestOk

896+ takeMVar usendTestOk

961− assertBool "Unexpected failure after sending last msg" res

962

897

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

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

964-- in between

899-- in between

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

984 runProcess localNode $ do

919 runProcess localNode $ do

985 pid <- getSelfPid

920 pid <- getSelfPid

986 send mathServer (Add pid 1 2)

921 send mathServer (Add pid 1 2)

987− three <- expect :: Process Double

922+ 3 <- expect :: Process Double

988 send mathServer (Divide pid 8 2)

923 send mathServer (Divide pid 8 2)

989− four <- expect :: Process Double

924+ 4 <- expect :: Process Double

990 send mathServer (Divide pid 8 0)

925 send mathServer (Divide pid 8 0)

991− divByZ <- expect

926+ DivByZero <- expect

992− liftIO $ putMVar clientDone (three, four, divByZ)

927+ liftIO $ putMVar clientDone ()

993

928

994− res <- takeMVar clientDone

929+ takeMVar clientDone

995− case res of

996− (3, 4, DivByZero) -> return ()

997− _ -> error "Unexpected result"

998

930

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

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

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

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

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

1021 runProcess localNode $ do

953 runProcess localNode $ do

1022 pid <- getSelfPid

954 pid <- getSelfPid

1023 send mathServer (Add pid 1 2)

955 send mathServer (Add pid 1 2)

1024− three <- expect :: Process Double

956+ 3 <- expect :: Process Double

1025 send mathServer (Divide pid 8 2)

957 send mathServer (Divide pid 8 2)

1026− res <- (expectTimeout 100000) :: Process (Maybe Double)

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

1027− liftIO $ putMVar clientDone $ three == 3 && res == Nothing

959+ liftIO $ putMVar clientDone ()

1028−

1029− verifyClient "Expected Nothing (i.e. timeout)" clientDone

1030

960

961+ takeMVar clientDone

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

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

1032 maybeForward s msg =

963 maybeForward s msg =

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

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

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

1055 Just _ -> die "NONSENSE")

986 Just _ -> die "NONSENSE")

1056 ]

987 ]

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

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

1058− res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]

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

1059− liftIO $ do

1060− assertBool "Expected timeout!" $ res == Nothing

1061− putMVar serverDone ()

990+ liftIO $ putMVar serverDone ()

1062 putMVar addr server

991 putMVar addr server

1063

992

1064 -- Client

993 -- Client

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

1101 runProcess localNode $ do

1030 runProcess localNode $ do

1102 pid <- getSelfPid

1031 pid <- getSelfPid

1103 send server (pid, "foo")

1032 send server (pid, "foo")

1104− foo <- expect

1033+ "foo" <- expect

1105− -- provoking what would be the wrong ordering is informative here...

1106−

1107− send server (pid, "bar")

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

1109−

1110 send server (pid, "baz")

1034 send server (pid, "baz")

1111− baz <- expect

1035+ "baz" <- expect

1112−

1036+ send server (pid, "bar")

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

1113− liftIO $ putMVar clientDone (foo, bar, baz)

1038+ liftIO $ putMVar clientDone ()

1114−

1115− res <- takeMVar clientDone

1116− let res' = res == ("foo", Nothing, "baz")

1117− assertBool "Expected timeout due to type mismatch" res'

1118

1039

1040+ takeMVar clientDone

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

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

1120 tryHandleMessage msg =

1042 tryHandleMessage msg =

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

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

@@ -1148,19 +1070,17 @@ testMatchMessageWithUnwrap TestTransport{..} = do

1148 runProcess localNode $ do

1070 runProcess localNode $ do

1149 pid <- getSelfPid

1071 pid <- getSelfPid

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

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

1151− foo <- expect

1073+ "foo" <- expect

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

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

1153− baz <- expect

1075+ "baz" <- expect

1154− liftIO $ putMVar clientDone (foo, baz)

1076+ liftIO $ putMVar clientDone ()

1155

1077

1156− res <- takeMVar clientDone

1078+ takeMVar clientDone

1157− assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")

1158

1079

1159-- Test 'receiveChanTimeout'

1080-- Test 'receiveChanTimeout'

1160testReceiveChanTimeout :: TestTransport -> Assertion

1081testReceiveChanTimeout :: TestTransport -> Assertion

1161testReceiveChanTimeout TestTransport{..} = do

1082testReceiveChanTimeout TestTransport{..} = do

1162 done <- newEmptyMVar

1083 done <- newEmptyMVar

1163− mvSender <- newEmptyMVar

1164 sendPort <- newEmptyMVar

1084 sendPort <- newEmptyMVar

1165

1085

1166 forkTry $ do

1086 forkTry $ do

@@ -1170,32 +1090,18 @@ testReceiveChanTimeout TestTransport{..} = do

1170 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

1090 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

1171 liftIO $ putMVar sendPort sp

1091 liftIO $ putMVar sendPort sp

1172

1092

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

1093+ -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second

1174− -- Nothing after the delay.

1175− receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1094+ Nothing <- receiveChanTimeout 1000000 rp

1176−

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

1178− liftIO $ putMVar mvSender ()

1179

1095

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

1096+ -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds

1181− -- 0.1 seconds

1182− res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return

1097+ Just True <- receiveChanTimeout 1000000 rp

1183− liftIO $ assertBool "Expected result to be 'True'" res

1184

1098

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

1099+ -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing

1186− -- available, we get Nothing

1187− receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1100+ Nothing <- receiveChanTimeout 0 rp

1188−

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

1190− liftIO $ putMVar mvSender ()

1191

1101

1192 -- Again, but now there is a message available

1102 -- Again, but now there is a message available

1193− fix $ \loop -> do

1194− liftIO $ threadDelay 100000

1103+ liftIO $ threadDelay 1000000

1195− mb <- receiveChanTimeout 0 rp

1104+ Just False <- receiveChanTimeout 0 rp

1196− case mb of

1197− Just b -> do liftIO $ assertBool "Unexpected Message" $ not b

1198− _ -> loop

1199

1105

1200 liftIO $ putMVar done ()

1106 liftIO $ putMVar done ()

1201

1107

@@ -1204,11 +1110,10 @@ testReceiveChanTimeout TestTransport{..} = do

1204 runProcess localNode $ do

1110 runProcess localNode $ do

1205 sp <- liftIO $ readMVar sendPort

1111 sp <- liftIO $ readMVar sendPort

1206

1112

1207− liftIO $ takeMVar mvSender

1208− liftIO $ threadDelay 100000

1113+ liftIO $ threadDelay 1500000

1209 sendChan sp True

1114 sendChan sp True

1210

1115

1211− liftIO $ takeMVar mvSender

1116+ liftIO $ threadDelay 500000

1212 sendChan sp False

1117 sendChan sp False

1213

1118

1214 takeMVar done

1119 takeMVar done

@@ -1231,8 +1136,8 @@ testReceiveChanFeatures TestTransport{..} = do

1231

1136

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

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

1233

1138

1234− receiveChan rp1 >>= liftIO . assertBool "Expected True"

1139+ True <- receiveChan rp1

1235− receiveChan rp1 >>= liftIO . assertBool "Expected False" . not

1140+ False <- receiveChan rp1

1236

1141

1237 -- Test Applicative instance

1142 -- Test Applicative instance

1238

1143

@@ -1241,7 +1146,7 @@ testReceiveChanFeatures TestTransport{..} = do

1241

1146

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

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

1243

1148

1244− receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)

1149+ 7 <- receiveChan rp2

1245

1150

1246 -- Test Alternative instance

1151 -- Test Alternative instance

1247

1152

@@ -1250,8 +1155,8 @@ testReceiveChanFeatures TestTransport{..} = do

1250

1155

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

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

1252

1157

1253− receiveChan rp3 >>= liftIO . assertBool "Expected False" . not

1158+ False <- receiveChan rp3

1254− receiveChan rp3 >>= liftIO . assertBool "Expected True"

1159+ True <- receiveChan rp3

1255

1160

1256 -- Test Monad instance

1161 -- Test Monad instance

1257

1162

@@ -1265,86 +1170,17 @@ testReceiveChanFeatures TestTransport{..} = do

1265 then rpInt

1170 then rpInt

1266 else return 7

1171 else return 7

1267

1172

1268− receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)

1173+ 5 <- receiveChan rp4

1269− receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)

1174+ 7 <- receiveChan rp4

1270

1175

1271 liftIO $ putMVar done ()

1176 liftIO $ putMVar done ()

1272

1177

1273 takeMVar done

1178 takeMVar done

1274

1179

1275−testChanLifecycle :: TestTransport -> Assertion

1276−testChanLifecycle TestTransport{..} = let delay = 3000000 in do

1277− result <- newEmptyMVar

1278− tchMV <- newEmptyMVar

1279− localNode <- newLocalNode testTransport initRemoteTable

1280− runProcess localNode $ do

1281−

1282− pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())

1283− liftIO $ putMVar tchMV tCh

1284− expect :: Process ()

1285− let (sp, _) = tCh

1286− sendChan sp ()

1287− expect :: Process ()

1288−

1289− mRefPid <- monitor pid

1290−

1291− cPid <- spawnLocal $ do

1292− (sp', rp) <- liftIO $ takeMVar tchMV

1293− -- say "picked up our test channel"

1294− send pid ()

1295− -- say "told pid to continue"

1296− res <- receiveChanTimeout delay rp

1297− case res of

1298− Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)

1299− Just () -> do mr <- monitor pid

1300− pause 10000

1301− -- say "sending pid a second () will cause it to exit"

1302− send pid ()

1303−

1304− -- say "make sure we see a DOWN notification for pid having stopped"

1305− receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]

1306−

1307− -- now that pid has died, the send port should be useless...

1308− liftIO $ putMVar tchMV (sp', rp)

1309−

1310− -- let's verify that we do not see the message from our

1311− -- parent process on the channel, once pid has died...

1312− recv <- receiveChanTimeout delay rp

1313− -- say $ "finished waiting for second (), writing result" ++ (show recv)

1314− liftIO $ putMVar result $ isNothing recv

1315−

1316− mRefCPid <- monitor cPid

1317−

1318− receiveWait

1319− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)

1320− (\_ -> return ())

1321− ]

1322−

1323− -- say "seen first pid die..."

1324−

1325− (sendPort, _) <- liftIO $ takeMVar tchMV

1326− sendChan sendPort ()

1327− -- say "sent () after owning pid died"

1328−

1329− -- let cPid know we've written to the channel...

1330− send cPid ()

1331−

1332− receiveWait

1333− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)

1334− (\_ -> return ())

1335− ]

1336−

1337− -- say "seen both pids die now..."

1338−

1339− -- and wait on the result back in IO land...

1340− testRes <- takeMVar result

1341− -- runProcess localNode $ say "got result..."

1342− assertBool "Expected sending on the channel to fail, but received data!" testRes

1343−

1344−

1345testKillLocal :: TestTransport -> Assertion

1180testKillLocal :: TestTransport -> Assertion

1346testKillLocal TestTransport{..} = do

1181testKillLocal TestTransport{..} = do

1347 localNode <- newLocalNode testTransport initRemoteTable

1182 localNode <- newLocalNode testTransport initRemoteTable

1183+ done <- newEmptyMVar

1348

1184

1349 pid <- forkProcess localNode $ do

1185 pid <- forkProcess localNode $ do

1350 liftIO $ threadDelay 1000000

1186 liftIO $ threadDelay 1000000

@@ -1353,18 +1189,17 @@ testKillLocal TestTransport{..} = do

1353 ref <- monitor pid

1189 ref <- monitor pid

1354 us <- getSelfPid

1190 us <- getSelfPid

1355 kill pid "TestKill"

1191 kill pid "TestKill"

1356− mn <- expect

1192+ ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

1357− case mn of

1358− ProcessMonitorNotification ref' pid' (DiedException ex) ->

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

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

1360− True -> return ()

1194+ liftIO $ putMVar done ()

1361− False -> die "Invalid ProcessMonitorNotification received"

1195+

1362− _ -> die "Something went horribly wrong"

1196+ takeMVar done

1363

1197

1364testKillRemote :: TestTransport -> Assertion

1198testKillRemote :: TestTransport -> Assertion

1365testKillRemote TestTransport{..} = do

1199testKillRemote TestTransport{..} = do

1366 node1 <- newLocalNode testTransport initRemoteTable

1200 node1 <- newLocalNode testTransport initRemoteTable

1367 node2 <- newLocalNode testTransport initRemoteTable

1201 node2 <- newLocalNode testTransport initRemoteTable

1202+ done <- newEmptyMVar

1368

1203

1369 pid <- forkProcess node1 $ do

1204 pid <- forkProcess node1 $ do

1370 liftIO $ threadDelay 1000000

1205 liftIO $ threadDelay 1000000

@@ -1373,17 +1208,11 @@ testKillRemote TestTransport{..} = do

1373 ref <- monitor pid

1208 ref <- monitor pid

1374 us <- getSelfPid

1209 us <- getSelfPid

1375 kill pid "TestKill"

1210 kill pid "TestKill"

1376− mn <- expect

1377− case mn of

1378− ProcessMonitorNotification ref' pid' (DiedException reason) ->

1211+ ProcessMonitorNotification ref' pid' (DiedException reason) <- expect

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

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

1380− (True, True, True) -> return ()

1213+ liftIO $ putMVar done ()

1381− (a, b, c) -> do

1214+

1382− let a' = if a then "" else "Invalid ref"

1215+ takeMVar done

1383− let b' = if b then "" else "Invalid pid"

1384− let c' = if c then "" else "Invalid message"

1385− die $ unwords [a', b', c']

1386− _ -> die "Received unexpected message"

1387

1216

1388testCatchesExit :: TestTransport -> Assertion

1217testCatchesExit :: TestTransport -> Assertion

1389testCatchesExit TestTransport{..} = do

1218testCatchesExit TestTransport{..} = do

@@ -1409,10 +1238,7 @@ testHandleMessageIf TestTransport{..} = do

1409 self <- getSelfPid

1238 self <- getSelfPid

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

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

1411 msg <- receiveWait [ matchMessage return ]

1240 msg <- receiveWait [ matchMessage return ]

1412− handleMessageIf msg

1241+ Nothing <- handleMessageIf msg (\() -> True) (\() -> die $ "whoops")

1413− (\() -> True)

1414− (\() -> die "whoops") >>= maybe (return ())

1415− (const $ die "Expected Mismatch")

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

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

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

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

1418 return ()

1244 return ()

@@ -1457,11 +1283,8 @@ testDie TestTransport{..} = do

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

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

1458 `catchExit` \_from reason -> do

1284 `catchExit` \_from reason -> do

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

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

1460− let res = reason == ("foobar", 123 :: Int)

1286+ True <- return $ reason == ("foobar", 123 :: Int)

1461 liftIO $ putMVar done ()

1287 liftIO $ putMVar done ()

1462− if res

1463− then return ()

1464− else die "Something went horribly wrong"

1465

1288

1466 takeMVar done

1289 takeMVar done

1467

1290

@@ -1475,11 +1298,8 @@ testPrettyExit TestTransport{..} = do

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

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

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

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

1477 in do

1300 in do

1478− let res = (show ex) == expected

1301+ True <- return $ (show ex) == expected

1479 liftIO $ putMVar done ()

1302 liftIO $ putMVar done ()

1480− if res

1481− then return ()

1482− else die "Something went horribly wrong"

1483

1303

1484 takeMVar done

1304 takeMVar done

1485

1305

@@ -1495,26 +1315,17 @@ testExitLocal TestTransport{..} = do

1495 pid <- forkProcess localNode $ do

1315 pid <- forkProcess localNode $ do

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

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

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

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

1498− res <- return $ reason == "TestExit"

1318+ True <- return $ reason == "TestExit"

1499 liftIO $ putMVar supervisedDone ()

1319 liftIO $ putMVar supervisedDone ()

1500− if res

1501− then return ()

1502− else die "Something went horribly wrong"

1503

1320

1504 runProcess localNode $ do

1321 runProcess localNode $ do

1505 liftIO $ takeMVar handlerSetUp

1322 liftIO $ takeMVar handlerSetUp

1506 ref <- monitor pid

1323 ref <- monitor pid

1507 exit pid "TestExit"

1324 exit pid "TestExit"

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

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

1509− mn <- expect

1510− case mn of

1511− ProcessMonitorNotification ref' pid' DiedNormal -> do

1326+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

1512− let res = ref == ref' && pid == pid'

1327+ True <- return $ ref == ref' && pid == pid'

1513− liftIO $ putMVar supervisorDone ()

1328+ liftIO $ putMVar supervisorDone ()

1514− if res

1515− then return ()

1516− else die "Something went horribly wrong"

1517− _ -> die "Something went horribly wrong"

1518

1329

1519 takeMVar supervisedDone

1330 takeMVar supervisedDone

1520 takeMVar supervisorDone

1331 takeMVar supervisorDone

@@ -1530,98 +1341,19 @@ testExitRemote TestTransport{..} = do

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

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

1531 `catchExit` \_from reason -> do

1342 `catchExit` \_from reason -> do

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

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

1533− res <- return $ reason == "TestExit"

1344+ True <- return $ reason == "TestExit"

1534 liftIO $ putMVar supervisedDone ()

1345 liftIO $ putMVar supervisedDone ()

1535− if res

1536− then return ()

1537− else die "Something went horribly wrong"

1538

1346

1539 runProcess node2 $ do

1347 runProcess node2 $ do

1540 ref <- monitor pid

1348 ref <- monitor pid

1541 exit pid "TestExit"

1349 exit pid "TestExit"

1542− mn <- expect

1543− case mn of

1544− ProcessMonitorNotification ref' pid' DiedNormal -> do

1350+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

1545− res' <- return $ ref == ref' && pid == pid'

1351+ True <- return $ ref == ref' && pid == pid'

1546− liftIO $ putMVar supervisorDone ()

1352+ liftIO $ putMVar supervisorDone ()

1547− if res'

1548− then return ()

1549− else die "Something went horribly wrong"

1550− _ -> die "Something went horribly wrong"

1551

1353

1552 takeMVar supervisedDone

1354 takeMVar supervisedDone

1553 takeMVar supervisorDone

1355 takeMVar supervisorDone

1554

1356

1555−testRegistryMonitoring :: TestTransport -> Assertion

1556−testRegistryMonitoring TestTransport{..} = do

1557− node1 <- newLocalNode testTransport initRemoteTable

1558− node2 <- newLocalNode testTransport initRemoteTable

1559−

1560− let nid = localNodeId node2

1561− pid <- forkProcess node1 $ do

1562− self <- getSelfPid

1563− runUntilRegistered nid self

1564− say $ (show self) ++ " registered as " ++ regName

1565− expect :: Process ()

1566− say $ (show self) ++ " exiting normally"

1567−

1568− runProcess node2 $ do

1569− register regName pid

1570− say $ regName ++ " registered to " ++ show pid

1571− res <- whereis regName

1572− send pid ()

1573− say $ " sent finish signal to " ++ show pid

1574− us <- getSelfPid

1575− liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)

1576−

1577−

1578− -- This delay isn't essential!

1579− -- The test case passes perfectly fine without it (feel free to comment out

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

1581− -- that in delayUntilMaybeUnregistered we will hit the match case right

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

1583− -- seconds appears to work optimally on osx and across several linux distros

1584− -- running in virtual machines (which is essentially what we do in CI)

1585− void $ receiveTimeout 4000000 [ matchAny return ]

1586−

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

1588− -- future patch breaks the cooperative behaviour of node controllers viz

1589− -- remote process registration and notification taking place via ncEffectDied,

1590− -- there would be the possibility of a race in the test case should we attempt

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

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

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

1594− -- so that there's a higher change the registrations have been cleaned up

1595− -- in either case.

1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid

1597−

1598− regHere <- newEmptyMVar

1599− runProcess node2 $ whereis regName >>= liftIO . putMVar regHere

1600− res <- takeMVar regHere

1601− case res of

1602− Nothing -> return ()

1603− Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False

1604−

1605− where

1606− runUntilRegistered nid us = do

1607− whereisRemoteAsync nid regName

1608− receiveWait [

1609− matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)

1610− (const $ return ())

1611− ]

1612−

1613− delayUntilMaybeUnregistered nid p = do

1614− whereisRemoteAsync nid regName

1615− res <- receiveTimeout 20000000 {- 20 sec delay -} [

1616− matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)

1617− (const $ return ())

1618− ]

1619− case res of

1620− Just () -> return ()

1621− Nothing -> delayUntilMaybeUnregistered nid p

1622−

1623− regName = "testRegisterRemote"

1624−

1625testUnsafeSend :: TestTransport -> Assertion

1357testUnsafeSend :: TestTransport -> Assertion

1626testUnsafeSend TestTransport{..} = do

1358testUnsafeSend TestTransport{..} = do

1627 serverAddr <- newEmptyMVar

1359 serverAddr <- newEmptyMVar

@@ -1637,7 +1369,8 @@ testUnsafeSend TestTransport{..} = do

1637 void $ forkProcess localNode $ do

1369 void $ forkProcess localNode $ do

1638 serverPid <- liftIO $ takeMVar serverAddr

1370 serverPid <- liftIO $ takeMVar serverAddr

1639 getSelfPid >>= unsafeSend serverPid

1371 getSelfPid >>= unsafeSend serverPid

1372+ () <- expect

1640− expect >>= liftIO . putMVar clientDone

1373+ liftIO $ putMVar clientDone ()

1641

1374

1642 takeMVar clientDone

1375 takeMVar clientDone

1643

1376

@@ -1656,7 +1389,8 @@ testUnsafeUSend TestTransport{..} = do

1656 void $ forkProcess localNode $ do

1389 void $ forkProcess localNode $ do

1657 serverPid <- liftIO $ takeMVar serverAddr

1390 serverPid <- liftIO $ takeMVar serverAddr

1658 getSelfPid >>= unsafeUSend serverPid

1391 getSelfPid >>= unsafeUSend serverPid

1392+ () <- expect

1659− expect >>= liftIO . putMVar clientDone

1393+ liftIO $ putMVar clientDone ()

1660

1394

1661 takeMVar clientDone

1395 takeMVar clientDone

1662

1396

@@ -1667,7 +1401,8 @@ testUnsafeNSend TestTransport{..} = do

1667 localNode <- newLocalNode testTransport initRemoteTable

1401 localNode <- newLocalNode testTransport initRemoteTable

1668

1402

1669 pid <- forkProcess localNode $ do

1403 pid <- forkProcess localNode $ do

1404+ () <- expect

1670− expect >>= liftIO . putMVar clientDone

1405+ liftIO $ putMVar clientDone ()

1671

1406

1672 void $ runProcess localNode $ do

1407 void $ runProcess localNode $ do

1673 register "foobar" pid

1408 register "foobar" pid

@@ -1685,7 +1420,8 @@ testUnsafeNSendRemote TestTransport{..} = do

1685 _ <- forkProcess localNode1 $ do

1420 _ <- forkProcess localNode1 $ do

1686 getSelfPid >>= register "foobar"

1421 getSelfPid >>= register "foobar"

1687 liftIO $ putMVar clientDone ()

1422 liftIO $ putMVar clientDone ()

1423+ () <- expect

1688− expect >>= liftIO . putMVar clientDone

1424+ liftIO $ putMVar clientDone ()

1689

1425

1690 takeMVar clientDone

1426 takeMVar clientDone

1691 void $ runProcess localNode2 $ do

1427 void $ runProcess localNode2 $ do

@@ -1709,7 +1445,7 @@ testUnsafeSendChan TestTransport{..} = do

1709 serverPid <- liftIO $ takeMVar serverAddr

1445 serverPid <- liftIO $ takeMVar serverAddr

1710 (sp, rp) <- newChan

1446 (sp, rp) <- newChan

1711 unsafeSend serverPid sp

1447 unsafeSend serverPid sp

1712− receiveChan rp :: Process ()

1448+ () <- receiveChan rp

1713 liftIO $ putMVar clientDone ()

1449 liftIO $ putMVar clientDone ()

1714

1450

1715 takeMVar clientDone

1451 takeMVar clientDone

@@ -1723,8 +1459,8 @@ testCallLocal TestTransport{..} = do

1723 runProcess node $ do

1459 runProcess node $ do

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

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

1725 liftIO $ putMVar result r

1461 liftIO $ putMVar result r

1726−

1727− takeMVar result >>= assertBool "Expected 'True'"

1462+ True <- takeMVar result

1463+ return ()

1728

1464

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

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

1730 ibox <- newIORef False

1466 ibox <- newIORef False

@@ -1741,9 +1477,10 @@ testCallLocal TestTransport{..} = do

1741 (send keeper ())

1477 (send keeper ())

1742 caller <- expect

1478 caller <- expect

1743 exit caller "test"

1479 exit caller "test"

1744− expect :: Process ()

1480+ () <- expect

1745−

1481+ return ()

1746− readIORef ibox >>= assertBool "Expected 'True'"

1482+ True <- readIORef ibox

1483+ return ()

1747

1484

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

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

1749 ibox2 <- newIORef False

1486 ibox2 <- newIORef False

@@ -1752,8 +1489,8 @@ testCallLocal TestTransport{..} = do

1752 liftIO $ writeIORef ibox2 $ case r of

1489 liftIO $ writeIORef ibox2 $ case r of

1753 Left (ErrorCall "e") -> True

1490 Left (ErrorCall "e") -> True

1754 _ -> False

1491 _ -> False

1755−

1756− readIORef ibox >>= assertBool "Expected 'True'"

1492+ True <- readIORef ibox

1493+ return ()

1757

1494

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

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

1759 ibox3 <- newIORef False

1496 ibox3 <- newIORef False

@@ -1770,8 +1507,8 @@ testCallLocal TestTransport{..} = do

1770 liftIO $ putMVar result3 =<< readIORef ibox3

1507 liftIO $ putMVar result3 =<< readIORef ibox3

1771 worker <- expect

1508 worker <- expect

1772 send worker ()

1509 send worker ()

1773−

1774− takeMVar result3 >>= assertBool "Expected 'True'"

1510+ True <- takeMVar result3

1511+ return ()

1775

1512

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

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

1777 ibox4 <- newIORef False

1514 ibox4 <- newIORef False

@@ -1787,10 +1524,14 @@ testCallLocal TestTransport{..} = do

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

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

1788 caller <- expect

1525 caller <- expect

1789 exit caller "hi!"

1526 exit caller "hi!"

1790−

1791− takeMVar result4 >>= assertBool "Expected 'True'"

1527+ True <- takeMVar result4

1528+ return ()

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

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

1793

1530

1531+

1532+

1533+

1534+

1794tests :: TestTransport -> IO [Test]

1535tests :: TestTransport -> IO [Test]

1795tests testtrans = return [

1536tests testtrans = return [

1796 testGroup "Basic features" [

1537 testGroup "Basic features" [

@@ -1814,7 +1555,6 @@ tests testtrans = return [

1814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1555 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1556 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1557 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1818 , testCase "KillLocal" (testKillLocal testtrans)

1558 , testCase "KillLocal" (testKillLocal testtrans)

1819 , testCase "KillRemote" (testKillRemote testtrans)

1559 , testCase "KillRemote" (testKillRemote testtrans)

1820 , testCase "Die" (testDie testtrans)

1560 , testCase "Die" (testDie testtrans)

@@ -1824,7 +1564,6 @@ tests testtrans = return [

1824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1564 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1825 , testCase "ExitLocal" (testExitLocal testtrans)

1565 , testCase "ExitLocal" (testExitLocal testtrans)

1826 , testCase "ExitRemote" (testExitRemote testtrans)

1566 , testCase "ExitRemote" (testExitRemote testtrans)

1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1828 , testCase "TextCallLocal" (testCallLocal testtrans)

1567 , testCase "TextCallLocal" (testCallLocal testtrans)

1829 -- Unsafe Primitives

1568 -- Unsafe Primitives

1830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1569 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

@@ -1877,3 +1616,17 @@ tests testtrans = return [

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

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

1878 ]

1617 ]

1879 ]

1618 ]

1619+

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

1621+syncBreakConnection breakConnection nid0 nid1 = do

1622+ m <- newEmptyMVar

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

1624+ runProcess nid0 $ do

1625+ them <- liftIO $ takeMVar m

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

1627+ _ <- monitorNode (localNodeId nid1)

1628+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1629+ (nodeAddress $ localNodeId nid1)

1630+ NodeMonitorNotification _ _ _ <- expect

1631+ kill pinger "finished"

1632+ return ()

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+48−89

@@ -169,11 +169,8 @@ testUnclosure TestTransport{..} rtable = do

169 node <- newLocalNode testTransport rtable

170 done <- newEmptyMVar

171 forkProcess node $ do

172− i <- join . unClosure $ factorialClosure 5

172+ 120 <- join . unClosure $ factorialClosure 5

173 liftIO $ putMVar done ()

174− if i == 720

175− then return ()

176− else error "Something went horribly wrong"

177 takeMVar done

174 takeMVar done

178

175

179testBind :: TestTransport -> RemoteTable -> Assertion

176testBind :: TestTransport -> RemoteTable -> Assertion

@@ -183,11 +180,8 @@ testBind TestTransport{..} rtable = do

183 runProcess node $ do

180 runProcess node $ do

184 us <- getSelfPid

181 us <- getSelfPid

185 join . unClosure $ sendFac 6 us

182 join . unClosure $ sendFac 6 us

186− (i :: Int) <- expect

183+ (720 :: Int) <- expect

187 liftIO $ putMVar done ()

184 liftIO $ putMVar done ()

188− if i == 720

189− then return ()

190− else error "Something went horribly wrong"

191 takeMVar done

185 takeMVar done

192

186

193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

187testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

@@ -200,7 +194,7 @@ testSendPureClosure TestTransport{..} rtable = do

200 addr <- forkProcess node $ do

194 addr <- forkProcess node $ do

201 cl <- expect

195 cl <- expect

202 fn <- unClosure cl :: Process (Int -> Int)

196 fn <- unClosure cl :: Process (Int -> Int)

203− (_ :: Int) <- return $ fn 6

197+ 13 <- return $ fn 6

204 liftIO $ putMVar serverDone ()

198 liftIO $ putMVar serverDone ()

205 putMVar serverAddr addr

199 putMVar serverAddr addr

206

200

@@ -224,11 +218,8 @@ testSendIOClosure TestTransport{..} rtable = do

224 liftIO $ do

218 liftIO $ do

225 someMVar <- newEmptyMVar

219 someMVar <- newEmptyMVar

226 io someMVar

220 io someMVar

227− i <- readMVar someMVar

221+ 5 <- readMVar someMVar

228 putMVar serverDone ()

222 putMVar serverDone ()

229− if i == 5

230− then return ()

231− else error "Something went horribly wrong"

232 putMVar serverAddr addr

223 putMVar serverAddr addr

233

224

234 forkIO $ do

225 forkIO $ do

@@ -257,10 +248,8 @@ testSendProcClosure TestTransport{..} rtable = do

257 runProcess node $ do

248 runProcess node $ do

258 pid <- getSelfPid

249 pid <- getSelfPid

259 send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

250 send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

260− i <- expect :: Process Int

251+ 5 <- expect :: Process Int

261− if i == 5

262− then liftIO $ putMVar clientDone ()

252+ liftIO $ putMVar clientDone ()

263− else error "Something went horribly wrong"

264

253

265 takeMVar clientDone

254 takeMVar clientDone

266

255

@@ -280,9 +269,8 @@ testSpawn TestTransport{..} rtable = do

280 pid <- getSelfPid

269 pid <- getSelfPid

281 pid' <- spawn nid (sendPidClosure pid)

270 pid' <- spawn nid (sendPidClosure pid)

282 pid'' <- expect

271 pid'' <- expect

283− if pid' == pid''

272+ True <- return $ pid' == pid''

284− then liftIO $ putMVar clientDone ()

273+ liftIO $ putMVar clientDone ()

285− else error "Something went horribly wrong"

286

274

287 takeMVar clientDone

275 takeMVar clientDone

288

276

@@ -306,9 +294,8 @@ testSpawnRace TestTransport{..} rtable = do

306 spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid

294 spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid

307 pid' <- expect :: Process ProcessId

295 pid' <- expect :: Process ProcessId

308 pid'' <- expect :: Process ProcessId

296 pid'' <- expect :: Process ProcessId

309− if pid' == pid''

297+ True <- return $ pid' == pid''

310− then return ()

298+ return ()

311− else error "Something went horribly wrong"

312

299

313 where

300 where

314

301

@@ -318,16 +305,14 @@ testSpawnRace TestTransport{..} rtable = do

318 wrapEP e =

305 wrapEP e =

319 e { NT.connect = \x y z -> do

306 e { NT.connect = \x y z -> do

320 healthy <- newIORef True

307 healthy <- newIORef True

321− fmap (fmap $ wrapConnection healthy e x) $ NT.connect e x y z

308+ fmap (fmap $ wrapConnection healthy) $ NT.connect e x y z

322 }

309 }

323

310

324− wrapConnection :: IORef Bool -> NT.EndPoint -> NT.EndPointAddress

325− -> NT.Connection -> NT.Connection

311+ wrapConnection :: IORef Bool -> NT.Connection -> NT.Connection

326− wrapConnection healthy e remoteAddr (NT.Connection s closeC) =

312+ wrapConnection healthy (NT.Connection s closeC) =

327 flip NT.Connection closeC $ \msg -> do

313 flip NT.Connection closeC $ \msg -> do

328 when (msg == messageToPayload (createMessage ())) $ do

314 when (msg == messageToPayload (createMessage ())) $ do

329 writeIORef healthy False

315 writeIORef healthy False

330− testBreakConnection (NT.address e) remoteAddr

331 isHealthy <- readIORef healthy

316 isHealthy <- readIORef healthy

332 if isHealthy then s msg

317 if isHealthy then s msg

333 else return $ Left $ NT.TransportError NT.SendFailed ""

318 else return $ Left $ NT.TransportError NT.SendFailed ""

@@ -345,10 +330,8 @@ testCall TestTransport{..} rtable = do

345 node <- newLocalNode testTransport rtable

330 node <- newLocalNode testTransport rtable

346 nid <- readMVar serverNodeAddr

331 nid <- readMVar serverNodeAddr

347 runProcess node $ do

332 runProcess node $ do

348− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

333+ (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

349− if a == 120

350− then liftIO $ putMVar clientDone ()

334+ liftIO $ putMVar clientDone ()

351− else error "something went horribly wrong"

352

335

353 takeMVar clientDone

336 takeMVar clientDone

354

337

@@ -365,10 +348,8 @@ testCallBind TestTransport{..} rtable = do

365 node <- newLocalNode testTransport rtable

348 node <- newLocalNode testTransport rtable

366 nid <- readMVar serverNodeAddr

349 nid <- readMVar serverNodeAddr

367 runProcess node $ do

350 runProcess node $ do

368− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

351+ (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

369− if a == 120

370− then liftIO $ putMVar clientDone ()

352+ liftIO $ putMVar clientDone ()

371− else error "Something went horribly wrong"

372

353

373 takeMVar clientDone

354 takeMVar clientDone

374

355

@@ -379,11 +360,9 @@ testSeq TestTransport{..} rtable = do

379 runProcess node $ do

360 runProcess node $ do

380 us <- getSelfPid

361 us <- getSelfPid

381 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

362 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

382− a :: Int <- expect

363+ 120 :: Int <- expect

383− b :: Int <- expect

364+ 720 :: Int <- expect

384− if a == 120 && b == 720

385− then liftIO $ putMVar done ()

365+ liftIO $ putMVar done ()

386− else error "Something went horribly wrong"

387 takeMVar done

366 takeMVar done

388

367

389-- Test 'spawnSupervised'

368-- Test 'spawnSupervised'

@@ -412,33 +391,25 @@ testSpawnSupervised TestTransport{..} rtable = do

412 throw supervisorDeath

391 throw supervisorDeath

413

392

414 forkProcess node2 $ do

393 forkProcess node2 $ do

415− res <- liftIO $ mapM readMVar [superPid, childPid]

394+ [super, child] <- liftIO $ mapM readMVar [superPid, childPid]

416− case res of

417− [super, child] -> do

418− ref <- monitor child

395+ ref <- monitor child

419− self <- getSelfPid

396+ self <- getSelfPid

420− let waitForMOrL = do

397+ let waitForMOrL = do

421− liftIO $ threadDelay 10000

398+ liftIO $ threadDelay 10000

422− mpinfo <- getProcessInfo child

399+ mpinfo <- getProcessInfo child

423− case mpinfo of

400+ case mpinfo of

424− Nothing -> waitForMOrL

401+ Nothing -> waitForMOrL

425− Just pinfo ->

402+ Just pinfo ->

426− unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL

403+ unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL

427− waitForMOrL

404+ waitForMOrL

428− liftIO $ putMVar linkUp ()

405+ liftIO $ putMVar linkUp ()

429− -- because monitor message was sent before message to process

406+ -- because monitor message was sent before message to process

430− -- we hope that it will be processed before

407+ -- we hope that it will be processed before

431− res' <- expect

408+ ProcessMonitorNotification ref' pid' (DiedException e) <- expect

432− case res' of

409+ True <- return $ ref' == ref

433− (ProcessMonitorNotification ref' pid' (DiedException e)) ->

434− if (ref' == ref && pid' == child &&

410+ && pid' == child

435− e == show (ProcessLinkException super

436− (DiedException (show supervisorDeath))))

411+ && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))

437− then liftIO $ putMVar thirdProcessDone ()

412+ liftIO $ putMVar thirdProcessDone ()

438− else error "Something went horribly wrong"

439− _ -> error "Something went horribly wrong"

440−

441− _ -> die $ "Something went horribly wrong"

442

413

443 takeMVar thirdProcessDone

414 takeMVar thirdProcessDone

444 where

415 where

@@ -453,10 +424,8 @@ testSpawnInvalid TestTransport{..} rtable = do

453 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)

424 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)

454 ProcessMonitorNotification ref' pid' _reason <- expect

425 ProcessMonitorNotification ref' pid' _reason <- expect

455 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

426 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

456− res <- return $ ref' == ref && pid == pid'

427+ True <- return $ ref' == ref && pid == pid'

457− if res == True

458− then liftIO $ putMVar done ()

428+ liftIO $ putMVar done ()

459− else error "Something went horribly wrong"

460 takeMVar done

429 takeMVar done

461

430

462testClosureExpect :: TestTransport -> RemoteTable -> Assertion

431testClosureExpect :: TestTransport -> RemoteTable -> Assertion

@@ -468,10 +437,8 @@ testClosureExpect TestTransport{..} rtable = do

468 us <- getSelfPid

437 us <- getSelfPid

469 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

438 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

470 send them (1234 :: Int)

439 send them (1234 :: Int)

471− (res :: Int) <- expect

440+ (1234 :: Int) <- expect

472− if res == 1234

473− then liftIO $ putMVar done ()

441+ liftIO $ putMVar done ()

474− else error "Something went horribly wrong"

475 takeMVar done

442 takeMVar done

476

443

477testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

444testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

@@ -496,10 +463,8 @@ testTDict TestTransport{..} rtable = do

496 done <- newEmptyMVar

463 done <- newEmptyMVar

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

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

498 forkProcess node1 $ do

465 forkProcess node1 $ do

499− res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

466+ True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

500− if res == True

501− then liftIO $ putMVar done ()

467+ liftIO $ putMVar done ()

502− else error "Something went horribly wrong..."

503 takeMVar done

468 takeMVar done

504

469

505testFib :: TestTransport -> RemoteTable -> Assertion

470testFib :: TestTransport -> RemoteTable -> Assertion

@@ -510,11 +475,8 @@ testFib TestTransport{..} rtable = do

510 forkProcess (head nodes) $ do

475 forkProcess (head nodes) $ do

511 (sport, rport) <- newChan

476 (sport, rport) <- newChan

512 spawnLocal $ dfib (map localNodeId nodes, sport, 10)

477 spawnLocal $ dfib (map localNodeId nodes, sport, 10)

513− ff <- receiveChan rport :: Process Integer

478+ 55 <- receiveChan rport :: Process Integer

514 liftIO $ putMVar done ()

479 liftIO $ putMVar done ()

515− if ff /= 55

516− then die $ "Something went horribly wrong"

517− else return ()

518

480

519 takeMVar done

481 takeMVar done

520

482

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

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

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

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

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

524 let nid1 = localNodeId node1

486 let nid1 = localNodeId node1

525− -- nid2 = localNodeId node2

487+ nid2 = localNodeId node2

526 done <- newEmptyMVar

488 done <- newEmptyMVar

527 iv <- newMVar (0 :: Int)

489 iv <- newMVar (0 :: Int)

528

490

@@ -539,12 +501,9 @@ testSpawnReconnect testtrans@TestTransport{..} rtable = do

539 liftIO $ threadDelay 100000

501 liftIO $ threadDelay 100000

540

502

541 count <- liftIO $ takeMVar iv

503 count <- liftIO $ takeMVar iv

542− res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

504+ True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

543

505

544 liftIO $ putMVar done ()

506 liftIO $ putMVar done ()

545− if res /= True

546− then error "Something went horribly wrong"

547− else return ()

548

507

549 takeMVar done

508 takeMVar done

550

509

distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+5−16

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

20 -- ping !

21 , Ping(Ping)

22 , ping

23− , pause

24 , shouldBe

23 , shouldBe

25 , shouldMatch

24 , shouldMatch

26 , shouldContain

25 , shouldContain

@@ -74,16 +73,15 @@ import Control.Concurrent

74import Control.Concurrent.MVar

73import Control.Concurrent.MVar

75 ( putMVar

74 ( putMVar

76 )

75 )

77−import Control.Distributed.Process hiding (finally, catch)

76+import Control.Distributed.Process

78import Control.Distributed.Process.Node

77import Control.Distributed.Process.Node

79import Control.Distributed.Process.Serializable()

78import Control.Distributed.Process.Serializable()

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

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

82−import Control.Monad (forever, void)

81+import Control.Monad (forever)

83−import Control.Monad.Catch (finally, catch)

84import Control.Monad.STM (atomically)

82import Control.Monad.STM (atomically)

85import Control.Rematch hiding (match)

83import Control.Rematch hiding (match)

86−import Control.Rematch.Run

84+import Control.Rematch.Run

87import Data.Binary

85import Data.Binary

88import Data.Typeable (Typeable)

86import Data.Typeable (Typeable)

@@ -91,7 +89,6 @@ import Test.HUnit (Assertion, assertFailure)

91import Test.HUnit.Base (assertBool)

89import Test.HUnit.Base (assertBool)

93import GHC.Generics

91import GHC.Generics

94−import System.Timeout (timeout)

96-- | A mutable cell containing a test result.

93-- | A mutable cell containing a test result.

97type TestResult a = MVar a

94type TestResult a = MVar a

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

110

107

111instance Binary TestProcessControl where

108instance Binary TestProcessControl where

112

109

113−data Private = Private

114− deriving (Typeable, Generic)

115−instance Binary Private where

116−

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

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

118noop :: Process ()

111noop :: Process ()

119noop = return ()

112noop = return ()

120

113

121−pause :: Int -> Process ()

122−pause delay =

123− void $ receiveTimeout delay [ match (\Private -> return ()) ]

124−

125synchronisedAssertion :: Eq a

114synchronisedAssertion :: Eq a

126 => String

115 => String

127 -> LocalNode

116 -> LocalNode

@@ -234,10 +223,10 @@ testProcessReport pid = do

234tryRunProcess :: LocalNode -> Process () -> IO ()

223tryRunProcess :: LocalNode -> Process () -> IO ()

235tryRunProcess node p = do

224tryRunProcess node p = do

236 tid <- liftIO myThreadId

225 tid <- liftIO myThreadId

237− void $ timeout (1000000 * 60 * 5 :: Int) $

238− runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

226+ runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

239

227

240tryForkProcess :: LocalNode -> Process () -> IO ProcessId

228tryForkProcess :: LocalNode -> Process () -> IO ProcessId

241tryForkProcess node p = do

229tryForkProcess node p = do

242 tid <- liftIO myThreadId

230 tid <- liftIO myThreadId

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

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

232+

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+129−385

@@ -1,23 +1,12 @@

1−{-# LANGUAGE DeriveGeneric #-}

1+{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE ParallelListComp #-}

3−

4module Control.Distributed.Process.Tests.Mx (tests) where

2module Control.Distributed.Process.Tests.Mx (tests) where

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

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

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

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

8−import Control.Distributed.Process hiding (bracket, finally, try)

7+import Control.Concurrent (threadDelay)

9−import Control.Distributed.Process.Internal.Types

8+import Control.Distributed.Process

10− ( ProcessExitException(..)

11− , unsafeCreateUnencodedMessage

12− )

13import Control.Distributed.Process.Node

9import Control.Distributed.Process.Node

14−import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe

15− ( send

16− , nsend

17− , nsendRemote

18− , usend

19− , sendChan

20− )

21import Control.Distributed.Process.Management

10import Control.Distributed.Process.Management

22 ( MxEvent(..)

11 ( MxEvent(..)

23 , MxAgentId(..)

12 , MxAgentId(..)

@@ -32,15 +21,19 @@ import Control.Distributed.Process.Management

32 , mxUpdateLocal

21 , mxUpdateLocal

33 , mxNotify

22 , mxNotify

34 , mxBroadcast

23 , mxBroadcast

24+ , mxGetId

25+ , mxGet

26+ , mxSet

27+ , mxClear

28+ , mxPurgeTable

29+ , mxDropTable

35 )

30 )

36−import Control.Monad (void, unless)

31+import Control.Monad (void)

37−import Control.Monad.Catch(finally, bracket, try)

38−import Control.Rematch (equalTo)

39import Data.Binary

32import Data.Binary

40−import Data.List (find, sort, intercalate)

33+import Data.List (find, sort)

41−import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)

34+import Data.Maybe (isJust)

42import Data.Typeable

35import Data.Typeable

43−import GHC.Generics hiding (from)

36+import GHC.Generics

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

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

45import Prelude hiding (catch, log)

38import Prelude hiding (catch, log)

46#endif

39#endif

@@ -56,17 +49,7 @@ data Publish = Publish

57instance Binary Publish where

50instance Binary Publish where

59−awaitExit :: ProcessId -> Process ()

60−awaitExit pid =

61− withMonitorRef pid $ \ref -> do

62− receiveWait

63− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == ref)

64− (\_ -> return ())

65− ]

66− where

67− withMonitorRef p = bracket (monitor p) unmonitor

68−

69−testAgentBroadcast :: TestResult (Maybe ()) -> Process ()

52+testAgentBroadcast :: TestResult () -> Process ()

70testAgentBroadcast result = do

53testAgentBroadcast result = do

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

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

@@ -81,7 +64,7 @@ testAgentBroadcast result = do

81 mxNotify ()

64 mxNotify ()

82 -- Once the publisher has seen our message, it will broadcast the Publish

65 -- Once the publisher has seen our message, it will broadcast the Publish

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

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

84− stash result =<< receiveChanTimeout 10000000 resultRP

67+ stash result =<< receiveChan resultRP

86 kill publisher "finished"

69 kill publisher "finished"

87 kill consumer "finished"

70 kill consumer "finished"

@@ -89,7 +72,7 @@ testAgentBroadcast result = do

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

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

90testAgentDualInput result = do

73testAgentDualInput result = do

91 (sp, rp) <- newChan

74 (sp, rp) <- newChan

92− s <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [

75+ _ <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [

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

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

94 mxSetLocal . (+i) =<< mxGetLocal

77 mxSetLocal . (+i) =<< mxGetLocal

95 i' <- mxGetLocal

78 i' <- mxGetLocal

@@ -99,8 +82,6 @@ testAgentDualInput result = do

99 else mxReady)

82 else mxReady)

100 ]

83 ]

101

102− mRef <- monitor s

103−

104 mxNotify (1 :: Int)

85 mxNotify (1 :: Int)

105 nsend "sum-agent" (3 :: Int)

86 nsend "sum-agent" (3 :: Int)

106 mxNotify (2 :: Int)

87 mxNotify (2 :: Int)

@@ -108,10 +89,6 @@ testAgentDualInput result = do

108 mxNotify (5 :: Int)

89 mxNotify (5 :: Int)

109

110 stash result =<< receiveChanTimeout 10000000 rp

91 stash result =<< receiveChanTimeout 10000000 rp

111− died <- receiveTimeout 10000000 [

112− matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) (const $ return True)

113− ]

114− died `shouldBe` equalTo (Just True)

115

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

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

117testAgentPrioritisation result = do

94testAgentPrioritisation result = do

@@ -123,12 +100,12 @@ testAgentPrioritisation result = do

123

100

124 let name = "prioritising-agent"

101 let name = "prioritising-agent"

125 (sp, rp) <- newChan

102 (sp, rp) <- newChan

126− s <- mxAgent (MxAgentId name) ["first"] [

103+ void $ mxAgent (MxAgentId name) ["first"] [

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

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

128− mxUpdateLocal (s:)

105+ mxUpdateLocal ((s:))

129 st <- mxGetLocal

106 st <- mxGetLocal

130 case length st of

107 case length st of

131− n | n == 5 -> do liftMX $ sendChan sp (sort st)

108+ n | n == 5 -> do liftMX $ sendChan sp st

132 mxDeactivate "finished"

109 mxDeactivate "finished"

133 _ -> mxReceive -- go to the mailbox

110 _ -> mxReceive -- go to the mailbox

134 )

111 )

@@ -139,33 +116,23 @@ testAgentPrioritisation result = do

139 mxNotify "fourth"

116 mxNotify "fourth"

140 nsend name "fifth"

117 nsend name "fifth"

141

118

142− stash result . fromMaybe [] =<< receiveChanTimeout 10000000 rp

119+ stash result . sort =<< receiveChan rp

143− awaitExit s

144

120

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

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

146testAgentMailboxHandling result = do

122testAgentMailboxHandling result = do

147 (sp, rp) <- newChan

123 (sp, rp) <- newChan

148− agent <- mxAgent (MxAgentId "mailbox-agent") () [

124+ agent <- mxAgent (MxAgentId "listener-agent") () [

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

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

150 ]

126 ]

151

127

152− nsend "mailbox-agent" ()

128+ nsend "listener-agent" ()

153

129

154 stash result =<< receiveChanTimeout 1000000 rp

130 stash result =<< receiveChanTimeout 1000000 rp

155 kill agent "finished"

131 kill agent "finished"

156

132

157testAgentEventHandling :: TestResult Bool -> Process ()

133testAgentEventHandling :: TestResult Bool -> Process ()

158testAgentEventHandling result = do

134testAgentEventHandling result = do

159− us <- getSelfPid

160− -- because this test is a bit racy, let's ensure it can't run indefinitely

161− timer <- spawnLocal $ do

162− pause (1000000 * 60 * 5)

163− -- okay we've waited 5 mins, let's kill the test off if it's stuck...

164− stash result False

165− kill us "Test Timed Out"

166−

167 let initState = [] :: [MxEvent]

135 let initState = [] :: [MxEvent]

168− (rc, rs) <- newChan

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

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

170 (mxSink $ \ev -> do

137 (mxSink $ \ev -> do

171 st <- mxGetLocal

138 st <- mxGetLocal

@@ -174,7 +141,7 @@ testAgentEventHandling result = do

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

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

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

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

176 _ -> return ()

143 _ -> return ()

177− act >> (liftMX $ sendChan rc ()) >> mxReady),

144+ act >> mxReady),

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

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

179 st <- mxGetLocal

146 st <- mxGetLocal

180 let found =

147 let found =

@@ -194,349 +161,126 @@ testAgentEventHandling result = do

194 mxReady)

161 mxReady)

195 ]

162 ]

196

163

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

164+ _ <- monitor agentPid

198− faff 2000000 rs

199−

200− (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())

165+ (sp, rp) <- newChan

201−

202− pid <- spawnLocal $ expect >>= sendChan sp

166+ pid <- spawnLocal $ sendChan sp ()

167+ () <- receiveChan rp

203

168

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

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

205− -- higher probably that the agent has seen the spawn and died events

170+ -- higher probably that the agent has seen

206 monitor pid

171 monitor pid

207−

208− send pid ()

209− rct <- receiveChanTimeout 10000000 rp

210− unless (isJust rct) $ die "No response on channel"

211−

212− pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]

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

213− unless (isJust pmn) $ die "No monitor notification arrived"

214−

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

216− faff 2000000 rs

217

173

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

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

219 mxNotify (MxSpawned pid, replyTo)

175 mxNotify (MxSpawned pid, replyTo)

220 mxNotify (MxProcessDied pid DiedNormal, replyTo)

176 mxNotify (MxProcessDied pid DiedNormal, replyTo)

221

177

222− seenAlive <- receiveChanTimeout 10000000 reply

178+ seenAlive <- receiveChan reply

223− seenDead <- receiveChanTimeout 10000000 reply

224−

225− stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]

226− kill timer "test-complete"

227− kill agentPid "test-complete"

228− where

229− faff delay port = do

230− res <- receiveChanTimeout delay port

231− unless (isNothing res) $ pause delay

232−

233−testMxRegEvents :: TestResult () -> Process ()

234−testMxRegEvents result = do

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

236− notified in the expected order - the remote cases related to the

237− behaviour of the node controller are contained in the CH test suite. -}

238− ensure (stash result ()) $ do

239− let label = "testMxRegEvents"

240− let agentLabel = "mxRegEvents-agent"

241− let delay = 1000000

242− (regChan, regSink) <- newChan

243− (unRegChan, unRegSink) <- newChan

244− agent <- mxAgent (MxAgentId agentLabel) () [

245− mxSink $ \ev -> do

246− case ev of

247− MxRegistered pid label'

248− | label' == label -> liftMX $ sendChan regChan (label', pid)

249− MxUnRegistered pid label'

250− | label' == label -> liftMX $ sendChan unRegChan (label', pid)

251− _ -> return ()

252− mxReady

253− ]

254−

255− p1 <- spawnLocal expect

256− p2 <- spawnLocal expect

257−

258− register label p1

259− reg1 <- receiveChanTimeout delay regSink

260− reg1 `shouldBe` equalTo (Just (label, p1))

261−

262− unregister label

263− unreg1 <- receiveChanTimeout delay unRegSink

264− unreg1 `shouldBe` equalTo (Just (label, p1))

265−

266− register label p2

267− reg2 <- receiveChanTimeout delay regSink

268− reg2 `shouldBe` equalTo (Just (label, p2))

269−

270− reregister label p1

271− unreg2 <- receiveChanTimeout delay unRegSink

272− unreg2 `shouldBe` equalTo (Just (label, p2))

273−

274− reg3 <- receiveChanTimeout delay regSink

275− reg3 `shouldBe` equalTo (Just (label, p1))

276−

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

278−

279−testMxRegMon :: LocalNode -> TestResult () -> Process ()

280−testMxRegMon remoteNode result = do

281− ensure (stash result ()) $ do

282− -- ensure that when a registered process dies, we get a notification that

283− -- it has been unregistered as well as seeing the name get removed

284− let label1 = "aaaaa"

285− let label2 = "bbbbb"

286− let isValid l = l == label1 || l == label2

287− let agentLabel = "mxRegMon-agent"

288− let delay = 1000000

289− (regChan, regSink) <- newChan

290− (unRegChan, unRegSink) <- newChan

291− agent <- mxAgent (MxAgentId agentLabel) () [

292− mxSink $ \ev -> do

293− case ev of

294− MxRegistered pid label

295− | isValid label -> liftMX $ sendChan regChan (label, pid)

296− MxUnRegistered pid label

297− | isValid label -> liftMX $ sendChan unRegChan (label, pid)

298− _ -> return ()

299− mxReady

300− ]

301−

302− (sp, rp) <- newChan

303− liftIO $ forkProcess remoteNode $ do

304− getSelfPid >>= sendChan sp

305− expect :: Process ()

306−

307− p1 <- receiveChan rp

179+ seenDead <- receiveChan reply

308−

309− register label1 p1

310− reg1 <- receiveChanTimeout delay regSink

311− reg1 `shouldBe` equalTo (Just (label1, p1))

312−

313− register label2 p1

314− reg2 <- receiveChanTimeout delay regSink

315− reg2 `shouldBe` equalTo (Just (label2, p1))

316−

317− n1 <- whereis label1

318− n1 `shouldBe` equalTo (Just p1)

319−

320− n2 <- whereis label2

321− n2 `shouldBe` equalTo (Just p1)

322−

323− kill p1 "goodbye"

324−

325− unreg1 <- receiveChanTimeout delay unRegSink

326− unreg2 <- receiveChanTimeout delay unRegSink

327−

328− let evts = [unreg1, unreg2]

329− -- we can't rely on the order of the values in the node controller's

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

331− -- so we simply verify that we received the un-registration events we expect

332− evts `shouldContain` (Just (label1, p1))

333− evts `shouldContain` (Just (label2, p1))

334−

335− kill agent "test-complete"

336−

337−ensure :: Process () -> Process () -> Process ()

338−ensure = flip finally

339−

340−testNSend :: (String -> () -> Process ())

341− -> Maybe LocalNode

342− -> Process ()

343−testNSend op n = do

344− us <- getSelfPid

345− let delay = 5000000

346− let label = "testMxSend" ++ (show us)

347− let isValid = isValidLabel n label

348−

349− testMxSend n label $ \p1 sink -> do

350− register label p1

351− reg1 <- receiveChanTimeout delay sink

352− case reg1 of

353− Just (MxRegistered pd lb)

354− | pd == p1 && isValid lb -> return ()

355− _ -> die $ "Reg-Failed: " ++ show reg1

356−

357− op label ()

358−

359− sent <- receiveChanTimeout delay sink

360− case sent of

361− Just (MxSentToName lb by _)

362− | by == us && isValid lb -> return True

363− _ -> die $ "Send-Failed: " ++ show sent

364−

365− where

366− isValidLabel nd l1 l2

367− | l2 == l2 = True

368− | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)

369− | otherwise = False

370−

371−testSend :: (ProcessId -> () -> Process ())

372− -> Maybe LocalNode

373− -> Process ()

374−testSend op n = do

375− us <- getSelfPid

376− let label = "testMxSend" ++ (show us)

377− testMxSend n label $ \p1 sink -> do

378− -- initiate a send

379− op p1 ()

380−

381− -- verify the management event

382− sent <- receiveChanTimeout 5000000 sink

383− case sent of

384− Just (MxSent pidTo pidFrom _)

385− | pidTo == p1 && pidFrom == us -> return True

386− _ -> return False

387−

388−testChan :: (SendPort () -> () -> Process ())

389− -> Maybe LocalNode

390− -> Process ()

391−testChan op n = testMxSend n "" $ \p1 sink -> do

392−

393− us <- getSelfPid

394− send p1 us

395−

396− cleared <- receiveChanTimeout 2000000 sink

397− case cleared of

398− Just (MxSent pidTo pidFrom _)

399− | pidTo == p1 && pidFrom == us -> return ()

400− _ -> die "Received uncleared Mx Event"

401−

402− chan <- receiveTimeout 5000000 [ match return ]

403− let ch' = fromMaybe (error "No reply chan received") chan

404−

405− -- initiate a send

406− op ch' ()

407−

408− -- verify the management event

409− sent <- receiveChanTimeout 5000000 sink

410− case sent of

411− Just (MxSentToPort sId spId _)

412− | sId == us && spId == sendPortId ch' -> return True

413− _ -> return False

414−

415−type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

416−

417−testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()

418−testMxSend mNode label test = do

419− us <- getSelfPid

420− (sp, rp) <- newChan

421− (chan, sink) <- newChan

422− agent <- mxAgent (MxAgentId $ agentLabel us) () [

423− mxSink $ \ev -> do

424− case ev of

425− m@(MxSentToPort _ cid _)

426− | cid /= sendPortId chan

427− && cid /= sendPortId sp -> liftMX $ sendChan chan m

428− m@(MxSent _ fromPid _)

429− | fromPid == us -> liftMX $ sendChan chan m

430− m@(MxSentToName _ fromPid _)

431− | fromPid == us -> liftMX $ sendChan chan m

432− m@(MxRegistered _ name)

433− | name == label -> liftMX $ sendChan chan m

434− _ -> return ()

435− mxReady

436− ]

437−

438− case mNode of

439− Nothing -> void $ spawnLocal (proc sp)

440− Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

441

180

442− p1 <- receiveChanTimeout 2000000 rp

181+ stash result $ seenAlive && seenDead

443− unless (isJust p1) $ die "Timed out waiting for ProcessId"

444− res <- try $ test (fromJust p1) sink

445

182

446− kill agent "bye"

183+testAgentPublication :: TestResult (Maybe Publish) -> Process ()

447− kill (fromJust p1) "bye"

184+testAgentPublication result = do

448−

185+ (syncChan, rp) <- newChan

449− case res of

186+ let ourId = MxAgentId "publication-agent"

450− Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

187+ agentPid <- mxAgent ourId () [

451− Right tr -> tr `shouldBe` equalTo True

188+ mxSink $ \() -> do

189+ selfId <- mxGetId

190+ liftMX $ mxSet selfId "publish" Publish >> sendChan syncChan ()

191+ mxReady

192+ ]

452

193

194+ mxNotify ()

195+ () <- receiveChan rp

453

196

454− where

197+ stash result =<< mxGet ourId "publish"

455− agentLabel s = "mx-unsafe-check-agent-" ++ show s

456− proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

457

198

458− go :: Maybe (ReceivePort ()) -> Process ()

199+ mref <- monitor agentPid

459− go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go

200+ kill agentPid "finished"

460− go c@(Just c') = receiveWait [ matchChan c' return ] >> go c

201+ receiveWait [

202+ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

203+ ((\_ -> return ()))

204+ ]

461

205

462− replyChannel p' = do

206+testAgentTableClear :: Int -> TestResult (Maybe Int, Maybe Int) -> Process ()

463− (s, r) <- newChan

207+testAgentTableClear val result =

464− send p' s

208+ let tId = (MxAgentId "agent-1")

465− return r

209+ tKey = "key-1" in do

210+ mxSet tId tKey val

211+ get1 <- mxGet tId tKey

212+ mxClear tId tKey

213+ get2 <- mxGet tId tKey

214+ stash result (get1, get2)

215+

216+testAgentTablePurge :: TestResult (Maybe Int) -> Process ()

217+testAgentTablePurge result =

218+ let tId = MxAgentId "agent-2"

219+ tKey = "key-2" in do

220+ mxSet tId tKey (12345 :: Int)

221+ mxPurgeTable tId

222+ stash result =<< mxGet tId tKey

223+

224+testAgentTableDelete :: Int

225+ -> TestResult (Maybe Int, Maybe Int, Maybe Int)

226+ -> Process ()

227+testAgentTableDelete val result =

228+ let tId = (MxAgentId "agent-3")

229+ tKey = "key-3" in do

230+ mxSet tId tKey val

231+ get1 <- mxGet tId tKey

232+ mxDropTable tId

233+ get2 <- mxGet tId tKey

234+ mxSet tId tKey val

235+ get3 <- mxGet tId tKey

236+ stash result (get1, get2, get3)

466

237

467tests :: TestTransport -> IO [Test]

238tests :: TestTransport -> IO [Test]

468tests TestTransport{..} = do

239tests TestTransport{..} = do

469 node1 <- newLocalNode testTransport initRemoteTable

240 node1 <- newLocalNode testTransport initRemoteTable

470− node2 <- newLocalNode testTransport initRemoteTable

471 return [

241 return [

472− testGroup "MxAgents" [

242+ testGroup "Mx Agents" [

473− testCase "EventHandling"

243+ testCase "Event Handling"

474− (delayedAssertion

244+ (delayedAssertion

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

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

476− node1 True testAgentEventHandling)

246+ node1 True testAgentEventHandling)

477− , testCase "InterAgentBroadcast"

247+ , testCase "Inter-Agent Broadcast"

478− (delayedAssertion

248+ (delayedAssertion

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

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

480− node1 (Just ()) testAgentBroadcast)

250+ node1 () testAgentBroadcast)

481− , testCase "AgentMailboxHandling"

251+ , testCase "Agent Mailbox Handling"

482− (delayedAssertion

252+ (delayedAssertion

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

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

484− node1 (Just ()) testAgentMailboxHandling)

254+ node1 (Just ()) testAgentMailboxHandling)

485− , testCase "AgentDualInputHandling"

255+ , testCase "Agent Dual Input Handling"

486− (delayedAssertion

256+ (delayedAssertion

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

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

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

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

489− , testCase "AgentInputPrioritisation"

259+ , testCase "Agent Input Prioritisation"

490− (delayedAssertion

260+ (delayedAssertion

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

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

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

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

493− "third", "fourth",

263+ "third", "fourth",

494− "fifth"]) testAgentPrioritisation)

264+ "fifth"]) testAgentPrioritisation)

495− ]

265+ ],

496− , testGroup "MxEvents" [

266+ testGroup "Mx Global Properties" [

497− testCase "NameRegistrationEvents"

267+ testCase "Global Property Publication"

498− (delayedAssertion

268+ (delayedAssertion

499− "expected registration events to map to the correct ProcessId"

269+ "expected (Just Publish), but no table entry was found"

500− node1 () testMxRegEvents)

270+ node1 (Just Publish) testAgentPublication)

501− , testCase "PostDeathNameUnRegistrationEvents"

271+ , testCase "Clearing Global Properties"

272+ (delayedAssertion

273+ "expected (Just 1024, Nothing): invalid table entry found!"

274+ node1 (Just 1024, Nothing) (testAgentTableClear 1024))

275+ , testCase "Purging Global Tables"

276+ (delayedAssertion

277+ "expected Nothing, but a table entry was found"

278+ node1 Nothing testAgentTablePurge)

279+ , testCase "Deleting and (Re)Creating Global Tables"

502− (delayedAssertion

280+ (delayedAssertion

503− "expected process deaths to result in unregistration events"

281+ "expected (Just 15, Nothing, Just 15): invalid table entry found!"

504− node1 () (testMxRegMon node2))

282+ node1 (Just 15, Nothing, Just 15) (testAgentTableDelete 15))

505− , testGroup "SendEvents" $ buildTestCases node1 node2

283+ -- Wait for other tests to finish.

506− ]

284+ , testCase "Wait" $

507− ]

285+ threadDelay 100000

508− where

509− buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [

510− ("NSend", [

511− ("nsend", testNSend nsend)

512− , ("Unsafe.nsend", testNSend Unsafe.nsend)

513− , ("nsendRemote", testNSend (nsendRemote nid))

514− , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))

515− ])

516− , ("Send", [

517− ("send", testSend send)

518− , ("Unsafe.send", testSend Unsafe.send)

519− , ("usend", testSend usend)

520− , ("Unsafe.usend", testSend Unsafe.usend)

521− , ("sendChan", testChan sendChan)

522− , ("Unsafe.sendChan", testChan Unsafe.sendChan)

523− ])

524− , ("Forward", [

525− ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))

526− , ("uforward", testSend (\p m -> uforward (unsafeCreateUnencodedMessage m) p))

527− ])

528− ]

529−

530− build :: LocalNode

531− -> LocalNode

532− -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

533− -> [Test]

534− build n ln specs =

535− [ testGroup (intercalate "-" [groupName, caseSuffix]) [

536− testCase (intercalate "-" [caseName, caseSuffix])

537− (runProcess n (caseImpl caseNode))

538− | (caseName, caseImpl) <- groupCases

539− ]

540− | (groupName, groupCases) <- specs

541− , (caseSuffix, caseNode) <- [("RemotePid", Just ln), ("LocalPid", Nothing)]

542− ]

286+ ]]

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

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

11import Network.Transport (Transport)

12import Control.Distributed.Process

13+import Control.Distributed.Process.Closure

13import Control.Distributed.Process.Node

14import Control.Distributed.Process.Node

15import Control.Monad

16import Control.Monad

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

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

18−import Test.Framework (Test)

19+import Test.Framework (Test, defaultMain)

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

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

21-- Tests:

22-- Tests:

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

42 -> SendPort String

43 -> SendPort String

43 -> ReceivePort String -> ReceivePort String

44 -> ReceivePort String -> ReceivePort String

44 -> Process ()

45 -> Process ()

45−recTest2 wait sync r1 _ = do

46+recTest2 wait sync r1 r2 = do

46 forever $ do

47 forever $ do

47 receiveChan wait

48 receiveChan wait

48 r <- receiveWait

49 r <- receiveWait

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

55 -> SendPort String

56 -> SendPort String

56 -> ReceivePort String -> ReceivePort String

57 -> ReceivePort String -> ReceivePort String

57 -> Process ()

58 -> Process ()

58−recTest3 wait sync r1 _ = do

59+recTest3 wait sync r1 r2 = do

59 forever $ do

60 forever $ do

60 receiveChan wait

61 receiveChan wait

61 r <- receiveWait

62 r <- receiveWait

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

68 -> SendPort String

69 -> SendPort String

69 -> ReceivePort String -> ReceivePort String

70 -> ReceivePort String -> ReceivePort String

70 -> Process ()

71 -> Process ()

71−recTest4 wait sync r1 _ = do

72+recTest4 wait sync r1 r2 = do

72 forever $ do

73 forever $ do

73 receiveChan wait

74 receiveChan wait

74 r <- receiveWait

75 r <- receiveWait

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

82master = do

83master = do

83 (waits,waitr) <- newChan

84 (waits,waitr) <- newChan

84 (syncs,syncr) <- newChan

85 (syncs,syncr) <- newChan

85− let go expected = do

86+ let go expect = do

86 sendChan waits ()

87 sendChan waits ()

87 r <- receiveChan syncr

88 r <- receiveChan syncr

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

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

89− liftIO $ r @?= expected

90+ liftIO $ r @?= expect

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

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

92 (s1,r1) <- newChan

93 (s1,r1) <- newChan

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+7−11

@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)

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

31testLocalDeadProcessInfo result = do

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

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

33 mref <- monitor pid

34 send pid "finish"

35 _ <- receiveWait [

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

52 link self

53 mRef <- monitor self

54 stash mon mRef

55− res <- expect

55+ "die" <- expect

56− case res of

57− "die" -> return ()

56+ return ()

58− _ -> die $ "unexpected message received: " ++ res

60 monRef <- liftIO $ takeMVar mon

58 monRef <- liftIO $ takeMVar mon

@@ -86,9 +84,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

86 -- our send op shouldn't overtake link or monitor requests AFAICT

84 -- our send op shouldn't overtake link or monitor requests AFAICT

87 -- so a little table tennis should get us synchronised properly

85 -- so a little table tennis should get us synchronised properly

88 send serverPid (self, "ping")

86 send serverPid (self, "ping")

89− pong <- expect

87+ "pong" <- expect

90 pInfo <- getProcessInfo serverPid

88 pInfo <- getProcessInfo serverPid

91− stash result $ pong == "pong" && pInfo /= Nothing

89+ stash result $ pInfo /= Nothing

92 where

90 where

93 launchRemote :: MVar ProcessId -> IO ()

91 launchRemote :: MVar ProcessId -> IO ()

94 launchRemote locMV = do

92 launchRemote locMV = do

@@ -99,10 +97,8 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

99 _ <- receiveWait [

97 _ <- receiveWait [

100 match (\(pid, "ping") -> send pid "pong")

98 match (\(pid, "ping") -> send pid "pong")

101 ]

99 ]

102− res <- expect

100+ "stop" <- expect

103− case res of

104− "stop" -> return ()

101+ return ()

105− _ -> die $ "unexpected message received: " ++ res

106 return ()

102 return ()

107

103

108 withActiveRemote :: LocalNode

104 withActiveRemote :: LocalNode

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+11−23

@@ -125,11 +125,9 @@ testTraceSending result = do

125 (\ev ->

126 case ev of

127 (MxSent to from msg) -> do

128− mS <- unwrapMessage msg :: Process (Maybe String)

128+ (Just s) <- unwrapMessage msg :: Process (Maybe String)

129− case mS of

130− (Just s) -> do stash res (to == pid && from == self && s == "hello there")

129+ stash res (to == pid && from == self && s == "hello there")

131− stash res (to == pid && from == self)

130+ stash res (to == pid && from == self)

132− _ -> die "failed state invariant, message type unmatched..."

133 _ ->

131 _ ->

134 return ()) $ do

132 return ()) $ do

135 send pid "hello there"

133 send pid "hello there"

@@ -248,8 +246,12 @@ testRemoteTraceRelay TestTransport{..} result =

248 -- Here we set up that relay, and then wait for a signal

246 -- Here we set up that relay, and then wait for a signal

249 -- that the tracer (on node1) has seen the expected

247 -- that the tracer (on node1) has seen the expected

250 -- MxSpawned message, at which point we're finished

248 -- 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 ())

251

254

252− pid <- splinchLogger node2 mvNid

253 nid <- liftIO $ takeMVar mvNid

255 nid <- liftIO $ takeMVar mvNid

254 mref <- monitor pid

256 mref <- monitor pid

255 observedPid <- liftIO $ newEmptyMVar

257 observedPid <- liftIO $ newEmptyMVar

@@ -289,17 +291,6 @@ testRemoteTraceRelay TestTransport{..} result =

289 -- and just to be polite...

291 -- and just to be polite...

290 liftIO $ closeLocalNode node2

292 liftIO $ closeLocalNode node2

291

293

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−

303-- | Sets the value of an environment variable while executing the given IO

294-- | Sets the value of an environment variable while executing the given IO

304-- computation and restores the preceeding value upon completion.

295-- computation and restores the preceeding value upon completion.

305withEnv :: String -> String -> IO a -> IO a

296withEnv :: String -> String -> IO a -> IO a

@@ -328,12 +319,9 @@ testSystemLoggerMsg t action interestingMessage =

328 -- Wait for the trace message.

319 -- Wait for the trace message.

329 receiveWait [ matchIf interestingMessage' $ const $ return () ]

320 receiveWait [ matchIf interestingMessage' $ const $ return () ]

330 -- Only one interesting message should arrive.

321 -- Only one interesting message should arrive.

331− expectedTimeout <- receiveTimeout

322+ Nothing <- receiveTimeout 100000

332− 100000

333− [ matchIf interestingMessage' $ const $ return () ]

323+ [ matchIf interestingMessage' $ const $ return () ]

334− case expectedTimeout of

335− Nothing -> return ()

324+ return ()

336− Just _ -> die "Unexpected message arrived..."

337

325

338

326

339-- | Tests that one and only one trace message is produced when a message is

327-- | Tests that one and only one trace message is produced when a message is

distributed-process-tests/tests/runInMemory.hs+1

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

8import Network.Transport.InMemory

9import Test.Framework (defaultMainWithArgs)

11+import Control.Concurrent (threadDelay)

11import System.Environment (getArgs)

12import System.Environment (getArgs)

13main :: IO ()

14main :: IO ()

distributed-process-tests/tests/runTCP.hs+1−2

@@ -10,7 +10,6 @@ import Network.Transport.TCP

10 ( createTransportExposeInternals

11 , TransportInternals(socketBetween)

12 , defaultTCPParameters

13− , defaultTCPAddr

14 , TCPParameters(..)

13 , TCPParameters(..)

15 )

14 )

16import Test.Framework (defaultMainWithArgs)

15import Test.Framework (defaultMainWithArgs)

@@ -25,7 +24,7 @@ main = do

25 hSetBuffering stdout LineBuffering

24 hSetBuffering stdout LineBuffering

26 hSetBuffering stderr LineBuffering

25 hSetBuffering stderr LineBuffering

27 Right (transport, internals) <-

26 Right (transport, internals) <-

28− createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")

27+ createTransportExposeInternals "127.0.0.1" "8080"

29 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

28 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

30 ts <- tests TestTransport

29 ts <- tests TestTransport

31 { testTransport = transport

30 { testTransport = transport

distributed-process.cabal+36−50

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

1Name: distributed-process

2−Version: 0.7.4

2+Version: 0.6.4

3Cabal-Version: >=1.8

4Build-Type: Simple

5License: BSD3

6License-File: LICENSE

7Copyright: Well-Typed LLP, Tweag I/O Limited

8Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9−Maintainer: Tim Watson <watson.timothy@gmail.com>

9+Maintainer: Facundo Domínguez <facundo.dominguez@tweag.io>

10Stability: experimental

11Homepage: http://haskell-distributed.github.com/

12Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues

@@ -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.10.3 GHC==8.0.2 GHC==8.2.2 GHC==8.4.4

24+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2 GHC==7.6.2

25Category: Control

26extra-source-files: ChangeLog

@@ -41,26 +41,23 @@ flag old-locale

41 default: False

43Library

44− Build-Depends: base >= 4.6 && < 5,

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

45− binary >= 0.6.3 && < 0.10,

45+ binary >= 0.6.3 && < 0.9,

46 hashable >= 1.2.0.5 && < 1.3,

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

47+ network-transport >= 0.4.1.0 && < 0.5,

48− stm >= 2.4 && < 2.6,

48+ stm >= 2.4 && < 2.5,

49 transformers >= 0.2 && < 0.6,

50 mtl >= 2.0 && < 2.4,

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

52 bytestring >= 0.9 && < 0.11,

53 random >= 1.0 && < 1.2,

54 distributed-static >= 0.2 && < 0.4,

55− rank1dynamic >= 0.1 && < 0.5,

55+ rank1dynamic >= 0.1 && < 0.4,

56− syb >= 0.3 && < 0.8,

56+ syb >= 0.3 && < 0.7,

57− exceptions >= 0.5,

57+ exceptions >= 0.5

58− containers >= 0.5 && < 0.7,

59− deepseq >= 1.3.0.1 && < 1.6

60 Exposed-modules: Control.Distributed.Process,

58 Exposed-modules: Control.Distributed.Process,

61 Control.Distributed.Process.Closure,

59 Control.Distributed.Process.Closure,

62 Control.Distributed.Process.Debug,

60 Control.Distributed.Process.Debug,

63− Control.Distributed.Process.Internal.BiMultiMap,

64 Control.Distributed.Process.Internal.Closure.BuiltIn,

61 Control.Distributed.Process.Internal.Closure.BuiltIn,

65 Control.Distributed.Process.Internal.Closure.Explicit,

62 Control.Distributed.Process.Internal.Closure.Explicit,

66 Control.Distributed.Process.Internal.CQueue,

63 Control.Distributed.Process.Internal.CQueue,

@@ -78,6 +75,7 @@ Library

78 Control.Distributed.Process.UnsafePrimitives

75 Control.Distributed.Process.UnsafePrimitives

79 Control.Distributed.Process.Management.Internal.Agent,

76 Control.Distributed.Process.Management.Internal.Agent,

80 Control.Distributed.Process.Management.Internal.Bus,

77 Control.Distributed.Process.Management.Internal.Bus,

78+ Control.Distributed.Process.Management.Internal.Table,

81 Control.Distributed.Process.Management.Internal.Types,

79 Control.Distributed.Process.Management.Internal.Types,

82 Control.Distributed.Process.Management.Internal.Trace.Primitives,

80 Control.Distributed.Process.Management.Internal.Trace.Primitives,

83 Control.Distributed.Process.Management.Internal.Trace.Remote,

81 Control.Distributed.Process.Management.Internal.Trace.Remote,

@@ -85,33 +83,21 @@ Library

85 Control.Distributed.Process.Management.Internal.Trace.Tracer

83 Control.Distributed.Process.Management.Internal.Trace.Tracer

86 ghc-options: -Wall

84 ghc-options: -Wall

87 HS-Source-Dirs: src

85 HS-Source-Dirs: src

88− other-extensions: BangPatterns

86+ if impl(ghc <= 7.4.2)

89− CPP

87+ Build-Depends: containers >= 0.4 && < 0.5,

90− DeriveDataTypeable

88+ deepseq == 1.3.0.0

91− DeriveFunctor

89+ else

92− DeriveGeneric

90+ Build-Depends: containers >= 0.4 && < 0.6,

93− ExistentialQuantification

91+ deepseq >= 1.3.0.1 && < 1.6

94− FlexibleInstances

95− GADTs

96− GeneralizedNewtypeDeriving

97− KindSignatures

98− MagicHash

99− PatternGuards

100− RankNTypes

101− RecordWildCards

102− ScopedTypeVariables

103− StandaloneDeriving

104− TypeFamilies

105− TypeSynonymInstances

106− UnboxedTuples

107− UndecidableInstances

108 if flag(old-locale)

92 if flag(old-locale)

109 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

93 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

110 else

94 else

111 Build-Depends: time >= 1.5

95 Build-Depends: time >= 1.5

112 if flag(th)

96 if flag(th)

113− other-extensions: TemplateHaskell

97+ if impl(ghc <= 7.4.2)

98+ Build-Depends: template-haskell >= 2.7 && < 2.8

99+ else

114− Build-Depends: template-haskell >= 2.6

100+ Build-Depends: template-haskell >= 2.6 && < 2.12

115 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

101 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

116 CPP-Options: -DTemplateHaskellSupport

102 CPP-Options: -DTemplateHaskellSupport

117

103

@@ -119,50 +105,50 @@ Library

119

105

120benchmark distributed-process-throughput

106benchmark distributed-process-throughput

121 Type: exitcode-stdio-1.0

107 Type: exitcode-stdio-1.0

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

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

123 distributed-process,

109 distributed-process,

124− network-transport-tcp >= 0.3 && < 0.7,

110+ network-transport-tcp >= 0.3 && < 0.6,

125 bytestring >= 0.9 && < 0.11,

111 bytestring >= 0.9 && < 0.11,

126− binary >= 0.6.3 && < 0.10

112+ binary >= 0.6.3 && < 0.9

127 Main-Is: benchmarks/Throughput.hs

113 Main-Is: benchmarks/Throughput.hs

128 ghc-options: -Wall

114 ghc-options: -Wall

129

115

130benchmark distributed-process-latency

116benchmark distributed-process-latency

131 Type: exitcode-stdio-1.0

117 Type: exitcode-stdio-1.0

132− Build-Depends: base >= 4.6 && < 5,

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

133 distributed-process,

119 distributed-process,

134− network-transport-tcp >= 0.3 && < 0.7,

120+ network-transport-tcp >= 0.3 && < 0.6,

135 bytestring >= 0.9 && < 0.11,

121 bytestring >= 0.9 && < 0.11,

136− binary >= 0.6.3 && < 0.10

122+ binary >= 0.6.3 && < 0.9

137 Main-Is: benchmarks/Latency.hs

123 Main-Is: benchmarks/Latency.hs

138 ghc-options: -Wall

124 ghc-options: -Wall

139

125

140benchmark distributed-process-channels

126benchmark distributed-process-channels

141 Type: exitcode-stdio-1.0

127 Type: exitcode-stdio-1.0

142− Build-Depends: base >= 4.6 && < 5,

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

143 distributed-process,

129 distributed-process,

144− network-transport-tcp >= 0.3 && < 0.7,

130+ network-transport-tcp >= 0.3 && < 0.6,

145 bytestring >= 0.9 && < 0.11,

131 bytestring >= 0.9 && < 0.11,

146− binary >= 0.6.3 && < 0.10

132+ binary >= 0.6.3 && < 0.9

147 Main-Is: benchmarks/Channels.hs

133 Main-Is: benchmarks/Channels.hs

148 ghc-options: -Wall

134 ghc-options: -Wall

149

135

150benchmark distributed-process-spawns

136benchmark distributed-process-spawns

151 Type: exitcode-stdio-1.0

137 Type: exitcode-stdio-1.0

152− Build-Depends: base >= 4.6 && < 5,

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

153 distributed-process,

139 distributed-process,

154− network-transport-tcp >= 0.3 && < 0.7,

140+ network-transport-tcp >= 0.3 && < 0.6,

155 bytestring >= 0.9 && < 0.11,

141 bytestring >= 0.9 && < 0.11,

156− binary >= 0.6.3 && < 0.10

142+ binary >= 0.6.3 && < 0.9

157 Main-Is: benchmarks/Spawns.hs

143 Main-Is: benchmarks/Spawns.hs

158 ghc-options: -Wall

144 ghc-options: -Wall

159

145

160benchmark distributed-process-ring

146benchmark distributed-process-ring

161 Type: exitcode-stdio-1.0

147 Type: exitcode-stdio-1.0

162− Build-Depends: base >= 4.6 && < 5,

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

163 distributed-process,

149 distributed-process,

164− network-transport-tcp >= 0.3 && < 0.7,

150+ network-transport-tcp >= 0.3 && < 0.6,

165 bytestring >= 0.9 && < 0.11,

151 bytestring >= 0.9 && < 0.11,

166− binary >= 0.6.3 && < 0.10

152+ binary >= 0.6.3 && < 0.9

167 Main-Is: benchmarks/ProcessRing.hs

153 Main-Is: benchmarks/ProcessRing.hs

168 ghc-options: -Wall -threaded -O2 -rtsopts

154 ghc-options: -Wall -threaded -O2 -rtsopts

src/Control/Distributed/Process.hs−2

@@ -102,7 +102,6 @@ module Control.Distributed.Process

102 , monitorPort

103 , unmonitor

104 , withMonitor

105− , withMonitor_

106 , MonitorRef -- opaque

105 , MonitorRef -- opaque

107 , ProcessLinkException(..)

106 , ProcessLinkException(..)

108 , NodeLinkException(..)

107 , NodeLinkException(..)

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

270 , monitorPort

269 , monitorPort

271 , unmonitor

270 , unmonitor

272 , withMonitor

271 , withMonitor

273− , withMonitor_

274 -- Logging

272 -- Logging

275 , say

273 , say

276 -- Registry

274 -- Registry

src/Control/Distributed/Process/Internal/BiMultiMap.hsdeleted−135

@@ -1,135 +0,0 @@

1−-- | This is an implementation of bidirectional multimaps.

2−module Control.Distributed.Process.Internal.BiMultiMap

3− ( BiMultiMap

4− , empty

5− , singleton

6− , size

7− , insert

8− , lookupBy1st

9− , lookupBy2nd

10− , delete

11− , deleteAllBy1st

12− , deleteAllBy2nd

13− , partitionWithKeyBy1st

14− , partitionWithKeyBy2nd

15− , flip

16− ) where

17−

18−import Data.List (foldl')

19−import Data.Map.Strict (Map)

20−import qualified Data.Map.Strict as Map

21−import Data.Set (Set)

22−import qualified Data.Set as Set

23−import Prelude hiding (flip, lookup)

24−

25−-- | A bidirectional multimaps @BiMultiMap a b v@ is a set of triplets of type

26−-- @(a, b, v)@.

27−--

28−-- It is possible to lookup values by using either @a@ or @b@ as keys.

29−--

30−data BiMultiMap a b v = BiMultiMap !(Map a (Set (b, v))) !(Map b (Set (a, v)))

31−

32−-- The bidirectional multimap is implemented with a pair of multimaps.

33−--

34−-- Each multimap represents a set of triples, and one invariant is that both

35−-- multimaps should represent exactly the same set of triples.

36−--

37−-- Each of the multimaps, however, uses a different component of the triplets

38−-- as key. This allows to do efficient deletions by any of the two components.

39−

40−-- | The empty bidirectional multimap.

41−empty :: BiMultiMap a b v

42−empty = BiMultiMap Map.empty Map.empty

43−

44−-- | A bidirectional multimap containing a single triplet.

45−singleton :: (Ord a, Ord b, Ord v) => a -> b -> v -> BiMultiMap a b v

46−singleton a b v = insert a b v empty

47−

48−-- | Yields the amount of triplets in the multimap.

49−size :: BiMultiMap a b v -> Int

50−size (BiMultiMap m _) = foldl' (+) 0 $ map Set.size $ Map.elems m

51−

52−-- | Inserts a triplet in the multimap.

53−insert :: (Ord a, Ord b, Ord v)

54− => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

55−insert a b v (BiMultiMap m r) =

56− BiMultiMap (Map.insertWith (\_new old -> Set.insert (b, v) old)

57− a

58− (Set.singleton (b, v))

59− m)

60− (Map.insertWith (\_new old -> Set.insert (a, v) old)

61− b

62− (Set.singleton (a, v))

63− r)

64−

65−-- | Looks up all the triplets whose first component is the given value.

66−lookupBy1st :: Ord a => a -> BiMultiMap a b v -> Set (b, v)

67−lookupBy1st a (BiMultiMap m _) = maybe Set.empty id $ Map.lookup a m

68−

69−-- | Looks up all the triplets whose second component is the given value.

70−lookupBy2nd :: Ord b => b -> BiMultiMap a b v -> Set (a, v)

71−lookupBy2nd b = lookupBy1st b . flip

72−

73−-- | Deletes a triplet. It yields the original multimap if the triplet is

74−-- not present.

75−delete :: (Ord a, Ord b, Ord v)

76− => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

77−delete a b v (BiMultiMap m r) =

78− let m' = Map.update (nothingWhen Set.null . Set.delete (b, v)) a m

79− r' = Map.update (nothingWhen Set.null . Set.delete (a, v)) b r

80− in BiMultiMap m' r'

81−

82−-- | Deletes all triplets whose first component is the given value.

83−deleteAllBy1st :: (Ord a, Ord b, Ord v) => a -> BiMultiMap a b v -> BiMultiMap a b v

84−deleteAllBy1st a (BiMultiMap m r) =

85− let (mm, m') = Map.updateLookupWithKey (\_ _ -> Nothing) a m

86− r' = case mm of

87− Nothing -> r

88− Just mb -> reverseDelete a (Set.toList mb) r

89− in BiMultiMap m' r'

90−

91−-- | Like 'deleteAllBy1st' but deletes by the second component of the triplets.

92−deleteAllBy2nd :: (Ord a, Ord b, Ord v)

93− => b -> BiMultiMap a b v -> BiMultiMap a b v

94−deleteAllBy2nd b = flip . deleteAllBy1st b . flip

95−

96−-- | Yields the triplets satisfying the given predicate, and a multimap

97−-- with all this triplets removed.

98−partitionWithKeyBy1st :: (Ord a, Ord b, Ord v)

99− => (a -> Set (b, v) -> Bool) -> BiMultiMap a b v

100− -> (Map a (Set (b, v)), BiMultiMap a b v)

101−partitionWithKeyBy1st p (BiMultiMap m r) =

102− let (m0, m1) = Map.partitionWithKey p m

103− r1 = foldl' (\rr (a, mb) -> reverseDelete a (Set.toList mb) rr) r $

104− Map.toList m0

105− in (m0, BiMultiMap m1 r1)

106−

107−-- | Like 'partitionWithKeyBy1st' but the predicates takes the second component

108−-- of the triplets as first argument.

109−partitionWithKeyBy2nd :: (Ord a, Ord b, Ord v)

110− => (b -> Set (a, v) -> Bool) -> BiMultiMap a b v

111− -> (Map b (Set (a, v)), BiMultiMap a b v)

112−partitionWithKeyBy2nd p b = let (m, b') = partitionWithKeyBy1st p $ flip b

113− in (m, flip b')

114−

115−-- | Exchange the first and the second components of all triplets.

116−flip :: BiMultiMap a b v -> BiMultiMap b a v

117−flip (BiMultiMap m r) = BiMultiMap r m

118−

119−-- Internal functions

120−

121−-- | @reverseDelete a bs m@ removes from @m@ all the triplets wich have @a@ as

122−-- first component and second and third components in @bs@.

123−--

124−-- The @m@ map is in reversed form, meaning that the second component of the

125−-- triplets is used as key.

126−reverseDelete :: (Ord a, Ord b, Ord v)

127− => a -> [(b, v)] -> Map b (Set (a, v)) -> Map b (Set (a, v))

128−reverseDelete a bs r = foldl' (\rr (b, v) -> Map.update (rmb v) b rr) r bs

129− where

130− rmb v = nothingWhen Set.null . Set.delete (a, v)

131−

132−-- | @nothingWhen p a@ is @Just a@ when @a@ satisfies predicate @p@.

133−-- Yields @Nothing@ otherwise.

134−nothingWhen :: (a -> Bool) -> a -> Maybe a

135−nothingWhen p a = if p a then Nothing else Just a

src/Control/Distributed/Process/Internal/Messaging.hs+1−1

@@ -201,7 +201,7 @@ sendCtrlMsg mNid signal = do

201 liftIO $ writeChan (localCtrlChan (processNode proc)) $! msg

202 Just nid ->

203 liftIO $ sendBinary (processNode proc)

204− (NodeIdentifier (processNodeId $ processId proc))

204+ (ProcessIdentifier (processId proc))

205 (NodeIdentifier nid)

206 WithImplicitReconnect

207 msg

src/Control/Distributed/Process/Internal/Primitives.hs+58−130

@@ -76,11 +76,8 @@ module Control.Distributed.Process.Internal.Primitives

76 , unlink

77 , monitor

78 , unmonitor

79− , unmonitorAsync

80 , withMonitor

79 , withMonitor

81− , withMonitor_

82 -- * Logging

80 -- * Logging

83− , SayMessage(..)

84 , say

81 , say

85 -- * Registry

82 -- * Registry

86 , register

83 , register

@@ -128,9 +125,8 @@ module Control.Distributed.Process.Internal.Primitives

128import Prelude hiding (catch)

125import Prelude hiding (catch)

129#endif

126#endif

130

127

131−import Data.Binary (Binary(..), Put, Get, decode)

128+import Data.Binary (decode)

132−import Data.Time.Clock (getCurrentTime, UTCTime(..))

129+import Data.Time.Clock (getCurrentTime)

133−import Data.Time.Calendar (Day(..))

134import Data.Time.Format (formatTime)

130import Data.Time.Format (formatTime)

135#if MIN_VERSION_time(1,5,0)

131#if MIN_VERSION_time(1,5,0)

136import Data.Time.Format (defaultTimeLocale)

132import Data.Time.Format (defaultTimeLocale)

@@ -138,7 +134,7 @@ import Data.Time.Format (defaultTimeLocale)

138import System.Locale (defaultTimeLocale)

134import System.Locale (defaultTimeLocale)

139#endif

135#endif

140import System.Timeout (timeout)

136import System.Timeout (timeout)

141−import Control.Monad (when, void)

137+import Control.Monad (when)

142import Control.Monad.Reader (ask)

138import Control.Monad.Reader (ask)

143import Control.Monad.IO.Class (liftIO)

139import Control.Monad.IO.Class (liftIO)

144import Control.Monad.Catch

140import Control.Monad.Catch

@@ -188,7 +184,6 @@ import Control.Distributed.Process.Internal.Types

188 , SpawnRef(..)

184 , SpawnRef(..)

189 , ProcessSignal(..)

185 , ProcessSignal(..)

190 , NodeMonitorNotification(..)

186 , NodeMonitorNotification(..)

191− , ProcessMonitorNotification(..)

192 , monitorCounter

187 , monitorCounter

193 , spawnCounter

188 , spawnCounter

194 , SendPort(..)

189 , SendPort(..)

@@ -254,15 +249,17 @@ send them msg = do

254 node = processNode proc

249 node = processNode proc

255 nodeId = localNodeId node

250 nodeId = localNodeId node

256 destNode = (processNodeId them) in do

251 destNode = (processNodeId them) in do

252+ case destNode == nodeId of

253+ True -> sendLocal them msg

254+ False -> liftIO $ sendMessage (processNode proc)

255+ (ProcessIdentifier (processId proc))

256+ (ProcessIdentifier them)

257+ NoImplicitReconnect

258+ msg

259+ -- We do not fire the trace event until after the sending is complete;

260+ -- In the remote case, 'sendMessage' can block in the networking stack.

257 liftIO $ traceEvent (localEventBus node)

261 liftIO $ traceEvent (localEventBus node)

258 (MxSent them us (createUnencodedMessage msg))

262 (MxSent them us (createUnencodedMessage msg))

259− if destNode == nodeId

260− then sendLocal them msg

261− else liftIO $ sendMessage (processNode proc)

262− (ProcessIdentifier (processId proc))

263− (ProcessIdentifier them)

264− NoImplicitReconnect

265− msg

266

263

267-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

264-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

268-- and (in the case when the destination process resides on the same local

265-- and (in the case when the destination process resides on the same local

@@ -282,12 +279,9 @@ unsafeSend = Unsafe.send

282--

279--

283usend :: Serializable a => ProcessId -> a -> Process ()

280usend :: Serializable a => ProcessId -> a -> Process ()

284usend them msg = do

281usend them msg = do

285− proc <- ask

282+ here <- getSelfNode

286 let there = processNodeId them

283 let there = processNodeId them

287− let (us, node) = (processId proc, processNode proc)

284+ if here == there

288− let msg' = wrapMessage msg

289− liftIO $ traceEvent (localEventBus node) (MxSent them us msg')

290− if localNodeId (processNode proc) == there

291 then sendLocal them msg

285 then sendLocal them msg

292 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

286 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

293 (createMessage msg)

287 (createMessage msg)

@@ -307,13 +301,7 @@ expect = receiveWait [match return]

307-- Channels --

301-- Channels --

308--------------------------------------------------------------------------------

302--------------------------------------------------------------------------------

309

303

310−-- | Create a new typed channel, bound to the calling Process

304+-- | Create a new typed channel

311−--

312−-- Note that the channel is bound to the lifecycle of the process that evaluates

313−-- this function, such that when it dies/exits, the channel will no longer

314−-- function, but will remain accessible. Thus reading from the ReceivePort will

315−-- fail silently thereafter, blocking indefinitely (unless a timeout is used).

316−--

317newChan :: Serializable a => Process (SendPort a, ReceivePort a)

305newChan :: Serializable a => Process (SendPort a, ReceivePort a)

318newChan = do

306newChan = do

319 proc <- ask

307 proc <- ask

@@ -341,16 +329,13 @@ newChan = do

341sendChan :: Serializable a => SendPort a -> a -> Process ()

329sendChan :: Serializable a => SendPort a -> a -> Process ()

342sendChan (SendPort cid) msg = do

330sendChan (SendPort cid) msg = do

343 proc <- ask

331 proc <- ask

344− let node = processNode proc

345− pid = processId proc

346− us = localNodeId node

332+ let node = localNodeId (processNode proc)

347− them = processNodeId (sendPortProcessId cid) in do

333+ destNode = processNodeId (sendPortProcessId cid) in do

348− liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)

349− case them == us of

334+ case destNode == node of

350 True -> sendChanLocal cid msg

335 True -> sendChanLocal cid msg

351 False -> do

336 False -> do

352− liftIO $ sendBinary node

337+ liftIO $ sendBinary (processNode proc)

353− (ProcessIdentifier pid)

338+ (ProcessIdentifier (processId proc))

354 (SendPortIdentifier cid)

339 (SendPortIdentifier cid)

355 NoImplicitReconnect

340 NoImplicitReconnect

356 msg

341 msg

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

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

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

412receiveWait ms = do

397receiveWait ms = do

413 queue <- processQueue <$> ask

398 queue <- processQueue <$> ask

414− mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)

399+ Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)

415− case mProc of

416− Just proc' -> proc'

400+ proc

417− Nothing -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "

418− ++ "in the absence of a timeout value."

419

401

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

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

421--

403--

@@ -494,14 +476,17 @@ forward msg them = do

494 us = processId proc

476 us = processId proc

495 nid = localNodeId node

477 nid = localNodeId node

496 destNode = (processNodeId them) in do

478 destNode = (processNodeId them) in do

497− liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

498− if destNode == nid

479+ case destNode == nid of

499− then sendCtrlMsg Nothing (LocalSend them msg)

480+ True -> sendCtrlMsg Nothing (LocalSend them msg)

500− else liftIO $ sendPayload (processNode proc)

481+ False -> liftIO $ sendPayload (processNode proc)

501− (ProcessIdentifier (processId proc))

482+ (ProcessIdentifier (processId proc))

502− (ProcessIdentifier them)

483+ (ProcessIdentifier them)

503− NoImplicitReconnect

484+ NoImplicitReconnect

504− (messageToPayload msg)

485+ (messageToPayload msg)

486+ -- We do not fire the trace event until after the sending is complete;

487+ -- In the remote case, 'sendMessage' can block in the networking stack.

488+ liftIO $ traceEvent (localEventBus node)

489+ (MxSent them us msg)

505

490

506-- | Forward a raw 'Message' to the given 'ProcessId'.

491-- | Forward a raw 'Message' to the given 'ProcessId'.

507--

492--

@@ -515,10 +500,14 @@ uforward msg them = do

515 us = processId proc

500 us = processId proc

516 nid = localNodeId node

501 nid = localNodeId node

517 destNode = (processNodeId them) in do

502 destNode = (processNodeId them) in do

518− liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

519− if destNode == nid

503+ case destNode == nid of

520− then sendCtrlMsg Nothing (LocalSend them msg)

504+ True -> sendCtrlMsg Nothing (LocalSend them msg)

521− else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg

505+ False -> sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them)

506+ msg

507+ -- We do not fire the trace event until after the sending is complete;

508+ -- In the remote case, 'sendCtrlMsg' can block in the networking stack.

509+ liftIO $ traceEvent (localEventBus node)

510+ (MxSent them us msg)

522

511

523-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

512-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

524-- 'Serializable' - like the datum they contain - but also note, deserialising

513-- 'Serializable' - like the datum they contain - but also note, deserialising

@@ -896,19 +885,12 @@ monitor = monitor' . ProcessIdentifier

896-- @withMonitor@ returns, there might still be unreceived monitor

885-- @withMonitor@ returns, there might still be unreceived monitor

897-- messages in the queue.

886-- messages in the queue.

898--

887--

899−withMonitor :: ProcessId -> (MonitorRef -> Process a) -> Process a

888+withMonitor :: ProcessId -> Process a -> Process a

900−withMonitor pid = bracket (monitor pid) unmonitor

889+withMonitor pid code = bracket (monitor pid) unmonitor (\_ -> code)

901−

890+ -- unmonitor blocks waiting for the response, so there's a possibility

902−-- | Establishes temporary monitoring of another process.

891+ -- that an exception might interrupt withMonitor before the unmonitor

903−--

892+ -- has completed. I think that's better than making the unmonitor

904−-- @withMonitor_ pid code@ sets up monitoring of @pid@ for the duration

893+ -- uninterruptible.

905−-- of @code@. Note: although monitoring is no longer active when

906−-- @withMonitor_@ returns, there might still be unreceived monitor

907−-- messages in the queue.

908−--

909−-- Since 0.6.1

910−withMonitor_ :: ProcessId -> Process a -> Process a

911−withMonitor_ p = withMonitor p . const

912

894

913-- | Remove a link

895-- | Remove a link

914--

896--

@@ -946,21 +928,12 @@ unlinkPort sport = do

946-- | Remove a monitor

928-- | Remove a monitor

947--

929--

948-- This has the same synchronous/asynchronous nature as 'unlink'.

930-- This has the same synchronous/asynchronous nature as 'unlink'.

949−--

950−-- ProcessMonitorNotification messages for the given MonitorRef are removed from

951−-- the mailbox.

952unmonitor :: MonitorRef -> Process ()

931unmonitor :: MonitorRef -> Process ()

953unmonitor ref = do

932unmonitor ref = do

954 unmonitorAsync ref

933 unmonitorAsync ref

955 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

934 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

956 (\_ -> return ())

935 (\_ -> return ())

957 ]

936 ]

958− -- Discard the notification if any. With the current NC implementation at most

959− -- one notification is in the mailbox for any given ref.

960− void $ receiveTimeout 0

961− [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == ref)

962− (const $ return ())

963− ]

964

937

965--------------------------------------------------------------------------------

938--------------------------------------------------------------------------------

966-- Exception handling --

939-- Exception handling --

@@ -974,7 +947,7 @@ catch = Catch.catch

974-- | Lift 'Control.Exception.try'

947-- | Lift 'Control.Exception.try'

975try :: Exception e => Process a -> Process (Either e a)

948try :: Exception e => Process a -> Process (Either e a)

976try = Catch.try

949try = Catch.try

977−{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}

950+{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}

978

951

979-- | Lift 'Control.Exception.mask'

952-- | Lift 'Control.Exception.mask'

980mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

953mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

@@ -1086,52 +1059,17 @@ unlinkPortAsync (SendPort cid) =

1086-- Logging --

1059-- Logging --

1087--------------------------------------------------------------------------------

1060--------------------------------------------------------------------------------

1088

1061

1089−data SayMessage = SayMessage { sayTime :: UTCTime

1090− , sayProcess :: ProcessId

1091− , sayMessage :: String }

1092− deriving (Typeable)

1093−

1094−-- There is sadly no Show UTCTime instance

1095−instance Show SayMessage where

1096− showsPrec p msg =

1097− showParen (p >= 11)

1098− $ showString "SayMessage "

1099− . showString (formatTime defaultTimeLocale "%c" (sayTime msg))

1100− . showChar ' '

1101− . showsPrec 11 (sayProcess msg) . showChar ' '

1102− . showsPrec 11 (sayMessage msg) . showChar ' '

1103−

1104−instance Binary SayMessage where

1105− put s = do

1106− putUTCTime (sayTime s)

1107− put (sayProcess s)

1108− put (sayMessage s)

1109− get = SayMessage <$> getUTCTime <*> get <*> get

1110−

1111−-- Sadly there is no Binary UTCTime instance

1112−putUTCTime :: UTCTime -> Put

1113−putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do

1114− put day

1115− put (toRational tod)

1116−

1117−getUTCTime :: Get UTCTime

1118−getUTCTime = do

1119− day <- get

1120− tod <- get

1121− return $! UTCTime (ModifiedJulianDay day)

1122− (fromRational tod)

1123−

1124-- | Log a string

1062-- | Log a string

1125--

1063--

1126−-- @say message@ sends a message of type 'SayMessage' with the current time and

1064+-- @say message@ sends a message (time, pid of the current process, message)

1127−-- 'ProcessId' of the current process to the process registered as @logger@. By

1065+-- to the process registered as 'logger'. By default, this process simply

1128−-- default, this process simply sends the string to @stderr@. Individual Cloud

1066+-- sends the string to 'stderr'. Individual Cloud Haskell backends might

1129−-- Haskell backends might replace this with a different logger process, however.

1067+-- replace this with a different logger process, however.

1130say :: String -> Process ()

1068say :: String -> Process ()

1131say string = do

1069say string = do

1132 now <- liftIO getCurrentTime

1070 now <- liftIO getCurrentTime

1133 us <- getSelfPid

1071 us <- getSelfPid

1134− nsend "logger" (SayMessage now us string)

1072+ nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

1135

1073

1136--------------------------------------------------------------------------------

1074--------------------------------------------------------------------------------

1137-- Registry --

1075-- Registry --

@@ -1227,12 +1165,8 @@ whereisRemoteAsync nid label = do

1227

1165

1228-- | Named send to a process in the local registry (asynchronous)

1166-- | Named send to a process in the local registry (asynchronous)

1229nsend :: Serializable a => String -> a -> Process ()

1167nsend :: Serializable a => String -> a -> Process ()

1230−nsend label msg = do

1168+nsend label msg =

1231− proc <- ask

1232− let msg' = createUnencodedMessage msg

1233− liftIO $ traceEvent (localEventBus (processNode proc))

1234− (MxSentToName label (processId proc) msg')

1235− sendCtrlMsg Nothing (NamedSend label msg')

1169+ sendCtrlMsg Nothing (NamedSend label (createUnencodedMessage msg))

1236

1170

1237-- | Named send to a process in the local registry (asynchronous).

1171-- | Named send to a process in the local registry (asynchronous).

1238-- This function makes /no/ attempt to serialize and (in the case when the

1172-- This function makes /no/ attempt to serialize and (in the case when the

@@ -1244,15 +1178,9 @@ unsafeNSend = Unsafe.nsend

1244-- | Named send to a process in a remote registry (asynchronous)

1178-- | Named send to a process in a remote registry (asynchronous)

1245nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1179nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1246nsendRemote nid label msg = do

1180nsendRemote nid label msg = do

1247− proc <- ask

1181+ here <- getSelfNode

1248− let us = processId proc

1249− let node = processNode proc

1250− if localNodeId node == nid

1251− then nsend label msg

1182+ if here == nid then nsend label msg

1252− else let lbl = label ++ "@" ++ show nid in do

1253− liftIO $ traceEvent (localEventBus node)

1254− (MxSentToName lbl us (wrapMessage msg))

1255− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1183+ else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1256

1184

1257-- | Named send to a process in a remote registry (asynchronous)

1185-- | Named send to a process in a remote registry (asynchronous)

1258-- This function makes /no/ attempt to serialize and (in the case when the

1186-- This function makes /no/ attempt to serialize and (in the case when the

src/Control/Distributed/Process/Internal/Spawn.hs+3−3

@@ -43,7 +43,7 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

43 )

44import Control.Distributed.Process.Internal.Primitives

45 ( -- Basic messaging

46− usend

46+ send

47 , expect

48 , receiveWait

49 , match

@@ -71,7 +71,7 @@ spawn nid proc = do

71 receiveWait [

72 matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do

73 unmonitor mRef

74− usend pid ()

74+ send pid ()

75 return pid

76 , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) $ \_ ->

77 return (nullProcessId nid)

@@ -118,7 +118,7 @@ call dict nid proc = do

118 cpDelayed us (returnCP sdictUnit ())

119 )

120 mResult <- receiveWait

121− [ match $ \a -> usend pid () >> return (Right a)

121+ [ match $ \a -> send pid () >> return (Right a)

122 , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

123 (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

124 ]

src/Control/Distributed/Process/Internal/Types.hs+1−9

@@ -366,14 +366,6 @@ instance MonadCatch Process where

366 lproc <- ask

367 liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

368instance MonadMask Process where

369−#if MIN_VERSION_exceptions(0,10,0)

370− generalBracket acquire release inner = do

371− lproc <- ask

372− liftIO $

373− generalBracket (runLocalProcess lproc acquire)

374− (\a e -> runLocalProcess lproc $ release a e)

375− (runLocalProcess lproc . inner)

376−#endif

377 mask p = do

369 mask p = do

378 lproc <- ask

370 lproc <- ask

379 liftIO $ mask $ \restore ->

371 liftIO $ mask $ \restore ->

@@ -637,7 +629,7 @@ newtype DidUnlinkPort = DidUnlinkPort SendPortId

637

629

638-- | 'SpawnRef' are used to return pids of spawned processes

630-- | 'SpawnRef' are used to return pids of spawned processes

639newtype SpawnRef = SpawnRef Int32

631newtype SpawnRef = SpawnRef Int32

640− deriving (Show, Binary, Typeable, Eq, Ord)

632+ deriving (Show, Binary, Typeable, Eq)

641

633

642-- | (Asynchronius) reply from 'spawn'

634-- | (Asynchronius) reply from 'spawn'

643data DidSpawn = DidSpawn SpawnRef ProcessId

635data DidSpawn = DidSpawn SpawnRef ProcessId

src/Control/Distributed/Process/Management.hs+81−38

@@ -76,40 +76,6 @@

76--

77-- * Whether messages will be taken from the mailbox first, or the event bus.

78--

79−-- Since the event bus uses STM broadcast channels to communicate with agents,

80−-- no message written to the bus successfully can be lost.

81−--

82−-- Agents can also receive messages via their mailboxes - these are subject to

83−-- the same guarantees as all inter-process message sending.

84−--

85−-- Messages dispatched on an STM broadcast channel (i.e., management event bus)

86−-- are guaranteed to be delivered with the same FIFO ordering guarantees that

87−-- exist between two communicating processes, such that communication from the

88−-- node controller's threads (i.e., MxEvent's) will never be re-ordered, but

89−-- messages dispatched to the event bus by other processes (including, but not

90−-- limited to agents) are only guaranteed to be ordered between one sender and

91−-- one receiver.

92−--

93−-- No guarantee exists for the ordering in which messages sent to an agent's

94−-- mailbox will be delivered, vs messages dispatched via the event bus.

95−--

96−-- Because of the above, there are no ordering guarantees for messages sent

97−-- between agents, or for processes to agents, except for those that apply to

98−-- messages sent between regular processes, since agents are

99−-- implemented as such.

100−--

101−-- The event bus is serial and single threaded. Anything that is published by

102−-- the node controller will be seen in FIFO order. There are no ordering

103−-- guarantees pertaining to entries published to the event bus by other

104−-- processes or agents.

105−--

106−-- It should not be possible to see, for example, an @MxReceived@ before the

107−-- corresponding @MxSent@ event, since the places where we issue the @MxSent@

108−-- write directly to the event bus (using STM) in the calling (green) thread,

109−-- before dispatching instructions to the node controller to perform the

110−-- necessary routing to deliver the message to a process (or registered name,

111−-- or typed channel) locally or remotely.

112−--

113-- [Management Data API]

79-- [Management Data API]

114--

80--

115-- Both management agents and clients of the API have access to a variety of

81-- Both management agents and clients of the API have access to a variety of

@@ -117,8 +83,28 @@

117-- system information. Agents maintain their own internal state privately (via a

83-- system information. Agents maintain their own internal state privately (via a

118-- state transformer - see 'mxGetLocal' et al), however it is possible for

84-- state transformer - see 'mxGetLocal' et al), however it is possible for

119-- agents to share additional data with each other (and the outside world)

85-- agents to share additional data with each other (and the outside world)

120−-- using whatever mechanism the user wishes, e.g., acidstate, or shared memory

86+-- using /data tables/.

121−-- primitives.

87+--

88+-- Each agent is assigned its own data table, which acts as a shared map, where

89+-- the keys are @String@s and the values are @Serializable@ datum of whatever

90+-- type the agent or its clients stores.

91+--

92+-- Because an agent's /data table/ stores its values in raw 'Message' format,

93+-- it works effectively as an /un-typed dictionary/, into which data of varying

94+-- types can be fed and later retrieved. The upside of this is that different

95+-- keys can be mapped to various types without any additional work on the part

96+-- of the developer. The downside is that the code reading these values must

97+-- know in advance what type(s) to expect, and the API provides no additional

98+-- support for handling that.

99+--

100+-- Publishing is accomplished using the 'mxPublish' and 'mxSet' APIs, whilst

101+-- querying and deletion are handled by 'mxGet', 'mxClear', 'mxPurgeTable' and

102+-- 'mxDropTable' respectively.

103+--

104+-- When a management agent terminates, their tables are left in memory despite

105+-- termination, such that an agent may resume its role (by restarting) or have

106+-- its 'MxAgentId' taken over by another subsequent agent, leaving the data

107+-- originally captured in place.

122--

108--

123-- [Defining Agents]

109-- [Defining Agents]

124--

110--

@@ -178,6 +164,8 @@

178-- > monitorNames = getSelfPid >>= nsend "name-monitor"

164-- > monitorNames = getSelfPid >>= nsend "name-monitor"

179-- > monitorNames2 = getSelfPid >>= mxNotify

165-- > monitorNames2 = getSelfPid >>= mxNotify

180--

166--

167+-- For some real-world examples, see the distributed-process-platform package.

168+--

181-- [Performance, Stablity and Scalability]

169-- [Performance, Stablity and Scalability]

182--

170--

183-- /Management Agents/ offer numerous advantages over regular processes:

171-- /Management Agents/ offer numerous advantages over regular processes:

@@ -206,6 +194,10 @@

206-- the event bus /and/ their own mailboxes, plus searching through the set of

194-- the event bus /and/ their own mailboxes, plus searching through the set of

207-- event sinks (for each agent) to determine the right handler for the event.

195-- event sinks (for each agent) to determine the right handler for the event.

208--

196--

197+-- Each management agent requires not only its own @Process@ (in which the agent

198+-- code is run), but also a peer process that provides its /data table/. These

199+-- data tables also have to be coordinated and manaaged on each agent's behalf.

200+--

209-- [Architecture Overview]

201-- [Architecture Overview]

210--

202--

211-- The architecture of the management event bus is internal and subject to

203-- The architecture of the management event bus is internal and subject to

@@ -272,6 +264,13 @@ module Control.Distributed.Process.Management

272 , mxGetLocal

264 , mxGetLocal

273 , mxUpdateLocal

265 , mxUpdateLocal

274 , liftMX

266 , liftMX

267+ -- * Mx Data API

268+ , mxPublish

269+ , mxSet

270+ , mxGet

271+ , mxClear

272+ , mxPurgeTable

273+ , mxDropTable

275 ) where

274 ) where

276

275

277import Control.Applicative

276import Control.Applicative

@@ -282,7 +281,10 @@ import Control.Concurrent.STM.TChan

282 , TChan

281 , TChan

283 )

282 )

284import Control.Distributed.Process.Internal.Primitives

283import Control.Distributed.Process.Internal.Primitives

284+ ( newChan

285+ , nsend

285− ( receiveWait

286+ , receiveWait

287+ , matchChan

286 , matchAny

288 , matchAny

287 , matchSTM

289 , matchSTM

288 , unwrapMessage

290 , unwrapMessage

@@ -300,12 +302,14 @@ import Control.Distributed.Process.Internal.Types

300 , unsafeCreateUnencodedMessage

302 , unsafeCreateUnencodedMessage

301 )

303 )

302import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

304import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

305+import qualified Control.Distributed.Process.Management.Internal.Table as Table

303import Control.Distributed.Process.Management.Internal.Types

306import Control.Distributed.Process.Management.Internal.Types

304 ( MxAgentId(..)

307 ( MxAgentId(..)

305 , MxAgent(..)

308 , MxAgent(..)

306 , MxAction(..)

309 , MxAction(..)

307 , ChannelSelector(..)

310 , ChannelSelector(..)

308 , MxAgentState(..)

311 , MxAgentState(..)

312+ , MxAgentStart(..)

309 , MxSink

313 , MxSink

310 , MxEvent(..)

314 , MxEvent(..)

311 )

315 )

@@ -331,6 +335,42 @@ mxNotify msg = do

331 bus <- localEventBus . processNode <$> ask

335 bus <- localEventBus . processNode <$> ask

332 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

336 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

333

337

338+-- | Publish an arbitrary @Message@ as a property in the management database.

339+--

340+-- For publishing @Serializable@ data, use 'mxSet' instead.

341+--

342+mxPublish :: MxAgentId -> String -> Message -> Process ()

343+mxPublish a k v = Table.set k v (Table.MxForAgent a)

344+

345+-- | Sets an arbitrary @Serializable@ datum against a key in the management

346+-- database. Note that /no attempt is made to force the argument/, therefore

347+-- it is very important that you do not pass unevaluated thunks that might

348+-- crash some other, arbitrary process (or management agent!) that obtains

349+-- and attempts to force the value later on.

350+--

351+mxSet :: Serializable a => MxAgentId -> String -> a -> Process ()

352+mxSet mxId key msg = do

353+ Table.set key (unsafeCreateUnencodedMessage msg) (Table.MxForAgent mxId)

354+

355+-- | Fetches a property from the management database for the given key.

356+-- If the property is not set, or does not match the expected type when

357+-- typechecked (at runtime), returns @Nothing@.

358+mxGet :: Serializable a => MxAgentId -> String -> Process (Maybe a)

359+mxGet = Table.fetch . Table.MxForAgent

360+

361+-- | Clears a property from the management database using the given key.

362+-- If the key does not exist in the database, this is a noop.

363+mxClear :: MxAgentId -> String -> Process ()

364+mxClear mxId key = Table.clear key (Table.MxForAgent mxId)

365+

366+-- | Purges a table in the management database of all its stored properties.

367+mxPurgeTable :: MxAgentId -> Process ()

368+mxPurgeTable = Table.purge . Table.MxForAgent

369+

370+-- | Deletes a table from the management database.

371+mxDropTable :: MxAgentId -> Process ()

372+mxDropTable = Table.delete . Table.MxForAgent

373+

334--------------------------------------------------------------------------------

374--------------------------------------------------------------------------------

335-- API for writing user defined management extensions (i.e., agents) --

375-- API for writing user defined management extensions (i.e., agents) --

336--------------------------------------------------------------------------------

376--------------------------------------------------------------------------------

@@ -450,7 +490,10 @@ mxAgentWithFinalize mxId initState handlers dtor = do

450 return pid

490 return pid

451 where

491 where

452 start (sendTChan, recvTChan) = do

492 start (sendTChan, recvTChan) = do

493+ (sp, rp) <- newChan

494+ nsend Table.mxTableCoordinator (MxAgentStart sp mxId)

495+ tablePid <- receiveWait [ matchChan rp (\(p :: ProcessId) -> return p) ]

453− let nState = MxAgentState mxId sendTChan initState

496+ let nState = MxAgentState mxId sendTChan tablePid initState

454 runAgent dtor handlers InputChan recvTChan nState

497 runAgent dtor handlers InputChan recvTChan nState

455

498

456 runAgent :: MxAgent s ()

499 runAgent :: MxAgent s ()

src/Control/Distributed/Process/Management/Internal/Table.hsnew file+222

@@ -0,0 +1,222 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE RecordWildCards #-}

7+module Control.Distributed.Process.Management.Internal.Table

8+ ( MxTableRequest(..)

9+ , MxTableId(..)

10+ , mxTableCoordinator

11+ , startTableCoordinator

12+ , delete

13+ , purge

14+ , clear

15+ , set

16+ , get

17+ , fetch

18+ ) where

19+

20+import Control.Distributed.Process.Internal.Primitives

21+ ( receiveWait

22+ , receiveChan

23+ , match

24+ , matchAny

25+ , matchIf

26+ , matchChan

27+ , send

28+ , nsend

29+ , sendChan

30+ , getSelfPid

31+ , link

32+ , monitor

33+ , unwrapMessage

34+ , newChan

35+ , withMonitor

36+ )

37+import Control.Distributed.Process.Internal.Types

38+ ( Process

39+ , ProcessId

40+ , ProcessMonitorNotification(..)

41+ , SendPort

42+ , ReceivePort

43+ , Message

44+ , unsafeCreateUnencodedMessage

45+ )

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

47+ ( MxTableId(..)

48+ , MxAgentId(..)

49+ , MxAgentStart(..)

50+ , Fork)

51+import Control.Distributed.Process.Serializable (Serializable)

52+import Control.Monad.IO.Class (liftIO)

53+import Data.Accessor (Accessor, accessor, (^=), (^:))

54+import Data.Binary (Binary)

55+import Data.Map (Map)

56+import qualified Data.Map as Map

57+import Data.Typeable (Typeable)

58+

59+import GHC.Generics

60+

61+-- An extremely lightweight shared Map implementation, for use

62+-- by /management agents/ and their cohorts. Each agent is assigned

63+-- a table, into which any serializable @Message@ can be inserted.

64+-- Data are inserted, removed and searched for via their key, which

65+-- is a string. Tables can be purged, values can be set, fetched or

66+-- cleared/removed.

67+--

68+

69+data MxTableRequest =

70+ Delete

71+ | Purge

72+ | Clear !String

73+ | Set !String !Message

74+ | Get !String !(SendPort (Maybe Message)) -- see [note: un-typed send port]

75+ deriving (Typeable, Generic)

76+instance Binary MxTableRequest where

77+

78+data MxTableState = MxTableState { _name :: !String

79+ , _entries :: !(Map String Message)

80+ }

81+

82+type MxTables = Map MxAgentId ProcessId

83+

84+mxTableCoordinator :: String

85+mxTableCoordinator = "mx.table.coordinator"

86+

87+delete :: MxTableId -> Process ()

88+delete = sendReq Delete

89+

90+purge :: MxTableId -> Process ()

91+purge = sendReq Purge

92+

93+clear :: String -> MxTableId -> Process ()

94+clear k = sendReq (Clear k)

95+

96+set :: String -> Message -> MxTableId -> Process ()

97+set k v = sendReq (Set k v)

98+

99+fetch :: forall a. (Serializable a)

100+ => MxTableId

101+ -> String

102+ -> Process (Maybe a)

103+fetch (MxForPid pid) key = get pid key

104+fetch mxId@(MxForAgent _) key = do

105+ (sp, rp) <- newChan :: Process (SendPort (Maybe Message),

106+ ReceivePort (Maybe Message))

107+ sendReq (Get key sp) mxId

108+ receiveChan rp >>= maybe (return Nothing)

109+ (unwrapMessage :: Message -> Process (Maybe a))

110+

111+-- [note: un-typed send port]

112+-- Here, fetch uses a typed channel over a raw Message to obtain

113+-- its result, so type checking is deferred until receipt and will

114+-- be handled in the caller's thread. This is necessary because

115+-- the server portion of the code knows nothing about the types

116+-- involved, nor should it, since these tables can be used to

117+-- store arbitrary serializable data.

118+

119+get :: forall a. (Serializable a)

120+ => ProcessId

121+ -> String

122+ -> Process (Maybe a)

123+get pid key = do

124+ safeFetch pid key >>= maybe (return Nothing)

125+ (unwrapMessage :: Message -> Process (Maybe a))

126+

127+safeFetch :: ProcessId -> String -> Process (Maybe Message)

128+safeFetch pid key = do

129+ (sp, rp) <- newChan

130+ send pid $ Get key sp

131+ withMonitor pid $ do

132+ receiveWait [

133+ matchChan rp return

134+ , matchIf (\(ProcessMonitorNotification _ pid' _) -> pid' == pid)

135+ (\_ -> return $ Just (unsafeCreateUnencodedMessage ()))

136+ ]

137+

138+sendReq :: MxTableRequest -> MxTableId -> Process ()

139+sendReq req tid = (resolve tid) req

140+

141+resolve :: Serializable a => MxTableId -> (a -> Process ())

142+resolve (MxForAgent agent) = \msg -> nsend mxTableCoordinator (agent, msg)

143+resolve (MxForPid pid) = \msg -> send pid msg

144+

145+startTableCoordinator :: Fork -> Process ()

146+startTableCoordinator fork = run Map.empty

147+ where

148+ run :: MxTables -> Process ()

149+ run tables =

150+ receiveWait [

151+ -- note that this state change can race with MxAgentStart requests

152+ match (\(ProcessMonitorNotification _ pid _) -> do

153+ return $ Map.filter (/= pid) tables)

154+ , match (\(MxAgentStart ch agent) -> do

155+ lookupAgent tables agent >>= \(p, t) -> do

156+ sendChan ch p >> return t)

157+ , match (\req@(agent, tReq :: MxTableRequest) -> do

158+ case tReq of

159+ Get k sp -> do

160+ lookupAgent tables agent >>= \(p, t) -> do

161+ safeFetch p k >>= sendChan sp >> return t

162+ _ -> do

163+ handleRequest tables req)

164+ , matchAny (\_ -> return tables) -- unrecognised messages are dropped

165+ ] >>= run

166+

167+ handleRequest :: MxTables

168+ -> (MxAgentId, MxTableRequest)

169+ -> Process MxTables

170+ handleRequest tables' (agent, req) = do

171+ lookupAgent tables' agent >>= \(p, t) -> send p req >> return t

172+

173+ lookupAgent :: MxTables -> MxAgentId -> Process (ProcessId, MxTables)

174+ lookupAgent tables' agentId' = do

175+ case Map.lookup agentId' tables' of

176+ Nothing -> launchNew agentId' tables'

177+ Just p -> return (p, tables')

178+

179+ launchNew :: MxAgentId

180+ -> MxTables

181+ -> Process (ProcessId, MxTables)

182+ launchNew mxId tblMap = do

183+ let initState = MxTableState { _name = (agentId mxId)

184+ , _entries = Map.empty

185+ }

186+ (pid, _) <- spawnSup $ tableHandler initState

187+ return $ (pid, mxId `seq` pid `seq` Map.insert mxId pid tblMap)

188+

189+ spawnSup proc = do

190+ us <- getSelfPid

191+ -- we need to use that passed in "fork", in order to

192+ -- break an import cycle with Node.hs courtesy of the

193+ -- management agent, API and tracing modules

194+ them <- liftIO $ fork $ link us >> proc

195+ ref <- monitor them

196+ return (them, ref)

197+

198+tableHandler :: MxTableState -> Process ()

199+tableHandler state = do

200+ ns <- receiveWait [

201+ match (handleTableRequest state)

202+ , matchAny (\_ -> return (Just state))

203+ ]

204+ case ns of

205+ Nothing -> return ()

206+ Just s' -> tableHandler s'

207+ where

208+ handleTableRequest _ Delete = return Nothing

209+ handleTableRequest st Purge = return $ Just $ (entries ^= Map.empty) $ st

210+ handleTableRequest st (Clear k) = return $ Just $ (entries ^: (k `seq` Map.delete k)) $ st

211+ handleTableRequest st (Set k v) = return $ Just $ (entries ^: (k `seq` v `seq` Map.insert k v)) st

212+ handleTableRequest st (Get k c) = getEntry k c st >> return (Just st)

213+

214+getEntry :: String

215+ -> SendPort (Maybe Message)

216+ -> MxTableState

217+ -> Process ()

218+getEntry k m MxTableState{..} = do

219+ sendChan m =<< return (Map.lookup k _entries)

220+

221+entries :: Accessor MxTableState (Map String Message)

222+entries = accessor _entries (\ls st -> st { _entries = ls })

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

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

33 ( whereis

34 , newChan

35 , receiveChan

36− , die

37 )

36 )

38import Control.Distributed.Process.Management.Internal.Trace.Types

37import Control.Distributed.Process.Management.Internal.Trace.Types

39 ( TraceArg(..)

38 ( TraceArg(..)

@@ -169,11 +168,6 @@ withRegisteredTracer act = do

169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

168 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

170 currentTracer <- receiveChan rp

169 currentTracer <- receiveChan rp

171 case currentTracer of

170 case currentTracer of

172− Nothing -> do mTP <- whereis "tracer.initial"

171+ Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

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)"

179 (Just p) -> act p

172 (Just p) -> act p

173+

src/Control/Distributed/Process/Management/Internal/Trace/Types.hs+10

@@ -43,6 +43,7 @@ import Control.Distributed.Process.Serializable

43import Data.Binary

44import Data.List (intersperse)

45import Data.Set (Set)

46+import qualified Data.Set as Set (fromList)

46import Data.Typeable

47import Data.Typeable

47import GHC.Generics

48import GHC.Generics

@@ -157,3 +158,12 @@ getTraceFlags t s = publishEvent t (unsafeCreateUnencodedMessage s)

157

158

158getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

159getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

159getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)

160getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)

161+

162+class Traceable a where

163+ uod :: [a] -> TraceSubject

164+

165+instance Traceable ProcessId where

166+ uod = TraceProcs . Set.fromList

167+

168+instance Traceable String where

169+ uod = TraceNames . Set.fromList

src/Control/Distributed/Process/Management/Internal/Types.hs+18−9

@@ -4,10 +4,12 @@

4{-# LANGUAGE DeriveGeneric #-}

5module Control.Distributed.Process.Management.Internal.Types

6 ( MxAgentId(..)

7+ , MxTableId(..)

7 , MxAgentState(..)

8 , MxAgentState(..)

8 , MxAgent(..)

9 , MxAgent(..)

9 , MxAction(..)

10 , MxAction(..)

10 , ChannelSelector(..)

11 , ChannelSelector(..)

12+ , MxAgentStart(..)

11 , Fork

13 , Fork

12 , MxSink

14 , MxSink

13 , MxEvent(..)

15 , MxEvent(..)

@@ -21,8 +23,8 @@ import Control.Concurrent.STM

21import Control.Distributed.Process.Internal.Types

23import Control.Distributed.Process.Internal.Types

22 ( Process

24 ( Process

23 , ProcessId

25 , ProcessId

24− , SendPortId

25 , Message

26 , Message

27+ , SendPort

26 , DiedReason

28 , DiedReason

27 , NodeId

29 , NodeId

28 )

30 )

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

31 ( MonadState

33 ( MonadState

32 , StateT

34 , StateT

33 )

35 )

34−import Control.Monad.Fix (MonadFix)

35import Data.Binary

36import Data.Binary

36import Data.Typeable (Typeable)

37import Data.Typeable (Typeable)

37import GHC.Generics

38import GHC.Generics

@@ -58,14 +59,8 @@ data MxEvent =

58 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

59 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

59 | MxSent ProcessId ProcessId Message

60 | MxSent ProcessId ProcessId Message

60 -- ^ fired whenever a message is sent from a local process

61 -- ^ fired whenever a message is sent from a local process

61− | MxSentToName String ProcessId Message

62− -- ^ fired whenever a named send occurs

63− | MxSentToPort ProcessId SendPortId Message

64− -- ^ fired whenever a sendChan occurs

65 | MxReceived ProcessId Message

62 | MxReceived ProcessId Message

66 -- ^ fired whenever a message is received by a local process

63 -- ^ fired whenever a message is received by a local process

67− | MxReceivedPort SendPortId Message

68− -- ^ fired whenever a message is received via a typed channel

69 | MxConnected ConnectionId EndPointAddress

64 | MxConnected ConnectionId EndPointAddress

70 -- ^ fired when a network-transport connection is first established

65 -- ^ fired when a network-transport connection is first established

71 | MxDisconnected ConnectionId EndPointAddress

66 | MxDisconnected ConnectionId EndPointAddress

@@ -104,10 +99,17 @@ type Fork = (Process () -> IO ProcessId)

104newtype MxAgentId = MxAgentId { agentId :: String }

99newtype MxAgentId = MxAgentId { agentId :: String }

105 deriving (Typeable, Binary, Eq, Ord)

100 deriving (Typeable, Binary, Eq, Ord)

106

101

102+data MxTableId =

103+ MxForAgent !MxAgentId

104+ | MxForPid !ProcessId

105+ deriving (Typeable, Generic)

106+instance Binary MxTableId where

107+

107data MxAgentState s = MxAgentState

108data MxAgentState s = MxAgentState

108 {

109 {

109 mxAgentId :: !MxAgentId

110 mxAgentId :: !MxAgentId

110 , mxBus :: !(TChan Message)

111 , mxBus :: !(TChan Message)

112+ , mxSharedTable :: !ProcessId

111 , mxLocalState :: !s

113 , mxLocalState :: !s

112 }

114 }

113

115

@@ -120,12 +122,19 @@ newtype MxAgent s a =

120 } deriving ( Functor

122 } deriving ( Functor

121 , Monad

123 , Monad

122 , MonadIO

124 , MonadIO

123− , MonadFix

124 , ST.MonadState (MxAgentState s)

125 , ST.MonadState (MxAgentState s)

125 , Typeable

126 , Typeable

126 , Applicative

127 , Applicative

127 )

128 )

128

129

130+data MxAgentStart = MxAgentStart

131+ {

132+ mxAgentTableChan :: SendPort ProcessId

133+ , mxAgentIdStart :: MxAgentId

134+ }

135+ deriving (Typeable, Generic)

136+instance Binary MxAgentStart where

137+

129data ChannelSelector = InputChan | Mailbox

138data ChannelSelector = InputChan | Mailbox

130

139

131-- | Represents the actions a management agent can take

140-- | Represents the actions a management agent can take

src/Control/Distributed/Process/Node.hs+57−99

@@ -28,33 +28,22 @@ import Data.Binary (decode)

28import Data.Map (Map)

29import qualified Data.Map as Map

30 ( empty

31− , delete

32 , toList

31 , toList

33 , fromList

32 , fromList

34− , insert

33+ , filter

35− , lookup

36− , partition

37 , partitionWithKey

34 , partitionWithKey

38 , elems

35 , elems

39 , size

36 , size

40 , filterWithKey

37 , filterWithKey

41 , foldlWithKey

38 , foldlWithKey

42 )

39 )

43−import Data.Time.Format (formatTime)

44−#if MIN_VERSION_time(1,5,0)

45−import Data.Time.Format (defaultTimeLocale)

46−#else

47−import System.Locale (defaultTimeLocale)

48−#endif

49import Data.Set (Set)

40import Data.Set (Set)

50import qualified Data.Set as Set

41import qualified Data.Set as Set

51 ( empty

42 ( empty

52 , insert

43 , insert

53 , delete

44 , delete

54− , map

55 , member

45 , member

56 , toList

46 , toList

57− , union

58 )

47 )

59import Data.Foldable (forM_)

48import Data.Foldable (forM_)

60import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

49import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

@@ -82,8 +71,6 @@ import qualified Control.Exception as Exception

82 , finally

71 , finally

83 )

72 )

84import Control.Concurrent (forkIO, killThread)

73import Control.Concurrent (forkIO, killThread)

85−import Control.Distributed.Process.Internal.BiMultiMap (BiMultiMap)

86−import qualified Control.Distributed.Process.Internal.BiMultiMap as BiMultiMap

87import Control.Distributed.Process.Internal.StrictMVar

74import Control.Distributed.Process.Internal.StrictMVar

88 ( newMVar

75 ( newMVar

89 , withMVar

76 , withMVar

@@ -186,8 +173,9 @@ import Control.Distributed.Process.Internal.Types

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

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

187 ( mxAgentController

174 ( mxAgentController

188 )

175 )

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

176+import qualified Control.Distributed.Process.Management.Internal.Table as Table

190− ( MxEvent(..)

177+ ( mxTableCoordinator

178+ , startTableCoordinator

191 )

179 )

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

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

193 ( remoteTable

181 ( remoteTable

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

201 , traceLogFmt

189 , traceLogFmt

202 , enableTrace

190 , enableTrace

203 )

191 )

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

193+ ( MxEvent(..)

194+ )

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

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

205import Control.Distributed.Process.Internal.Messaging

196import Control.Distributed.Process.Internal.Messaging

206 ( sendBinary

197 ( sendBinary

@@ -213,10 +204,6 @@ import Control.Distributed.Process.Internal.Primitives

213 , match

204 , match

214 , sendChan

205 , sendChan

215 , unwrapMessage

206 , unwrapMessage

216− , monitor

217− , unmonitorAsync

218− , getSelfNode

219− , SayMessage(..)

220 )

207 )

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

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

222import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

209import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

@@ -324,6 +311,8 @@ startServiceProcesses node = do

324 -- before /that/ process has started - this is a totally harmless race

311 -- before /that/ process has started - this is a totally harmless race

325 -- however, so we deliberably ignore it

312 -- however, so we deliberably ignore it

326 startDefaultTracer node

313 startDefaultTracer node

314+ tableCoordinatorPid <- fork $ Table.startTableCoordinator fork

315+ runProcess node $ register Table.mxTableCoordinator tableCoordinatorPid

327 logger <- forkProcess node loop

316 logger <- forkProcess node loop

328 runProcess node $ do

317 runProcess node $ do

329 register "logger" logger

318 register "logger" logger

@@ -332,11 +321,12 @@ startServiceProcesses node = do

332 -- process which uses 'send' or other primitives which are traced.

321 -- process which uses 'send' or other primitives which are traced.

333 register "trace.logger" logger

322 register "trace.logger" logger

334 where

323 where

324+ fork = forkProcess node

325+

335 loop = do

326 loop = do

336 receiveWait

327 receiveWait

337− [ match $ \(SayMessage time pid string) -> do

328+ [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do

338− let time' = formatTime defaultTimeLocale "%c" time

339− liftIO . hPutStrLn stderr $ time' ++ " " ++ show pid ++ ": " ++ string

329+ liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

340 loop

330 loop

341 , match $ \((time, string) :: (String, String)) -> do

331 , match $ \((time, string) :: (String, String)) -> do

342 -- this is a 'trace' message from the local node tracer

332 -- this is a 'trace' message from the local node tracer

@@ -492,7 +482,7 @@ type IncomingConnection = (NT.EndPointAddress, IncomingTarget)

492data IncomingTarget =

482data IncomingTarget =

493 Uninit

483 Uninit

494 | ToProc ProcessId (Weak (CQueue Message))

484 | ToProc ProcessId (Weak (CQueue Message))

495− | ToChan SendPortId TypedChannel

485+ | ToChan TypedChannel

496 | ToNode

486 | ToNode

497

487

498data ConnectionState = ConnectionState {

488data ConnectionState = ConnectionState {

@@ -547,17 +537,13 @@ handleIncomingMessages node = go initConnectionState

547 enqueue queue msg -- 'enqueue' is strict

537 enqueue queue msg -- 'enqueue' is strict

548 trace node (MxReceived pid msg)

538 trace node (MxReceived pid msg)

549 go st

539 go st

550− Just (_, ToChan chId (TypedChannel chan')) -> do

540+ Just (_, ToChan (TypedChannel chan')) -> do

551 mChan <- deRefWeak chan'

541 mChan <- deRefWeak chan'

552 -- If mChan is Nothing, the process has given up the read end of

542 -- If mChan is Nothing, the process has given up the read end of

553 -- the channel and we simply ignore the incoming message

543 -- the channel and we simply ignore the incoming message

554− forM_ mChan $ \chan -> do

544+ forM_ mChan $ \chan -> atomically $

555− msg' <- atomically $ do

556− msg <- return $! decode (BSL.fromChunks payload)

557− -- We make sure the message is fully decoded when it is enqueued

545+ -- We make sure the message is fully decoded when it is enqueued

558− writeTQueue chan msg

546+ writeTQueue chan $! decode (BSL.fromChunks payload)

559− return msg

560− trace node $ MxReceivedPort chId $ unsafeCreateUnencodedMessage msg'

561 go st

547 go st

562 Just (_, ToNode) -> do

548 Just (_, ToNode) -> do

563 let ctrlMsg = decode . BSL.fromChunks $ payload

549 let ctrlMsg = decode . BSL.fromChunks $ payload

@@ -584,7 +570,7 @@ handleIncomingMessages node = go initConnectionState

584 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

570 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

585 case mChannel of

571 case mChannel of

586 Just channel ->

572 Just channel ->

587− go (incomingAt cid ^= Just (src, ToChan chId channel) $ st)

573+ go (incomingAt cid ^= Just (src, ToChan channel) $ st)

588 Nothing ->

574 Nothing ->

589 invalidRequest cid st $

575 invalidRequest cid st $

590 "incoming attempt to connect to unknown channel of"

576 "incoming attempt to connect to unknown channel of"

@@ -670,9 +656,9 @@ runNodeController node =

670

656

671data NCState = NCState

657data NCState = NCState

672 { -- Mapping from remote processes to linked local processes

658 { -- Mapping from remote processes to linked local processes

673− _links :: !(BiMultiMap Identifier ProcessId ())

659+ _links :: !(Map Identifier (Set ProcessId))

674 -- Mapping from remote processes to monitoring local processes

660 -- Mapping from remote processes to monitoring local processes

675− , _monitors :: !(BiMultiMap Identifier ProcessId MonitorRef)

661+ , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))

676 -- Process registry: names and where they live, mapped to the PIDs

662 -- Process registry: names and where they live, mapped to the PIDs

677 , _registeredHere :: !(Map String ProcessId)

663 , _registeredHere :: !(Map String ProcessId)

678 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

664 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

@@ -688,8 +674,8 @@ newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

688 )

674 )

689

675

690initNCState :: NCState

676initNCState :: NCState

691−initNCState = NCState { _links = BiMultiMap.empty

677+initNCState = NCState { _links = Map.empty

692− , _monitors = BiMultiMap.empty

678+ , _monitors = Map.empty

693 , _registeredHere = Map.empty

679 , _registeredHere = Map.empty

694 , _registeredOnNodes = Map.empty

680 , _registeredOnNodes = Map.empty

695 }

681 }

@@ -832,8 +818,8 @@ ncEffectMonitor from them mRef = do

832 case (shouldLink, isLocal node (ProcessIdentifier from)) of

818 case (shouldLink, isLocal node (ProcessIdentifier from)) of

833 (True, _) -> -- [Unified: first rule]

819 (True, _) -> -- [Unified: first rule]

834 case mRef of

820 case mRef of

835− Just ref -> modify' $ monitors ^: BiMultiMap.insert them from ref

821+ Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)

836− Nothing -> modify' $ links ^: BiMultiMap.insert them from ()

822+ Nothing -> modify' $ linksFor them ^: Set.insert from

837 (False, True) -> -- [Unified: second rule]

823 (False, True) -> -- [Unified: second rule]

838 notifyDied from them DiedUnknownId mRef

824 notifyDied from them DiedUnknownId mRef

839 (False, False) -> -- [Unified: third rule]

825 (False, False) -> -- [Unified: third rule]

@@ -857,7 +843,7 @@ ncEffectUnlink from them = do

857 postAsMessage from $ DidUnlinkNode nid

843 postAsMessage from $ DidUnlinkNode nid

858 SendPortIdentifier cid ->

844 SendPortIdentifier cid ->

859 postAsMessage from $ DidUnlinkPort cid

845 postAsMessage from $ DidUnlinkPort cid

860− modify' $ links ^: BiMultiMap.delete them from ()

846+ modify' $ linksFor them ^: Set.delete from

861

847

862-- [Unified: Table 11]

848-- [Unified: Table 11]

863ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

849ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

@@ -865,7 +851,7 @@ ncEffectUnmonitor from ref = do

865 node <- ask

851 node <- ask

866 when (isLocal node (ProcessIdentifier from)) $

852 when (isLocal node (ProcessIdentifier from)) $

867 postAsMessage from $ DidUnmonitor ref

853 postAsMessage from $ DidUnmonitor ref

868− modify' $ monitors ^: BiMultiMap.delete (monitorRefIdent ref) from ref

854+ modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)

869

855

870-- [Unified: Table 12]

856-- [Unified: Table 12]

871ncEffectDied :: Identifier -> DiedReason -> NC ()

857ncEffectDied :: Identifier -> DiedReason -> NC ()

@@ -880,7 +866,7 @@ ncEffectDied ident reason = do

880 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

866 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

881

867

882 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

868 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

883− forM_ uss $ \(us, _) ->

869+ forM_ uss $ \us ->

884 when (localOnly <= isLocal node (ProcessIdentifier us)) $

870 when (localOnly <= isLocal node (ProcessIdentifier us)) $

885 notifyDied us them reason Nothing

871 notifyDied us them reason Nothing

886

872

@@ -889,35 +875,9 @@ ncEffectDied ident reason = do

889 when (localOnly <= isLocal node (ProcessIdentifier us)) $

875 when (localOnly <= isLocal node (ProcessIdentifier us)) $

890 notifyDied us them reason (Just ref)

876 notifyDied us them reason (Just ref)

891

877

892− -- Notify remote nodes that the process died so it can be removed from monitor

893− -- lists.

894− mapM_ (forwardDeath node) $

895− [ nid | ProcessIdentifier pid <- [ident]

896− , i <- Set.toList $ Set.union

897− (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedLinks)

898− (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedMons)

899− , let nid = nodeOf i

900− , nid /= localNodeId node

901− ]

902−

903− -- Delete monitors in the local node.

904− let deleteDeads :: (Ord a, Ord v)

905− => BiMultiMap a ProcessId v -> BiMultiMap a ProcessId v

906− deleteDeads = case ident of

907− -- deleteAllBy2nd is faster than partitionWithKeyBy2nd

908− ProcessIdentifier pid -> BiMultiMap.deleteAllBy2nd pid

909− _ -> snd . BiMultiMap.partitionWithKeyBy2nd

910− (\pid _ -> ident `impliesDeathOf` ProcessIdentifier pid)

911− unaffectedLinks' = deleteDeads unaffectedLinks

912− unaffectedMons' = deleteDeads unaffectedMons

913−

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

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

915−

879+

916− -- we now consider all labels for this identifier unregistered

917− let toDrop pid = not $ ident `impliesDeathOf` ProcessIdentifier pid

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

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

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

920− modify' $ registeredHere ^= keepNames

921

881

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

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

923 mapM (\(pid,nidlist) ->

883 mapM (\(pid,nidlist) ->

@@ -925,12 +885,12 @@ ncEffectDied ident reason = do

925 True ->

885 True ->

926 do forM_ nidlist $ \(nid,_) ->

886 do forM_ nidlist $ \(nid,_) ->

927 when (not $ isLocal node (NodeIdentifier nid))

887 when (not $ isLocal node (NodeIdentifier nid))

928− (forwardDeath node nid)

888+ (forwardNameDeath node nid)

929 return Nothing

889 return Nothing

930 False -> return $ Just (pid,nidlist) )

890 False -> return $ Just (pid,nidlist) )

931 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

891 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

932 where

892 where

933− forwardDeath node nid = ncSendToNode nid

893+ forwardNameDeath node nid = ncSendToNode nid

934 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

894 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

935 , ctrlMsgSignal = Died ident reason

895 , ctrlMsgSignal = Died ident reason

936 }

896 }

@@ -969,11 +929,7 @@ ncEffectRegister from label atnode mPid reregistration = do

969 do modify' $ registeredHereFor label ^= mPid

929 do modify' $ registeredHereFor label ^= mPid

970 updateRemote node currentVal mPid

930 updateRemote node currentVal mPid

971 case mPid of

931 case mPid of

972− (Just p) -> do

973− if reregistration

974− then liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

975− else return ()

976− liftIO $ trace node (MxRegistered p label)

932+ (Just p) -> liftIO $ trace node (MxRegistered p label)

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

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

978 newVal <- gets (^. registeredHereFor label)

934 newVal <- gets (^. registeredHereFor label)

979 ncSendToProcess from $ unsafeCreateUnencodedMessage $

935 ncSendToProcess from $ unsafeCreateUnencodedMessage $

@@ -1054,12 +1010,11 @@ ncEffectLocalPortSend from msg = do

1054 -- If ch is Nothing, the process has given up the read end of

1010 -- If ch is Nothing, the process has given up the read end of

1055 -- the channel and we simply ignore the incoming message - this

1011 -- the channel and we simply ignore the incoming message - this

1056 ch <- deRefWeak chan'

1012 ch <- deRefWeak chan'

1057− forM_ ch $ \chan -> deliverChan node from msg chan

1013+ forM_ ch $ \chan -> deliverChan msg chan

1058− where deliverChan :: forall a . LocalNode -> SendPortId -> Message -> TQueue a -> IO ()

1014+ where deliverChan :: forall a . Message -> TQueue a -> IO ()

1059− deliverChan n p (UnencodedMessage _ raw) chan' = do

1015+ deliverChan (UnencodedMessage _ raw) chan' =

1060 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1016 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1061− trace n (MxReceivedPort p $ unsafeCreateUnencodedMessage raw)

1062− deliverChan _ _ (EncodedMessage _ _) _ =

1017+ deliverChan (EncodedMessage _ _) _ =

1063 -- this will not happen unless someone screws with Primitives.hs

1018 -- this will not happen unless someone screws with Primitives.hs

1064 error "invalid local channel delivery"

1019 error "invalid local channel delivery"

1065

1020

@@ -1089,10 +1044,9 @@ ncEffectGetInfo from pid =

1089 case mProc of

1044 case mProc of

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

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

1091 from (ProcessInfoNone DiedUnknownId)

1046 from (ProcessInfoNone DiedUnknownId)

1092− Just proc -> do

1047+ Just proc -> do

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

1048+ itsLinks <- gets (^. linksFor them)

1094− gets (^. links)

1049+ itsMons <- gets (^. monitorsFor them)

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

1096 registered <- gets (^. registeredHere)

1050 registered <- gets (^. registeredHere)

1097 size <- liftIO $ queueSize $ processQueue $ proc

1051 size <- liftIO $ queueSize $ processQueue $ proc

1098

1052

@@ -1103,8 +1057,8 @@ ncEffectGetInfo from pid =

1103 infoNode = (processNodeId pid)

1057 infoNode = (processNodeId pid)

1104 , infoRegisteredNames = reg

1058 , infoRegisteredNames = reg

1105 , infoMessageQueueLength = size

1059 , infoMessageQueueLength = size

1106− , infoMonitors = Set.toList itsMons

1060+ , infoMonitors = Set.toList itsMons

1107− , infoLinks = Set.toList itsLinks

1061+ , infoLinks = Set.toList itsLinks

1108 }

1062 }

1109 where dispatch :: (Serializable a)

1063 where dispatch :: (Serializable a)

1110 => Bool

1064 => Bool

@@ -1128,8 +1082,8 @@ ncEffectGetNodeStats from _nid = do

1128 NodeStats {

1082 NodeStats {

1129 nodeStatsNode = localNodeId node

1083 nodeStatsNode = localNodeId node

1130 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1084 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1131− , nodeStatsMonitors = BiMultiMap.size $ ncState ^. monitors

1085+ , nodeStatsMonitors = Map.size $ ncState ^. monitors

1132− , nodeStatsLinks = BiMultiMap.size $ ncState ^. links

1086+ , nodeStatsLinks = Map.size $ ncState ^. links

1133 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1087 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1134 }

1088 }

1135 postAsMessage from stats

1089 postAsMessage from stats

@@ -1250,10 +1204,10 @@ withLocalProc node pid p =

1250-- Accessors --

1204-- Accessors --

1251--------------------------------------------------------------------------------

1205--------------------------------------------------------------------------------

1252

1206

1253−links :: Accessor NCState (BiMultiMap Identifier ProcessId ())

1207+links :: Accessor NCState (Map Identifier (Set ProcessId))

1254links = accessor _links (\ls st -> st { _links = ls })

1208links = accessor _links (\ls st -> st { _links = ls })

1255

1209

1256−monitors :: Accessor NCState (BiMultiMap Identifier ProcessId MonitorRef)

1210+monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

1257monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1211monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1258

1212

1259registeredHere :: Accessor NCState (Map String ProcessId)

1213registeredHere :: Accessor NCState (Map String ProcessId)

@@ -1262,6 +1216,12 @@ registeredHere = accessor _registeredHere (\ry st -> st { _registeredHere = ry }

1262registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1216registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1263registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1217registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1264

1218

1219+linksFor :: Identifier -> Accessor NCState (Set ProcessId)

1220+linksFor ident = links >>> DAC.mapDefault Set.empty ident

1221+

1222+monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

1223+monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

1224+

1265registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1225registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1266registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1226registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1267

1227

@@ -1288,12 +1248,10 @@ registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident

1288-- * the notifications for typed channels to that process.

1248-- * the notifications for typed channels to that process.

1289--

1249--

1290-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1250-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1291−splitNotif :: (Ord a, Ord v)

1292− => Identifier

1251+splitNotif :: Identifier

1293− -> BiMultiMap Identifier a v

1252+ -> Map Identifier a

1294− -> (Map Identifier (Set (a,v)), BiMultiMap Identifier a v)

1253+ -> (Map Identifier a, Map Identifier a)

1295−splitNotif ident =

1254+splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)

1296− BiMultiMap.partitionWithKeyBy1st (\k !_v -> ident `impliesDeathOf` k)

1297

1255

1298--------------------------------------------------------------------------------

1256--------------------------------------------------------------------------------

1299-- Auxiliary --

1257-- Auxiliary --

src/Control/Distributed/Process/Serializable.hs+13−3

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

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE UndecidableInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE CPP #-}

6module Control.Distributed.Process.Serializable

7 ( Serializable

8 , encodeFingerprint

@@ -17,7 +17,13 @@ module Control.Distributed.Process.Serializable

18import Data.Binary (Binary)

20+#if MIN_VERSION_base(4,7,0)

20−import Data.Typeable (Typeable, typeRepFingerprint, typeOf)

21+import Data.Typeable (Typeable)

22+import Data.Typeable.Internal (TypeRep(TypeRep), typeOf)

23+#else

24+import Data.Typeable (Typeable(..))

25+import Data.Typeable.Internal (TypeRep(TypeRep))

26+#endif

22import Numeric (showHex)

28import Numeric (showHex)

23import Control.Exception (throw)

29import Control.Exception (throw)

@@ -65,7 +71,11 @@ sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

66-- | The fingerprint of the typeRep of the argument

72-- | The fingerprint of the typeRep of the argument

67fingerprint :: Typeable a => a -> Fingerprint

73fingerprint :: Typeable a => a -> Fingerprint

74+#if MIN_VERSION_base(4,8,0)

75+fingerprint a = let TypeRep fp _ _ _ = typeOf a in fp

76+#else

68−fingerprint = typeRepFingerprint . typeOf

77+fingerprint a = let TypeRep fp _ _ = typeOf a in fp

78+#endif

70-- | Show fingerprint (for debugging purposes)

80-- | Show fingerprint (for debugging purposes)

71showFingerprint :: Fingerprint -> ShowS

81showFingerprint :: Fingerprint -> ShowS

src/Control/Distributed/Process/UnsafePrimitives.hs+33−82

@@ -32,24 +32,7 @@

32-- the /normal/ strategy).

33--

34-- Use of the functions in this module can potentially change the runtime

35−-- behaviour of your application. In addition, messages passed between Cloud

36−-- Haskell processes are written to a tracing infrastructure on the local node,

37−-- to provide improved introspection and debugging facilities for complex actor

38−-- based systems. This module makes no attempt to force evaluation in these

39−-- cases either, thus evaluation problems in passed data structures could not

40−-- only crash your processes, but could also bring down critical internal

41−-- services on which the node relies to function correctly.

42−--

43−-- If you wish to repudiate such issues, you are advised to consider the use

44−-- of NFSerialisable in the distributed-process-extras package, which type

45−-- class brings NFData into scope along with Serializable, such that we can

46−-- force evaluation. Intended for use with modules such as this one, this

47−-- approach guarantees correct evaluatedness in terms of @NFData@. Please note

48−-- however, that we /cannot/ guarantee that an @NFData@ instance will behave the

49−-- same way as a @Binary@ one with regards evaluation, so it is still possible

50−-- to introduce unexpected behaviour by using /unsafe/ primitives in this way.

51−--

52−-- You have been warned!

35+-- behaviour of your application. You have been warned!

53--

36--

54-- This module is exported so that you can replace the use of Cloud Haskell's

37-- This module is exported so that you can replace the use of Cloud Haskell's

55-- /safe/ messaging primitives. If you want to use both variants, then you can

38-- /safe/ messaging primitives. If you want to use both variants, then you can

@@ -72,12 +55,7 @@ import Control.Distributed.Process.Internal.Messaging

72 , sendBinary

55 , sendBinary

73 , sendCtrlMsg

56 , sendCtrlMsg

74 )

57 )

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

58+

76− ( MxEvent(..)

77− )

78−import Control.Distributed.Process.Management.Internal.Trace.Types

79− ( traceEvent

80− )

81import Control.Distributed.Process.Internal.Types

59import Control.Distributed.Process.Internal.Types

82 ( ProcessId(..)

60 ( ProcessId(..)

83 , NodeId(..)

61 , NodeId(..)

@@ -101,48 +79,34 @@ import Control.Monad.Reader (ask)

101

102-- | Named send to a process in the local registry (asynchronous)

80-- | Named send to a process in the local registry (asynchronous)

103nsend :: Serializable a => String -> a -> Process ()

81nsend :: Serializable a => String -> a -> Process ()

104−nsend label msg = do

82+nsend label msg =

105− proc <- ask

106− let us = processId proc

107− let msg' = wrapMessage msg

108− -- see [note: tracing]

109− liftIO $ traceEvent (localEventBus (processNode proc))

110− (MxSentToName label us msg')

111− sendCtrlMsg Nothing (NamedSend label msg')

83+ sendCtrlMsg Nothing (NamedSend label (unsafeCreateUnencodedMessage msg))

112

113-- | Named send to a process in a remote registry (asynchronous)

85-- | Named send to a process in a remote registry (asynchronous)

114nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

86nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

115nsendRemote nid label msg = do

87nsendRemote nid label msg = do

116 proc <- ask

88 proc <- ask

117− let us = processId proc

118− let node = processNode proc

119− if localNodeId node == nid

89+ if localNodeId (processNode proc) == nid

120 then nsend label msg

90 then nsend label msg

121− else

122− let lbl = label ++ "@" ++ show nid in do

123− -- see [note: tracing] NB: this is a remote call to another NC...

124− liftIO $ traceEvent (localEventBus node)

125− (MxSentToName lbl us (wrapMessage msg))

126− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

91+ else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

127

128-- | Send a message

93-- | Send a message

129send :: Serializable a => ProcessId -> a -> Process ()

94send :: Serializable a => ProcessId -> a -> Process ()

130send them msg = do

95send them msg = do

131 proc <- ask

96 proc <- ask

132 let node = localNodeId (processNode proc)

97 let node = localNodeId (processNode proc)

133− destNode = (processNodeId them)

98+ destNode = (processNodeId them) in do

134− us = (processId proc)

135− msg' = wrapMessage msg in do

136− -- see [note: tracing]

137− liftIO $ traceEvent (localEventBus (processNode proc))

138− (MxSent them us msg')

139− if destNode == node

99+ case destNode == node of

100+ True -> unsafeSendLocal them msg

101+ False -> liftIO $ sendMessage (processNode proc)

102+ (ProcessIdentifier (processId proc))

103+ (ProcessIdentifier them)

104+ NoImplicitReconnect

105+ msg

106+ where

107+ unsafeSendLocal :: (Serializable a) => ProcessId -> a -> Process ()

108+ unsafeSendLocal pid msg' =

140− then sendCtrlMsg Nothing $ LocalSend them msg'

109+ sendCtrlMsg Nothing $ LocalSend pid (unsafeCreateUnencodedMessage msg')

141− else liftIO $ sendMessage (processNode proc)

142− (ProcessIdentifier (processId proc))

143− (ProcessIdentifier them)

144− NoImplicitReconnect

145− msg

146

110

147-- | Send a message unreliably.

111-- | Send a message unreliably.

148--

112--

@@ -157,43 +121,30 @@ usend :: Serializable a => ProcessId -> a -> Process ()

157usend them msg = do

121usend them msg = do

158 proc <- ask

122 proc <- ask

159 let there = processNodeId them

123 let there = processNodeId them

160− let (us, node) = (processId proc, processNode proc)

161− let msg' = wrapMessage msg

162− -- see [note: tracing]

163− liftIO $ traceEvent (localEventBus node) (MxSent them us msg')

164 if localNodeId (processNode proc) == there

124 if localNodeId (processNode proc) == there

165− then sendCtrlMsg Nothing $ LocalSend them msg'

125+ then sendCtrlMsg Nothing $

126+ LocalSend them (unsafeCreateUnencodedMessage msg)

166 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

127 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

167 (createMessage msg)

128 (createMessage msg)

168

129

169−-- [note: tracing]

170−-- Note that tracing writes to the local node's control channel, and this

171−-- module explicitly specifies to its clients that it does unsafe message

172−-- encoding. The same is true for the messages it puts onto the Management

173−-- event bus, however we do *not* want unevaluated thunks hitting the event

174−-- bus control thread. Hence the word /Unsafe/ in this module's name!

175−--

176−

177-- | Send a message on a typed channel

130-- | Send a message on a typed channel

178sendChan :: Serializable a => SendPort a -> a -> Process ()

131sendChan :: Serializable a => SendPort a -> a -> Process ()

179sendChan (SendPort cid) msg = do

132sendChan (SendPort cid) msg = do

180 proc <- ask

133 proc <- ask

181− let node = processNode proc

182− pid = processId proc

183− us = localNodeId node

134+ let node = localNodeId (processNode proc)

184− them = processNodeId (sendPortProcessId cid)

135+ destNode = processNodeId (sendPortProcessId cid) in do

185− msg' = wrapMessage msg in do

136+ case destNode == node of

186− liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid msg')

187− if them == us

188− then unsafeSendChanLocal cid msg' -- NB: we wrap to P.Message !!!

137+ True -> unsafeSendChanLocal cid msg

138+ False -> do

189− else liftIO $ sendBinary node

139+ liftIO $ sendBinary (processNode proc)

190− (ProcessIdentifier pid)

140+ (ProcessIdentifier (processId proc))

191− (SendPortIdentifier cid)

141+ (SendPortIdentifier cid)

192− NoImplicitReconnect

142+ NoImplicitReconnect

193− msg

143+ msg

194 where

144 where

195− unsafeSendChanLocal :: SendPortId -> Message -> Process ()

145+ unsafeSendChanLocal :: (Serializable a) => SendPortId -> a -> Process ()

146+ unsafeSendChanLocal spId msg' =

196− unsafeSendChanLocal p m = sendCtrlMsg Nothing $ LocalPortSend p m

147+ sendCtrlMsg Nothing $ LocalPortSend spId (unsafeCreateUnencodedMessage msg')

197

148

198-- | Create an unencoded @Message@ for any @Serializable@ type.

149-- | Create an unencoded @Message@ for any @Serializable@ type.

199wrapMessage :: Serializable a => a -> Message

150wrapMessage :: Serializable a => a -> Message

stack-ghc-7.10.3.yaml−12

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

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

19flags:

7flags:

20 distributed-process-tests:

8 distributed-process-tests:

stack-ghc-7.8.4.yamlnew file+15

@@ -0,0 +1,15 @@

1+resolver: lts-2.22

3+packages:

4+- '.'

5+- distributed-process-tests/

7+extra-deps:

8+- network-transport-inmemory-0.5.1

9+- network-transport-tcp-0.5.1

10+

11+flags:

12+ distributed-process:

13+ old-locale: true

14+ distributed-process-tests:

15+ tcp: true

stack-ghc-8.0.2.yamldeleted−23

@@ -1,23 +0,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 :/

4−

5−packages:

6−- '.'

7−- distributed-process-tests/

8−- location:

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

10− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11− extra-dep: true

12−

13−extra-deps:

14−- rank1dynamic-0.4.0

15−- distributed-static-0.3.8

16−- network-transport-0.5.2

17−- network-transport-inmemory-0.5.2

18−- rematch-0.2.0.0

19−# - exceptions-0.8.2.1 # test dependency

20−

21−flags:

22− distributed-process-tests:

23− tcp: true

stack-ghc-8.2.2.yamldeleted−21

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

1−resolver: lts-11.22

2−

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.yamldeleted−20

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

1−resolver: lts-12.18

2−

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.yamldeleted−26

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

1−resolver: nightly

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−- location:

7− git: https://github.com/haskell-distributed/distributed-static.git

8− commit: c51e6aadd3a44c044e96a8e986c11d3a94b45b11

9− extra-dep: true

10−- location:

11− git: https://github.com/haskell-distributed/network-transport-tcp.git

12− commit: 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+6−11

@@ -1,20 +1,15 @@

1−resolver: lts-12.18 # Use GHC 8.4.4

1+resolver: nightly-2016-06-09

2−

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

5packages:

3packages:

6- '.'

4- '.'

7- distributed-process-tests/

5- distributed-process-tests/

8−- location:

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

10− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11− extra-dep: true

13extra-deps:

7extra-deps:

14−- rank1dynamic-0.4.0

8+- rank1dynamic-0.3.3.0

15−- distributed-static-0.3.8

9+- distributed-static-0.3.5.0

10+- network-transport-0.4.4.0

16−- network-transport-0.5.2

11+- network-transport-tcp-0.5.1

17−- network-transport-inmemory-0.5.2

12+- network-transport-inmemory-0.5.1

18- rematch-0.2.0.0

13- rematch-0.2.0.0

20flags:

15flags: