474de0d..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+44

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

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+

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

22+

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

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

25+* Expose the MonitorRef in the withMonitor call.

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

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

28+other packages. (#276)

29+* Add Ord instance to SpawnRef.

30+

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

32+

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

34+

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

36+

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

38+* Improve documentation of CQueue.

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

40+* Fix various warnings. (#292)

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

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

43+(#290)

44+

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

3* Fixup build errors.

47* Fixup build errors.

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

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

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

48 DeriveDataTypeable,

49 DeriveDataTypeable,

49 DeriveGeneric,

50 DeriveGeneric,

50 GeneralizedNewtypeDeriving,

51 GeneralizedNewtypeDeriving,

51− OverlappingInstances,

52 RankNTypes,

53 RecordWildCards,

54 ScopedTypeVariables

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

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

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

63 distributed-process-tests,

64− network >= 2.3 && < 2.7,

64+ network >= 2.3 && < 2.9,

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

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

66 network-transport-inmemory >= 0.5,

67 test-framework >= 0.6 && < 0.9

68 Extensions: CPP

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

76 if flag(tcp)

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

78 distributed-process-tests,

79− network >= 2.3 && < 2.7,

79+ network >= 2.3 && < 2.9,

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

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

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

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

82 test-framework >= 0.6 && < 0.9

83 else

84 Buildable: False

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

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

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

95 distributed-process-tests,

96− network >= 2.3 && < 2.7,

96+ network >= 2.3 && < 2.9,

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

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

98 network-transport-inmemory >= 0.5,

99 test-framework >= 0.6 && < 0.9

100 Extensions: CPP

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

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

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

109 distributed-process-tests,

110− network >= 2.3 && < 2.7,

110+ network >= 2.3 && < 2.9,

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

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

112 network-transport-inmemory >= 0.5,

113 test-framework >= 0.6 && < 0.9

114 Extensions: CPP

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

116 HS-Source-Dirs: tests

117

118−

119−Test-Suite TestMx

118+Test-Suite TestMxInMemory

120 Type: exitcode-stdio-1.0

119 Type: exitcode-stdio-1.0

121 Main-Is: runInMemory.hs

120 Main-Is: runInMemory.hs

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

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

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

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

124 distributed-process-tests,

123 distributed-process-tests,

125− network >= 2.3 && < 2.7,

124+ network >= 2.3 && < 2.9,

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

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

127 network-transport-inmemory >= 0.5,

126 network-transport-inmemory >= 0.5,

128 test-framework >= 0.6 && < 0.9

127 test-framework >= 0.6 && < 0.9

129 Extensions: CPP

128 Extensions: CPP

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

131 HS-Source-Dirs: tests

130 HS-Source-Dirs: tests

132

131

133−Test-Suite TestTracing

132+Test-Suite TestTracingInMemory

134 Type: exitcode-stdio-1.0

133 Type: exitcode-stdio-1.0

135 Main-Is: runInMemory.hs

134 Main-Is: runInMemory.hs

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

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

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

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

138 distributed-process-tests,

137 distributed-process-tests,

139− network >= 2.3 && < 2.7,

138+ network >= 2.3 && < 2.9,

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

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

141 network-transport-inmemory >= 0.5,

140 network-transport-inmemory >= 0.5,

142 test-framework >= 0.6 && < 0.9

141 test-framework >= 0.6 && < 0.9

143 Extensions: CPP

142 Extensions: CPP

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

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

145 HS-Source-Dirs: tests

158 HS-Source-Dirs: tests

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

@@ -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,17 +1148,19 @@ 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

1082testReceiveChanTimeout TestTransport{..} = do

1161testReceiveChanTimeout TestTransport{..} = do

1083 done <- newEmptyMVar

1162 done <- newEmptyMVar

1163+ mvSender <- newEmptyMVar

1084 sendPort <- newEmptyMVar

1164 sendPort <- newEmptyMVar

1085

1165

1086 forkTry $ do

1166 forkTry $ do

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

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

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

1091 liftIO $ putMVar sendPort sp

1171 liftIO $ putMVar sendPort sp

1092

1172

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

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

1174+ -- Nothing after the delay.

1094− Nothing <- receiveChanTimeout 1000000 rp

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

1176+

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

1178+ liftIO $ putMVar mvSender ()

1095

1179

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

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

1181+ -- 0.1 seconds

1097− Just True <- receiveChanTimeout 1000000 rp

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

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

1098

1184

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

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

1186+ -- available, we get Nothing

1100− Nothing <- receiveChanTimeout 0 rp

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

1188+

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

1190+ liftIO $ putMVar mvSender ()

1101

1191

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

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

1193+ fix $ \loop -> do

1103− liftIO $ threadDelay 1000000

1194+ liftIO $ threadDelay 100000

1104− Just False <- receiveChanTimeout 0 rp

1195+ mb <- receiveChanTimeout 0 rp

1196+ case mb of

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

1198+ _ -> loop

1105

1199

1106 liftIO $ putMVar done ()

1200 liftIO $ putMVar done ()

1107

1201

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

1110 runProcess localNode $ do

1204 runProcess localNode $ do

1111 sp <- liftIO $ readMVar sendPort

1205 sp <- liftIO $ readMVar sendPort

1112

1206

1207+ liftIO $ takeMVar mvSender

1113− liftIO $ threadDelay 1500000

1208+ liftIO $ threadDelay 100000

1114 sendChan sp True

1209 sendChan sp True

1115

1210

1116− liftIO $ threadDelay 500000

1211+ liftIO $ takeMVar mvSender

1117 sendChan sp False

1212 sendChan sp False

1118

1213

1119 takeMVar done

1214 takeMVar done

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

1136

1231

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

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

1138

1233

1139− True <- receiveChan rp1

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

1140− False <- receiveChan rp1

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

1141

1236

1142 -- Test Applicative instance

1237 -- Test Applicative instance

1143

1238

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

1146

1241

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

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

1148

1243

1149− 7 <- receiveChan rp2

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

1150

1245

1151 -- Test Alternative instance

1246 -- Test Alternative instance

1152

1247

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

1155

1250

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

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

1157

1252

1158− False <- receiveChan rp3

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

1159− True <- receiveChan rp3

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

1160

1255

1161 -- Test Monad instance

1256 -- Test Monad instance

1162

1257

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

1170 then rpInt

1265 then rpInt

1171 else return 7

1266 else return 7

1172

1267

1173− 5 <- receiveChan rp4

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

1174− 7 <- receiveChan rp4

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

1175

1270

1176 liftIO $ putMVar done ()

1271 liftIO $ putMVar done ()

1177

1272

1178 takeMVar done

1273 takeMVar done

1179

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+

1180testKillLocal :: TestTransport -> Assertion

1345testKillLocal :: TestTransport -> Assertion

1181testKillLocal TestTransport{..} = do

1346testKillLocal TestTransport{..} = do

1182 localNode <- newLocalNode testTransport initRemoteTable

1347 localNode <- newLocalNode testTransport initRemoteTable

1183− done <- newEmptyMVar

1184

1348

1185 pid <- forkProcess localNode $ do

1349 pid <- forkProcess localNode $ do

1186 liftIO $ threadDelay 1000000

1350 liftIO $ threadDelay 1000000

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

1189 ref <- monitor pid

1353 ref <- monitor pid

1190 us <- getSelfPid

1354 us <- getSelfPid

1191 kill pid "TestKill"

1355 kill pid "TestKill"

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

1356+ mn <- expect

1357+ case mn of

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

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

1194− liftIO $ putMVar done ()

1360+ True -> return ()

1195−

1361+ False -> die "Invalid ProcessMonitorNotification received"

1196− takeMVar done

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

1197

1363

1198testKillRemote :: TestTransport -> Assertion

1364testKillRemote :: TestTransport -> Assertion

1199testKillRemote TestTransport{..} = do

1365testKillRemote TestTransport{..} = do

1200 node1 <- newLocalNode testTransport initRemoteTable

1366 node1 <- newLocalNode testTransport initRemoteTable

1201 node2 <- newLocalNode testTransport initRemoteTable

1367 node2 <- newLocalNode testTransport initRemoteTable

1202− done <- newEmptyMVar

1203

1368

1204 pid <- forkProcess node1 $ do

1369 pid <- forkProcess node1 $ do

1205 liftIO $ threadDelay 1000000

1370 liftIO $ threadDelay 1000000

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

1208 ref <- monitor pid

1373 ref <- monitor pid

1209 us <- getSelfPid

1374 us <- getSelfPid

1210 kill pid "TestKill"

1375 kill pid "TestKill"

1376+ mn <- expect

1377+ case mn of

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

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

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

1213− liftIO $ putMVar done ()

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

1214−

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

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

1216

1387

1217testCatchesExit :: TestTransport -> Assertion

1388testCatchesExit :: TestTransport -> Assertion

1218testCatchesExit TestTransport{..} = do

1389testCatchesExit TestTransport{..} = do

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

1238 self <- getSelfPid

1409 self <- getSelfPid

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

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

1240 msg <- receiveWait [ matchMessage return ]

1411 msg <- receiveWait [ matchMessage return ]

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

1412+ handleMessageIf msg

1413+ (\() -> True)

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

1415+ (const $ die "Expected Mismatch")

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

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

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

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

1244 return ()

1418 return ()

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

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

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

1284 `catchExit` \_from reason -> do

1458 `catchExit` \_from reason -> do

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

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

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

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

1287 liftIO $ putMVar done ()

1461 liftIO $ putMVar done ()

1462+ if res

1463+ then return ()

1464+ else die "Something went horribly wrong"

1288

1465

1289 takeMVar done

1466 takeMVar done

1290

1467

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

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

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

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

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

1300 in do

1477 in do

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

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

1302 liftIO $ putMVar done ()

1479 liftIO $ putMVar done ()

1480+ if res

1481+ then return ()

1482+ else die "Something went horribly wrong"

1303

1483

1304 takeMVar done

1484 takeMVar done

1305

1485

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

1315 pid <- forkProcess localNode $ do

1495 pid <- forkProcess localNode $ do

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

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

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

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

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

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

1319 liftIO $ putMVar supervisedDone ()

1499 liftIO $ putMVar supervisedDone ()

1500+ if res

1501+ then return ()

1502+ else die "Something went horribly wrong"

1320

1503

1321 runProcess localNode $ do

1504 runProcess localNode $ do

1322 liftIO $ takeMVar handlerSetUp

1505 liftIO $ takeMVar handlerSetUp

1323 ref <- monitor pid

1506 ref <- monitor pid

1324 exit pid "TestExit"

1507 exit pid "TestExit"

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

1326− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1511+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

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

1329

1518

1330 takeMVar supervisedDone

1519 takeMVar supervisedDone

1331 takeMVar supervisorDone

1520 takeMVar supervisorDone

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

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

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

1342 `catchExit` \_from reason -> do

1531 `catchExit` \_from reason -> do

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

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

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

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

1345 liftIO $ putMVar supervisedDone ()

1534 liftIO $ putMVar supervisedDone ()

1535+ if res

1536+ then return ()

1537+ else die "Something went horribly wrong"

1346

1538

1347 runProcess node2 $ do

1539 runProcess node2 $ do

1348 ref <- monitor pid

1540 ref <- monitor pid

1349 exit pid "TestExit"

1541 exit pid "TestExit"

1542+ mn <- expect

1543+ case mn of

1350− ProcessMonitorNotification ref' pid' DiedNormal <- expect

1544+ ProcessMonitorNotification ref' pid' DiedNormal -> do

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

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

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

1353

1551

1354 takeMVar supervisedDone

1552 takeMVar supervisedDone

1355 takeMVar supervisorDone

1553 takeMVar supervisorDone

1356

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+

1357testUnsafeSend :: TestTransport -> Assertion

1625testUnsafeSend :: TestTransport -> Assertion

1358testUnsafeSend TestTransport{..} = do

1626testUnsafeSend TestTransport{..} = do

1359 serverAddr <- newEmptyMVar

1627 serverAddr <- newEmptyMVar

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

1369 void $ forkProcess localNode $ do

1637 void $ forkProcess localNode $ do

1370 serverPid <- liftIO $ takeMVar serverAddr

1638 serverPid <- liftIO $ takeMVar serverAddr

1371 getSelfPid >>= unsafeSend serverPid

1639 getSelfPid >>= unsafeSend serverPid

1372− () <- expect

1373− liftIO $ putMVar clientDone ()

1640+ expect >>= liftIO . putMVar clientDone

1374

1641

1375 takeMVar clientDone

1642 takeMVar clientDone

1376

1643

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

1389 void $ forkProcess localNode $ do

1656 void $ forkProcess localNode $ do

1390 serverPid <- liftIO $ takeMVar serverAddr

1657 serverPid <- liftIO $ takeMVar serverAddr

1391 getSelfPid >>= unsafeUSend serverPid

1658 getSelfPid >>= unsafeUSend serverPid

1392− () <- expect

1393− liftIO $ putMVar clientDone ()

1659+ expect >>= liftIO . putMVar clientDone

1394

1660

1395 takeMVar clientDone

1661 takeMVar clientDone

1396

1662

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

1401 localNode <- newLocalNode testTransport initRemoteTable

1667 localNode <- newLocalNode testTransport initRemoteTable

1402

1668

1403 pid <- forkProcess localNode $ do

1669 pid <- forkProcess localNode $ do

1404− () <- expect

1405− liftIO $ putMVar clientDone ()

1670+ expect >>= liftIO . putMVar clientDone

1406

1671

1407 void $ runProcess localNode $ do

1672 void $ runProcess localNode $ do

1408 register "foobar" pid

1673 register "foobar" pid

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

1420 _ <- forkProcess localNode1 $ do

1685 _ <- forkProcess localNode1 $ do

1421 getSelfPid >>= register "foobar"

1686 getSelfPid >>= register "foobar"

1422 liftIO $ putMVar clientDone ()

1687 liftIO $ putMVar clientDone ()

1423− () <- expect

1424− liftIO $ putMVar clientDone ()

1688+ expect >>= liftIO . putMVar clientDone

1425

1689

1426 takeMVar clientDone

1690 takeMVar clientDone

1427 void $ runProcess localNode2 $ do

1691 void $ runProcess localNode2 $ do

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

1445 serverPid <- liftIO $ takeMVar serverAddr

1709 serverPid <- liftIO $ takeMVar serverAddr

1446 (sp, rp) <- newChan

1710 (sp, rp) <- newChan

1447 unsafeSend serverPid sp

1711 unsafeSend serverPid sp

1448− () <- receiveChan rp

1712+ receiveChan rp :: Process ()

1449 liftIO $ putMVar clientDone ()

1713 liftIO $ putMVar clientDone ()

1450

1714

1451 takeMVar clientDone

1715 takeMVar clientDone

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

1459 runProcess node $ do

1723 runProcess node $ do

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

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

1461 liftIO $ putMVar result r

1725 liftIO $ putMVar result r

1726+

1462− True <- takeMVar result

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

1463− return ()

1464

1728

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

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

1466 ibox <- newIORef False

1730 ibox <- newIORef False

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

1477 (send keeper ())

1741 (send keeper ())

1478 caller <- expect

1742 caller <- expect

1479 exit caller "test"

1743 exit caller "test"

1480− () <- expect

1744+ expect :: Process ()

1481− return ()

1745+

1482− True <- readIORef ibox

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

1483− return ()

1484

1747

1485 -- 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.

1486 ibox2 <- newIORef False

1749 ibox2 <- newIORef False

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

1489 liftIO $ writeIORef ibox2 $ case r of

1752 liftIO $ writeIORef ibox2 $ case r of

1490 Left (ErrorCall "e") -> True

1753 Left (ErrorCall "e") -> True

1491 _ -> False

1754 _ -> False

1755+

1492− True <- readIORef ibox

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

1493− return ()

1494

1757

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

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

1496 ibox3 <- newIORef False

1759 ibox3 <- newIORef False

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

1507 liftIO $ putMVar result3 =<< readIORef ibox3

1770 liftIO $ putMVar result3 =<< readIORef ibox3

1508 worker <- expect

1771 worker <- expect

1509 send worker ()

1772 send worker ()

1773+

1510− True <- takeMVar result3

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

1511− return ()

1512

1775

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

1514 ibox4 <- newIORef False

1777 ibox4 <- newIORef False

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

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

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

1525 caller <- expect

1788 caller <- expect

1526 exit caller "hi!"

1789 exit caller "hi!"

1527− True <- takeMVar result4

1528− return ()

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

1530−

1531−

1532−

1533

1790

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

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

1534

1793

1535tests :: TestTransport -> IO [Test]

1794tests :: TestTransport -> IO [Test]

1536tests testtrans = return [

1795tests testtrans = return [

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

1555 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1556 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1557 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1558 , testCase "KillLocal" (testKillLocal testtrans)

1818 , testCase "KillLocal" (testKillLocal testtrans)

1559 , testCase "KillRemote" (testKillRemote testtrans)

1819 , testCase "KillRemote" (testKillRemote testtrans)

1560 , testCase "Die" (testDie testtrans)

1820 , testCase "Die" (testDie testtrans)

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

1564 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1565 , testCase "ExitLocal" (testExitLocal testtrans)

1825 , testCase "ExitLocal" (testExitLocal testtrans)

1566 , testCase "ExitRemote" (testExitRemote testtrans)

1826 , testCase "ExitRemote" (testExitRemote testtrans)

1827+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1567 , testCase "TextCallLocal" (testCallLocal testtrans)

1828 , testCase "TextCallLocal" (testCallLocal testtrans)

1568 -- Unsafe Primitives

1829 -- Unsafe Primitives

1569 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

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

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

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

1617 ]

1878 ]

1618 ]

1879 ]

1619−

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

1621−syncBreakConnection breakConnection nid0 nid1 = do

1622− m <- newEmptyMVar

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

1624− runProcess nid0 $ do

1625− them <- liftIO $ takeMVar m

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

1627− _ <- monitorNode (localNodeId nid1)

1628− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1629− (nodeAddress $ localNodeId nid1)

1630− NodeMonitorNotification _ _ _ <- expect

1631− kill pinger "finished"

1632− return ()

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

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

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

305 wrapEP e =

318 wrapEP e =

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

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

307 healthy <- newIORef True

320 healthy <- newIORef True

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

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

309 }

322 }

310

323

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

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

325+ -> NT.Connection -> NT.Connection

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

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

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

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

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

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

315 writeIORef healthy False

329 writeIORef healthy False

330+ testBreakConnection (NT.address e) remoteAddr

316 isHealthy <- readIORef healthy

331 isHealthy <- readIORef healthy

317 if isHealthy then s msg

332 if isHealthy then s msg

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

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

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

330 node <- newLocalNode testTransport rtable

345 node <- newLocalNode testTransport rtable

331 nid <- readMVar serverNodeAddr

346 nid <- readMVar serverNodeAddr

332 runProcess node $ do

347 runProcess node $ do

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

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

349+ if a == 120

334− liftIO $ putMVar clientDone ()

350+ then liftIO $ putMVar clientDone ()

351+ else error "something went horribly wrong"

335

352

336 takeMVar clientDone

353 takeMVar clientDone

337

354

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

348 node <- newLocalNode testTransport rtable

365 node <- newLocalNode testTransport rtable

349 nid <- readMVar serverNodeAddr

366 nid <- readMVar serverNodeAddr

350 runProcess node $ do

367 runProcess node $ do

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

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

369+ if a == 120

352− liftIO $ putMVar clientDone ()

370+ then liftIO $ putMVar clientDone ()

371+ else error "Something went horribly wrong"

353

372

354 takeMVar clientDone

373 takeMVar clientDone

355

374

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

360 runProcess node $ do

379 runProcess node $ do

361 us <- getSelfPid

380 us <- getSelfPid

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

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

363− 120 :: Int <- expect

382+ a :: Int <- expect

364− 720 :: Int <- expect

383+ b :: Int <- expect

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

365− liftIO $ putMVar done ()

385+ then liftIO $ putMVar done ()

386+ else error "Something went horribly wrong"

366 takeMVar done

387 takeMVar done

367

388

368-- Test 'spawnSupervised'

389-- Test 'spawnSupervised'

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

391 throw supervisorDeath

412 throw supervisorDeath

392

413

393 forkProcess node2 $ do

414 forkProcess node2 $ do

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

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

416+ case res of

417+ [super, child] -> do

395− ref <- monitor child

418+ ref <- monitor child

396− self <- getSelfPid

419+ self <- getSelfPid

397− let waitForMOrL = do

420+ let waitForMOrL = do

398− liftIO $ threadDelay 10000

421+ liftIO $ threadDelay 10000

399− mpinfo <- getProcessInfo child

422+ mpinfo <- getProcessInfo child

400− case mpinfo of

423+ case mpinfo of

401− Nothing -> waitForMOrL

424+ Nothing -> waitForMOrL

402− Just pinfo ->

425+ Just pinfo ->

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

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

404− waitForMOrL

427+ waitForMOrL

405− liftIO $ putMVar linkUp ()

428+ liftIO $ putMVar linkUp ()

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

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

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

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

431+ res' <- expect

432+ case res' of

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

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

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

410− && pid' == child

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

435+ e == show (ProcessLinkException super

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

436+ (DiedException (show supervisorDeath))))

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

413

442

414 takeMVar thirdProcessDone

443 takeMVar thirdProcessDone

415 where

444 where

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

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

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

425 ProcessMonitorNotification ref' pid' _reason <- expect

454 ProcessMonitorNotification ref' pid' _reason <- expect

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

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

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

457+ if res == True

428− liftIO $ putMVar done ()

458+ then liftIO $ putMVar done ()

459+ else error "Something went horribly wrong"

429 takeMVar done

460 takeMVar done

430

461

431testClosureExpect :: TestTransport -> RemoteTable -> Assertion

462testClosureExpect :: TestTransport -> RemoteTable -> Assertion

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

437 us <- getSelfPid

468 us <- getSelfPid

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

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

439 send them (1234 :: Int)

470 send them (1234 :: Int)

440− (1234 :: Int) <- expect

471+ (res :: Int) <- expect

472+ if res == 1234

441− liftIO $ putMVar done ()

473+ then liftIO $ putMVar done ()

474+ else error "Something went horribly wrong"

442 takeMVar done

475 takeMVar done

443

476

444testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

477testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

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

463 done <- newEmptyMVar

496 done <- newEmptyMVar

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

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

465 forkProcess node1 $ do

498 forkProcess node1 $ do

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

467− liftIO $ putMVar done ()

501+ then liftIO $ putMVar done ()

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

468 takeMVar done

503 takeMVar done

469

504

470testFib :: TestTransport -> RemoteTable -> Assertion

505testFib :: TestTransport -> RemoteTable -> Assertion

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

475 forkProcess (head nodes) $ do

510 forkProcess (head nodes) $ do

476 (sport, rport) <- newChan

511 (sport, rport) <- newChan

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

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

478− 55 <- receiveChan rport :: Process Integer

513+ ff <- receiveChan rport :: Process Integer

479 liftIO $ putMVar done ()

514 liftIO $ putMVar done ()

515+ if ff /= 55

516+ then die $ "Something went horribly wrong"

517+ else return ()

480

518

481 takeMVar done

519 takeMVar done

482

520

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

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

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

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

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

486 let nid1 = localNodeId node1

524 let nid1 = localNodeId node1

487− nid2 = localNodeId node2

525+ -- nid2 = localNodeId node2

488 done <- newEmptyMVar

526 done <- newEmptyMVar

489 iv <- newMVar (0 :: Int)

527 iv <- newMVar (0 :: Int)

490

528

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

501 liftIO $ threadDelay 100000

539 liftIO $ threadDelay 100000

502

540

503 count <- liftIO $ takeMVar iv

541 count <- liftIO $ takeMVar iv

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

505

543

506 liftIO $ putMVar done ()

544 liftIO $ putMVar done ()

545+ if res /= True

546+ then error "Something went horribly wrong"

547+ else return ()

507

548

508 takeMVar done

549 takeMVar done

509

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+385−129

@@ -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,19 +32,15 @@ import Control.Distributed.Process.Management

21 , mxUpdateLocal

32 , mxUpdateLocal

22 , mxNotify

33 , mxNotify

23 , mxBroadcast

34 , mxBroadcast

24− , mxGetId

25− , mxGet

26− , mxSet

27− , mxClear

28− , mxPurgeTable

29− , mxDropTable

30 )

35 )

31−import Control.Monad (void)

36+import Control.Monad (void, unless)

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

38+import Control.Rematch (equalTo)

32import Data.Binary

39import Data.Binary

33−import Data.List (find, sort)

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

34−import Data.Maybe (isJust)

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

35import Data.Typeable

42import Data.Typeable

36−import GHC.Generics

43+import GHC.Generics hiding (from)

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

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

38import Prelude hiding (catch, log)

45import Prelude hiding (catch, log)

39#endif

46#endif

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

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

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

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

53testAgentBroadcast result = do

70testAgentBroadcast result = do

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

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

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

64 mxNotify ()

81 mxNotify ()

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

66 -- 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.

67− stash result =<< receiveChan resultRP

84+ stash result =<< receiveChanTimeout 10000000 resultRP

69 kill publisher "finished"

86 kill publisher "finished"

70 kill consumer "finished"

87 kill consumer "finished"

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

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

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

73testAgentDualInput result = do

90testAgentDualInput result = do

74 (sp, rp) <- newChan

91 (sp, rp) <- newChan

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

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

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

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

77 mxSetLocal . (+i) =<< mxGetLocal

94 mxSetLocal . (+i) =<< mxGetLocal

78 i' <- mxGetLocal

95 i' <- mxGetLocal

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

82 else mxReady)

99 else mxReady)

83 ]

100 ]

101

102+ mRef <- monitor s

103+

85 mxNotify (1 :: Int)

104 mxNotify (1 :: Int)

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

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

87 mxNotify (2 :: Int)

106 mxNotify (2 :: Int)

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

89 mxNotify (5 :: Int)

108 mxNotify (5 :: Int)

109

91 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

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

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

94testAgentPrioritisation result = do

117testAgentPrioritisation result = do

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

100

123

101 let name = "prioritising-agent"

124 let name = "prioritising-agent"

102 (sp, rp) <- newChan

125 (sp, rp) <- newChan

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

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

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

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

105− mxUpdateLocal ((s:))

128+ mxUpdateLocal (s:)

106 st <- mxGetLocal

129 st <- mxGetLocal

107 case length st of

130 case length st of

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

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

109 mxDeactivate "finished"

132 mxDeactivate "finished"

110 _ -> mxReceive -- go to the mailbox

133 _ -> mxReceive -- go to the mailbox

111 )

134 )

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

116 mxNotify "fourth"

139 mxNotify "fourth"

117 nsend name "fifth"

140 nsend name "fifth"

118

141

119− stash result . sort =<< receiveChan rp

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

143+ awaitExit s

120

144

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

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

122testAgentMailboxHandling result = do

146testAgentMailboxHandling result = do

123 (sp, rp) <- newChan

147 (sp, rp) <- newChan

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

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

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

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

126 ]

150 ]

127

151

128− nsend "listener-agent" ()

152+ nsend "mailbox-agent" ()

129

153

130 stash result =<< receiveChanTimeout 1000000 rp

154 stash result =<< receiveChanTimeout 1000000 rp

131 kill agent "finished"

155 kill agent "finished"

132

156

133testAgentEventHandling :: TestResult Bool -> Process ()

157testAgentEventHandling :: TestResult Bool -> Process ()

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

135 let initState = [] :: [MxEvent]

167 let initState = [] :: [MxEvent]

168+ (rc, rs) <- newChan

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

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

137 (mxSink $ \ev -> do

170 (mxSink $ \ev -> do

138 st <- mxGetLocal

171 st <- mxGetLocal

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

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

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

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

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

143 _ -> return ()

176 _ -> return ()

144− act >> mxReady),

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

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

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

146 st <- mxGetLocal

179 st <- mxGetLocal

147 let found =

180 let found =

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

161 mxReady)

194 mxReady)

162 ]

195 ]

163

196

164− _ <- monitor agentPid

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

198+ faff 2000000 rs

199+

165− (sp, rp) <- newChan

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

201+

166− pid <- spawnLocal $ sendChan sp ()

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

167− () <- receiveChan rp

168

203

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

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

170− -- higher probably that the agent has seen

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

171 monitor pid

206 monitor pid

207+

208+ send pid ()

209+ rct <- receiveChanTimeout 10000000 rp

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

211+

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

173

217

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

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

175 mxNotify (MxSpawned pid, replyTo)

219 mxNotify (MxSpawned pid, replyTo)

176 mxNotify (MxProcessDied pid DiedNormal, replyTo)

220 mxNotify (MxProcessDied pid DiedNormal, replyTo)

177

221

178− seenAlive <- receiveChan reply

222+ seenAlive <- receiveChanTimeout 10000000 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+

179− seenDead <- receiveChan reply

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"

324+

325+ unreg1 <- receiveChanTimeout delay unRegSink

326+ unreg2 <- receiveChanTimeout delay unRegSink

327+

328+ let evts = [unreg1, unreg2]

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

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

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

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

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

334+

335+ kill agent "test-complete"

336+

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

338+ensure = flip finally

339+

340+testNSend :: (String -> () -> Process ())

341+ -> Maybe LocalNode

342+ -> Process ()

343+testNSend op n = do

344+ us <- getSelfPid

345+ let delay = 5000000

346+ let label = "testMxSend" ++ (show us)

347+ let isValid = isValidLabel n label

348+

349+ testMxSend n label $ \p1 sink -> do

350+ register label p1

351+ reg1 <- receiveChanTimeout delay sink

352+ case reg1 of

353+ Just (MxRegistered pd lb)

354+ | pd == p1 && isValid lb -> return ()

355+ _ -> die $ "Reg-Failed: " ++ show reg1

356+

357+ op label ()

358+

359+ sent <- receiveChanTimeout delay sink

360+ case sent of

361+ Just (MxSentToName lb by _)

362+ | by == us && isValid lb -> return True

363+ _ -> die $ "Send-Failed: " ++ show sent

364+

365+ where

366+ isValidLabel nd l1 l2

367+ | l2 == l2 = True

368+ | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)

369+ | otherwise = False

370+

371+testSend :: (ProcessId -> () -> Process ())

372+ -> Maybe LocalNode

373+ -> Process ()

374+testSend op n = do

375+ us <- getSelfPid

376+ let label = "testMxSend" ++ (show us)

377+ testMxSend n label $ \p1 sink -> do

378+ -- initiate a send

379+ op p1 ()

380+

381+ -- verify the management event

382+ sent <- receiveChanTimeout 5000000 sink

383+ case sent of

384+ Just (MxSent pidTo pidFrom _)

385+ | pidTo == p1 && pidFrom == us -> return True

386+ _ -> return False

387+

388+testChan :: (SendPort () -> () -> Process ())

389+ -> Maybe LocalNode

390+ -> Process ()

391+testChan op n = testMxSend n "" $ \p1 sink -> do

392+

393+ us <- getSelfPid

394+ send p1 us

395+

396+ cleared <- receiveChanTimeout 2000000 sink

397+ case cleared of

398+ Just (MxSent pidTo pidFrom _)

399+ | pidTo == p1 && pidFrom == us -> return ()

400+ _ -> die "Received uncleared Mx Event"

401+

402+ chan <- receiveTimeout 5000000 [ match return ]

403+ let ch' = fromMaybe (error "No reply chan received") chan

404+

405+ -- initiate a send

406+ op ch' ()

407+

408+ -- verify the management event

409+ sent <- receiveChanTimeout 5000000 sink

410+ case sent of

411+ Just (MxSentToPort sId spId _)

412+ | sId == us && spId == sendPortId ch' -> return True

413+ _ -> return False

414+

415+type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

416+

417+testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()

418+testMxSend mNode label test = do

419+ us <- getSelfPid

420+ (sp, rp) <- newChan

421+ (chan, sink) <- newChan

422+ agent <- mxAgent (MxAgentId $ agentLabel us) () [

423+ mxSink $ \ev -> do

424+ case ev of

425+ m@(MxSentToPort _ cid _)

426+ | cid /= sendPortId chan

427+ && cid /= sendPortId sp -> liftMX $ sendChan chan m

428+ m@(MxSent _ fromPid _)

429+ | fromPid == us -> liftMX $ sendChan chan m

430+ m@(MxSentToName _ fromPid _)

431+ | fromPid == us -> liftMX $ sendChan chan m

432+ m@(MxRegistered _ name)

433+ | name == label -> liftMX $ sendChan chan m

434+ _ -> return ()

435+ mxReady

436+ ]

180

437

181− stash result $ seenAlive && seenDead

438+ case mNode of

439+ Nothing -> void $ spawnLocal (proc sp)

440+ Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

182

441

183−testAgentPublication :: TestResult (Maybe Publish) -> Process ()

442+ p1 <- receiveChanTimeout 2000000 rp

184−testAgentPublication result = do

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

185− (syncChan, rp) <- newChan

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

186− let ourId = MxAgentId "publication-agent"

187− agentPid <- mxAgent ourId () [

188− mxSink $ \() -> do

189− selfId <- mxGetId

190− liftMX $ mxSet selfId "publish" Publish >> sendChan syncChan ()

191− mxReady

192− ]

193

445

194− mxNotify ()

446+ kill agent "bye"

195− () <- receiveChan rp

447+ kill (fromJust p1) "bye"

196

448

197− stash result =<< mxGet ourId "publish"

449+ case res of

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

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

198

452

199− mref <- monitor agentPid

200− kill agentPid "finished"

201− receiveWait [

202− matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

203− ((\_ -> return ()))

204− ]

205

453

206−testAgentTableClear :: Int -> TestResult (Maybe Int, Maybe Int) -> Process ()

454+ where

207−testAgentTableClear val result =

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

208− let tId = (MxAgentId "agent-1")

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

209− tKey = "key-1" in do

457+

210− mxSet tId tKey val

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

211− get1 <- mxGet tId tKey

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

212− mxClear tId tKey

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

213− get2 <- mxGet tId tKey

461+

214− stash result (get1, get2)

462+ replyChannel p' = do

215−

463+ (s, r) <- newChan

216−testAgentTablePurge :: TestResult (Maybe Int) -> Process ()

464+ send p' s

217−testAgentTablePurge result =

465+ return r

218− let tId = MxAgentId "agent-2"

219− tKey = "key-2" in do

220− mxSet tId tKey (12345 :: Int)

221− mxPurgeTable tId

222− stash result =<< mxGet tId tKey

223−

224−testAgentTableDelete :: Int

225− -> TestResult (Maybe Int, Maybe Int, Maybe Int)

226− -> Process ()

227−testAgentTableDelete val result =

228− let tId = (MxAgentId "agent-3")

229− tKey = "key-3" in do

230− mxSet tId tKey val

231− get1 <- mxGet tId tKey

232− mxDropTable tId

233− get2 <- mxGet tId tKey

234− mxSet tId tKey val

235− get3 <- mxGet tId tKey

236− stash result (get1, get2, get3)

237

466

238tests :: TestTransport -> IO [Test]

467tests :: TestTransport -> IO [Test]

239tests TestTransport{..} = do

468tests TestTransport{..} = do

240 node1 <- newLocalNode testTransport initRemoteTable

469 node1 <- newLocalNode testTransport initRemoteTable

470+ node2 <- newLocalNode testTransport initRemoteTable

241 return [

471 return [

242− testGroup "Mx Agents" [

472+ testGroup "MxAgents" [

243− testCase "Event Handling"

473+ testCase "EventHandling"

244− (delayedAssertion

474+ (delayedAssertion

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

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

246− node1 True testAgentEventHandling)

476+ node1 True testAgentEventHandling)

247− , testCase "Inter-Agent Broadcast"

477+ , testCase "InterAgentBroadcast"

248− (delayedAssertion

478+ (delayedAssertion

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

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

250− node1 () testAgentBroadcast)

480+ node1 (Just ()) testAgentBroadcast)

251− , testCase "Agent Mailbox Handling"

481+ , testCase "AgentMailboxHandling"

252− (delayedAssertion

482+ (delayedAssertion

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

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

254− node1 (Just ()) testAgentMailboxHandling)

484+ node1 (Just ()) testAgentMailboxHandling)

255− , testCase "Agent Dual Input Handling"

485+ , testCase "AgentDualInputHandling"

256− (delayedAssertion

486+ (delayedAssertion

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

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

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

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

259− , testCase "Agent Input Prioritisation"

489+ , testCase "AgentInputPrioritisation"

260− (delayedAssertion

490+ (delayedAssertion

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

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

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

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

263− "third", "fourth",

493+ "third", "fourth",

264− "fifth"]) testAgentPrioritisation)

494+ "fifth"]) testAgentPrioritisation)

265− ],

495+ ]

266− testGroup "Mx Global Properties" [

496+ , testGroup "MxEvents" [

267− testCase "Global Property Publication"

497+ testCase "NameRegistrationEvents"

268− (delayedAssertion

498+ (delayedAssertion

269− "expected (Just Publish), but no table entry was found"

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

270− node1 (Just Publish) testAgentPublication)

500+ node1 () testMxRegEvents)

271− , testCase "Clearing Global Properties"

501+ , testCase "PostDeathNameUnRegistrationEvents"

272− (delayedAssertion

502+ (delayedAssertion

273− "expected (Just 1024, Nothing): invalid table entry found!"

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

274− node1 (Just 1024, Nothing) (testAgentTableClear 1024))

504+ node1 () (testMxRegMon node2))

275− , testCase "Purging Global Tables"

505+ , testGroup "SendEvents" $ buildTestCases node1 node2

276− (delayedAssertion

506+ ]

277− "expected Nothing, but a table entry was found"

507+ ]

278− node1 Nothing testAgentTablePurge)

508+ where

279− , testCase "Deleting and (Re)Creating Global Tables"

509+ buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [

280− (delayedAssertion

510+ ("NSend", [

281− "expected (Just 15, Nothing, Just 15): invalid table entry found!"

511+ ("nsend", testNSend nsend)

282− node1 (Just 15, Nothing, Just 15) (testAgentTableDelete 15))

512+ , ("Unsafe.nsend", testNSend Unsafe.nsend)

283− -- Wait for other tests to finish.

513+ , ("nsendRemote", testNSend (nsendRemote nid))

284− , testCase "Wait" $

514+ , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))

285− threadDelay 100000

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

286− ]]

542+ ]

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

@@ -1,4 +1,4 @@

1−{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}

1+{-# LANGUAGE TemplateHaskell #-}

2{-# OPTIONS_GHC -Wall #-}

4-- | XXX test doesn't work, because failure exceptions don't get propagated. The

@@ -10,16 +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

17−import Text.Printf

18−import Data.Binary

19−import Data.Typeable

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

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

22−import Test.Framework (Test, defaultMain)

18+import Test.Framework (Test)

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

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

25-- Tests:

21-- Tests:

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

46 -> SendPort String

42 -> SendPort String

47 -> ReceivePort String -> ReceivePort String

43 -> ReceivePort String -> ReceivePort String

48 -> Process ()

44 -> Process ()

49−recTest2 wait sync r1 r2 = do

45+recTest2 wait sync r1 _ = do

50 forever $ do

46 forever $ do

51 receiveChan wait

47 receiveChan wait

52 r <- receiveWait

48 r <- receiveWait

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

59 -> SendPort String

55 -> SendPort String

60 -> ReceivePort String -> ReceivePort String

56 -> ReceivePort String -> ReceivePort String

61 -> Process ()

57 -> Process ()

62−recTest3 wait sync r1 r2 = do

58+recTest3 wait sync r1 _ = do

63 forever $ do

59 forever $ do

64 receiveChan wait

60 receiveChan wait

65 r <- receiveWait

61 r <- receiveWait

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

72 -> SendPort String

68 -> SendPort String

73 -> ReceivePort String -> ReceivePort String

69 -> ReceivePort String -> ReceivePort String

74 -> Process ()

70 -> Process ()

75−recTest4 wait sync r1 r2 = do

71+recTest4 wait sync r1 _ = do

76 forever $ do

72 forever $ do

77 receiveChan wait

73 receiveChan wait

78 r <- receiveWait

74 r <- receiveWait

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

86master = do

82master = do

87 (waits,waitr) <- newChan

83 (waits,waitr) <- newChan

88 (syncs,syncr) <- newChan

84 (syncs,syncr) <- newChan

89− let go expect = do

85+ let go expected = do

90 sendChan waits ()

86 sendChan waits ()

91 r <- receiveChan syncr

87 r <- receiveChan syncr

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

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

93− liftIO $ r @?= expect

89+ liftIO $ r @?= expected

95 liftIO $ putStrLn "---- Test 1 ----"

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

96 (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+50−36

@@ -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,23 +41,26 @@ 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,

63+ Control.Distributed.Process.Internal.BiMultiMap,

61 Control.Distributed.Process.Internal.Closure.BuiltIn,

64 Control.Distributed.Process.Internal.Closure.BuiltIn,

62 Control.Distributed.Process.Internal.Closure.Explicit,

65 Control.Distributed.Process.Internal.Closure.Explicit,

63 Control.Distributed.Process.Internal.CQueue,

66 Control.Distributed.Process.Internal.CQueue,

@@ -75,7 +78,6 @@ Library

75 Control.Distributed.Process.UnsafePrimitives

78 Control.Distributed.Process.UnsafePrimitives

76 Control.Distributed.Process.Management.Internal.Agent,

79 Control.Distributed.Process.Management.Internal.Agent,

77 Control.Distributed.Process.Management.Internal.Bus,

80 Control.Distributed.Process.Management.Internal.Bus,

78− Control.Distributed.Process.Management.Internal.Table,

79 Control.Distributed.Process.Management.Internal.Types,

81 Control.Distributed.Process.Management.Internal.Types,

80 Control.Distributed.Process.Management.Internal.Trace.Primitives,

82 Control.Distributed.Process.Management.Internal.Trace.Primitives,

81 Control.Distributed.Process.Management.Internal.Trace.Remote,

83 Control.Distributed.Process.Management.Internal.Trace.Remote,

@@ -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.hs+2

@@ -102,6 +102,7 @@ module Control.Distributed.Process

102 , monitorPort

103 , unmonitor

104 , withMonitor

105+ , withMonitor_

105 , MonitorRef -- opaque

106 , MonitorRef -- opaque

106 , ProcessLinkException(..)

107 , ProcessLinkException(..)

107 , NodeLinkException(..)

108 , NodeLinkException(..)

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

269 , monitorPort

270 , monitorPort

270 , unmonitor

271 , unmonitor

271 , withMonitor

272 , withMonitor

273+ , withMonitor_

272 -- Logging

274 -- Logging

273 , say

275 , say

274 -- Registry

276 -- Registry

src/Control/Distributed/Process/Internal/BiMultiMap.hsnew file+135

@@ -0,0 +1,135 @@

1+-- | This is an implementation of bidirectional multimaps.

2+module Control.Distributed.Process.Internal.BiMultiMap

3+ ( BiMultiMap

4+ , empty

5+ , singleton

6+ , size

7+ , insert

8+ , lookupBy1st

9+ , lookupBy2nd

10+ , delete

11+ , deleteAllBy1st

12+ , deleteAllBy2nd

13+ , partitionWithKeyBy1st

14+ , partitionWithKeyBy2nd

15+ , flip

16+ ) where

17+

18+import Data.List (foldl')

19+import Data.Map.Strict (Map)

20+import qualified Data.Map.Strict as Map

21+import Data.Set (Set)

22+import qualified Data.Set as Set

23+import Prelude hiding (flip, lookup)

24+

25+-- | A bidirectional multimaps @BiMultiMap a b v@ is a set of triplets of type

26+-- @(a, b, v)@.

27+--

28+-- It is possible to lookup values by using either @a@ or @b@ as keys.

29+--

30+data BiMultiMap a b v = BiMultiMap !(Map a (Set (b, v))) !(Map b (Set (a, v)))

31+

32+-- The bidirectional multimap is implemented with a pair of multimaps.

33+--

34+-- Each multimap represents a set of triples, and one invariant is that both

35+-- multimaps should represent exactly the same set of triples.

36+--

37+-- Each of the multimaps, however, uses a different component of the triplets

38+-- as key. This allows to do efficient deletions by any of the two components.

39+

40+-- | The empty bidirectional multimap.

41+empty :: BiMultiMap a b v

42+empty = BiMultiMap Map.empty Map.empty

43+

44+-- | A bidirectional multimap containing a single triplet.

45+singleton :: (Ord a, Ord b, Ord v) => a -> b -> v -> BiMultiMap a b v

46+singleton a b v = insert a b v empty

47+

48+-- | Yields the amount of triplets in the multimap.

49+size :: BiMultiMap a b v -> Int

50+size (BiMultiMap m _) = foldl' (+) 0 $ map Set.size $ Map.elems m

51+

52+-- | Inserts a triplet in the multimap.

53+insert :: (Ord a, Ord b, Ord v)

54+ => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

55+insert a b v (BiMultiMap m r) =

56+ BiMultiMap (Map.insertWith (\_new old -> Set.insert (b, v) old)

57+ a

58+ (Set.singleton (b, v))

59+ m)

60+ (Map.insertWith (\_new old -> Set.insert (a, v) old)

61+ b

62+ (Set.singleton (a, v))

63+ r)

64+

65+-- | Looks up all the triplets whose first component is the given value.

66+lookupBy1st :: Ord a => a -> BiMultiMap a b v -> Set (b, v)

67+lookupBy1st a (BiMultiMap m _) = maybe Set.empty id $ Map.lookup a m

68+

69+-- | Looks up all the triplets whose second component is the given value.

70+lookupBy2nd :: Ord b => b -> BiMultiMap a b v -> Set (a, v)

71+lookupBy2nd b = lookupBy1st b . flip

72+

73+-- | Deletes a triplet. It yields the original multimap if the triplet is

74+-- not present.

75+delete :: (Ord a, Ord b, Ord v)

76+ => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

77+delete a b v (BiMultiMap m r) =

78+ let m' = Map.update (nothingWhen Set.null . Set.delete (b, v)) a m

79+ r' = Map.update (nothingWhen Set.null . Set.delete (a, v)) b r

80+ in BiMultiMap m' r'

81+

82+-- | Deletes all triplets whose first component is the given value.

83+deleteAllBy1st :: (Ord a, Ord b, Ord v) => a -> BiMultiMap a b v -> BiMultiMap a b v

84+deleteAllBy1st a (BiMultiMap m r) =

85+ let (mm, m') = Map.updateLookupWithKey (\_ _ -> Nothing) a m

86+ r' = case mm of

87+ Nothing -> r

88+ Just mb -> reverseDelete a (Set.toList mb) r

89+ in BiMultiMap m' r'

90+

91+-- | Like 'deleteAllBy1st' but deletes by the second component of the triplets.

92+deleteAllBy2nd :: (Ord a, Ord b, Ord v)

93+ => b -> BiMultiMap a b v -> BiMultiMap a b v

94+deleteAllBy2nd b = flip . deleteAllBy1st b . flip

95+

96+-- | Yields the triplets satisfying the given predicate, and a multimap

97+-- with all this triplets removed.

98+partitionWithKeyBy1st :: (Ord a, Ord b, Ord v)

99+ => (a -> Set (b, v) -> Bool) -> BiMultiMap a b v

100+ -> (Map a (Set (b, v)), BiMultiMap a b v)

101+partitionWithKeyBy1st p (BiMultiMap m r) =

102+ let (m0, m1) = Map.partitionWithKey p m

103+ r1 = foldl' (\rr (a, mb) -> reverseDelete a (Set.toList mb) rr) r $

104+ Map.toList m0

105+ in (m0, BiMultiMap m1 r1)

106+

107+-- | Like 'partitionWithKeyBy1st' but the predicates takes the second component

108+-- of the triplets as first argument.

109+partitionWithKeyBy2nd :: (Ord a, Ord b, Ord v)

110+ => (b -> Set (a, v) -> Bool) -> BiMultiMap a b v

111+ -> (Map b (Set (a, v)), BiMultiMap a b v)

112+partitionWithKeyBy2nd p b = let (m, b') = partitionWithKeyBy1st p $ flip b

113+ in (m, flip b')

114+

115+-- | Exchange the first and the second components of all triplets.

116+flip :: BiMultiMap a b v -> BiMultiMap b a v

117+flip (BiMultiMap m r) = BiMultiMap r m

118+

119+-- Internal functions

120+

121+-- | @reverseDelete a bs m@ removes from @m@ all the triplets wich have @a@ as

122+-- first component and second and third components in @bs@.

123+--

124+-- The @m@ map is in reversed form, meaning that the second component of the

125+-- triplets is used as key.

126+reverseDelete :: (Ord a, Ord b, Ord v)

127+ => a -> [(b, v)] -> Map b (Set (a, v)) -> Map b (Set (a, v))

128+reverseDelete a bs r = foldl' (\rr (b, v) -> Map.update (rmb v) b rr) r bs

129+ where

130+ rmb v = nothingWhen Set.null . Set.delete (a, v)

131+

132+-- | @nothingWhen p a@ is @Just a@ when @a@ satisfies predicate @p@.

133+-- Yields @Nothing@ otherwise.

134+nothingWhen :: (a -> Bool) -> a -> Maybe a

135+nothingWhen p a = if p a then Nothing else Just a

src/Control/Distributed/Process/Internal/Closure/TH.hs+11−7

@@ -29,11 +29,14 @@ import Language.Haskell.TH

29 , Type(AppT, ForallT, VarT, ArrowT)

30 , Info(VarI)

31 , TyVarBndr(PlainTV, KindedTV)

32−#if ! MIN_VERSION_template_haskell(2,10,0)

33 , Pred

32 , Pred

33+#if MIN_VERSION_template_haskell(2,10,0)

34+ , conT

35+ , appT

36+#else

37+ , classP

34#endif

38#endif

35 , varT

39 , varT

36− , classP

37 -- Lifted constructors

40 -- Lifted constructors

38 -- .. Literals

41 -- .. Literals

39 , stringL

42 , stringL

@@ -71,10 +74,6 @@ import Control.Distributed.Process.Serializable

71 )

74 )

72import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

75import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

74−#if MIN_VERSION_template_haskell(2,10,0)

75−type Pred = Type

76−#endif

77−

78--------------------------------------------------------------------------------

77--------------------------------------------------------------------------------

79-- User-level API --

78-- User-level API --

80--------------------------------------------------------------------------------

79--------------------------------------------------------------------------------

@@ -261,7 +260,12 @@ generateStatic n xs typ = do

261 ]

260 ]

262 where

261 where

263 typeable :: TyVarBndr -> Q Pred

262 typeable :: TyVarBndr -> Q Pred

263+ typeable tv =

264+#if MIN_VERSION_template_haskell(2,10,0)

265+ conT (mkName "Typeable") `appT` varT (tyVarBndrName tv)

266+#else

264− typeable tv = classP (mkName "Typeable") [varT (tyVarBndrName tv)]

267+ classP (mkName "Typeable") [varT (tyVarBndrName tv)]

268+#endif

265

269

266-- | Generate a serialization dictionary with name 'n' for type 'typ'

270-- | Generate a serialization dictionary with name 'n' for type 'typ'

267generateDict :: Name -> Type -> Q [Dec]

271generateDict :: Name -> Type -> Q [Dec]

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+130−58

@@ -76,8 +76,11 @@ module Control.Distributed.Process.Internal.Primitives

76 , unlink

77 , monitor

78 , unmonitor

79+ , unmonitorAsync

79 , withMonitor

80 , withMonitor

81+ , withMonitor_

80 -- * Logging

82 -- * Logging

83+ , SayMessage(..)

81 , say

84 , say

82 -- * Registry

85 -- * Registry

83 , register

86 , register

@@ -125,8 +128,9 @@ module Control.Distributed.Process.Internal.Primitives

125import Prelude hiding (catch)

128import Prelude hiding (catch)

126#endif

129#endif

127

130

128−import Data.Binary (decode)

131+import Data.Binary (Binary(..), Put, Get, decode)

129−import Data.Time.Clock (getCurrentTime)

132+import Data.Time.Clock (getCurrentTime, UTCTime(..))

133+import Data.Time.Calendar (Day(..))

130import Data.Time.Format (formatTime)

134import Data.Time.Format (formatTime)

131#if MIN_VERSION_time(1,5,0)

135#if MIN_VERSION_time(1,5,0)

132import Data.Time.Format (defaultTimeLocale)

136import Data.Time.Format (defaultTimeLocale)

@@ -134,7 +138,7 @@ import Data.Time.Format (defaultTimeLocale)

134import System.Locale (defaultTimeLocale)

138import System.Locale (defaultTimeLocale)

135#endif

139#endif

136import System.Timeout (timeout)

140import System.Timeout (timeout)

137−import Control.Monad (when)

141+import Control.Monad (when, void)

138import Control.Monad.Reader (ask)

142import Control.Monad.Reader (ask)

139import Control.Monad.IO.Class (liftIO)

143import Control.Monad.IO.Class (liftIO)

140import Control.Monad.Catch

144import Control.Monad.Catch

@@ -184,6 +188,7 @@ import Control.Distributed.Process.Internal.Types

184 , SpawnRef(..)

188 , SpawnRef(..)

185 , ProcessSignal(..)

189 , ProcessSignal(..)

186 , NodeMonitorNotification(..)

190 , NodeMonitorNotification(..)

191+ , ProcessMonitorNotification(..)

187 , monitorCounter

192 , monitorCounter

188 , spawnCounter

193 , spawnCounter

189 , SendPort(..)

194 , SendPort(..)

@@ -249,17 +254,15 @@ send them msg = do

249 node = processNode proc

254 node = processNode proc

250 nodeId = localNodeId node

255 nodeId = localNodeId node

251 destNode = (processNodeId them) in do

256 destNode = (processNodeId them) in do

252− case destNode == nodeId of

253− True -> sendLocal them msg

254− False -> liftIO $ sendMessage (processNode proc)

255− (ProcessIdentifier (processId proc))

256− (ProcessIdentifier them)

257− NoImplicitReconnect

258− msg

259− -- We do not fire the trace event until after the sending is complete;

260− -- In the remote case, 'sendMessage' can block in the networking stack.

261 liftIO $ traceEvent (localEventBus node)

257 liftIO $ traceEvent (localEventBus node)

262 (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

263

266

264-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

267-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

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

@@ -279,9 +282,12 @@ unsafeSend = Unsafe.send

279--

282--

280usend :: Serializable a => ProcessId -> a -> Process ()

283usend :: Serializable a => ProcessId -> a -> Process ()

281usend them msg = do

284usend them msg = do

282− here <- getSelfNode

285+ proc <- ask

283 let there = processNodeId them

286 let there = processNodeId them

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

285 then sendLocal them msg

291 then sendLocal them msg

286 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

292 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

287 (createMessage msg)

293 (createMessage msg)

@@ -301,7 +307,13 @@ expect = receiveWait [match return]

301-- Channels --

307-- Channels --

302--------------------------------------------------------------------------------

308--------------------------------------------------------------------------------

303

309

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

305newChan :: Serializable a => Process (SendPort a, ReceivePort a)

317newChan :: Serializable a => Process (SendPort a, ReceivePort a)

306newChan = do

318newChan = do

307 proc <- ask

319 proc <- ask

@@ -329,13 +341,16 @@ newChan = do

329sendChan :: Serializable a => SendPort a -> a -> Process ()

341sendChan :: Serializable a => SendPort a -> a -> Process ()

330sendChan (SendPort cid) msg = do

342sendChan (SendPort cid) msg = do

331 proc <- ask

343 proc <- ask

332− let node = localNodeId (processNode proc)

344+ let node = processNode proc

345+ pid = processId proc

346+ us = localNodeId node

333− destNode = processNodeId (sendPortProcessId cid) in do

347+ them = processNodeId (sendPortProcessId cid) in do

348+ liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)

334− case destNode == node of

349+ case them == us of

335 True -> sendChanLocal cid msg

350 True -> sendChanLocal cid msg

336 False -> do

351 False -> do

337− liftIO $ sendBinary (processNode proc)

352+ liftIO $ sendBinary node

338− (ProcessIdentifier (processId proc))

353+ (ProcessIdentifier pid)

339 (SendPortIdentifier cid)

354 (SendPortIdentifier cid)

340 NoImplicitReconnect

355 NoImplicitReconnect

341 msg

356 msg

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

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

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

397receiveWait ms = do

412receiveWait ms = do

398 queue <- processQueue <$> ask

413 queue <- processQueue <$> ask

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

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

415+ case mProc of

400− proc

416+ Just proc' -> proc'

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

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

401

419

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

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

403--

421--

@@ -476,17 +494,14 @@ forward msg them = do

476 us = processId proc

494 us = processId proc

477 nid = localNodeId node

495 nid = localNodeId node

478 destNode = (processNodeId them) in do

496 destNode = (processNodeId them) in do

497+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

479− case destNode == nid of

498+ if destNode == nid

480− True -> sendCtrlMsg Nothing (LocalSend them msg)

499+ then sendCtrlMsg Nothing (LocalSend them msg)

481− False -> liftIO $ sendPayload (processNode proc)

500+ else liftIO $ sendPayload (processNode proc)

482− (ProcessIdentifier (processId proc))

501+ (ProcessIdentifier (processId proc))

483− (ProcessIdentifier them)

502+ (ProcessIdentifier them)

484− NoImplicitReconnect

503+ NoImplicitReconnect

485− (messageToPayload msg)

504+ (messageToPayload msg)

486− -- We do not fire the trace event until after the sending is complete;

487− -- In the remote case, 'sendMessage' can block in the networking stack.

488− liftIO $ traceEvent (localEventBus node)

489− (MxSent them us msg)

490

505

491-- | Forward a raw 'Message' to the given 'ProcessId'.

506-- | Forward a raw 'Message' to the given 'ProcessId'.

492--

507--

@@ -500,14 +515,10 @@ uforward msg them = do

500 us = processId proc

515 us = processId proc

501 nid = localNodeId node

516 nid = localNodeId node

502 destNode = (processNodeId them) in do

517 destNode = (processNodeId them) in do

518+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

503− case destNode == nid of

519+ if destNode == nid

504− True -> sendCtrlMsg Nothing (LocalSend them msg)

520+ then sendCtrlMsg Nothing (LocalSend them msg)

505− False -> sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them)

521+ else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg

506− msg

507− -- We do not fire the trace event until after the sending is complete;

508− -- In the remote case, 'sendCtrlMsg' can block in the networking stack.

509− liftIO $ traceEvent (localEventBus node)

510− (MxSent them us msg)

511

522

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

513-- 'Serializable' - like the datum they contain - but also note, deserialising

524-- 'Serializable' - like the datum they contain - but also note, deserialising

@@ -885,12 +896,19 @@ monitor = monitor' . ProcessIdentifier

885-- @withMonitor@ returns, there might still be unreceived monitor

896-- @withMonitor@ returns, there might still be unreceived monitor

886-- messages in the queue.

897-- messages in the queue.

887--

898--

888−withMonitor :: ProcessId -> Process a -> Process a

899+withMonitor :: ProcessId -> (MonitorRef -> Process a) -> Process a

889−withMonitor pid code = bracket (monitor pid) unmonitor (\_ -> code)

900+withMonitor pid = bracket (monitor pid) unmonitor

890− -- unmonitor blocks waiting for the response, so there's a possibility

901+

891− -- that an exception might interrupt withMonitor before the unmonitor

902+-- | Establishes temporary monitoring of another process.

892− -- has completed. I think that's better than making the unmonitor

903+--

893− -- uninterruptible.

904+-- @withMonitor_ pid code@ sets up monitoring of @pid@ for the duration

905+-- of @code@. Note: although monitoring is no longer active when

906+-- @withMonitor_@ returns, there might still be unreceived monitor

907+-- messages in the queue.

908+--

909+-- Since 0.6.1

910+withMonitor_ :: ProcessId -> Process a -> Process a

911+withMonitor_ p = withMonitor p . const

894

912

895-- | Remove a link

913-- | Remove a link

896--

914--

@@ -928,12 +946,21 @@ unlinkPort sport = do

928-- | Remove a monitor

946-- | Remove a monitor

929--

947--

930-- This has the same synchronous/asynchronous nature as 'unlink'.

948-- This has the same synchronous/asynchronous nature as 'unlink'.

949+--

950+-- ProcessMonitorNotification messages for the given MonitorRef are removed from

951+-- the mailbox.

931unmonitor :: MonitorRef -> Process ()

952unmonitor :: MonitorRef -> Process ()

932unmonitor ref = do

953unmonitor ref = do

933 unmonitorAsync ref

954 unmonitorAsync ref

934 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

955 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

935 (\_ -> return ())

956 (\_ -> return ())

936 ]

957 ]

958+ -- Discard the notification if any. With the current NC implementation at most

959+ -- one notification is in the mailbox for any given ref.

960+ void $ receiveTimeout 0

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

962+ (const $ return ())

963+ ]

937

964

938--------------------------------------------------------------------------------

965--------------------------------------------------------------------------------

939-- Exception handling --

966-- Exception handling --

@@ -947,7 +974,7 @@ catch = Catch.catch

947-- | Lift 'Control.Exception.try'

974-- | Lift 'Control.Exception.try'

948try :: Exception e => Process a -> Process (Either e a)

975try :: Exception e => Process a -> Process (Either e a)

949try = Catch.try

976try = Catch.try

950−{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}

977+{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}

951

978

952-- | Lift 'Control.Exception.mask'

979-- | Lift 'Control.Exception.mask'

953mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

980mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

@@ -1059,17 +1086,52 @@ unlinkPortAsync (SendPort cid) =

1059-- Logging --

1086-- Logging --

1060--------------------------------------------------------------------------------

1087--------------------------------------------------------------------------------

1061

1088

1089+data SayMessage = SayMessage { sayTime :: UTCTime

1090+ , sayProcess :: ProcessId

1091+ , sayMessage :: String }

1092+ deriving (Typeable)

1093+

1094+-- There is sadly no Show UTCTime instance

1095+instance Show SayMessage where

1096+ showsPrec p msg =

1097+ showParen (p >= 11)

1098+ $ showString "SayMessage "

1099+ . showString (formatTime defaultTimeLocale "%c" (sayTime msg))

1100+ . showChar ' '

1101+ . showsPrec 11 (sayProcess msg) . showChar ' '

1102+ . showsPrec 11 (sayMessage msg) . showChar ' '

1103+

1104+instance Binary SayMessage where

1105+ put s = do

1106+ putUTCTime (sayTime s)

1107+ put (sayProcess s)

1108+ put (sayMessage s)

1109+ get = SayMessage <$> getUTCTime <*> get <*> get

1110+

1111+-- Sadly there is no Binary UTCTime instance

1112+putUTCTime :: UTCTime -> Put

1113+putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do

1114+ put day

1115+ put (toRational tod)

1116+

1117+getUTCTime :: Get UTCTime

1118+getUTCTime = do

1119+ day <- get

1120+ tod <- get

1121+ return $! UTCTime (ModifiedJulianDay day)

1122+ (fromRational tod)

1123+

1062-- | Log a string

1124-- | Log a string

1063--

1125--

1064−-- @say message@ sends a message (time, pid of the current process, message)

1126+-- @say message@ sends a message of type 'SayMessage' with the current time and

1065−-- to the process registered as 'logger'. By default, this process simply

1127+-- 'ProcessId' of the current process to the process registered as @logger@. By

1066−-- sends the string to 'stderr'. Individual Cloud Haskell backends might

1128+-- default, this process simply sends the string to @stderr@. Individual Cloud

1067−-- replace this with a different logger process, however.

1129+-- Haskell backends might replace this with a different logger process, however.

1068say :: String -> Process ()

1130say :: String -> Process ()

1069say string = do

1131say string = do

1070 now <- liftIO getCurrentTime

1132 now <- liftIO getCurrentTime

1071 us <- getSelfPid

1133 us <- getSelfPid

1072− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

1134+ nsend "logger" (SayMessage now us string)

1073

1135

1074--------------------------------------------------------------------------------

1136--------------------------------------------------------------------------------

1075-- Registry --

1137-- Registry --

@@ -1165,8 +1227,12 @@ whereisRemoteAsync nid label = do

1165

1227

1166-- | Named send to a process in the local registry (asynchronous)

1228-- | Named send to a process in the local registry (asynchronous)

1167nsend :: Serializable a => String -> a -> Process ()

1229nsend :: Serializable a => String -> a -> Process ()

1168−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')

1169− sendCtrlMsg Nothing (NamedSend label (createUnencodedMessage msg))

1235+ sendCtrlMsg Nothing (NamedSend label msg')

1170

1236

1171-- | Named send to a process in the local registry (asynchronous).

1237-- | Named send to a process in the local registry (asynchronous).

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

@@ -1178,9 +1244,15 @@ unsafeNSend = Unsafe.nsend

1178-- | Named send to a process in a remote registry (asynchronous)

1244-- | Named send to a process in a remote registry (asynchronous)

1179nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1245nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1180nsendRemote nid label msg = do

1246nsendRemote nid label msg = do

1181− here <- getSelfNode

1247+ proc <- ask

1248+ let us = processId proc

1249+ let node = processNode proc

1250+ if localNodeId node == nid

1182− 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))

1183− else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1255+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1184

1256

1185-- | Named send to a process in a remote registry (asynchronous)

1257-- | Named send to a process in a remote registry (asynchronous)

1186-- 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+38−81

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

@@ -83,28 +117,8 @@

83-- system information. Agents maintain their own internal state privately (via a

117-- system information. Agents maintain their own internal state privately (via a

84-- state transformer - see 'mxGetLocal' et al), however it is possible for

118-- state transformer - see 'mxGetLocal' et al), however it is possible for

85-- agents to share additional data with each other (and the outside world)

119-- agents to share additional data with each other (and the outside world)

86−-- using /data tables/.

120+-- using whatever mechanism the user wishes, e.g., acidstate, or shared memory

87−--

121+-- primitives.

88−-- Each agent is assigned its own data table, which acts as a shared map, where

89−-- the keys are @String@s and the values are @Serializable@ datum of whatever

90−-- type the agent or its clients stores.

91−--

92−-- Because an agent's /data table/ stores its values in raw 'Message' format,

93−-- it works effectively as an /un-typed dictionary/, into which data of varying

94−-- types can be fed and later retrieved. The upside of this is that different

95−-- keys can be mapped to various types without any additional work on the part

96−-- of the developer. The downside is that the code reading these values must

97−-- know in advance what type(s) to expect, and the API provides no additional

98−-- support for handling that.

99−--

100−-- Publishing is accomplished using the 'mxPublish' and 'mxSet' APIs, whilst

101−-- querying and deletion are handled by 'mxGet', 'mxClear', 'mxPurgeTable' and

102−-- 'mxDropTable' respectively.

103−--

104−-- When a management agent terminates, their tables are left in memory despite

105−-- termination, such that an agent may resume its role (by restarting) or have

106−-- its 'MxAgentId' taken over by another subsequent agent, leaving the data

107−-- originally captured in place.

108--

122--

109-- [Defining Agents]

123-- [Defining Agents]

110--

124--

@@ -164,8 +178,6 @@

164-- > monitorNames = getSelfPid >>= nsend "name-monitor"

178-- > monitorNames = getSelfPid >>= nsend "name-monitor"

165-- > monitorNames2 = getSelfPid >>= mxNotify

179-- > monitorNames2 = getSelfPid >>= mxNotify

166--

180--

167−-- For some real-world examples, see the distributed-process-platform package.

168−--

169-- [Performance, Stablity and Scalability]

181-- [Performance, Stablity and Scalability]

170--

182--

171-- /Management Agents/ offer numerous advantages over regular processes:

183-- /Management Agents/ offer numerous advantages over regular processes:

@@ -194,10 +206,6 @@

194-- the event bus /and/ their own mailboxes, plus searching through the set of

206-- the event bus /and/ their own mailboxes, plus searching through the set of

195-- event sinks (for each agent) to determine the right handler for the event.

207-- event sinks (for each agent) to determine the right handler for the event.

196--

208--

197−-- Each management agent requires not only its own @Process@ (in which the agent

198−-- code is run), but also a peer process that provides its /data table/. These

199−-- data tables also have to be coordinated and manaaged on each agent's behalf.

200−--

201-- [Architecture Overview]

209-- [Architecture Overview]

202--

210--

203-- The architecture of the management event bus is internal and subject to

211-- The architecture of the management event bus is internal and subject to

@@ -264,13 +272,6 @@ module Control.Distributed.Process.Management

264 , mxGetLocal

272 , mxGetLocal

265 , mxUpdateLocal

273 , mxUpdateLocal

266 , liftMX

274 , liftMX

267− -- * Mx Data API

268− , mxPublish

269− , mxSet

270− , mxGet

271− , mxClear

272− , mxPurgeTable

273− , mxDropTable

274 ) where

275 ) where

275

276

276import Control.Applicative

277import Control.Applicative

@@ -281,10 +282,7 @@ import Control.Concurrent.STM.TChan

281 , TChan

282 , TChan

282 )

283 )

283import Control.Distributed.Process.Internal.Primitives

284import Control.Distributed.Process.Internal.Primitives

284− ( newChan

285− , nsend

286− , receiveWait

285+ ( receiveWait

287− , matchChan

288 , matchAny

286 , matchAny

289 , matchSTM

287 , matchSTM

290 , unwrapMessage

288 , unwrapMessage

@@ -302,14 +300,12 @@ import Control.Distributed.Process.Internal.Types

302 , unsafeCreateUnencodedMessage

300 , unsafeCreateUnencodedMessage

303 )

301 )

304import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

302import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

305−import qualified Control.Distributed.Process.Management.Internal.Table as Table

306import Control.Distributed.Process.Management.Internal.Types

303import Control.Distributed.Process.Management.Internal.Types

307 ( MxAgentId(..)

304 ( MxAgentId(..)

308 , MxAgent(..)

305 , MxAgent(..)

309 , MxAction(..)

306 , MxAction(..)

310 , ChannelSelector(..)

307 , ChannelSelector(..)

311 , MxAgentState(..)

308 , MxAgentState(..)

312− , MxAgentStart(..)

313 , MxSink

309 , MxSink

314 , MxEvent(..)

310 , MxEvent(..)

315 )

311 )

@@ -335,42 +331,6 @@ mxNotify msg = do

335 bus <- localEventBus . processNode <$> ask

331 bus <- localEventBus . processNode <$> ask

336 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

332 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

337

333

338−-- | Publish an arbitrary @Message@ as a property in the management database.

339−--

340−-- For publishing @Serializable@ data, use 'mxSet' instead.

341−--

342−mxPublish :: MxAgentId -> String -> Message -> Process ()

343−mxPublish a k v = Table.set k v (Table.MxForAgent a)

344−

345−-- | Sets an arbitrary @Serializable@ datum against a key in the management

346−-- database. Note that /no attempt is made to force the argument/, therefore

347−-- it is very important that you do not pass unevaluated thunks that might

348−-- crash some other, arbitrary process (or management agent!) that obtains

349−-- and attempts to force the value later on.

350−--

351−mxSet :: Serializable a => MxAgentId -> String -> a -> Process ()

352−mxSet mxId key msg = do

353− Table.set key (unsafeCreateUnencodedMessage msg) (Table.MxForAgent mxId)

354−

355−-- | Fetches a property from the management database for the given key.

356−-- If the property is not set, or does not match the expected type when

357−-- typechecked (at runtime), returns @Nothing@.

358−mxGet :: Serializable a => MxAgentId -> String -> Process (Maybe a)

359−mxGet = Table.fetch . Table.MxForAgent

360−

361−-- | Clears a property from the management database using the given key.

362−-- If the key does not exist in the database, this is a noop.

363−mxClear :: MxAgentId -> String -> Process ()

364−mxClear mxId key = Table.clear key (Table.MxForAgent mxId)

365−

366−-- | Purges a table in the management database of all its stored properties.

367−mxPurgeTable :: MxAgentId -> Process ()

368−mxPurgeTable = Table.purge . Table.MxForAgent

369−

370−-- | Deletes a table from the management database.

371−mxDropTable :: MxAgentId -> Process ()

372−mxDropTable = Table.delete . Table.MxForAgent

373−

374--------------------------------------------------------------------------------

334--------------------------------------------------------------------------------

375-- API for writing user defined management extensions (i.e., agents) --

335-- API for writing user defined management extensions (i.e., agents) --

376--------------------------------------------------------------------------------

336--------------------------------------------------------------------------------

@@ -490,10 +450,7 @@ mxAgentWithFinalize mxId initState handlers dtor = do

490 return pid

450 return pid

491 where

451 where

492 start (sendTChan, recvTChan) = do

452 start (sendTChan, recvTChan) = do

493− (sp, rp) <- newChan

494− nsend Table.mxTableCoordinator (MxAgentStart sp mxId)

495− tablePid <- receiveWait [ matchChan rp (\(p :: ProcessId) -> return p) ]

496− let nState = MxAgentState mxId sendTChan tablePid initState

453+ let nState = MxAgentState mxId sendTChan initState

497 runAgent dtor handlers InputChan recvTChan nState

454 runAgent dtor handlers InputChan recvTChan nState

498

455

499 runAgent :: MxAgent s ()

456 runAgent :: MxAgent s ()

src/Control/Distributed/Process/Management/Internal/Table.hsdeleted−222

@@ -1,222 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RankNTypes #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE RecordWildCards #-}

6−

7−module Control.Distributed.Process.Management.Internal.Table

8− ( MxTableRequest(..)

9− , MxTableId(..)

10− , mxTableCoordinator

11− , startTableCoordinator

12− , delete

13− , purge

14− , clear

15− , set

16− , get

17− , fetch

18− ) where

19−

20−import Control.Distributed.Process.Internal.Primitives

21− ( receiveWait

22− , receiveChan

23− , match

24− , matchAny

25− , matchIf

26− , matchChan

27− , send

28− , nsend

29− , sendChan

30− , getSelfPid

31− , link

32− , monitor

33− , unwrapMessage

34− , newChan

35− , withMonitor

36− )

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

38− ( Process

39− , ProcessId

40− , ProcessMonitorNotification(..)

41− , SendPort

42− , ReceivePort

43− , Message

44− , unsafeCreateUnencodedMessage

45− )

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

47− ( MxTableId(..)

48− , MxAgentId(..)

49− , MxAgentStart(..)

50− , Fork)

51−import Control.Distributed.Process.Serializable (Serializable)

52−import Control.Monad.IO.Class (liftIO)

53−import Data.Accessor (Accessor, accessor, (^=), (^:))

54−import Data.Binary (Binary)

55−import Data.Map (Map)

56−import qualified Data.Map as Map

57−import Data.Typeable (Typeable)

58−

59−import GHC.Generics

60−

61−-- An extremely lightweight shared Map implementation, for use

62−-- by /management agents/ and their cohorts. Each agent is assigned

63−-- a table, into which any serializable @Message@ can be inserted.

64−-- Data are inserted, removed and searched for via their key, which

65−-- is a string. Tables can be purged, values can be set, fetched or

66−-- cleared/removed.

67−--

68−

69−data MxTableRequest =

70− Delete

71− | Purge

72− | Clear !String

73− | Set !String !Message

74− | Get !String !(SendPort (Maybe Message)) -- see [note: un-typed send port]

75− deriving (Typeable, Generic)

76−instance Binary MxTableRequest where

77−

78−data MxTableState = MxTableState { _name :: !String

79− , _entries :: !(Map String Message)

80− }

81−

82−type MxTables = Map MxAgentId ProcessId

83−

84−mxTableCoordinator :: String

85−mxTableCoordinator = "mx.table.coordinator"

86−

87−delete :: MxTableId -> Process ()

88−delete = sendReq Delete

89−

90−purge :: MxTableId -> Process ()

91−purge = sendReq Purge

92−

93−clear :: String -> MxTableId -> Process ()

94−clear k = sendReq (Clear k)

95−

96−set :: String -> Message -> MxTableId -> Process ()

97−set k v = sendReq (Set k v)

98−

99−fetch :: forall a. (Serializable a)

100− => MxTableId

101− -> String

102− -> Process (Maybe a)

103−fetch (MxForPid pid) key = get pid key

104−fetch mxId@(MxForAgent _) key = do

105− (sp, rp) <- newChan :: Process (SendPort (Maybe Message),

106− ReceivePort (Maybe Message))

107− sendReq (Get key sp) mxId

108− receiveChan rp >>= maybe (return Nothing)

109− (unwrapMessage :: Message -> Process (Maybe a))

110−

111−-- [note: un-typed send port]

112−-- Here, fetch uses a typed channel over a raw Message to obtain

113−-- its result, so type checking is deferred until receipt and will

114−-- be handled in the caller's thread. This is necessary because

115−-- the server portion of the code knows nothing about the types

116−-- involved, nor should it, since these tables can be used to

117−-- store arbitrary serializable data.

118−

119−get :: forall a. (Serializable a)

120− => ProcessId

121− -> String

122− -> Process (Maybe a)

123−get pid key = do

124− safeFetch pid key >>= maybe (return Nothing)

125− (unwrapMessage :: Message -> Process (Maybe a))

126−

127−safeFetch :: ProcessId -> String -> Process (Maybe Message)

128−safeFetch pid key = do

129− (sp, rp) <- newChan

130− send pid $ Get key sp

131− withMonitor pid $ do

132− receiveWait [

133− matchChan rp return

134− , matchIf (\(ProcessMonitorNotification _ pid' _) -> pid' == pid)

135− (\_ -> return $ Just (unsafeCreateUnencodedMessage ()))

136− ]

137−

138−sendReq :: MxTableRequest -> MxTableId -> Process ()

139−sendReq req tid = (resolve tid) req

140−

141−resolve :: Serializable a => MxTableId -> (a -> Process ())

142−resolve (MxForAgent agent) = \msg -> nsend mxTableCoordinator (agent, msg)

143−resolve (MxForPid pid) = \msg -> send pid msg

144−

145−startTableCoordinator :: Fork -> Process ()

146−startTableCoordinator fork = run Map.empty

147− where

148− run :: MxTables -> Process ()

149− run tables =

150− receiveWait [

151− -- note that this state change can race with MxAgentStart requests

152− match (\(ProcessMonitorNotification _ pid _) -> do

153− return $ Map.filter (/= pid) tables)

154− , match (\(MxAgentStart ch agent) -> do

155− lookupAgent tables agent >>= \(p, t) -> do

156− sendChan ch p >> return t)

157− , match (\req@(agent, tReq :: MxTableRequest) -> do

158− case tReq of

159− Get k sp -> do

160− lookupAgent tables agent >>= \(p, t) -> do

161− safeFetch p k >>= sendChan sp >> return t

162− _ -> do

163− handleRequest tables req)

164− , matchAny (\_ -> return tables) -- unrecognised messages are dropped

165− ] >>= run

166−

167− handleRequest :: MxTables

168− -> (MxAgentId, MxTableRequest)

169− -> Process MxTables

170− handleRequest tables' (agent, req) = do

171− lookupAgent tables' agent >>= \(p, t) -> send p req >> return t

172−

173− lookupAgent :: MxTables -> MxAgentId -> Process (ProcessId, MxTables)

174− lookupAgent tables' agentId' = do

175− case Map.lookup agentId' tables' of

176− Nothing -> launchNew agentId' tables'

177− Just p -> return (p, tables')

178−

179− launchNew :: MxAgentId

180− -> MxTables

181− -> Process (ProcessId, MxTables)

182− launchNew mxId tblMap = do

183− let initState = MxTableState { _name = (agentId mxId)

184− , _entries = Map.empty

185− }

186− (pid, _) <- spawnSup $ tableHandler initState

187− return $ (pid, mxId `seq` pid `seq` Map.insert mxId pid tblMap)

188−

189− spawnSup proc = do

190− us <- getSelfPid

191− -- we need to use that passed in "fork", in order to

192− -- break an import cycle with Node.hs courtesy of the

193− -- management agent, API and tracing modules

194− them <- liftIO $ fork $ link us >> proc

195− ref <- monitor them

196− return (them, ref)

197−

198−tableHandler :: MxTableState -> Process ()

199−tableHandler state = do

200− ns <- receiveWait [

201− match (handleTableRequest state)

202− , matchAny (\_ -> return (Just state))

203− ]

204− case ns of

205− Nothing -> return ()

206− Just s' -> tableHandler s'

207− where

208− handleTableRequest _ Delete = return Nothing

209− handleTableRequest st Purge = return $ Just $ (entries ^= Map.empty) $ st

210− handleTableRequest st (Clear k) = return $ Just $ (entries ^: (k `seq` Map.delete k)) $ st

211− handleTableRequest st (Set k v) = return $ Just $ (entries ^: (k `seq` v `seq` Map.insert k v)) st

212− handleTableRequest st (Get k c) = getEntry k c st >> return (Just st)

213−

214−getEntry :: String

215− -> SendPort (Maybe Message)

216− -> MxTableState

217− -> Process ()

218−getEntry k m MxTableState{..} = do

219− sendChan m =<< return (Map.lookup k _entries)

220−

221−entries :: Accessor MxTableState (Map String Message)

222−entries = accessor _entries (\ls st -> st { _entries = ls })

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+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−18

@@ -4,12 +4,10 @@

4{-# LANGUAGE DeriveGeneric #-}

5module Control.Distributed.Process.Management.Internal.Types

6 ( MxAgentId(..)

7− , MxTableId(..)

8 , MxAgentState(..)

7 , MxAgentState(..)

9 , MxAgent(..)

8 , MxAgent(..)

10 , MxAction(..)

9 , MxAction(..)

11 , ChannelSelector(..)

10 , ChannelSelector(..)

12− , MxAgentStart(..)

13 , Fork

11 , Fork

14 , MxSink

12 , MxSink

15 , MxEvent(..)

13 , MxEvent(..)

@@ -23,8 +21,8 @@ import Control.Concurrent.STM

23import Control.Distributed.Process.Internal.Types

21import Control.Distributed.Process.Internal.Types

24 ( Process

22 ( Process

25 , ProcessId

23 , ProcessId

24+ , SendPortId

26 , Message

25 , Message

27− , SendPort

28 , DiedReason

26 , DiedReason

29 , NodeId

27 , NodeId

30 )

28 )

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

33 ( MonadState

31 ( MonadState

34 , StateT

32 , StateT

35 )

33 )

34+import Control.Monad.Fix (MonadFix)

36import Data.Binary

35import Data.Binary

37import Data.Typeable (Typeable)

36import Data.Typeable (Typeable)

38import GHC.Generics

37import GHC.Generics

@@ -59,8 +58,14 @@ data MxEvent =

59 -- ^ 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)

60 | MxSent ProcessId ProcessId Message

59 | MxSent ProcessId ProcessId Message

61 -- ^ 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

62 | MxReceived ProcessId Message

65 | MxReceived ProcessId Message

63 -- ^ 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

64 | MxConnected ConnectionId EndPointAddress

69 | MxConnected ConnectionId EndPointAddress

65 -- ^ fired when a network-transport connection is first established

70 -- ^ fired when a network-transport connection is first established

66 | MxDisconnected ConnectionId EndPointAddress

71 | MxDisconnected ConnectionId EndPointAddress

@@ -99,17 +104,10 @@ type Fork = (Process () -> IO ProcessId)

99newtype MxAgentId = MxAgentId { agentId :: String }

104newtype MxAgentId = MxAgentId { agentId :: String }

100 deriving (Typeable, Binary, Eq, Ord)

105 deriving (Typeable, Binary, Eq, Ord)

101

106

102−data MxTableId =

103− MxForAgent !MxAgentId

104− | MxForPid !ProcessId

105− deriving (Typeable, Generic)

106−instance Binary MxTableId where

107−

108data MxAgentState s = MxAgentState

107data MxAgentState s = MxAgentState

109 {

108 {

110 mxAgentId :: !MxAgentId

109 mxAgentId :: !MxAgentId

111 , mxBus :: !(TChan Message)

110 , mxBus :: !(TChan Message)

112− , mxSharedTable :: !ProcessId

113 , mxLocalState :: !s

111 , mxLocalState :: !s

114 }

112 }

115

113

@@ -122,19 +120,12 @@ newtype MxAgent s a =

122 } deriving ( Functor

120 } deriving ( Functor

123 , Monad

121 , Monad

124 , MonadIO

122 , MonadIO

123+ , MonadFix

125 , ST.MonadState (MxAgentState s)

124 , ST.MonadState (MxAgentState s)

126 , Typeable

125 , Typeable

127 , Applicative

126 , Applicative

128 )

127 )

129

128

130−data MxAgentStart = MxAgentStart

131− {

132− mxAgentTableChan :: SendPort ProcessId

133− , mxAgentIdStart :: MxAgentId

134− }

135− deriving (Typeable, Generic)

136−instance Binary MxAgentStart where

137−

138data ChannelSelector = InputChan | Mailbox

129data ChannelSelector = InputChan | Mailbox

139

130

140-- | Represents the actions a management agent can take

131-- | Represents the actions a management agent can take

src/Control/Distributed/Process/Node.hs+99−57

@@ -28,22 +28,33 @@ 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 )

43+import Data.Time.Format (formatTime)

44+#if MIN_VERSION_time(1,5,0)

45+import Data.Time.Format (defaultTimeLocale)

46+#else

47+import System.Locale (defaultTimeLocale)

48+#endif

40import Data.Set (Set)

49import Data.Set (Set)

41import qualified Data.Set as Set

50import qualified Data.Set as Set

42 ( empty

51 ( empty

43 , insert

52 , insert

44 , delete

53 , delete

54+ , map

45 , member

55 , member

46 , toList

56 , toList

57+ , union

47 )

58 )

48import Data.Foldable (forM_)

59import Data.Foldable (forM_)

49import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

60import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

@@ -71,6 +82,8 @@ import qualified Control.Exception as Exception

71 , finally

82 , finally

72 )

83 )

73import Control.Concurrent (forkIO, killThread)

84import Control.Concurrent (forkIO, killThread)

85+import Control.Distributed.Process.Internal.BiMultiMap (BiMultiMap)

86+import qualified Control.Distributed.Process.Internal.BiMultiMap as BiMultiMap

74import Control.Distributed.Process.Internal.StrictMVar

87import Control.Distributed.Process.Internal.StrictMVar

75 ( newMVar

88 ( newMVar

76 , withMVar

89 , withMVar

@@ -173,9 +186,8 @@ import Control.Distributed.Process.Internal.Types

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

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

174 ( mxAgentController

187 ( mxAgentController

175 )

188 )

176−import qualified Control.Distributed.Process.Management.Internal.Table as Table

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

177− ( mxTableCoordinator

190+ ( MxEvent(..)

178− , startTableCoordinator

179 )

191 )

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

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

181 ( remoteTable

193 ( remoteTable

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

189 , traceLogFmt

201 , traceLogFmt

190 , enableTrace

202 , enableTrace

191 )

203 )

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

193− ( MxEvent(..)

194− )

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

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

196import Control.Distributed.Process.Internal.Messaging

205import Control.Distributed.Process.Internal.Messaging

197 ( sendBinary

206 ( sendBinary

@@ -204,6 +213,10 @@ import Control.Distributed.Process.Internal.Primitives

204 , match

213 , match

205 , sendChan

214 , sendChan

206 , unwrapMessage

215 , unwrapMessage

216+ , monitor

217+ , unmonitorAsync

218+ , getSelfNode

219+ , SayMessage(..)

207 )

220 )

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

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

209import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

222import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

@@ -311,8 +324,6 @@ startServiceProcesses node = do

311 -- before /that/ process has started - this is a totally harmless race

324 -- before /that/ process has started - this is a totally harmless race

312 -- however, so we deliberably ignore it

325 -- however, so we deliberably ignore it

313 startDefaultTracer node

326 startDefaultTracer node

314− tableCoordinatorPid <- fork $ Table.startTableCoordinator fork

315− runProcess node $ register Table.mxTableCoordinator tableCoordinatorPid

316 logger <- forkProcess node loop

327 logger <- forkProcess node loop

317 runProcess node $ do

328 runProcess node $ do

318 register "logger" logger

329 register "logger" logger

@@ -321,12 +332,11 @@ startServiceProcesses node = do

321 -- process which uses 'send' or other primitives which are traced.

332 -- process which uses 'send' or other primitives which are traced.

322 register "trace.logger" logger

333 register "trace.logger" logger

323 where

334 where

324− fork = forkProcess node

325−

326 loop = do

335 loop = do

327 receiveWait

336 receiveWait

328− [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do

337+ [ match $ \(SayMessage time pid string) -> do

338+ let time' = formatTime defaultTimeLocale "%c" time

329− liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

339+ liftIO . hPutStrLn stderr $ time' ++ " " ++ show pid ++ ": " ++ string

330 loop

340 loop

331 , match $ \((time, string) :: (String, String)) -> do

341 , match $ \((time, string) :: (String, String)) -> do

332 -- this is a 'trace' message from the local node tracer

342 -- this is a 'trace' message from the local node tracer

@@ -482,7 +492,7 @@ type IncomingConnection = (NT.EndPointAddress, IncomingTarget)

482data IncomingTarget =

492data IncomingTarget =

483 Uninit

493 Uninit

484 | ToProc ProcessId (Weak (CQueue Message))

494 | ToProc ProcessId (Weak (CQueue Message))

485− | ToChan TypedChannel

495+ | ToChan SendPortId TypedChannel

486 | ToNode

496 | ToNode

487

497

488data ConnectionState = ConnectionState {

498data ConnectionState = ConnectionState {

@@ -537,13 +547,17 @@ handleIncomingMessages node = go initConnectionState

537 enqueue queue msg -- 'enqueue' is strict

547 enqueue queue msg -- 'enqueue' is strict

538 trace node (MxReceived pid msg)

548 trace node (MxReceived pid msg)

539 go st

549 go st

540− Just (_, ToChan (TypedChannel chan')) -> do

550+ Just (_, ToChan chId (TypedChannel chan')) -> do

541 mChan <- deRefWeak chan'

551 mChan <- deRefWeak chan'

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

543 -- the channel and we simply ignore the incoming message

553 -- the channel and we simply ignore the incoming message

544− forM_ mChan $ \chan -> atomically $

554+ forM_ mChan $ \chan -> do

555+ msg' <- atomically $ do

556+ msg <- return $! decode (BSL.fromChunks payload)

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

546− writeTQueue chan $! decode (BSL.fromChunks payload)

558+ writeTQueue chan msg

559+ return msg

560+ trace node $ MxReceivedPort chId $ unsafeCreateUnencodedMessage msg'

547 go st

561 go st

548 Just (_, ToNode) -> do

562 Just (_, ToNode) -> do

549 let ctrlMsg = decode . BSL.fromChunks $ payload

563 let ctrlMsg = decode . BSL.fromChunks $ payload

@@ -570,7 +584,7 @@ handleIncomingMessages node = go initConnectionState

570 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

584 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

571 case mChannel of

585 case mChannel of

572 Just channel ->

586 Just channel ->

573− go (incomingAt cid ^= Just (src, ToChan channel) $ st)

587+ go (incomingAt cid ^= Just (src, ToChan chId channel) $ st)

574 Nothing ->

588 Nothing ->

575 invalidRequest cid st $

589 invalidRequest cid st $

576 "incoming attempt to connect to unknown channel of"

590 "incoming attempt to connect to unknown channel of"

@@ -656,9 +670,9 @@ runNodeController node =

656

670

657data NCState = NCState

671data NCState = NCState

658 { -- Mapping from remote processes to linked local processes

672 { -- Mapping from remote processes to linked local processes

659− _links :: !(Map Identifier (Set ProcessId))

673+ _links :: !(BiMultiMap Identifier ProcessId ())

660 -- Mapping from remote processes to monitoring local processes

674 -- Mapping from remote processes to monitoring local processes

661− , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))

675+ , _monitors :: !(BiMultiMap Identifier ProcessId MonitorRef)

662 -- Process registry: names and where they live, mapped to the PIDs

676 -- Process registry: names and where they live, mapped to the PIDs

663 , _registeredHere :: !(Map String ProcessId)

677 , _registeredHere :: !(Map String ProcessId)

664 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

678 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

@@ -674,8 +688,8 @@ newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

674 )

688 )

675

689

676initNCState :: NCState

690initNCState :: NCState

677−initNCState = NCState { _links = Map.empty

691+initNCState = NCState { _links = BiMultiMap.empty

678− , _monitors = Map.empty

692+ , _monitors = BiMultiMap.empty

679 , _registeredHere = Map.empty

693 , _registeredHere = Map.empty

680 , _registeredOnNodes = Map.empty

694 , _registeredOnNodes = Map.empty

681 }

695 }

@@ -818,8 +832,8 @@ ncEffectMonitor from them mRef = do

818 case (shouldLink, isLocal node (ProcessIdentifier from)) of

832 case (shouldLink, isLocal node (ProcessIdentifier from)) of

819 (True, _) -> -- [Unified: first rule]

833 (True, _) -> -- [Unified: first rule]

820 case mRef of

834 case mRef of

821− Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)

835+ Just ref -> modify' $ monitors ^: BiMultiMap.insert them from ref

822− Nothing -> modify' $ linksFor them ^: Set.insert from

836+ Nothing -> modify' $ links ^: BiMultiMap.insert them from ()

823 (False, True) -> -- [Unified: second rule]

837 (False, True) -> -- [Unified: second rule]

824 notifyDied from them DiedUnknownId mRef

838 notifyDied from them DiedUnknownId mRef

825 (False, False) -> -- [Unified: third rule]

839 (False, False) -> -- [Unified: third rule]

@@ -843,7 +857,7 @@ ncEffectUnlink from them = do

843 postAsMessage from $ DidUnlinkNode nid

857 postAsMessage from $ DidUnlinkNode nid

844 SendPortIdentifier cid ->

858 SendPortIdentifier cid ->

845 postAsMessage from $ DidUnlinkPort cid

859 postAsMessage from $ DidUnlinkPort cid

846− modify' $ linksFor them ^: Set.delete from

860+ modify' $ links ^: BiMultiMap.delete them from ()

847

861

848-- [Unified: Table 11]

862-- [Unified: Table 11]

849ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

863ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

@@ -851,7 +865,7 @@ ncEffectUnmonitor from ref = do

851 node <- ask

865 node <- ask

852 when (isLocal node (ProcessIdentifier from)) $

866 when (isLocal node (ProcessIdentifier from)) $

853 postAsMessage from $ DidUnmonitor ref

867 postAsMessage from $ DidUnmonitor ref

854− modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)

868+ modify' $ monitors ^: BiMultiMap.delete (monitorRefIdent ref) from ref

855

869

856-- [Unified: Table 12]

870-- [Unified: Table 12]

857ncEffectDied :: Identifier -> DiedReason -> NC ()

871ncEffectDied :: Identifier -> DiedReason -> NC ()

@@ -866,7 +880,7 @@ ncEffectDied ident reason = do

866 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

880 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

867

881

868 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

882 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

869− forM_ uss $ \us ->

883+ forM_ uss $ \(us, _) ->

870 when (localOnly <= isLocal node (ProcessIdentifier us)) $

884 when (localOnly <= isLocal node (ProcessIdentifier us)) $

871 notifyDied us them reason Nothing

885 notifyDied us them reason Nothing

872

886

@@ -875,9 +889,35 @@ ncEffectDied ident reason = do

875 when (localOnly <= isLocal node (ProcessIdentifier us)) $

889 when (localOnly <= isLocal node (ProcessIdentifier us)) $

876 notifyDied us them reason (Just ref)

890 notifyDied us them reason (Just ref)

877

891

892+ -- Notify remote nodes that the process died so it can be removed from monitor

893+ -- lists.

894+ mapM_ (forwardDeath node) $

895+ [ nid | ProcessIdentifier pid <- [ident]

896+ , i <- Set.toList $ Set.union

897+ (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedLinks)

898+ (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedMons)

899+ , let nid = nodeOf i

900+ , nid /= localNodeId node

901+ ]

902+

903+ -- Delete monitors in the local node.

904+ let deleteDeads :: (Ord a, Ord v)

905+ => BiMultiMap a ProcessId v -> BiMultiMap a ProcessId v

906+ deleteDeads = case ident of

907+ -- deleteAllBy2nd is faster than partitionWithKeyBy2nd

908+ ProcessIdentifier pid -> BiMultiMap.deleteAllBy2nd pid

909+ _ -> snd . BiMultiMap.partitionWithKeyBy2nd

910+ (\pid _ -> ident `impliesDeathOf` ProcessIdentifier pid)

911+ unaffectedLinks' = deleteDeads unaffectedLinks

912+ unaffectedMons' = deleteDeads unaffectedMons

913+

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

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

879−

915+

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

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

881

921

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

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

883 mapM (\(pid,nidlist) ->

923 mapM (\(pid,nidlist) ->

@@ -885,12 +925,12 @@ ncEffectDied ident reason = do

885 True ->

925 True ->

886 do forM_ nidlist $ \(nid,_) ->

926 do forM_ nidlist $ \(nid,_) ->

887 when (not $ isLocal node (NodeIdentifier nid))

927 when (not $ isLocal node (NodeIdentifier nid))

888− (forwardNameDeath node nid)

928+ (forwardDeath node nid)

889 return Nothing

929 return Nothing

890 False -> return $ Just (pid,nidlist) )

930 False -> return $ Just (pid,nidlist) )

891 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

931 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

892 where

932 where

893− forwardNameDeath node nid = ncSendToNode nid

933+ forwardDeath node nid = ncSendToNode nid

894 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

934 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

895 , ctrlMsgSignal = Died ident reason

935 , ctrlMsgSignal = Died ident reason

896 }

936 }

@@ -929,7 +969,11 @@ ncEffectRegister from label atnode mPid reregistration = do

929 do modify' $ registeredHereFor label ^= mPid

969 do modify' $ registeredHereFor label ^= mPid

930 updateRemote node currentVal mPid

970 updateRemote node currentVal mPid

931 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 ()

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

976+ liftIO $ trace node (MxRegistered p label)

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

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

934 newVal <- gets (^. registeredHereFor label)

978 newVal <- gets (^. registeredHereFor label)

935 ncSendToProcess from $ unsafeCreateUnencodedMessage $

979 ncSendToProcess from $ unsafeCreateUnencodedMessage $

@@ -1010,11 +1054,12 @@ ncEffectLocalPortSend from msg = do

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

1011 -- the channel and we simply ignore the incoming message - this

1055 -- the channel and we simply ignore the incoming message - this

1012 ch <- deRefWeak chan'

1056 ch <- deRefWeak chan'

1013− forM_ ch $ \chan -> deliverChan msg chan

1057+ forM_ ch $ \chan -> deliverChan node from msg chan

1014− where deliverChan :: forall a . Message -> TQueue a -> IO ()

1058+ where deliverChan :: forall a . LocalNode -> SendPortId -> Message -> TQueue a -> IO ()

1015− deliverChan (UnencodedMessage _ raw) chan' =

1059+ deliverChan n p (UnencodedMessage _ raw) chan' = do

1016 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1060 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1061+ trace n (MxReceivedPort p $ unsafeCreateUnencodedMessage raw)

1017− deliverChan (EncodedMessage _ _) _ =

1062+ deliverChan _ _ (EncodedMessage _ _) _ =

1018 -- this will not happen unless someone screws with Primitives.hs

1063 -- this will not happen unless someone screws with Primitives.hs

1019 error "invalid local channel delivery"

1064 error "invalid local channel delivery"

1020

1065

@@ -1044,9 +1089,10 @@ ncEffectGetInfo from pid =

1044 case mProc of

1089 case mProc of

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

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

1046 from (ProcessInfoNone DiedUnknownId)

1091 from (ProcessInfoNone DiedUnknownId)

1047− Just proc -> do

1092+ Just proc -> do

1048− itsLinks <- gets (^. linksFor them)

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

1049− itsMons <- gets (^. monitorsFor them)

1094+ gets (^. links)

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

1050 registered <- gets (^. registeredHere)

1096 registered <- gets (^. registeredHere)

1051 size <- liftIO $ queueSize $ processQueue $ proc

1097 size <- liftIO $ queueSize $ processQueue $ proc

1052

1098

@@ -1057,8 +1103,8 @@ ncEffectGetInfo from pid =

1057 infoNode = (processNodeId pid)

1103 infoNode = (processNodeId pid)

1058 , infoRegisteredNames = reg

1104 , infoRegisteredNames = reg

1059 , infoMessageQueueLength = size

1105 , infoMessageQueueLength = size

1060− , infoMonitors = Set.toList itsMons

1106+ , infoMonitors = Set.toList itsMons

1061− , infoLinks = Set.toList itsLinks

1107+ , infoLinks = Set.toList itsLinks

1062 }

1108 }

1063 where dispatch :: (Serializable a)

1109 where dispatch :: (Serializable a)

1064 => Bool

1110 => Bool

@@ -1082,8 +1128,8 @@ ncEffectGetNodeStats from _nid = do

1082 NodeStats {

1128 NodeStats {

1083 nodeStatsNode = localNodeId node

1129 nodeStatsNode = localNodeId node

1084 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1130 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1085− , nodeStatsMonitors = Map.size $ ncState ^. monitors

1131+ , nodeStatsMonitors = BiMultiMap.size $ ncState ^. monitors

1086− , nodeStatsLinks = Map.size $ ncState ^. links

1132+ , nodeStatsLinks = BiMultiMap.size $ ncState ^. links

1087 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1133 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1088 }

1134 }

1089 postAsMessage from stats

1135 postAsMessage from stats

@@ -1204,10 +1250,10 @@ withLocalProc node pid p =

1204-- Accessors --

1250-- Accessors --

1205--------------------------------------------------------------------------------

1251--------------------------------------------------------------------------------

1206

1252

1207−links :: Accessor NCState (Map Identifier (Set ProcessId))

1253+links :: Accessor NCState (BiMultiMap Identifier ProcessId ())

1208links = accessor _links (\ls st -> st { _links = ls })

1254links = accessor _links (\ls st -> st { _links = ls })

1209

1255

1210−monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

1256+monitors :: Accessor NCState (BiMultiMap Identifier ProcessId MonitorRef)

1211monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1257monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1212

1258

1213registeredHere :: Accessor NCState (Map String ProcessId)

1259registeredHere :: Accessor NCState (Map String ProcessId)

@@ -1216,12 +1262,6 @@ registeredHere = accessor _registeredHere (\ry st -> st { _registeredHere = ry }

1216registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1262registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1217registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1263registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1218

1264

1219−linksFor :: Identifier -> Accessor NCState (Set ProcessId)

1220−linksFor ident = links >>> DAC.mapDefault Set.empty ident

1221−

1222−monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

1223−monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

1224−

1225registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1265registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1226registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1266registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1227

1267

@@ -1248,10 +1288,12 @@ registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident

1248-- * the notifications for typed channels to that process.

1288-- * the notifications for typed channels to that process.

1249--

1289--

1250-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1290-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1291+splitNotif :: (Ord a, Ord v)

1251−splitNotif :: Identifier

1292+ => Identifier

1252− -> Map Identifier a

1293+ -> BiMultiMap Identifier a v

1253− -> (Map Identifier a, Map Identifier a)

1294+ -> (Map Identifier (Set (a,v)), BiMultiMap Identifier a v)

1254−splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)

1295+splitNotif ident =

1296+ BiMultiMap.partitionWithKeyBy1st (\k !_v -> ident `impliesDeathOf` k)

1255

1297

1256--------------------------------------------------------------------------------

1298--------------------------------------------------------------------------------

1257-- Auxiliary --

1299-- Auxiliary --

src/Control/Distributed/Process/Serializable.hs+6−18

@@ -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,25 +17,17 @@ 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)

30import GHC.Fingerprint.Type (Fingerprint(..))

24import GHC.Fingerprint.Type (Fingerprint(..))

31import Data.ByteString (ByteString)

25import Data.ByteString (ByteString)

32import qualified Data.ByteString as BS

26import qualified Data.ByteString as BS

33−import qualified Data.ByteString.Internal as BSI ( unsafeCreate

27+import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr )

34− , inlinePerformIO

35− , toForeignPtr

36− )

37import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

28import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

38import Foreign.ForeignPtr (withForeignPtr)

29import Foreign.ForeignPtr (withForeignPtr)

30+import System.IO.Unsafe (unsafePerformIO)

40-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

32-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

41data SerializableDict a where

33data SerializableDict a where

@@ -63,7 +55,7 @@ decodeFingerprint :: ByteString -> Fingerprint

63decodeFingerprint bs

55decodeFingerprint bs

64 | BS.length bs /= sizeOfFingerprint =

56 | BS.length bs /= sizeOfFingerprint =

65 throw $ userError "decodeFingerprint: Invalid length"

57 throw $ userError "decodeFingerprint: Invalid length"

66− | otherwise = BSI.inlinePerformIO $ do

58+ | otherwise = unsafePerformIO $ do

67 let (fp, offset, _) = BSI.toForeignPtr bs

59 let (fp, offset, _) = BSI.toForeignPtr bs

68 withForeignPtr fp $ \p -> peekByteOff p offset

60 withForeignPtr fp $ \p -> peekByteOff p offset

@@ -73,11 +65,7 @@ sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

74-- | The fingerprint of the typeRep of the argument

66-- | The fingerprint of the typeRep of the argument

75fingerprint :: Typeable a => a -> Fingerprint

67fingerprint :: Typeable a => a -> Fingerprint

76−#if MIN_VERSION_base(4,8,0)

68+fingerprint = typeRepFingerprint . typeOf

77−fingerprint a = let TypeRep fp _ _ _ = typeOf a in fp

78−#else

79−fingerprint a = let TypeRep fp _ _ = typeOf a in fp

80−#endif

82-- | Show fingerprint (for debugging purposes)

70-- | Show fingerprint (for debugging purposes)

83showFingerprint :: 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: