89c0030...master · distributed-process

git.iko.soy/distributed-process

on master help sign in

.travis.yml+24−56

since splitsnapshots

unifiedsplit

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

5matrix:

6 include:

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

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

9−

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

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

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

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

12−

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

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

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

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

15−

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

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

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

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

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

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

19cache:

16cache:

20 directories:

17 directories:

21 - $HOME/.stack

18 - $HOME/.stack

22− - $HOME/.cabal/packages

24before_install:

20before_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)

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

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

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

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

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

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

33− stack --version

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

44install:

26install:

45−- case "$BUILD" in

46− stack)

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

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

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

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

55script:

30script:

56−- case "$BUILD" in

57− stack)

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

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

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

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

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

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

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

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

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

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

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

36+- stack ${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

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

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

40+

41+notifications:

42+ slack:

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

ChangeLog+41−2

@@ -1,7 +1,46 @@

1+[Unrealeased]

3+*

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

7+* Added support for exceptions >= 0.10

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+

1−2016-07-06 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0

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

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

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

4−type (`SayMessage`) with a proper `UTCTime`.

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)

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

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

benchmarks/Channels.hs+6−4

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

4import Control.Applicative

5import Control.Distributed.Process

6import Control.Distributed.Process.Node

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

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

8import Data.Binary (encode, decode)

9import qualified Data.ByteString.Lazy as BSL

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

36main :: IO ()

37main = do

38 [role, host, port] <- getArgs

39− Right transport <- createTransport host port defaultTCPParameters

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

40+ case trans of

40− node <- newLocalNode transport initRemoteTable

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

41− runProcess node $ initialProcess role

42+ runProcess node $ initialProcess role

43+ Left other -> error $ show other

benchmarks/Latency.hs+7−4

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

3import Control.Applicative

4import Control.Distributed.Process

5import Control.Distributed.Process.Node

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

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

7import Data.Binary (encode, decode)

8import qualified Data.ByteString.Lazy as BSL

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

31main :: IO ()

32main = do

33 [role, host, port] <- getArgs

34+ trans <- createTransport

34− Right transport <- createTransport host port defaultTCPParameters

35+ (defaultTCPAddr host port) defaultTCPParameters

36+ case trans of

35− node <- newLocalNode transport initRemoteTable

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

36− runProcess node $ initialProcess role

38+ runProcess node $ initialProcess role

39+ Left other -> error $ show other

benchmarks/ProcessRing.hs+3−2

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

12import Control.Distributed.Process hiding (catch)

13import Control.Distributed.Process.Node

14import Control.Exception (catch, SomeException)

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

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

16import System.Environment

17import System.Console.GetOpt

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

110 argv <- getArgs

111 (opt, _) <- parseArgv argv

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

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

113+ Right transport <- createTransport

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

114 node <- newLocalNode transport initRemoteTable

115 node <- newLocalNode transport initRemoteTable

115 catch (void $ runProcess node $ initialProcess opt)

116 catch (void $ runProcess node $ initialProcess opt)

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

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

benchmarks/Spawns.hs+6−4

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

7import Control.Applicative

8import Control.Distributed.Process

9import Control.Distributed.Process.Node

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

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

11import Data.Binary (encode, decode)

12import qualified Data.ByteString.Lazy as BSL

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

42main :: IO ()

43main = do

44 [role, host, port] <- getArgs

45− Right transport <- createTransport host port defaultTCPParameters

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

46+ case trans of

46− node <- newLocalNode transport initRemoteTable

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

47− runProcess node $ initialProcess role

48+ runProcess node $ initialProcess role

49+ Left other -> error $ show other

benchmarks/Throughput.hs+6−4

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

6import Control.Applicative

7import Control.Distributed.Process

8import Control.Distributed.Process.Node

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

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

10import Data.Binary

11import qualified Data.ByteString.Lazy as BSL

12import Data.Typeable

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

67main :: IO ()

68main = do

69 [role, host, port] <- getArgs

70− Right transport <- createTransport host port defaultTCPParameters

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

71+ case trans of

71− node <- newLocalNode transport initRemoteTable

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

72− runProcess node $ initialProcess role

73+ runProcess node $ initialProcess role

74+ Left other -> error $ show other

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

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

1name: distributed-process-tests

2−version: 0.4.6

2+version: 0.4.11

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: Facundo Domínguez <facundo.dominguez@tweag.io>

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

10copyright: Well-Typed LLP

11category: Control, Cloud Haskell

12build-type: Simple

@@ -26,14 +26,15 @@ 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 && < 0.7,

29+ ansi-terminal >= 0.5,

30 binary >= 0.5 && < 0.9,

31 bytestring >= 0.9 && < 0.12,

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

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

33 distributed-static,

34+ exceptions >= 0.5,

34− HUnit >= 1.2 && < 1.4,

35+ HUnit >= 1.2 && < 1.7,

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

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

36− network >= 2.5 && < 2.7,

37+ network >= 2.5 && < 2.9,

37 random >= 1.0 && < 1.2,

38 random >= 1.0 && < 1.2,

38 rematch >= 0.1.2.1,

39 rematch >= 0.1.2.1,

39 setenv >= 0.1.1.3,

40 setenv >= 0.1.1.3,

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

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

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

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

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

62 distributed-process-tests,

63 distributed-process-tests,

63− network >= 2.3 && < 2.7,

64+ network >= 2.3 && < 2.9,

64− network-transport >= 0.4.1.0 && < 0.5,

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

65 network-transport-inmemory >= 0.5,

66 network-transport-inmemory >= 0.5,

66 test-framework >= 0.6 && < 0.9

67 test-framework >= 0.6 && < 0.9

67 Extensions: CPP

68 Extensions: CPP

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

75 if flag(tcp)

76 if flag(tcp)

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

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

77 distributed-process-tests,

78 distributed-process-tests,

78− network >= 2.3 && < 2.7,

79+ network >= 2.3 && < 2.9,

79− network-transport >= 0.4.1.0 && < 0.5,

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

80− network-transport-tcp >= 0.5 && < 0.6,

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

81 test-framework >= 0.6 && < 0.9

82 test-framework >= 0.6 && < 0.9

82 else

83 else

83 Buildable: False

84 Buildable: False

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

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

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

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

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

94 distributed-process-tests,

95 distributed-process-tests,

95− network >= 2.3 && < 2.7,

96+ network >= 2.3 && < 2.9,

96− network-transport >= 0.4.1.0 && < 0.5,

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

97 network-transport-inmemory >= 0.5,

98 network-transport-inmemory >= 0.5,

98 test-framework >= 0.6 && < 0.9

99 test-framework >= 0.6 && < 0.9

99 Extensions: CPP

100 Extensions: CPP

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

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

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

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

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

108 distributed-process-tests,

109 distributed-process-tests,

109− network >= 2.3 && < 2.7,

110+ network >= 2.3 && < 2.9,

110− network-transport >= 0.4.1.0 && < 0.5,

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

111 network-transport-inmemory >= 0.5,

112 network-transport-inmemory >= 0.5,

112 test-framework >= 0.6 && < 0.9

113 test-framework >= 0.6 && < 0.9

113 Extensions: CPP

114 Extensions: CPP

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

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

115 HS-Source-Dirs: tests

116 HS-Source-Dirs: tests

116

117

117−

118−Test-Suite TestMx

118+Test-Suite TestMxInMemory

119 Type: exitcode-stdio-1.0

120 Main-Is: runInMemory.hs

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

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

123 distributed-process-tests,

124− network >= 2.3 && < 2.7,

124+ network >= 2.3 && < 2.9,

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

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

126 network-transport-inmemory >= 0.5,

127 test-framework >= 0.6 && < 0.9

128 Extensions: CPP

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

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

130 HS-Source-Dirs: tests

131

132−Test-Suite TestTracing

132+Test-Suite TestTracingInMemory

133 Type: exitcode-stdio-1.0

134 Main-Is: runInMemory.hs

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

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

137 distributed-process-tests,

138− network >= 2.3 && < 2.7,

138+ network >= 2.3 && < 2.9,

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

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

140 network-transport-inmemory >= 0.5,

141 test-framework >= 0.6 && < 0.9

142 Extensions: CPP

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

144+ HS-Source-Dirs: tests

145+

146+Test-Suite TestMxInTCP

147+ Type: exitcode-stdio-1.0

148+ Main-Is: runInMemory.hs

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

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

151+ distributed-process-tests,

152+ network >= 2.3 && < 2.9,

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

154+ network-transport-inmemory >= 0.5,

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

156+ Extensions: CPP

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

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

144 HS-Source-Dirs: tests

158 HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+466−234

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

25 )

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

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

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

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

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

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

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

31−import Control.Distributed.Process

31+import Control.Distributed.Process hiding

32+ ( try

33+ , catch

34+ , finally

35+ , mask

36+ , onException

37+ )

32import Control.Distributed.Process.Internal.Types

38import Control.Distributed.Process.Internal.Types

33− ( NodeId(nodeAddress)

34− , LocalNode(localEndPoint)

39+ ( LocalNode(localEndPoint)

35 , ProcessExitException(..)

40 , ProcessExitException(..)

36 , nullProcessId

41 , nullProcessId

37 , createUnencodedMessage

42 , createUnencodedMessage

38 )

43 )

39import Control.Distributed.Process.Node

44import Control.Distributed.Process.Node

45+import Control.Distributed.Process.Debug

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

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

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

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

41−

49+import Data.Maybe (isNothing, isJust)

42−import Test.HUnit (Assertion, assertFailure)

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

43import Test.Framework (Test, testGroup)

51import Test.Framework (Test, testGroup)

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

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

45−import Control.Rematch hiding (match)

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

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

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

48newtype Ping = Ping ProcessId

56newtype Ping = Ping ProcessId

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

65forkTry :: IO () -> IO ThreadId

73forkTry :: IO () -> IO ThreadId

66forkTry p = do

74forkTry p = do

67 tid <- myThreadId

75 tid <- myThreadId

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

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

70-- | The ping server from the paper

78-- | The ping server from the paper

71ping :: Process ()

79ping :: Process ()

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

75 send partner (Ping self)

83 send partner (Ping self)

76 ping

84 ping

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

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

88+

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

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

91+ where

92+ checkPing (Ping _) = True

93+

78-- | Quick and dirty synchronous version of whereisRemoteAsync

94-- | Quick and dirty synchronous version of whereisRemoteAsync

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

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

80whereisRemote nid string = do

96whereisRemote nid string = do

81 whereisRemoteAsync nid string

97 whereisRemoteAsync nid string

98+ receiveWait [

82− WhereIsReply _ mPid <- expect

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

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"

83− return mPid

125+ return ()

126

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

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

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

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

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

155 unmonitor ref

197 unmonitor ref

156 liftIO $ putMVar done ()

198 liftIO $ putMVar done ()

157 (False, ref) -> do

199 (False, ref) -> do

200+ receiveWait [

158− ProcessMonitorNotification ref' pid reason' <- expect

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

202+ liftIO $ do

203+ assertBool "Bad Monitor Signal"

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

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

205+ mOrL && reason == reason')

160− liftIO $ putMVar done ()

206+ putMVar done ())

207+ ]

161 )

208 )

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

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

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

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

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

164 liftIO $ putMVar done ()

212 liftIO $ putMVar done ()

165 )

213 )

166

214

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

191 pid <- getSelfPid

239 pid <- getSelfPid

192 replicateM_ numPings $ do

240 replicateM_ numPings $ do

193 send pingServer (Pong pid)

241 send pingServer (Pong pid)

194− Ping _ <- expect

242+ p <- expectTimeout 3000000

243+ case p of

195− return ()

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

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

196

246

197 putMVar clientDone ()

247 putMVar clientDone ()

198

248

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

279 runProcess localNode $ do

329 runProcess localNode $ do

280 monitor theirAddr

330 monitor theirAddr

281 -- wait for the process to die

331 -- wait for the process to die

282− ProcessMonitorNotification _ _ _ <- expect

332+ expect :: Process ProcessMonitorNotification

283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

333 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

284

334

285 takeMVar done

335 takeMVar done

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

353 runProcess localNode $ do

403 runProcess localNode $ do

354 pid <- getSelfPid

404 pid <- getSelfPid

355 send mathServer (Add pid 1 2)

405 send mathServer (Add pid 1 2)

356− 3 <- expect :: Process Double

406+ three <- expect :: Process Double

357 send mathServer (Divide pid 8 2)

407 send mathServer (Divide pid 8 2)

358− 4 <- expect :: Process Double

408+ four <- expect :: Process Double

359 send mathServer (Divide pid 8 0)

409 send mathServer (Divide pid 8 0)

360− DivByZero <- expect

410+ divByZ <- expect

361− liftIO $ putMVar clientDone ()

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

362

412

363− takeMVar clientDone

413+ res <- takeMVar clientDone

414+ case res of

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

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

364

417

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

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

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

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

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

388 pid <- getSelfPid

441 pid <- getSelfPid

389 send server1 "Hi"

442 send server1 "Hi"

390 send server2 (Pong pid)

443 send server2 (Pong pid)

391− Ping pid' <- expect

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

393− liftIO $ putMVar clientDone ()

444+ expectPing clientDone

394

445

395− takeMVar clientDone

446+ verifyClient "Expected Ping from server" clientDone

396

447

397-- | Test (non-zero) timeout

448-- | Test (non-zero) timeout

398testTimeout :: TestTransport -> Assertion

449testTimeout :: TestTransport -> Assertion

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

401 done <- newEmptyMVar

452 done <- newEmptyMVar

402

453

403 runProcess localNode $ do

454 runProcess localNode $ do

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

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

405− liftIO $ putMVar done ()

456+ liftIO $ putMVar done $ res == Nothing

406

457

407− takeMVar done

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

408

459

409-- | Test zero timeout

460-- | Test zero timeout

410testTimeout0 :: TestTransport -> Assertion

461testTimeout0 :: TestTransport -> Assertion

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

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

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

433 replicateM_ 10000 $ send server "Irrelevant message"

484 replicateM_ 10000 $ send server "Irrelevant message"

434 send server (Pong pid)

485 send server (Pong pid)

435− Ping _ <- expect

436− liftIO $ putMVar clientDone ()

486+ expectPing clientDone

437

487

438− takeMVar clientDone

488+ verifyClient "Expected Ping from server" clientDone

439

489

440-- | Test typed channels

490-- | Test typed channels

441testTypedChannels :: TestTransport -> Assertion

491testTypedChannels :: TestTransport -> Assertion

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

458 runProcess localNode $ do

508 runProcess localNode $ do

459 (clientSendPort, rport) <- newChan

509 (clientSendPort, rport) <- newChan

460 sendChan serverSendPort (clientSendPort, 5)

510 sendChan serverSendPort (clientSendPort, 5)

461− False <- receiveChan rport

511+ ch <- receiveChan rport

462− liftIO $ putMVar clientDone ()

512+ liftIO $ putMVar clientDone $ ch == False

463

513

464− takeMVar clientDone

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

465

515

466-- | Test merging receive ports

516-- | Test merging receive ports

467testMergeChannels :: TestTransport -> Assertion

517testMergeChannels :: TestTransport -> Assertion

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

484 rs <- mapM charChannel "abc"

534 rs <- mapM charChannel "abc"

485 m <- mergePorts biased rs

535 m <- mergePorts biased rs

486 xs <- replicateM 9 $ receiveChan m

536 xs <- replicateM 9 $ receiveChan m

487− True <- return $ xs == expected

488− liftIO $ putMVar done ()

537+ liftIO $ putMVar done $ xs == expected

489− takeMVar done

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

490

539

491 -- Two layers of merging

540 -- Two layers of merging

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

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

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

497 ms <- mapM (mergePorts biasedInner) rss

546 ms <- mapM (mergePorts biasedInner) rss

498 m <- mergePorts biasedOuter ms

547 m <- mergePorts biasedOuter ms

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

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

500− True <- return $ xs == expected

549+ liftIO $ putMVar done $ xs == expected

501− liftIO $ putMVar done ()

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

502− takeMVar done

503

551

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

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

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

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

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

508 done <- newEmptyMVar

556 done <- newEmptyMVar

509

557

510 forkProcess localNode $ do

558 forkProcess localNode $ do

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

559+ ss <- liftIO $ mapM readMVar vs

560+ case ss of

561+ [sa, sb, sc] ->

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

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

513− [ -- a, b, c

563+ [ -- a, b, c

514− (sa, 'a')

564+ (sa, 'a')

515− , (sb, 'b')

565+ , (sb, 'b')

516− , (sc, 'c')

566+ , (sc, 'c')

517− -- a, c, b

567+ -- a, c, b

518− , (sa, 'a')

568+ , (sa, 'a')

519− , (sc, 'c')

569+ , (sc, 'c')

520− , (sb, 'b')

570+ , (sb, 'b')

521− -- b, a, c

571+ -- b, a, c

522− , (sb, 'b')

572+ , (sb, 'b')

523− , (sa, 'a')

573+ , (sa, 'a')

524− , (sc, 'c')

574+ , (sc, 'c')

525− -- b, c, a

575+ -- b, c, a

526− , (sb, 'b')

576+ , (sb, 'b')

527− , (sc, 'c')

577+ , (sc, 'c')

528− , (sa, 'a')

578+ , (sa, 'a')

529− -- c, a, b

579+ -- c, a, b

530− , (sc, 'c')

580+ , (sc, 'c')

531− , (sa, 'a')

581+ , (sa, 'a')

532− , (sb, 'b')

582+ , (sb, 'b')

533− -- c, b, a

583+ -- c, b, a

534− , (sc, 'c')

584+ , (sc, 'c')

535− , (sb, 'b')

585+ , (sb, 'b')

536− , (sa, 'a')

586+ , (sa, 'a')

537− ]

587+ ]

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

538

589

539 forkProcess localNode $ do

590 forkProcess localNode $ do

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

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

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

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

542 m <- mergePorts biased rs

593 m <- mergePorts biased rs

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

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

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

545− liftIO $ putMVar done ()

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

546

596

547− takeMVar done

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

548

598

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

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

550 mergePorts True = mergePortsBiased

600 mergePorts True = mergePortsBiased

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

562 localNode <- newLocalNode testTransport initRemoteTable

612 localNode <- newLocalNode testTransport initRemoteTable

563 runProcess localNode $ do

613 runProcess localNode $ do

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

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

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

615+ if either show show e == show ProcessTerminationException

566− return ()

616+ then return ()

617+ else die "Unexpected result from terminate"

567

618

568testMonitorNode :: TestTransport -> Assertion

619testMonitorNode :: TestTransport -> Assertion

569testMonitorNode TestTransport{..} = do

620testMonitorNode TestTransport{..} = do

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

574

625

575 runProcess node2 $ do

626 runProcess node2 $ do

576 ref <- monitorNode (localNodeId node1)

627 ref <- monitorNode (localNodeId node1)

628+ receiveWait [

577− NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

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

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

579− liftIO $ putMVar done ()

631+ ] >>= liftIO . putMVar done

580

632

581− takeMVar done

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

582

634

583testMonitorLiveNode :: TestTransport -> Assertion

635testMonitorLiveNode :: TestTransport -> Assertion

584testMonitorLiveNode TestTransport{..} = do

636testMonitorLiveNode TestTransport{..} = do

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

593 liftIO $ putMVar ready ()

645 liftIO $ putMVar ready ()

594 liftIO $ takeMVar readyr

646 liftIO $ takeMVar readyr

595 send p ()

647 send p ()

648+ receiveWait [

596− NodeMonitorNotification ref' nid _ <- expect

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

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

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

598− liftIO $ putMVar done ()

651+ ] >>= liftIO . putMVar done

599

652

600 takeMVar ready

653 takeMVar ready

601 closeLocalNode node1

654 closeLocalNode node1

602 putMVar readyr ()

655 putMVar readyr ()

603

656

604− takeMVar done

657+ verifyClient "Expected NodeMonitorNotification for LIVE node" done

605

658

606testMonitorChannel :: TestTransport -> Assertion

659testMonitorChannel :: TestTransport -> Assertion

607testMonitorChannel TestTransport{..} = do

660testMonitorChannel TestTransport{..} = do

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

611 pid <- forkProcess node1 $ do

664 pid <- forkProcess node1 $ do

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

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

613 ref <- monitorPort sport

666 ref <- monitorPort sport

614− PortMonitorNotification ref' port' reason <- expect

667+ receiveWait [

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

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

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

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

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

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

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

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

618− liftIO $ putMVar gotNotification ()

673+ ] >>= liftIO . putMVar gotNotification

619

674

620 runProcess node2 $ do

675 runProcess node2 $ do

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

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

622 send pid sport

677 send pid sport

623 liftIO $ threadDelay 100000

678 liftIO $ threadDelay 100000

624

679

625− takeMVar gotNotification

680+ verifyClient "Expected PortMonitorNotification" gotNotification

626

681

627testRegistry :: TestTransport -> Assertion

682testRegistry :: TestTransport -> Assertion

628testRegistry TestTransport{..} = do

683testRegistry TestTransport{..} = do

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

634

689

635 runProcess node $ do

690 runProcess node $ do

636 register "ping" pingServer

691 register "ping" pingServer

637− Just pid <- whereis "ping"

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

638− True <- return $ pingServer == pid

639 us <- getSelfPid

693 us <- getSelfPid

640 nsend "ping" (Pong us)

694 nsend "ping" (Pong us)

641− Ping pid' <- expect

695+ receiveWait [

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

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

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

697+ ]

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

698+ checkRegException "dead" Nothing deadProcess

645− True <- return $ x == pingServer

699+ checkRegException "ping" (Just pingServer) deadProcess

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

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

647 liftIO $ putMVar done ()

701 liftIO $ putMVar done ()

648

702

649 takeMVar done

703 takeMVar done

650

704

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+

651testRegistryRemoteProcess :: TestTransport -> Assertion

714testRegistryRemoteProcess :: TestTransport -> Assertion

652testRegistryRemoteProcess TestTransport{..} = do

715testRegistryRemoteProcess TestTransport{..} = do

653 node1 <- newLocalNode testTransport initRemoteTable

716 node1 <- newLocalNode testTransport initRemoteTable

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

658

721

659 runProcess node2 $ do

722 runProcess node2 $ do

660 register "ping" pingServer

723 register "ping" pingServer

661− Just pid <- whereis "ping"

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

662− True <- return $ pingServer == pid

663 us <- getSelfPid

725 us <- getSelfPid

664 nsend "ping" (Pong us)

726 nsend "ping" (Pong us)

665− Ping pid' <- expect

727+ receiveWait [

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

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

667− liftIO $ putMVar done ()

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

730+ ]

668

731

669 takeMVar done

732 takeMVar done

670

733

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

672testRemoteRegistry TestTransport{..} = do

735testRemoteRegistry TestTransport{..} = do

673 node1 <- newLocalNode testTransport initRemoteTable

736 node1 <- newLocalNode testTransport initRemoteTable

674 node2 <- newLocalNode testTransport initRemoteTable

737 node2 <- newLocalNode testTransport initRemoteTable

675− done <- newEmptyMVar

676

738

677 pingServer <- forkProcess node1 ping

739 pingServer <- forkProcess node1 ping

678 deadProcess <- forkProcess node1 (return ())

740 deadProcess <- forkProcess node1 (return ())

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

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

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

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

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

687

749

688− Just pid <- whereisRemote nid1 "ping"

750+ pid <- verifyWhereIsRemote nid1 "ping"

689− True <- return $ pingServer == pid

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

752+

690 us <- getSelfPid

753 us <- getSelfPid

691 nsendRemote nid1 "ping" (Pong us)

754 nsendRemote nid1 "ping" (Pong us)

692− Ping pid' <- expect

755+ receiveWait [

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

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

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

694

758

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

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

696 -- in owner field.

760 -- in owner field.

697 registerRemoteAsync nid1 "dead" deadProcess

761 registerRemoteAsync nid1 "dead" deadProcess

698− receiveWait [

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

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

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

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

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

765+

701 registerRemoteAsync nid1 "ping" deadProcess

766 registerRemoteAsync nid1 "ping" deadProcess

702 receiveWait [

767 receiveWait [

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

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

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

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

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

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

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

772+

706 unregisterRemoteAsync nid1 "dead"

773 unregisterRemoteAsync nid1 "dead"

707 receiveWait [

774 receiveWait [

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

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

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

714

778

715testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

779testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

716testRemoteRegistryRemoteProcess TestTransport{..} = do

780testRemoteRegistryRemoteProcess TestTransport{..} = do

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

726 receiveWait [

790 receiveWait [

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

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

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

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

729− Just pid <- whereisRemote nid1 "ping"

793+ pid <- verifyWhereIsRemote nid1 "ping"

730− True <- return $ pingServer == pid

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

731 us <- getSelfPid

795 us <- getSelfPid

732 nsendRemote nid1 "ping" (Pong us)

796 nsendRemote nid1 "ping" (Pong us)

733− Ping pid' <- expect

797+ receiveWait [

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

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

735− liftIO $ putMVar done ()

799+ ] >>= liftIO . putMVar done

736

800

737− takeMVar done

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

738

802

739testSpawnLocal :: TestTransport -> Assertion

803testSpawnLocal :: TestTransport -> Assertion

740testSpawnLocal TestTransport{..} = do

804testSpawnLocal TestTransport{..} = do

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

748 sport <- expect

812 sport <- expect

749 sendChan sport (1234 :: Int)

813 sendChan sport (1234 :: Int)

750

814

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

815+ sport <- spawnChannelLocal $

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

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

753− send us ()

754

817

755 send pid sport

818 send pid sport

756− () <- expect

757− liftIO $ putMVar done ()

819+ expect >>= liftIO . putMVar done

758

820

759− takeMVar done

821+ res <- takeMVar done

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

760

823

761testSpawnAsyncStrictness :: TestTransport -> Assertion

824testSpawnAsyncStrictness :: TestTransport -> Assertion

762testSpawnAsyncStrictness TestTransport{..} = do

825testSpawnAsyncStrictness TestTransport{..} = do

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

785 liftIO $ putMVar processA us

848 liftIO $ putMVar processA us

786 msg1 <- expect

849 msg1 <- expect

787 msg2 <- expect

850 msg2 <- expect

851+ liftIO $ do

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

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

789− liftIO $ putMVar sendTestOk ()

853+ putMVar sendTestOk ()

790

854

791 forkProcess node2 $ do

855 forkProcess node2 $ do

792 {-

856 {-

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

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

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

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

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

821

885

822− Just _ <- whereisRemote nid1 "a"

886+ _ <- whereisRemote nid1 "a"

823

887

824

888

825 -- Simulate network failure

889 -- Simulate network failure

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

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

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

839

903

840 -- Check

904 -- Check

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

905+ mPid <- 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

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

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

843− Just _ <- whereisRemote nid1 "c"

908+ verifyWhereIsRemote nid1 "c"

844

909

845 liftIO $ putMVar registerTestOk ()

910 liftIO $ putMVar registerTestOk ()

846

911

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

881 isSorted _ = True

946 isSorted _ = True

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

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

883 -- the last message.

948 -- the last message.

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

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

885− liftIO $ putMVar usendTestOk ()

886

950

887 forkProcess node2 $ do

951 forkProcess node2 $ do

888 them <- liftIO $ readMVar processA

952 them <- liftIO $ readMVar processA

889 getSelfPid >>= send them

953 getSelfPid >>= send them

890− () <- expect

954+ expect :: Process ()

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

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

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

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

893 usendPrim them i

957 usendPrim them i

894 liftIO (threadDelay 30000)

958 liftIO (threadDelay 30000)

895

959

896− takeMVar usendTestOk

960+ res <- takeMVar usendTestOk

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

897

962

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

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

899-- in between

964-- in between

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

919 runProcess localNode $ do

984 runProcess localNode $ do

920 pid <- getSelfPid

985 pid <- getSelfPid

921 send mathServer (Add pid 1 2)

986 send mathServer (Add pid 1 2)

922− 3 <- expect :: Process Double

987+ three <- expect :: Process Double

923 send mathServer (Divide pid 8 2)

988 send mathServer (Divide pid 8 2)

924− 4 <- expect :: Process Double

989+ four <- expect :: Process Double

925 send mathServer (Divide pid 8 0)

990 send mathServer (Divide pid 8 0)

926− DivByZero <- expect

991+ divByZ <- expect

927− liftIO $ putMVar clientDone ()

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

928

993

929− takeMVar clientDone

994+ res <- takeMVar clientDone

995+ case res of

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

997+ _ -> error "Unexpected result"

930

998

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

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

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

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

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

953 runProcess localNode $ do

1021 runProcess localNode $ do

954 pid <- getSelfPid

1022 pid <- getSelfPid

955 send mathServer (Add pid 1 2)

1023 send mathServer (Add pid 1 2)

956− 3 <- expect :: Process Double

1024+ three <- expect :: Process Double

957 send mathServer (Divide pid 8 2)

1025 send mathServer (Divide pid 8 2)

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

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

959− liftIO $ putMVar clientDone ()

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

1028+

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

960

1030

961− takeMVar clientDone

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

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

963 maybeForward s msg =

1032 maybeForward s msg =

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

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

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

986 Just _ -> die "NONSENSE")

1055 Just _ -> die "NONSENSE")

987 ]

1056 ]

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

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

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

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

1059+ liftIO $ do

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

990− liftIO $ putMVar serverDone ()

1061+ putMVar serverDone ()

991 putMVar addr server

1062 putMVar addr server

992

1063

993 -- Client

1064 -- Client

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

1030 runProcess localNode $ do

1101 runProcess localNode $ do

1031 pid <- getSelfPid

1102 pid <- getSelfPid

1032 send server (pid, "foo")

1103 send server (pid, "foo")

1033− "foo" <- expect

1104+ foo <- expect

1034− send server (pid, "baz")

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

1035− "baz" <- expect

1106+

1036 send server (pid, "bar")

1107 send server (pid, "bar")

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

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

1109+

1110+ send server (pid, "baz")

1111+ baz <- expect

1112+

1038− liftIO $ putMVar clientDone ()

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

1114+

1115+ res <- takeMVar clientDone

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

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

1039

1118

1040− takeMVar clientDone

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

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

1042 tryHandleMessage msg =

1120 tryHandleMessage msg =

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

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

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

1070 runProcess localNode $ do

1148 runProcess localNode $ do

1071 pid <- getSelfPid

1149 pid <- getSelfPid

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

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

1073− "foo" <- expect

1151+ foo <- expect

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

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

1075− "baz" <- expect

1153+ baz <- expect

1076− liftIO $ putMVar clientDone ()

1154+ liftIO $ putMVar clientDone (foo, baz)

1077

1155

1078− takeMVar clientDone

1156+ res <- takeMVar clientDone

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

1079

1158

1080-- Test 'receiveChanTimeout'

1159-- Test 'receiveChanTimeout'

1081testReceiveChanTimeout :: TestTransport -> Assertion

1160testReceiveChanTimeout :: TestTransport -> Assertion

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

1093

1172

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

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

1095 -- Nothing after the delay.

1174 -- Nothing after the delay.

1096− Nothing <- receiveChanTimeout 100000 rp

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

1097

1176

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

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

1099 liftIO $ putMVar mvSender ()

1178 liftIO $ putMVar mvSender ()

1100

1179

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

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

1102 -- 0.1 seconds

1181 -- 0.1 seconds

1103− Just True <- receiveChanTimeout 20000000 rp

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

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

1104

1184

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

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

1106 -- available, we get Nothing

1186 -- available, we get Nothing

1107− Nothing <- receiveChanTimeout 0 rp

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

1108

1188

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

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

1110 liftIO $ putMVar mvSender ()

1190 liftIO $ putMVar mvSender ()

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

1114 liftIO $ threadDelay 100000

1194 liftIO $ threadDelay 100000

1115 mb <- receiveChanTimeout 0 rp

1195 mb <- receiveChanTimeout 0 rp

1116 case mb of

1196 case mb of

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

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

1118 _ -> loop

1198 _ -> loop

1119

1199

1120 liftIO $ putMVar done ()

1200 liftIO $ putMVar done ()

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

1151

1231

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

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

1153

1233

1154− True <- receiveChan rp1

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

1155− False <- receiveChan rp1

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

1156

1236

1157 -- Test Applicative instance

1237 -- Test Applicative instance

1158

1238

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

1161

1241

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

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

1163

1243

1164− 7 <- receiveChan rp2

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

1165

1245

1166 -- Test Alternative instance

1246 -- Test Alternative instance

1167

1247

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

1170

1250

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

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

1172

1252

1173− False <- receiveChan rp3

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

1174− True <- receiveChan rp3

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

1175

1255

1176 -- Test Monad instance

1256 -- Test Monad instance

1177

1257

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

1185 then rpInt

1265 then rpInt

1186 else return 7

1266 else return 7

1187

1267

1188− 5 <- receiveChan rp4

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

1189− 7 <- receiveChan rp4

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

1190

1270

1191 liftIO $ putMVar done ()

1271 liftIO $ putMVar done ()

1192

1272

1193 takeMVar done

1273 takeMVar done

1194

1274

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+

1195testKillLocal :: TestTransport -> Assertion

1345testKillLocal :: TestTransport -> Assertion

1196testKillLocal TestTransport{..} = do

1346testKillLocal TestTransport{..} = do

1197 localNode <- newLocalNode testTransport initRemoteTable

1347 localNode <- newLocalNode testTransport initRemoteTable

1198− done <- newEmptyMVar

1199

1348

1200 pid <- forkProcess localNode $ do

1349 pid <- forkProcess localNode $ do

1201 liftIO $ threadDelay 1000000

1350 liftIO $ threadDelay 1000000

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

1204 ref <- monitor pid

1353 ref <- monitor pid

1205 us <- getSelfPid

1354 us <- getSelfPid

1206 kill pid "TestKill"

1355 kill pid "TestKill"

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

1356+ mn <- expect

1357+ case mn of

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

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

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

1209− liftIO $ putMVar done ()

1360+ True -> return ()

1210−

1361+ False -> die "Invalid ProcessMonitorNotification received"

1211− takeMVar done

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

1212

1363

1213testKillRemote :: TestTransport -> Assertion

1364testKillRemote :: TestTransport -> Assertion

1214testKillRemote TestTransport{..} = do

1365testKillRemote TestTransport{..} = do

1215 node1 <- newLocalNode testTransport initRemoteTable

1366 node1 <- newLocalNode testTransport initRemoteTable

1216 node2 <- newLocalNode testTransport initRemoteTable

1367 node2 <- newLocalNode testTransport initRemoteTable

1217− done <- newEmptyMVar

1218

1368

1219 pid <- forkProcess node1 $ do

1369 pid <- forkProcess node1 $ do

1220 liftIO $ threadDelay 1000000

1370 liftIO $ threadDelay 1000000

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

1223 ref <- monitor pid

1373 ref <- monitor pid

1224 us <- getSelfPid

1374 us <- getSelfPid

1225 kill pid "TestKill"

1375 kill pid "TestKill"

1376+ mn <- expect

1377+ case mn of

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

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

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

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

1228− liftIO $ putMVar done ()

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

1229−

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

1230− takeMVar done

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

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"

1231

1387

1232testCatchesExit :: TestTransport -> Assertion

1388testCatchesExit :: TestTransport -> Assertion

1233testCatchesExit TestTransport{..} = do

1389testCatchesExit TestTransport{..} = do

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

1253 self <- getSelfPid

1409 self <- getSelfPid

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

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

1255 msg <- receiveWait [ matchMessage return ]

1411 msg <- receiveWait [ matchMessage return ]

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

1412+ handleMessageIf msg

1413+ (\() -> True)

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

1415+ (const $ die "Expected Mismatch")

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

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

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

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

1259 return ()

1418 return ()

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

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

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

1299 `catchExit` \_from reason -> do

1458 `catchExit` \_from reason -> do

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

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

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

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

1302 liftIO $ putMVar done ()

1461 liftIO $ putMVar done ()

1462+ if res

1463+ then return ()

1464+ else die "Something went horribly wrong"

1303

1465

1304 takeMVar done

1466 takeMVar done

1305

1467

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

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

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

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

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

1315 in do

1477 in do

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

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

1317 liftIO $ putMVar done ()

1479 liftIO $ putMVar done ()

1480+ if res

1481+ then return ()

1482+ else die "Something went horribly wrong"

1318

1483

1319 takeMVar done

1484 takeMVar done

1320

1485

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

1330 pid <- forkProcess localNode $ do

1495 pid <- forkProcess localNode $ do

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

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

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

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

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

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

1334 liftIO $ putMVar supervisedDone ()

1499 liftIO $ putMVar supervisedDone ()

1500+ if res

1501+ then return ()

1502+ else die "Something went horribly wrong"

1335

1503

1336 runProcess localNode $ do

1504 runProcess localNode $ do

1337 liftIO $ takeMVar handlerSetUp

1505 liftIO $ takeMVar handlerSetUp

1338 ref <- monitor pid

1506 ref <- monitor pid

1339 exit pid "TestExit"

1507 exit pid "TestExit"

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

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

1509+ mn <- expect

1510+ case mn of

1341− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1511+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1343− liftIO $ putMVar supervisorDone ()

1513+ liftIO $ putMVar supervisorDone ()

1514+ if res

1515+ then return ()

1516+ else die "Something went horribly wrong"

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

1344

1518

1345 takeMVar supervisedDone

1519 takeMVar supervisedDone

1346 takeMVar supervisorDone

1520 takeMVar supervisorDone

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

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

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

1357 `catchExit` \_from reason -> do

1531 `catchExit` \_from reason -> do

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

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

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

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

1360 liftIO $ putMVar supervisedDone ()

1534 liftIO $ putMVar supervisedDone ()

1535+ if res

1536+ then return ()

1537+ else die "Something went horribly wrong"

1361

1538

1362 runProcess node2 $ do

1539 runProcess node2 $ do

1363 ref <- monitor pid

1540 ref <- monitor pid

1364 exit pid "TestExit"

1541 exit pid "TestExit"

1542+ mn <- expect

1543+ case mn of

1365− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1544+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

1367− liftIO $ putMVar supervisorDone ()

1546+ liftIO $ putMVar supervisorDone ()

1547+ if res'

1548+ then return ()

1549+ else die "Something went horribly wrong"

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

1368

1551

1369 takeMVar supervisedDone

1552 takeMVar supervisedDone

1370 takeMVar supervisorDone

1553 takeMVar supervisorDone

1371

1554

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+

1372testUnsafeSend :: TestTransport -> Assertion

1625testUnsafeSend :: TestTransport -> Assertion

1373testUnsafeSend TestTransport{..} = do

1626testUnsafeSend TestTransport{..} = do

1374 serverAddr <- newEmptyMVar

1627 serverAddr <- newEmptyMVar

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

1384 void $ forkProcess localNode $ do

1637 void $ forkProcess localNode $ do

1385 serverPid <- liftIO $ takeMVar serverAddr

1638 serverPid <- liftIO $ takeMVar serverAddr

1386 getSelfPid >>= unsafeSend serverPid

1639 getSelfPid >>= unsafeSend serverPid

1387− () <- expect

1388− liftIO $ putMVar clientDone ()

1640+ expect >>= liftIO . putMVar clientDone

1389

1641

1390 takeMVar clientDone

1642 takeMVar clientDone

1391

1643

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

1404 void $ forkProcess localNode $ do

1656 void $ forkProcess localNode $ do

1405 serverPid <- liftIO $ takeMVar serverAddr

1657 serverPid <- liftIO $ takeMVar serverAddr

1406 getSelfPid >>= unsafeUSend serverPid

1658 getSelfPid >>= unsafeUSend serverPid

1407− () <- expect

1408− liftIO $ putMVar clientDone ()

1659+ expect >>= liftIO . putMVar clientDone

1409

1660

1410 takeMVar clientDone

1661 takeMVar clientDone

1411

1662

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

1416 localNode <- newLocalNode testTransport initRemoteTable

1667 localNode <- newLocalNode testTransport initRemoteTable

1417

1668

1418 pid <- forkProcess localNode $ do

1669 pid <- forkProcess localNode $ do

1419− () <- expect

1420− liftIO $ putMVar clientDone ()

1670+ expect >>= liftIO . putMVar clientDone

1421

1671

1422 void $ runProcess localNode $ do

1672 void $ runProcess localNode $ do

1423 register "foobar" pid

1673 register "foobar" pid

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

1435 _ <- forkProcess localNode1 $ do

1685 _ <- forkProcess localNode1 $ do

1436 getSelfPid >>= register "foobar"

1686 getSelfPid >>= register "foobar"

1437 liftIO $ putMVar clientDone ()

1687 liftIO $ putMVar clientDone ()

1438− () <- expect

1439− liftIO $ putMVar clientDone ()

1688+ expect >>= liftIO . putMVar clientDone

1440

1689

1441 takeMVar clientDone

1690 takeMVar clientDone

1442 void $ runProcess localNode2 $ do

1691 void $ runProcess localNode2 $ do

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

1460 serverPid <- liftIO $ takeMVar serverAddr

1709 serverPid <- liftIO $ takeMVar serverAddr

1461 (sp, rp) <- newChan

1710 (sp, rp) <- newChan

1462 unsafeSend serverPid sp

1711 unsafeSend serverPid sp

1463− () <- receiveChan rp

1712+ receiveChan rp :: Process ()

1464 liftIO $ putMVar clientDone ()

1713 liftIO $ putMVar clientDone ()

1465

1714

1466 takeMVar clientDone

1715 takeMVar clientDone

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

1474 runProcess node $ do

1723 runProcess node $ do

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

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

1476 liftIO $ putMVar result r

1725 liftIO $ putMVar result r

1726+

1477− True <- takeMVar result

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

1478− return ()

1479

1728

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

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

1481 ibox <- newIORef False

1730 ibox <- newIORef False

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

1492 (send keeper ())

1741 (send keeper ())

1493 caller <- expect

1742 caller <- expect

1494 exit caller "test"

1743 exit caller "test"

1495− () <- expect

1744+ expect :: Process ()

1496− return ()

1745+

1497− True <- readIORef ibox

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

1498− return ()

1499

1747

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

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

1501 ibox2 <- newIORef False

1749 ibox2 <- newIORef False

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

1504 liftIO $ writeIORef ibox2 $ case r of

1752 liftIO $ writeIORef ibox2 $ case r of

1505 Left (ErrorCall "e") -> True

1753 Left (ErrorCall "e") -> True

1506 _ -> False

1754 _ -> False

1755+

1507− True <- readIORef ibox

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

1508− return ()

1509

1757

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

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

1511 ibox3 <- newIORef False

1759 ibox3 <- newIORef False

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

1522 liftIO $ putMVar result3 =<< readIORef ibox3

1770 liftIO $ putMVar result3 =<< readIORef ibox3

1523 worker <- expect

1771 worker <- expect

1524 send worker ()

1772 send worker ()

1773+

1525− True <- takeMVar result3

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

1526− return ()

1527

1775

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

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

1529 ibox4 <- newIORef False

1777 ibox4 <- newIORef False

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

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

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

1540 caller <- expect

1788 caller <- expect

1541 exit caller "hi!"

1789 exit caller "hi!"

1542− True <- takeMVar result4

1543− return ()

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

1545−

1546−

1547−

1548

1790

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

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

1549

1793

1550tests :: TestTransport -> IO [Test]

1794tests :: TestTransport -> IO [Test]

1551tests testtrans = return [

1795tests testtrans = return [

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

1570 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1571 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1572 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1573 , testCase "KillLocal" (testKillLocal testtrans)

1818 , testCase "KillLocal" (testKillLocal testtrans)

1574 , testCase "KillRemote" (testKillRemote testtrans)

1819 , testCase "KillRemote" (testKillRemote testtrans)

1575 , testCase "Die" (testDie testtrans)

1820 , testCase "Die" (testDie testtrans)

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

1579 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1580 , testCase "ExitLocal" (testExitLocal testtrans)

1825 , testCase "ExitLocal" (testExitLocal testtrans)

1581 , testCase "ExitRemote" (testExitRemote testtrans)

1826 , testCase "ExitRemote" (testExitRemote testtrans)

1827+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1582 , testCase "TextCallLocal" (testCallLocal testtrans)

1828 , testCase "TextCallLocal" (testCallLocal testtrans)

1583 -- Unsafe Primitives

1829 -- Unsafe Primitives

1584 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

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

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

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

1632 ]

1878 ]

1633 ]

1879 ]

1634−

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

1636−syncBreakConnection breakConnection nid0 nid1 = do

1637− m <- newEmptyMVar

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

1639− runProcess nid0 $ do

1640− them <- liftIO $ takeMVar m

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

1642− _ <- monitorNode (localNodeId nid1)

1643− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1644− (nodeAddress $ localNodeId nid1)

1645− NodeMonitorNotification _ _ _ <- expect

1646− kill pinger "finished"

1647− return ()

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

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

169 node <- newLocalNode testTransport rtable

170 done <- newEmptyMVar

171 forkProcess node $ do

172− 120 <- join . unClosure $ factorialClosure 5

172+ i <- join . unClosure $ factorialClosure 5

173 liftIO $ putMVar done ()

174+ if i == 720

175+ then return ()

176+ else error "Something went horribly wrong"

174 takeMVar done

177 takeMVar done

175

178

176testBind :: TestTransport -> RemoteTable -> Assertion

179testBind :: TestTransport -> RemoteTable -> Assertion

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

180 runProcess node $ do

183 runProcess node $ do

181 us <- getSelfPid

184 us <- getSelfPid

182 join . unClosure $ sendFac 6 us

185 join . unClosure $ sendFac 6 us

183− (720 :: Int) <- expect

186+ (i :: Int) <- expect

184 liftIO $ putMVar done ()

187 liftIO $ putMVar done ()

188+ if i == 720

189+ then return ()

190+ else error "Something went horribly wrong"

185 takeMVar done

191 takeMVar done

186

192

187testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

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

194 addr <- forkProcess node $ do

200 addr <- forkProcess node $ do

195 cl <- expect

201 cl <- expect

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

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

197− 13 <- return $ fn 6

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

198 liftIO $ putMVar serverDone ()

204 liftIO $ putMVar serverDone ()

199 putMVar serverAddr addr

205 putMVar serverAddr addr

200

206

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

218 liftIO $ do

224 liftIO $ do

219 someMVar <- newEmptyMVar

225 someMVar <- newEmptyMVar

220 io someMVar

226 io someMVar

221− 5 <- readMVar someMVar

227+ i <- readMVar someMVar

222 putMVar serverDone ()

228 putMVar serverDone ()

229+ if i == 5

230+ then return ()

231+ else error "Something went horribly wrong"

223 putMVar serverAddr addr

232 putMVar serverAddr addr

224

233

225 forkIO $ do

234 forkIO $ do

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

248 runProcess node $ do

257 runProcess node $ do

249 pid <- getSelfPid

258 pid <- getSelfPid

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

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

251− 5 <- expect :: Process Int

260+ i <- expect :: Process Int

261+ if i == 5

252− liftIO $ putMVar clientDone ()

262+ then liftIO $ putMVar clientDone ()

263+ else error "Something went horribly wrong"

253

264

254 takeMVar clientDone

265 takeMVar clientDone

255

266

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

269 pid <- getSelfPid

280 pid <- getSelfPid

270 pid' <- spawn nid (sendPidClosure pid)

281 pid' <- spawn nid (sendPidClosure pid)

271 pid'' <- expect

282 pid'' <- expect

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

283+ if pid' == pid''

273− liftIO $ putMVar clientDone ()

284+ then liftIO $ putMVar clientDone ()

285+ else error "Something went horribly wrong"

274

286

275 takeMVar clientDone

287 takeMVar clientDone

276

288

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

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

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

295 pid' <- expect :: Process ProcessId

307 pid' <- expect :: Process ProcessId

296 pid'' <- expect :: Process ProcessId

308 pid'' <- expect :: Process ProcessId

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

309+ if pid' == pid''

298− return ()

310+ then return ()

311+ else error "Something went horribly wrong"

299

312

300 where

313 where

301

314

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

332 node <- newLocalNode testTransport rtable

345 node <- newLocalNode testTransport rtable

333 nid <- readMVar serverNodeAddr

346 nid <- readMVar serverNodeAddr

334 runProcess node $ do

347 runProcess node $ do

335− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

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

349+ if a == 120

336− liftIO $ putMVar clientDone ()

350+ then liftIO $ putMVar clientDone ()

351+ else error "something went horribly wrong"

337

352

338 takeMVar clientDone

353 takeMVar clientDone

339

354

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

350 node <- newLocalNode testTransport rtable

365 node <- newLocalNode testTransport rtable

351 nid <- readMVar serverNodeAddr

366 nid <- readMVar serverNodeAddr

352 runProcess node $ do

367 runProcess node $ do

353− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

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

369+ if a == 120

354− liftIO $ putMVar clientDone ()

370+ then liftIO $ putMVar clientDone ()

371+ else error "Something went horribly wrong"

355

372

356 takeMVar clientDone

373 takeMVar clientDone

357

374

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

362 runProcess node $ do

379 runProcess node $ do

363 us <- getSelfPid

380 us <- getSelfPid

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

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

365− 120 :: Int <- expect

382+ a :: Int <- expect

366− 720 :: Int <- expect

383+ b :: Int <- expect

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

367− liftIO $ putMVar done ()

385+ then liftIO $ putMVar done ()

386+ else error "Something went horribly wrong"

368 takeMVar done

387 takeMVar done

369

388

370-- Test 'spawnSupervised'

389-- Test 'spawnSupervised'

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

393 throw supervisorDeath

412 throw supervisorDeath

394

413

395 forkProcess node2 $ do

414 forkProcess node2 $ do

396− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]

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

416+ case res of

417+ [super, child] -> do

397− ref <- monitor child

418+ ref <- monitor child

398− self <- getSelfPid

419+ self <- getSelfPid

399− let waitForMOrL = do

420+ let waitForMOrL = do

400− liftIO $ threadDelay 10000

421+ liftIO $ threadDelay 10000

401− mpinfo <- getProcessInfo child

422+ mpinfo <- getProcessInfo child

402− case mpinfo of

423+ case mpinfo of

403− Nothing -> waitForMOrL

424+ Nothing -> waitForMOrL

404− Just pinfo ->

425+ Just pinfo ->

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

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

406− waitForMOrL

427+ waitForMOrL

407− liftIO $ putMVar linkUp ()

428+ liftIO $ putMVar linkUp ()

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

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

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

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

431+ res' <- expect

432+ case res' of

410− ProcessMonitorNotification ref' pid' (DiedException e) <- expect

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

411− True <- return $ ref' == ref

412− && pid' == child

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

435+ e == show (ProcessLinkException super

413− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))

436+ (DiedException (show supervisorDeath))))

414− liftIO $ putMVar thirdProcessDone ()

437+ then liftIO $ putMVar thirdProcessDone ()

438+ else error "Something went horribly wrong"

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

440+

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

415

442

416 takeMVar thirdProcessDone

443 takeMVar thirdProcessDone

417 where

444 where

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

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

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

427 ProcessMonitorNotification ref' pid' _reason <- expect

454 ProcessMonitorNotification ref' pid' _reason <- expect

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

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

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

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

457+ if res == True

430− liftIO $ putMVar done ()

458+ then liftIO $ putMVar done ()

459+ else error "Something went horribly wrong"

431 takeMVar done

460 takeMVar done

432

461

433testClosureExpect :: TestTransport -> RemoteTable -> Assertion

462testClosureExpect :: TestTransport -> RemoteTable -> Assertion

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

439 us <- getSelfPid

468 us <- getSelfPid

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

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

441 send them (1234 :: Int)

470 send them (1234 :: Int)

442− (1234 :: Int) <- expect

471+ (res :: Int) <- expect

472+ if res == 1234

443− liftIO $ putMVar done ()

473+ then liftIO $ putMVar done ()

474+ else error "Something went horribly wrong"

444 takeMVar done

475 takeMVar done

445

476

446testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

477testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

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

465 done <- newEmptyMVar

496 done <- newEmptyMVar

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

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

467 forkProcess node1 $ do

498 forkProcess node1 $ do

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

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

500+ if res == True

469− liftIO $ putMVar done ()

501+ then liftIO $ putMVar done ()

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

470 takeMVar done

503 takeMVar done

471

504

472testFib :: TestTransport -> RemoteTable -> Assertion

505testFib :: TestTransport -> RemoteTable -> Assertion

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

477 forkProcess (head nodes) $ do

510 forkProcess (head nodes) $ do

478 (sport, rport) <- newChan

511 (sport, rport) <- newChan

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

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

480− 55 <- receiveChan rport :: Process Integer

513+ ff <- receiveChan rport :: Process Integer

481 liftIO $ putMVar done ()

514 liftIO $ putMVar done ()

515+ if ff /= 55

516+ then die $ "Something went horribly wrong"

517+ else return ()

482

518

483 takeMVar done

519 takeMVar done

484

520

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

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

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

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

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

488 let nid1 = localNodeId node1

524 let nid1 = localNodeId node1

489− nid2 = localNodeId node2

525+ -- nid2 = localNodeId node2

490 done <- newEmptyMVar

526 done <- newEmptyMVar

491 iv <- newMVar (0 :: Int)

527 iv <- newMVar (0 :: Int)

492

528

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

503 liftIO $ threadDelay 100000

539 liftIO $ threadDelay 100000

504

540

505 count <- liftIO $ takeMVar iv

541 count <- liftIO $ takeMVar iv

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

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

507

543

508 liftIO $ putMVar done ()

544 liftIO $ putMVar done ()

545+ if res /= True

546+ then error "Something went horribly wrong"

547+ else return ()

509

548

510 takeMVar done

549 takeMVar done

511

550

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

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

20 -- ping !

21 , Ping(Ping)

22 , ping

23+ , pause

23 , shouldBe

24 , shouldBe

24 , shouldMatch

25 , shouldMatch

25 , shouldContain

26 , shouldContain

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

73import Control.Concurrent.MVar

74import Control.Concurrent.MVar

74 ( putMVar

75 ( putMVar

75 )

76 )

76−import Control.Distributed.Process

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

77import Control.Distributed.Process.Node

78import Control.Distributed.Process.Node

78import Control.Distributed.Process.Serializable()

79import Control.Distributed.Process.Serializable()

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

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

81−import Control.Monad (forever)

82+import Control.Monad (forever, void)

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

82import Control.Monad.STM (atomically)

84import Control.Monad.STM (atomically)

83import Control.Rematch hiding (match)

85import Control.Rematch hiding (match)

84−import Control.Rematch.Run

86+import Control.Rematch.Run

85import Data.Binary

87import Data.Binary

86import Data.Typeable (Typeable)

88import Data.Typeable (Typeable)

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

89import Test.HUnit.Base (assertBool)

91import Test.HUnit.Base (assertBool)

91import GHC.Generics

93import GHC.Generics

94+import System.Timeout (timeout)

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

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

94type TestResult a = MVar a

97type TestResult a = MVar a

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

107

110

108instance Binary TestProcessControl where

111instance Binary TestProcessControl where

109

112

113+data Private = Private

114+ deriving (Typeable, Generic)

115+instance Binary Private where

116+

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

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

111noop :: Process ()

118noop :: Process ()

112noop = return ()

119noop = return ()

113

120

121+pause :: Int -> Process ()

122+pause delay =

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

124+

114synchronisedAssertion :: Eq a

125synchronisedAssertion :: Eq a

115 => String

126 => String

116 -> LocalNode

127 -> LocalNode

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

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

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

224tryRunProcess node p = do

235tryRunProcess node p = do

225 tid <- liftIO myThreadId

236 tid <- liftIO myThreadId

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

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

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

227

239

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

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

229tryForkProcess node p = do

241tryForkProcess node p = do

230 tid <- liftIO myThreadId

242 tid <- liftIO myThreadId

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

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

232−

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+390−53

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

1−{-# LANGUAGE DeriveGeneric #-}

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE ParallelListComp #-}

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

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

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

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

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

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

6−

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

7−import Control.Concurrent (threadDelay)

8−import Control.Distributed.Process

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

10+ ( ProcessExitException(..)

11+ , unsafeCreateUnencodedMessage

12+ )

9import Control.Distributed.Process.Node

13import Control.Distributed.Process.Node

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

15+ ( send

16+ , nsend

17+ , nsendRemote

18+ , usend

19+ , sendChan

20+ )

10import Control.Distributed.Process.Management

21import Control.Distributed.Process.Management

11 ( MxEvent(..)

22 ( MxEvent(..)

12 , MxAgentId(..)

23 , MxAgentId(..)

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

21 , mxUpdateLocal

32 , mxUpdateLocal

22 , mxNotify

33 , mxNotify

23 , mxBroadcast

34 , mxBroadcast

24− , mxGetId

25 )

35 )

26−import Control.Monad (void)

36+import Control.Monad (void, unless)

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

38+import Control.Rematch (equalTo)

27import Data.Binary

39import Data.Binary

28−import Data.List (find, sort)

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

29−import Data.Maybe (isJust)

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

30import Data.Typeable

42import Data.Typeable

31−import GHC.Generics

43+import GHC.Generics hiding (from)

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

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

33import Prelude hiding (catch, log)

45import Prelude hiding (catch, log)

34#endif

46#endif

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

45instance Binary Publish where

57instance 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+

47−testAgentBroadcast :: TestResult () -> Process ()

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

48testAgentBroadcast result = do

70testAgentBroadcast result = do

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

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

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

59 mxNotify ()

81 mxNotify ()

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

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

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

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

62− stash result =<< receiveChan resultRP

84+ stash result =<< receiveChanTimeout 10000000 resultRP

64 kill publisher "finished"

86 kill publisher "finished"

65 kill consumer "finished"

87 kill consumer "finished"

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

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

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

68testAgentDualInput result = do

90testAgentDualInput result = do

69 (sp, rp) <- newChan

91 (sp, rp) <- newChan

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

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

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

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

72 mxSetLocal . (+i) =<< mxGetLocal

94 mxSetLocal . (+i) =<< mxGetLocal

73 i' <- mxGetLocal

95 i' <- mxGetLocal

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

77 else mxReady)

99 else mxReady)

78 ]

100 ]

101

102+ mRef <- monitor s

103+

80 mxNotify (1 :: Int)

104 mxNotify (1 :: Int)

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

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

82 mxNotify (2 :: Int)

106 mxNotify (2 :: Int)

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

84 mxNotify (5 :: Int)

108 mxNotify (5 :: Int)

109

86 stash result =<< receiveChanTimeout 10000000 rp

110 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

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

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

89testAgentPrioritisation result = do

117testAgentPrioritisation result = do

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

123

96 let name = "prioritising-agent"

124 let name = "prioritising-agent"

97 (sp, rp) <- newChan

125 (sp, rp) <- newChan

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

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

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

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

100− mxUpdateLocal ((s:))

128+ mxUpdateLocal (s:)

101 st <- mxGetLocal

129 st <- mxGetLocal

102 case length st of

130 case length st of

103− n | n == 5 -> do liftMX $ sendChan sp st

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

104 mxDeactivate "finished"

132 mxDeactivate "finished"

105 _ -> mxReceive -- go to the mailbox

133 _ -> mxReceive -- go to the mailbox

106 )

134 )

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

111 mxNotify "fourth"

139 mxNotify "fourth"

112 nsend name "fifth"

140 nsend name "fifth"

113

141

114− stash result . sort =<< receiveChan rp

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

143+ awaitExit s

115

144

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

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

117testAgentMailboxHandling result = do

146testAgentMailboxHandling result = do

118 (sp, rp) <- newChan

147 (sp, rp) <- newChan

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

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

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

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

121 ]

150 ]

122

151

123− nsend "listener-agent" ()

152+ nsend "mailbox-agent" ()

124

153

125 stash result =<< receiveChanTimeout 1000000 rp

154 stash result =<< receiveChanTimeout 1000000 rp

126 kill agent "finished"

155 kill agent "finished"

127

156

128testAgentEventHandling :: TestResult Bool -> Process ()

157testAgentEventHandling :: TestResult Bool -> Process ()

129testAgentEventHandling result = do

158testAgentEventHandling 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+

130 let initState = [] :: [MxEvent]

167 let initState = [] :: [MxEvent]

168+ (rc, rs) <- newChan

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

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

132 (mxSink $ \ev -> do

170 (mxSink $ \ev -> do

133 st <- mxGetLocal

171 st <- mxGetLocal

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

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

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

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

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

138 _ -> return ()

176 _ -> return ()

139− act >> mxReady),

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

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

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

141 st <- mxGetLocal

179 st <- mxGetLocal

142 let found =

180 let found =

@@ -156,50 +194,349 @@ testAgentEventHandling result = do

156 mxReady)

194 mxReady)

157 ]

195 ]

158

196

159− _ <- monitor agentPid

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

198+ faff 2000000 rs

199+

160− (sp, rp) <- newChan

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

201+

161− pid <- spawnLocal $ sendChan sp ()

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

162− () <- receiveChan rp

163

203

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

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

165− -- higher probably that the agent has seen

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

166 monitor pid

206 monitor pid

207+

208+ send pid ()

209+ rct <- receiveChanTimeout 10000000 rp

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

211+

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

212+ pmn <- receiveTimeout 2000000 [ 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

168

217

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

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

170 mxNotify (MxSpawned pid, replyTo)

219 mxNotify (MxSpawned pid, replyTo)

171 mxNotify (MxProcessDied pid DiedNormal, replyTo)

220 mxNotify (MxProcessDied pid DiedNormal, replyTo)

172

221

173− seenAlive <- receiveChan reply

222+ seenAlive <- receiveChanTimeout 10000000 reply

174− seenDead <- 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

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"

175

324

176− stash result $ seenAlive && seenDead

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+

442+ p1 <- receiveChanTimeout 2000000 rp

443+ unless (isJust p1) $ die "Timed out waiting for ProcessId"

444+ res <- try $ test (fromJust p1) sink

445+

446+ kill agent "bye"

447+ kill (fromJust p1) "bye"

448+

449+ case res of

450+ Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

451+ Right tr -> tr `shouldBe` equalTo True

452+

453+

454+ where

455+ agentLabel s = "mx-unsafe-check-agent-" ++ show s

456+ proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

457+

458+ go :: Maybe (ReceivePort ()) -> Process ()

459+ go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go

460+ go c@(Just c') = receiveWait [ matchChan c' return ] >> go c

461+

462+ replyChannel p' = do

463+ (s, r) <- newChan

464+ send p' s

465+ return r

177

466

178tests :: TestTransport -> IO [Test]

467tests :: TestTransport -> IO [Test]

179tests TestTransport{..} = do

468tests TestTransport{..} = do

180 node1 <- newLocalNode testTransport initRemoteTable

469 node1 <- newLocalNode testTransport initRemoteTable

470+ node2 <- newLocalNode testTransport initRemoteTable

181 return [

471 return [

182− testGroup "Mx Agents" [

472+ testGroup "MxAgents" [

183− testCase "Event Handling"

473+ testCase "EventHandling"

184− (delayedAssertion

474+ (delayedAssertion

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

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

186− node1 True testAgentEventHandling)

476+ node1 True testAgentEventHandling)

187− , testCase "Inter-Agent Broadcast"

477+ , testCase "InterAgentBroadcast"

188− (delayedAssertion

478+ (delayedAssertion

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

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

190− node1 () testAgentBroadcast)

480+ node1 (Just ()) testAgentBroadcast)

191− , testCase "Agent Mailbox Handling"

481+ , testCase "AgentMailboxHandling"

192− (delayedAssertion

482+ (delayedAssertion

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

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

194− node1 (Just ()) testAgentMailboxHandling)

484+ node1 (Just ()) testAgentMailboxHandling)

195− , testCase "Agent Dual Input Handling"

485+ , testCase "AgentDualInputHandling"

196− (delayedAssertion

486+ (delayedAssertion

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

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

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

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

199− , testCase "Agent Input Prioritisation"

489+ , testCase "AgentInputPrioritisation"

200− (delayedAssertion

490+ (delayedAssertion

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

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

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

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

203− "third", "fourth",

493+ "third", "fourth",

204− "fifth"]) testAgentPrioritisation)

494+ "fifth"]) testAgentPrioritisation)

495+ ]

496+ , testGroup "MxEvents" [

497+ testCase "NameRegistrationEvents"

498+ (delayedAssertion

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

500+ node1 () testMxRegEvents)

501+ , testCase "PostDeathNameUnRegistrationEvents"

502+ (delayedAssertion

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

504+ node1 () (testMxRegMon node2))

505+ , testGroup "SendEvents" $ buildTestCases node1 node2

205− ]]

506+ ]

507+ ]

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

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

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

11import Network.Transport (Transport)

12import Control.Distributed.Process

13−import Control.Distributed.Process.Closure

14import Control.Distributed.Process.Node

13import Control.Distributed.Process.Node

16import Control.Monad

15import Control.Monad

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

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

19−import Test.Framework (Test, defaultMain)

18+import Test.Framework (Test)

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

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

22-- Tests:

21-- Tests:

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

43 -> SendPort String

42 -> SendPort String

44 -> ReceivePort String -> ReceivePort String

43 -> ReceivePort String -> ReceivePort String

45 -> Process ()

44 -> Process ()

46−recTest2 wait sync r1 r2 = do

45+recTest2 wait sync r1 _ = do

47 forever $ do

46 forever $ do

48 receiveChan wait

47 receiveChan wait

49 r <- receiveWait

48 r <- receiveWait

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

56 -> SendPort String

55 -> SendPort String

57 -> ReceivePort String -> ReceivePort String

56 -> ReceivePort String -> ReceivePort String

58 -> Process ()

57 -> Process ()

59−recTest3 wait sync r1 r2 = do

58+recTest3 wait sync r1 _ = do

60 forever $ do

59 forever $ do

61 receiveChan wait

60 receiveChan wait

62 r <- receiveWait

61 r <- receiveWait

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

69 -> SendPort String

68 -> SendPort String

70 -> ReceivePort String -> ReceivePort String

69 -> ReceivePort String -> ReceivePort String

71 -> Process ()

70 -> Process ()

72−recTest4 wait sync r1 r2 = do

71+recTest4 wait sync r1 _ = do

73 forever $ do

72 forever $ do

74 receiveChan wait

73 receiveChan wait

75 r <- receiveWait

74 r <- receiveWait

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

83master = do

82master = do

84 (waits,waitr) <- newChan

83 (waits,waitr) <- newChan

85 (syncs,syncr) <- newChan

84 (syncs,syncr) <- newChan

86− let go expect = do

85+ let go expected = do

87 sendChan waits ()

86 sendChan waits ()

88 r <- receiveChan syncr

87 r <- receiveChan syncr

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

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

90− liftIO $ r @?= expect

89+ liftIO $ r @?= expected

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

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

93 (s1,r1) <- newChan

92 (s1,r1) <- newChan

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+11−7

@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)

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

31testLocalDeadProcessInfo result = do

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

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

33 mref <- monitor pid

34 send pid "finish"

35 _ <- receiveWait [

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

52 link self

53 mRef <- monitor self

54 stash mon mRef

55− "die" <- expect

55+ res <- expect

56+ case res of

56− return ()

57+ "die" -> return ()

58+ _ -> die $ "unexpected message received: " ++ res

58 monRef <- liftIO $ takeMVar mon

60 monRef <- liftIO $ takeMVar mon

@@ -84,9 +86,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

84 -- our send op shouldn't overtake link or monitor requests AFAICT

86 -- our send op shouldn't overtake link or monitor requests AFAICT

85 -- so a little table tennis should get us synchronised properly

87 -- so a little table tennis should get us synchronised properly

86 send serverPid (self, "ping")

88 send serverPid (self, "ping")

87− "pong" <- expect

89+ pong <- expect

88 pInfo <- getProcessInfo serverPid

90 pInfo <- getProcessInfo serverPid

89− stash result $ pInfo /= Nothing

91+ stash result $ pong == "pong" && pInfo /= Nothing

90 where

92 where

91 launchRemote :: MVar ProcessId -> IO ()

93 launchRemote :: MVar ProcessId -> IO ()

92 launchRemote locMV = do

94 launchRemote locMV = do

@@ -97,8 +99,10 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

97 _ <- receiveWait [

99 _ <- receiveWait [

98 match (\(pid, "ping") -> send pid "pong")

100 match (\(pid, "ping") -> send pid "pong")

99 ]

101 ]

100− "stop" <- expect

102+ res <- expect

103+ case res of

101− return ()

104+ "stop" -> return ()

105+ _ -> die $ "unexpected message received: " ++ res

102 return ()

106 return ()

103

107

104 withActiveRemote :: LocalNode

108 withActiveRemote :: LocalNode

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+23−11

@@ -125,9 +125,11 @@ testTraceSending result = do

125 (\ev ->

126 case ev of

127 (MxSent to from msg) -> do

128− (Just s) <- unwrapMessage msg :: Process (Maybe String)

128+ mS <- unwrapMessage msg :: Process (Maybe String)

129+ case mS of

129− stash res (to == pid && from == self && s == "hello there")

130+ (Just s) -> do stash res (to == pid && from == self && s == "hello there")

130− stash res (to == pid && from == self)

131+ stash res (to == pid && from == self)

132+ _ -> die "failed state invariant, message type unmatched..."

131 _ ->

133 _ ->

132 return ()) $ do

134 return ()) $ do

133 send pid "hello there"

135 send pid "hello there"

@@ -246,12 +248,8 @@ testRemoteTraceRelay TestTransport{..} result =

246 -- Here we set up that relay, and then wait for a signal

248 -- Here we set up that relay, and then wait for a signal

247 -- that the tracer (on node1) has seen the expected

249 -- that the tracer (on node1) has seen the expected

248 -- MxSpawned message, at which point we're finished

250 -- MxSpawned message, at which point we're finished

249− (Just log') <- whereis "logger"

250− pid <- liftIO $ forkProcess node2 $ do

251− logRelay <- spawnLocal $ relay log'

252− reregister "logger" logRelay

253− getSelfNode >>= stash mvNid >> (expect :: Process ())

254

251

252+ pid <- splinchLogger node2 mvNid

255 nid <- liftIO $ takeMVar mvNid

253 nid <- liftIO $ takeMVar mvNid

256 mref <- monitor pid

254 mref <- monitor pid

257 observedPid <- liftIO $ newEmptyMVar

255 observedPid <- liftIO $ newEmptyMVar

@@ -291,6 +289,17 @@ testRemoteTraceRelay TestTransport{..} result =

291 -- and just to be polite...

289 -- and just to be polite...

292 liftIO $ closeLocalNode node2

290 liftIO $ closeLocalNode node2

293

291

292+ where

293+ splinchLogger n2 mv = do

294+ mLog <- whereis "logger"

295+ case mLog of

296+ Nothing -> die "no logger registered"

297+ Just log' -> do liftIO $ forkProcess n2 $ do

298+ logRelay <- spawnLocal $ relay log'

299+ reregister "logger" logRelay

300+ getSelfNode >>= stash mv >> (expect :: Process ())

301+

302+

294-- | Sets the value of an environment variable while executing the given IO

303-- | Sets the value of an environment variable while executing the given IO

295-- computation and restores the preceeding value upon completion.

304-- computation and restores the preceeding value upon completion.

296withEnv :: String -> String -> IO a -> IO a

305withEnv :: String -> String -> IO a -> IO a

@@ -319,9 +328,12 @@ testSystemLoggerMsg t action interestingMessage =

319 -- Wait for the trace message.

328 -- Wait for the trace message.

320 receiveWait [ matchIf interestingMessage' $ const $ return () ]

329 receiveWait [ matchIf interestingMessage' $ const $ return () ]

321 -- Only one interesting message should arrive.

330 -- Only one interesting message should arrive.

322− Nothing <- receiveTimeout 100000

331+ expectedTimeout <- receiveTimeout

332+ 100000

323− [ matchIf interestingMessage' $ const $ return () ]

333+ [ matchIf interestingMessage' $ const $ return () ]

334+ case expectedTimeout of

324− return ()

335+ Nothing -> return ()

336+ Just _ -> die "Unexpected message arrived..."

325

337

326

338

327-- | Tests that one and only one trace message is produced when a message is

339-- | Tests that one and only one trace message is produced when a message is

distributed-process-tests/tests/runInMemory.hs−1

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

8import Network.Transport.InMemory

9import Test.Framework (defaultMainWithArgs)

11−import Control.Concurrent (threadDelay)

12import System.Environment (getArgs)

11import System.Environment (getArgs)

14main :: IO ()

13main :: IO ()

distributed-process-tests/tests/runTCP.hs+2−1

@@ -10,6 +10,7 @@ import Network.Transport.TCP

10 ( createTransportExposeInternals

11 , TransportInternals(socketBetween)

12 , defaultTCPParameters

13+ , defaultTCPAddr

13 , TCPParameters(..)

14 , TCPParameters(..)

14 )

15 )

15import Test.Framework (defaultMainWithArgs)

16import Test.Framework (defaultMainWithArgs)

@@ -24,7 +25,7 @@ main = do

24 hSetBuffering stdout LineBuffering

25 hSetBuffering stdout LineBuffering

25 hSetBuffering stderr LineBuffering

26 hSetBuffering stderr LineBuffering

26 Right (transport, internals) <-

27 Right (transport, internals) <-

27− createTransportExposeInternals "127.0.0.1" "8080"

28+ createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")

28 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

29 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

29 ts <- tests TestTransport

30 ts <- tests TestTransport

30 { testTransport = transport

31 { testTransport = transport

distributed-process.cabal+49−35

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

1Name: distributed-process

2−Version: 0.6.4

2+Version: 0.7.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: Facundo Domínguez <facundo.dominguez@tweag.io>

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

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.2.2 GHC==7.4.1 GHC==7.4.2 GHC==7.6.2

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

25Category: Control

26extra-source-files: ChangeLog

@@ -41,20 +41,22 @@ flag old-locale

41 default: False

43Library

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

44+ Build-Depends: base >= 4.6 && < 5,

45− binary >= 0.6.3 && < 0.9,

45+ binary >= 0.6.3 && < 0.10,

46 hashable >= 1.2.0.5 && < 1.3,

47− network-transport >= 0.4.1.0 && < 0.5,

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

48− stm >= 2.4 && < 2.5,

48+ stm >= 2.4 && < 2.6,

49 transformers >= 0.2 && < 0.6,

50 mtl >= 2.0 && < 2.4,

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

52 bytestring >= 0.9 && < 0.11,

53 random >= 1.0 && < 1.2,

54 distributed-static >= 0.2 && < 0.4,

55− rank1dynamic >= 0.1 && < 0.4,

55+ rank1dynamic >= 0.1 && < 0.5,

56− syb >= 0.3 && < 0.7,

56+ syb >= 0.3 && < 0.8,

57− exceptions >= 0.5

57+ exceptions >= 0.5,

58+ containers >= 0.5 && < 0.7,

59+ deepseq >= 1.3.0.1 && < 1.6

58 Exposed-modules: Control.Distributed.Process,

60 Exposed-modules: Control.Distributed.Process,

59 Control.Distributed.Process.Closure,

61 Control.Distributed.Process.Closure,

60 Control.Distributed.Process.Debug,

62 Control.Distributed.Process.Debug,

@@ -83,21 +85,33 @@ Library

83 Control.Distributed.Process.Management.Internal.Trace.Tracer

85 Control.Distributed.Process.Management.Internal.Trace.Tracer

84 ghc-options: -Wall

86 ghc-options: -Wall

85 HS-Source-Dirs: src

87 HS-Source-Dirs: src

86− if impl(ghc <= 7.4.2)

88+ other-extensions: BangPatterns

87− Build-Depends: containers >= 0.4 && < 0.5,

89+ CPP

88− deepseq == 1.3.0.0

90+ DeriveDataTypeable

89− else

91+ DeriveFunctor

90− Build-Depends: containers >= 0.4 && < 0.6,

92+ DeriveGeneric

91− deepseq >= 1.3.0.1 && < 1.6

93+ ExistentialQuantification

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

92 if flag(old-locale)

108 if flag(old-locale)

93 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

109 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

94 else

110 else

95 Build-Depends: time >= 1.5

111 Build-Depends: time >= 1.5

96 if flag(th)

112 if flag(th)

97− if impl(ghc <= 7.4.2)

113+ other-extensions: TemplateHaskell

98− Build-Depends: template-haskell >= 2.7 && < 2.8

99− else

100− Build-Depends: template-haskell >= 2.6 && < 2.12

114+ Build-Depends: template-haskell >= 2.6

101 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

115 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

102 CPP-Options: -DTemplateHaskellSupport

116 CPP-Options: -DTemplateHaskellSupport

103

117

@@ -105,50 +119,50 @@ Library

105

119

106benchmark distributed-process-throughput

120benchmark distributed-process-throughput

107 Type: exitcode-stdio-1.0

121 Type: exitcode-stdio-1.0

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

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

109 distributed-process,

123 distributed-process,

110− network-transport-tcp >= 0.3 && < 0.6,

124+ network-transport-tcp >= 0.3 && < 0.7,

111 bytestring >= 0.9 && < 0.11,

125 bytestring >= 0.9 && < 0.11,

112− binary >= 0.6.3 && < 0.9

126+ binary >= 0.6.3 && < 0.10

113 Main-Is: benchmarks/Throughput.hs

127 Main-Is: benchmarks/Throughput.hs

114 ghc-options: -Wall

128 ghc-options: -Wall

115

129

116benchmark distributed-process-latency

130benchmark distributed-process-latency

117 Type: exitcode-stdio-1.0

131 Type: exitcode-stdio-1.0

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

132+ Build-Depends: base >= 4.6 && < 5,

119 distributed-process,

133 distributed-process,

120− network-transport-tcp >= 0.3 && < 0.6,

134+ network-transport-tcp >= 0.3 && < 0.7,

121 bytestring >= 0.9 && < 0.11,

135 bytestring >= 0.9 && < 0.11,

122− binary >= 0.6.3 && < 0.9

136+ binary >= 0.6.3 && < 0.10

123 Main-Is: benchmarks/Latency.hs

137 Main-Is: benchmarks/Latency.hs

124 ghc-options: -Wall

138 ghc-options: -Wall

125

139

126benchmark distributed-process-channels

140benchmark distributed-process-channels

127 Type: exitcode-stdio-1.0

141 Type: exitcode-stdio-1.0

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

142+ Build-Depends: base >= 4.6 && < 5,

129 distributed-process,

143 distributed-process,

130− network-transport-tcp >= 0.3 && < 0.6,

144+ network-transport-tcp >= 0.3 && < 0.7,

131 bytestring >= 0.9 && < 0.11,

145 bytestring >= 0.9 && < 0.11,

132− binary >= 0.6.3 && < 0.9

146+ binary >= 0.6.3 && < 0.10

133 Main-Is: benchmarks/Channels.hs

147 Main-Is: benchmarks/Channels.hs

134 ghc-options: -Wall

148 ghc-options: -Wall

135

149

136benchmark distributed-process-spawns

150benchmark distributed-process-spawns

137 Type: exitcode-stdio-1.0

151 Type: exitcode-stdio-1.0

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

152+ Build-Depends: base >= 4.6 && < 5,

139 distributed-process,

153 distributed-process,

140− network-transport-tcp >= 0.3 && < 0.6,

154+ network-transport-tcp >= 0.3 && < 0.7,

141 bytestring >= 0.9 && < 0.11,

155 bytestring >= 0.9 && < 0.11,

142− binary >= 0.6.3 && < 0.9

156+ binary >= 0.6.3 && < 0.10

143 Main-Is: benchmarks/Spawns.hs

157 Main-Is: benchmarks/Spawns.hs

144 ghc-options: -Wall

158 ghc-options: -Wall

145

159

146benchmark distributed-process-ring

160benchmark distributed-process-ring

147 Type: exitcode-stdio-1.0

161 Type: exitcode-stdio-1.0

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

162+ Build-Depends: base >= 4.6 && < 5,

149 distributed-process,

163 distributed-process,

150− network-transport-tcp >= 0.3 && < 0.6,

164+ network-transport-tcp >= 0.3 && < 0.7,

151 bytestring >= 0.9 && < 0.11,

165 bytestring >= 0.9 && < 0.11,

152− binary >= 0.6.3 && < 0.9

166+ binary >= 0.6.3 && < 0.10

153 Main-Is: benchmarks/ProcessRing.hs

167 Main-Is: benchmarks/ProcessRing.hs

154 ghc-options: -Wall -threaded -O2 -rtsopts

168 ghc-options: -Wall -threaded -O2 -rtsopts

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− (ProcessIdentifier (processId proc))

204+ (NodeIdentifier (processNodeId $ processId proc))

205 (NodeIdentifier nid)

206 WithImplicitReconnect

207 msg

src/Control/Distributed/Process/Internal/Primitives.hs+61−44

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

76 , unlink

77 , monitor

78 , unmonitor

79+ , unmonitorAsync

79 , withMonitor

80 , withMonitor

80 , withMonitor_

81 , withMonitor_

81 -- * Logging

82 -- * Logging

@@ -253,17 +254,15 @@ send them msg = do

253 node = processNode proc

254 node = processNode proc

254 nodeId = localNodeId node

255 nodeId = localNodeId node

255 destNode = (processNodeId them) in do

256 destNode = (processNodeId them) in do

256− case destNode == nodeId of

257− True -> sendLocal them msg

258− False -> liftIO $ sendMessage (processNode proc)

259− (ProcessIdentifier (processId proc))

260− (ProcessIdentifier them)

261− NoImplicitReconnect

262− msg

263− -- We do not fire the trace event until after the sending is complete;

264− -- In the remote case, 'sendMessage' can block in the networking stack.

265 liftIO $ traceEvent (localEventBus node)

257 liftIO $ traceEvent (localEventBus node)

266 (MxSent them us (createUnencodedMessage msg))

258 (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

267

266

268-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

267-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

269-- and (in the case when the destination process resides on the same local

268-- and (in the case when the destination process resides on the same local

@@ -283,9 +282,12 @@ unsafeSend = Unsafe.send

283--

282--

284usend :: Serializable a => ProcessId -> a -> Process ()

283usend :: Serializable a => ProcessId -> a -> Process ()

285usend them msg = do

284usend them msg = do

286− here <- getSelfNode

285+ proc <- ask

287 let there = processNodeId them

286 let there = processNodeId them

288− if here == there

287+ let (us, node) = (processId proc, processNode proc)

288+ let msg' = wrapMessage msg

289+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg')

290+ if localNodeId (processNode proc) == there

289 then sendLocal them msg

291 then sendLocal them msg

290 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

292 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

291 (createMessage msg)

293 (createMessage msg)

@@ -305,7 +307,13 @@ expect = receiveWait [match return]

305-- Channels --

307-- Channels --

306--------------------------------------------------------------------------------

308--------------------------------------------------------------------------------

307

309

308−-- | Create a new typed channel

310+-- | Create a new typed channel, bound to the calling Process

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

309newChan :: Serializable a => Process (SendPort a, ReceivePort a)

317newChan :: Serializable a => Process (SendPort a, ReceivePort a)

310newChan = do

318newChan = do

311 proc <- ask

319 proc <- ask

@@ -333,13 +341,16 @@ newChan = do

333sendChan :: Serializable a => SendPort a -> a -> Process ()

341sendChan :: Serializable a => SendPort a -> a -> Process ()

334sendChan (SendPort cid) msg = do

342sendChan (SendPort cid) msg = do

335 proc <- ask

343 proc <- ask

336− let node = localNodeId (processNode proc)

344+ let node = processNode proc

345+ pid = processId proc

346+ us = localNodeId node

337− destNode = processNodeId (sendPortProcessId cid) in do

347+ them = processNodeId (sendPortProcessId cid) in do

348+ liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)

338− case destNode == node of

349+ case them == us of

339 True -> sendChanLocal cid msg

350 True -> sendChanLocal cid msg

340 False -> do

351 False -> do

341− liftIO $ sendBinary (processNode proc)

352+ liftIO $ sendBinary node

342− (ProcessIdentifier (processId proc))

353+ (ProcessIdentifier pid)

343 (SendPortIdentifier cid)

354 (SendPortIdentifier cid)

344 NoImplicitReconnect

355 NoImplicitReconnect

345 msg

356 msg

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

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

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

401receiveWait ms = do

412receiveWait ms = do

402 queue <- processQueue <$> ask

413 queue <- processQueue <$> ask

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

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

415+ case mProc of

404− proc

416+ Just proc' -> proc'

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

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

405

419

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

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

407--

421--

@@ -480,17 +494,14 @@ forward msg them = do

480 us = processId proc

494 us = processId proc

481 nid = localNodeId node

495 nid = localNodeId node

482 destNode = (processNodeId them) in do

496 destNode = (processNodeId them) in do

497+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

483− case destNode == nid of

498+ if destNode == nid

484− True -> sendCtrlMsg Nothing (LocalSend them msg)

499+ then sendCtrlMsg Nothing (LocalSend them msg)

485− False -> liftIO $ sendPayload (processNode proc)

500+ else liftIO $ sendPayload (processNode proc)

486− (ProcessIdentifier (processId proc))

501+ (ProcessIdentifier (processId proc))

487− (ProcessIdentifier them)

502+ (ProcessIdentifier them)

488− NoImplicitReconnect

503+ NoImplicitReconnect

489− (messageToPayload msg)

504+ (messageToPayload msg)

490− -- We do not fire the trace event until after the sending is complete;

491− -- In the remote case, 'sendMessage' can block in the networking stack.

492− liftIO $ traceEvent (localEventBus node)

493− (MxSent them us msg)

494

505

495-- | Forward a raw 'Message' to the given 'ProcessId'.

506-- | Forward a raw 'Message' to the given 'ProcessId'.

496--

507--

@@ -504,14 +515,10 @@ uforward msg them = do

504 us = processId proc

515 us = processId proc

505 nid = localNodeId node

516 nid = localNodeId node

506 destNode = (processNodeId them) in do

517 destNode = (processNodeId them) in do

518+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

507− case destNode == nid of

519+ if destNode == nid

508− True -> sendCtrlMsg Nothing (LocalSend them msg)

520+ then sendCtrlMsg Nothing (LocalSend them msg)

509− False -> sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them)

521+ else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg

510− msg

511− -- We do not fire the trace event until after the sending is complete;

512− -- In the remote case, 'sendCtrlMsg' can block in the networking stack.

513− liftIO $ traceEvent (localEventBus node)

514− (MxSent them us msg)

515

522

516-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

523-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

517-- 'Serializable' - like the datum they contain - but also note, deserialising

524-- 'Serializable' - like the datum they contain - but also note, deserialising

@@ -967,7 +974,7 @@ catch = Catch.catch

967-- | Lift 'Control.Exception.try'

974-- | Lift 'Control.Exception.try'

968try :: Exception e => Process a -> Process (Either e a)

975try :: Exception e => Process a -> Process (Either e a)

969try = Catch.try

976try = Catch.try

970−{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}

977+{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}

971

978

972-- | Lift 'Control.Exception.mask'

979-- | Lift 'Control.Exception.mask'

973mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

980mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

@@ -1220,8 +1227,12 @@ whereisRemoteAsync nid label = do

1220

1227

1221-- | Named send to a process in the local registry (asynchronous)

1228-- | Named send to a process in the local registry (asynchronous)

1222nsend :: Serializable a => String -> a -> Process ()

1229nsend :: Serializable a => String -> a -> Process ()

1223−nsend label msg =

1230+nsend label msg = do

1231+ proc <- ask

1232+ let msg' = createUnencodedMessage msg

1233+ liftIO $ traceEvent (localEventBus (processNode proc))

1234+ (MxSentToName label (processId proc) msg')

1224− sendCtrlMsg Nothing (NamedSend label (createUnencodedMessage msg))

1235+ sendCtrlMsg Nothing (NamedSend label msg')

1225

1236

1226-- | Named send to a process in the local registry (asynchronous).

1237-- | Named send to a process in the local registry (asynchronous).

1227-- This function makes /no/ attempt to serialize and (in the case when the

1238-- This function makes /no/ attempt to serialize and (in the case when the

@@ -1233,9 +1244,15 @@ unsafeNSend = Unsafe.nsend

1233-- | Named send to a process in a remote registry (asynchronous)

1244-- | Named send to a process in a remote registry (asynchronous)

1234nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1245nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1235nsendRemote nid label msg = do

1246nsendRemote nid label msg = do

1236− here <- getSelfNode

1247+ proc <- ask

1248+ let us = processId proc

1249+ let node = processNode proc

1250+ if localNodeId node == nid

1237− if here == nid then nsend label msg

1251+ then nsend label msg

1252+ else let lbl = label ++ "@" ++ show nid in do

1253+ liftIO $ traceEvent (localEventBus node)

1254+ (MxSentToName lbl us (wrapMessage msg))

1238− else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1255+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1239

1256

1240-- | Named send to a process in a remote registry (asynchronous)

1257-- | Named send to a process in a remote registry (asynchronous)

1241-- This function makes /no/ attempt to serialize and (in the case when the

1258-- 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− send

46+ usend

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− send pid ()

74+ usend 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 -> send pid () >> return (Right a)

121+ [ match $ \a -> usend pid () >> return (Right a)

122 , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

123 (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

124 ]

src/Control/Distributed/Process/Internal/Types.hs+9−1

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

369 mask p = do

377 mask p = do

370 lproc <- ask

378 lproc <- ask

371 liftIO $ mask $ \restore ->

379 liftIO $ mask $ \restore ->

@@ -629,7 +637,7 @@ newtype DidUnlinkPort = DidUnlinkPort SendPortId

629

637

630-- | 'SpawnRef' are used to return pids of spawned processes

638-- | 'SpawnRef' are used to return pids of spawned processes

631newtype SpawnRef = SpawnRef Int32

639newtype SpawnRef = SpawnRef Int32

632− deriving (Show, Binary, Typeable, Eq)

640+ deriving (Show, Binary, Typeable, Eq, Ord)

633

641

634-- | (Asynchronius) reply from 'spawn'

642-- | (Asynchronius) reply from 'spawn'

635data DidSpawn = DidSpawn SpawnRef ProcessId

643data DidSpawn = DidSpawn SpawnRef ProcessId

src/Control/Distributed/Process/Management.hs+34−2

@@ -76,6 +76,40 @@

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

79-- [Management Data API]

113-- [Management Data API]

80--

114--

81-- Both management agents and clients of the API have access to a variety of

115-- Both management agents and clients of the API have access to a variety of

@@ -144,8 +178,6 @@

144-- > monitorNames = getSelfPid >>= nsend "name-monitor"

178-- > monitorNames = getSelfPid >>= nsend "name-monitor"

145-- > monitorNames2 = getSelfPid >>= mxNotify

179-- > monitorNames2 = getSelfPid >>= mxNotify

146--

180--

147−-- For some real-world examples, see the distributed-process-platform package.

148−--

149-- [Performance, Stablity and Scalability]

181-- [Performance, Stablity and Scalability]

150--

182--

151-- /Management Agents/ offer numerous advantages over regular processes:

183-- /Management Agents/ offer numerous advantages over regular processes:

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

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

33 ( whereis

34 , newChan

35 , receiveChan

36+ , die

36 )

37 )

37import Control.Distributed.Process.Management.Internal.Trace.Types

38import Control.Distributed.Process.Management.Internal.Trace.Types

38 ( TraceArg(..)

39 ( TraceArg(..)

@@ -168,6 +169,11 @@ withRegisteredTracer act = do

168 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

169 currentTracer <- receiveChan rp

170 currentTracer <- receiveChan rp

170 case currentTracer of

171 case currentTracer of

171− Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

172+ Nothing -> do mTP <- whereis "tracer.initial"

173+ -- NB: this should NOT ever happen, but forcing pattern matches

174+ -- is not considered cool in later versions of MonadFail

175+ case mTP of

176+ Just p' -> act p'

177+ Nothing -> die $ "System Invariant Violation: Tracer Process "

178+ ++ "Name Not Found (whereis tracer.initial)"

172 (Just p) -> act p

179 (Just p) -> act p

173−

src/Control/Distributed/Process/Management/Internal/Trace/Types.hs−10

@@ -43,7 +43,6 @@ import Control.Distributed.Process.Serializable

43import Data.Binary

44import Data.List (intersperse)

45import Data.Set (Set)

46−import qualified Data.Set as Set (fromList)

47import Data.Typeable

46import Data.Typeable

48import GHC.Generics

47import GHC.Generics

@@ -158,12 +157,3 @@ getTraceFlags t s = publishEvent t (unsafeCreateUnencodedMessage s)

158

157

159getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

158getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

160getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)

159getCurrentTraceClient 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+9

@@ -21,6 +21,7 @@ import Control.Concurrent.STM

21import Control.Distributed.Process.Internal.Types

22 ( Process

23 , ProcessId

24+ , SendPortId

24 , Message

25 , Message

25 , DiedReason

26 , DiedReason

26 , NodeId

27 , NodeId

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

30 ( MonadState

31 ( MonadState

31 , StateT

32 , StateT

32 )

33 )

34+import Control.Monad.Fix (MonadFix)

33import Data.Binary

35import Data.Binary

34import Data.Typeable (Typeable)

36import Data.Typeable (Typeable)

35import GHC.Generics

37import GHC.Generics

@@ -56,8 +58,14 @@ data MxEvent =

56 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

58 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

57 | MxSent ProcessId ProcessId Message

59 | MxSent ProcessId ProcessId Message

58 -- ^ fired whenever a message is sent from a local process

60 -- ^ 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

59 | MxReceived ProcessId Message

65 | MxReceived ProcessId Message

60 -- ^ fired whenever a message is received by a local process

66 -- ^ 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

61 | MxConnected ConnectionId EndPointAddress

69 | MxConnected ConnectionId EndPointAddress

62 -- ^ fired when a network-transport connection is first established

70 -- ^ fired when a network-transport connection is first established

63 | MxDisconnected ConnectionId EndPointAddress

71 | MxDisconnected ConnectionId EndPointAddress

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

112 } deriving ( Functor

120 } deriving ( Functor

113 , Monad

121 , Monad

114 , MonadIO

122 , MonadIO

123+ , MonadFix

115 , ST.MonadState (MxAgentState s)

124 , ST.MonadState (MxAgentState s)

116 , Typeable

125 , Typeable

117 , Applicative

126 , Applicative

src/Control/Distributed/Process/Node.hs+39−21

@@ -28,16 +28,18 @@ import Data.Binary (decode)

28import Data.Map (Map)

29import qualified Data.Map as Map

30 ( empty

31+ , delete

31 , toList

32 , toList

32 , fromList

33 , fromList

33− , filter

34+ , insert

35+ , lookup

36+ , partition

34 , partitionWithKey

37 , partitionWithKey

35 , elems

38 , elems

36 , size

39 , size

37 , filterWithKey

40 , filterWithKey

38 , foldlWithKey

41 , foldlWithKey

39 )

42 )

40−import qualified Data.Set as Set

41import Data.Time.Format (formatTime)

43import Data.Time.Format (formatTime)

42#if MIN_VERSION_time(1,5,0)

44#if MIN_VERSION_time(1,5,0)

43import Data.Time.Format (defaultTimeLocale)

45import Data.Time.Format (defaultTimeLocale)

@@ -52,9 +54,9 @@ import qualified Data.Set as Set

52 , map

54 , map

53 , member

55 , member

54 , toList

56 , toList

57+ , union

55 )

58 )

56import Data.Foldable (forM_)

59import Data.Foldable (forM_)

57−import Data.List (foldl')

58import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

60import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

59import Data.Typeable (Typeable)

61import Data.Typeable (Typeable)

60import Control.Category ((>>>))

62import Control.Category ((>>>))

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

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

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

185 ( mxAgentController

187 ( mxAgentController

186 )

188 )

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

190+ ( MxEvent(..)

191+ )

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

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

188 ( remoteTable

193 ( remoteTable

189 )

194 )

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

196 , traceLogFmt

201 , traceLogFmt

197 , enableTrace

202 , enableTrace

198 )

203 )

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

200− ( MxEvent(..)

201− )

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

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

203import Control.Distributed.Process.Internal.Messaging

205import Control.Distributed.Process.Internal.Messaging

204 ( sendBinary

206 ( sendBinary

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

211 , match

213 , match

212 , sendChan

214 , sendChan

213 , unwrapMessage

215 , unwrapMessage

216+ , monitor

217+ , unmonitorAsync

218+ , getSelfNode

214 , SayMessage(..)

219 , SayMessage(..)

215 )

220 )

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

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

@@ -487,7 +492,7 @@ type IncomingConnection = (NT.EndPointAddress, IncomingTarget)

487data IncomingTarget =

492data IncomingTarget =

488 Uninit

493 Uninit

489 | ToProc ProcessId (Weak (CQueue Message))

494 | ToProc ProcessId (Weak (CQueue Message))

490− | ToChan TypedChannel

495+ | ToChan SendPortId TypedChannel

491 | ToNode

496 | ToNode

492

497

493data ConnectionState = ConnectionState {

498data ConnectionState = ConnectionState {

@@ -542,13 +547,17 @@ handleIncomingMessages node = go initConnectionState

542 enqueue queue msg -- 'enqueue' is strict

547 enqueue queue msg -- 'enqueue' is strict

543 trace node (MxReceived pid msg)

548 trace node (MxReceived pid msg)

544 go st

549 go st

545− Just (_, ToChan (TypedChannel chan')) -> do

550+ Just (_, ToChan chId (TypedChannel chan')) -> do

546 mChan <- deRefWeak chan'

551 mChan <- deRefWeak chan'

547 -- If mChan is Nothing, the process has given up the read end of

552 -- If mChan is Nothing, the process has given up the read end of

548 -- the channel and we simply ignore the incoming message

553 -- the channel and we simply ignore the incoming message

549− forM_ mChan $ \chan -> atomically $

554+ forM_ mChan $ \chan -> do

555+ msg' <- atomically $ do

556+ msg <- return $! decode (BSL.fromChunks payload)

550− -- We make sure the message is fully decoded when it is enqueued

557+ -- We make sure the message is fully decoded when it is enqueued

551− writeTQueue chan $! decode (BSL.fromChunks payload)

558+ writeTQueue chan msg

559+ return msg

560+ trace node $ MxReceivedPort chId $ unsafeCreateUnencodedMessage msg'

552 go st

561 go st

553 Just (_, ToNode) -> do

562 Just (_, ToNode) -> do

554 let ctrlMsg = decode . BSL.fromChunks $ payload

563 let ctrlMsg = decode . BSL.fromChunks $ payload

@@ -575,7 +584,7 @@ handleIncomingMessages node = go initConnectionState

575 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

584 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

576 case mChannel of

585 case mChannel of

577 Just channel ->

586 Just channel ->

578− go (incomingAt cid ^= Just (src, ToChan channel) $ st)

587+ go (incomingAt cid ^= Just (src, ToChan chId channel) $ st)

579 Nothing ->

588 Nothing ->

580 invalidRequest cid st $

589 invalidRequest cid st $

581 "incoming attempt to connect to unknown channel of"

590 "incoming attempt to connect to unknown channel of"

@@ -904,7 +913,11 @@ ncEffectDied ident reason = do

904

913

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

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

906

915

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

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

917+ let toDrop 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

908

921

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

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

910 mapM (\(pid,nidlist) ->

923 mapM (\(pid,nidlist) ->

@@ -956,7 +969,11 @@ ncEffectRegister from label atnode mPid reregistration = do

956 do modify' $ registeredHereFor label ^= mPid

969 do modify' $ registeredHereFor label ^= mPid

957 updateRemote node currentVal mPid

970 updateRemote node currentVal mPid

958 case mPid of

971 case mPid of

972+ (Just p) -> do

973+ if reregistration

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

975+ else return ()

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

976+ liftIO $ trace node (MxRegistered p label)

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

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

961 newVal <- gets (^. registeredHereFor label)

978 newVal <- gets (^. registeredHereFor label)

962 ncSendToProcess from $ unsafeCreateUnencodedMessage $

979 ncSendToProcess from $ unsafeCreateUnencodedMessage $

@@ -1037,11 +1054,12 @@ ncEffectLocalPortSend from msg = do

1037 -- If ch is Nothing, the process has given up the read end of

1054 -- If ch is Nothing, the process has given up the read end of

1038 -- the channel and we simply ignore the incoming message - this

1055 -- the channel and we simply ignore the incoming message - this

1039 ch <- deRefWeak chan'

1056 ch <- deRefWeak chan'

1040− forM_ ch $ \chan -> deliverChan msg chan

1057+ forM_ ch $ \chan -> deliverChan node from msg chan

1041− where deliverChan :: forall a . Message -> TQueue a -> IO ()

1058+ where deliverChan :: forall a . LocalNode -> SendPortId -> Message -> TQueue a -> IO ()

1042− deliverChan (UnencodedMessage _ raw) chan' =

1059+ deliverChan n p (UnencodedMessage _ raw) chan' = do

1043 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1060 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1061+ trace n (MxReceivedPort p $ unsafeCreateUnencodedMessage raw)

1044− deliverChan (EncodedMessage _ _) _ =

1062+ deliverChan _ _ (EncodedMessage _ _) _ =

1045 -- this will not happen unless someone screws with Primitives.hs

1063 -- this will not happen unless someone screws with Primitives.hs

1046 error "invalid local channel delivery"

1064 error "invalid local channel delivery"

1047

1065

@@ -1071,7 +1089,7 @@ ncEffectGetInfo from pid =

1071 case mProc of

1089 case mProc of

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

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

1073 from (ProcessInfoNone DiedUnknownId)

1091 from (ProcessInfoNone DiedUnknownId)

1074− Just proc -> do

1092+ Just proc -> do

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

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

1076 gets (^. links)

1094 gets (^. links)

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

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

@@ -1085,8 +1103,8 @@ ncEffectGetInfo from pid =

1085 infoNode = (processNodeId pid)

1103 infoNode = (processNodeId pid)

1086 , infoRegisteredNames = reg

1104 , infoRegisteredNames = reg

1087 , infoMessageQueueLength = size

1105 , infoMessageQueueLength = size

1088− , infoMonitors = Set.toList itsMons

1106+ , infoMonitors = Set.toList itsMons

1089− , infoLinks = Set.toList itsLinks

1107+ , infoLinks = Set.toList itsLinks

1090 }

1108 }

1091 where dispatch :: (Serializable a)

1109 where dispatch :: (Serializable a)

1092 => Bool

1110 => Bool

src/Control/Distributed/Process/Serializable.hs+3−13

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

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE UndecidableInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE CPP #-}

6module Control.Distributed.Process.Serializable

7 ( Serializable

8 , encodeFingerprint

@@ -17,13 +17,7 @@ module Control.Distributed.Process.Serializable

18import Data.Binary (Binary)

20−#if MIN_VERSION_base(4,7,0)

21−import Data.Typeable (Typeable)

20+import Data.Typeable (Typeable, typeRepFingerprint, typeOf)

22−import Data.Typeable.Internal (TypeRep(TypeRep), typeOf)

23−#else

24−import Data.Typeable (Typeable(..))

25−import Data.Typeable.Internal (TypeRep(TypeRep))

26−#endif

28import Numeric (showHex)

22import Numeric (showHex)

29import Control.Exception (throw)

23import Control.Exception (throw)

@@ -71,11 +65,7 @@ sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

72-- | The fingerprint of the typeRep of the argument

66-- | The fingerprint of the typeRep of the argument

73fingerprint :: Typeable a => a -> Fingerprint

67fingerprint :: Typeable a => a -> Fingerprint

74−#if MIN_VERSION_base(4,8,0)

68+fingerprint = typeRepFingerprint . typeOf

75−fingerprint a = let TypeRep fp _ _ _ = typeOf a in fp

76−#else

77−fingerprint a = let TypeRep fp _ _ = typeOf a in fp

78−#endif

80-- | Show fingerprint (for debugging purposes)

70-- | Show fingerprint (for debugging purposes)

81showFingerprint :: Fingerprint -> ShowS

71showFingerprint :: Fingerprint -> ShowS

src/Control/Distributed/Process/UnsafePrimitives.hs+82−33

@@ -32,7 +32,24 @@

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

35−-- behaviour of your application. You have been warned!

52+-- You have been warned!

36--

53--

37-- This module is exported so that you can replace the use of Cloud Haskell's

54-- This module is exported so that you can replace the use of Cloud Haskell's

38-- /safe/ messaging primitives. If you want to use both variants, then you can

55-- /safe/ messaging primitives. If you want to use both variants, then you can

@@ -55,7 +72,12 @@ import Control.Distributed.Process.Internal.Messaging

55 , sendBinary

72 , sendBinary

56 , sendCtrlMsg

73 , sendCtrlMsg

57 )

74 )

58−

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

76+ ( MxEvent(..)

77+ )

78+import Control.Distributed.Process.Management.Internal.Trace.Types

79+ ( traceEvent

80+ )

59import Control.Distributed.Process.Internal.Types

81import Control.Distributed.Process.Internal.Types

60 ( ProcessId(..)

82 ( ProcessId(..)

61 , NodeId(..)

83 , NodeId(..)

@@ -79,34 +101,48 @@ import Control.Monad.Reader (ask)

101

80-- | Named send to a process in the local registry (asynchronous)

102-- | Named send to a process in the local registry (asynchronous)

81nsend :: Serializable a => String -> a -> Process ()

103nsend :: Serializable a => String -> a -> Process ()

82−nsend label msg =

104+nsend label msg = do

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')

83− sendCtrlMsg Nothing (NamedSend label (unsafeCreateUnencodedMessage msg))

111+ sendCtrlMsg Nothing (NamedSend label msg')

112

85-- | Named send to a process in a remote registry (asynchronous)

113-- | Named send to a process in a remote registry (asynchronous)

86nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

114nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

87nsendRemote nid label msg = do

115nsendRemote nid label msg = do

88 proc <- ask

116 proc <- ask

117+ let us = processId proc

118+ let node = processNode proc

89− if localNodeId (processNode proc) == nid

119+ if localNodeId node == nid

90 then nsend label msg

120 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))

91− else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

126+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

127

93-- | Send a message

128-- | Send a message

94send :: Serializable a => ProcessId -> a -> Process ()

129send :: Serializable a => ProcessId -> a -> Process ()

95send them msg = do

130send them msg = do

96 proc <- ask

131 proc <- ask

97 let node = localNodeId (processNode proc)

132 let node = localNodeId (processNode proc)

98− destNode = (processNodeId them) in do

133+ destNode = (processNodeId them)

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')

99− case destNode == node of

139+ if destNode == node

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' =

109− sendCtrlMsg Nothing $ LocalSend pid (unsafeCreateUnencodedMessage msg')

140+ then sendCtrlMsg Nothing $ LocalSend them msg'

141+ else liftIO $ sendMessage (processNode proc)

142+ (ProcessIdentifier (processId proc))

143+ (ProcessIdentifier them)

144+ NoImplicitReconnect

145+ msg

110

146

111-- | Send a message unreliably.

147-- | Send a message unreliably.

112--

148--

@@ -121,30 +157,43 @@ usend :: Serializable a => ProcessId -> a -> Process ()

121usend them msg = do

157usend them msg = do

122 proc <- ask

158 proc <- ask

123 let there = processNodeId them

159 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')

124 if localNodeId (processNode proc) == there

164 if localNodeId (processNode proc) == there

125− then sendCtrlMsg Nothing $

165+ then sendCtrlMsg Nothing $ LocalSend them msg'

126− LocalSend them (unsafeCreateUnencodedMessage msg)

127 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

166 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

128 (createMessage msg)

167 (createMessage msg)

129

168

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+

130-- | Send a message on a typed channel

177-- | Send a message on a typed channel

131sendChan :: Serializable a => SendPort a -> a -> Process ()

178sendChan :: Serializable a => SendPort a -> a -> Process ()

132sendChan (SendPort cid) msg = do

179sendChan (SendPort cid) msg = do

133 proc <- ask

180 proc <- ask

181+ let node = processNode proc

182+ pid = processId proc

134− let node = localNodeId (processNode proc)

183+ us = localNodeId node

135− destNode = processNodeId (sendPortProcessId cid) in do

184+ them = processNodeId (sendPortProcessId cid)

136− case destNode == node of

185+ msg' = wrapMessage msg in do

186+ liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid msg')

187+ if them == us

137− True -> unsafeSendChanLocal cid msg

188+ then unsafeSendChanLocal cid msg' -- NB: we wrap to P.Message !!!

138− False -> do

139− liftIO $ sendBinary (processNode proc)

189+ else liftIO $ sendBinary node

140− (ProcessIdentifier (processId proc))

190+ (ProcessIdentifier pid)

141− (SendPortIdentifier cid)

191+ (SendPortIdentifier cid)

142− NoImplicitReconnect

192+ NoImplicitReconnect

143− msg

193+ msg

144 where

194 where

145− unsafeSendChanLocal :: (Serializable a) => SendPortId -> a -> Process ()

195+ unsafeSendChanLocal :: SendPortId -> Message -> Process ()

146− unsafeSendChanLocal spId msg' =

147− sendCtrlMsg Nothing $ LocalPortSend spId (unsafeCreateUnencodedMessage msg')

196+ unsafeSendChanLocal p m = sendCtrlMsg Nothing $ LocalPortSend p m

148

197

149-- | Create an unencoded @Message@ for any @Serializable@ type.

198-- | Create an unencoded @Message@ for any @Serializable@ type.

150wrapMessage :: Serializable a => a -> Message

199wrapMessage :: Serializable a => a -> Message

stack-ghc-7.10.3.yaml+12

@@ -3,6 +3,18 @@ resolver: nightly-2016-03-08

3packages:

4- '.'

5- distributed-process-tests/

6+- location:

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

8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9+ extra-dep: true

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

7flags:

19flags:

8 distributed-process-tests:

20 distributed-process-tests:

stack-ghc-7.8.4.yamldeleted−15

@@ -1,15 +0,0 @@

1−resolver: lts-2.22

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−

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.yamlnew file+23

@@ -0,0 +1,23 @@

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

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.yamlnew file+21

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

1+resolver: lts-11.22

3+packages:

4+- '.'

5+- distributed-process-tests/

6+- location:

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

8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9+ extra-dep: true

10+

11+extra-deps:

12+- rank1dynamic-0.4.0

13+- distributed-static-0.3.8

14+- network-transport-0.5.2

15+- network-transport-inmemory-0.5.2

16+- rematch-0.2.0.0

17+# - exceptions-0.8.2.1 # test dependency

18+

19+flags:

20+ distributed-process-tests:

21+ tcp: true

stack-ghc-8.4.4.yamlnew file+20

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

1+resolver: lts-12.18

3+packages:

4+- '.'

5+- distributed-process-tests/

6+- location:

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

8+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9+ extra-dep: true

10+

11+extra-deps:

12+- rank1dynamic-0.4.0

13+- distributed-static-0.3.8

14+- network-transport-0.5.2

15+- network-transport-inmemory-0.5.2

16+- rematch-0.2.0.0

17+

18+flags:

19+ distributed-process-tests:

20+ tcp: true

stack-nightly.yamlnew file+26

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

1+resolver: nightly

3+packages:

4+- '.'

5+- distributed-process-tests/

6+- location:

7+ git: https://github.com/haskell-distributed/distributed-static.git

8+ commit: c51e6aadd3a44c044e96a8e986c11d3a94b45b11

9+ extra-dep: true

10+- location:

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

12+ commit: d58250e2388b86a1865ac4139373cbdc106e72e1

13+ extra-dep: true

14+- location:

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

16+ commit: 0ce97924f15a8c1570b2355151834305c9bd2a28

17+ extra-dep: true

18+

19+extra-deps:

20+- rank1dynamic-0.4.0

21+- network-transport-0.5.2

22+- rematch-0.2.0.0

23+

24+flags:

25+ distributed-process-tests:

26+ tcp: true

stack.yaml+11−6

@@ -1,15 +1,20 @@

1−resolver: nightly-2016-06-09

1+resolver: lts-12.18 # Use GHC 8.4.4

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

3packages:

5packages:

4- '.'

6- '.'

5- distributed-process-tests/

7- distributed-process-tests/

8+- location:

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

10+ commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11+ extra-dep: true

7extra-deps:

13extra-deps:

8−- rank1dynamic-0.3.3.0

14+- rank1dynamic-0.4.0

9−- distributed-static-0.3.5.0

15+- distributed-static-0.3.8

10−- network-transport-0.4.4.0

11−- network-transport-tcp-0.5.1

16+- network-transport-0.5.2

12−- network-transport-inmemory-0.5.1

17+- network-transport-inmemory-0.5.2

13- rematch-0.2.0.0

18- rematch-0.2.0.0

15flags:

20flags: