master..16d87d7 · distributed-process

git.iko.soy/distributed-process

on 16d87d7 help sign in

.travis.yml+25−31

since splitsnapshots

unifiedsplit

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

5matrix:

6 include:

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

7+ - env: CABALVER=1.22 GHCVER=7.6.3

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

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

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

9+ - env: CABALVER=1.22 GHCVER=7.8.4

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

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

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

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

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

11+ - env: CABALVER=1.22 GHCVER=7.10.3

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

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

15−

16−cache:

17− directories:

18− - $HOME/.stack

20before_install:

14before_install:

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

15+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:~/.cabal/bin:$PATH

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

16+ - ghc --version

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

17+ - cabal --version

24− stack --version

18+ - cabal update

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

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

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

26install:

23install:

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

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

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

30script:

26script:

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

27+ - cabal install --jobs=2

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

28+ - cd distributed-process-tests/

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

29+ - cabal configure -ftcp --enable-tests

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

30+ - cabal build --jobs=2

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

31+ # skip intermittent tests Reconnect and SpawnReconnect

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

32+ - dist/build/TestCHInMemory/TestCHInMemory --plain -t '!Flaky'

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

33+ - dist/build/TestCHInTCP/TestCHInTCP --plain -t '!Flaky'

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

34+ - dist/build/TestClosure/TestClosure --plain -t '!SpawnReconnect'

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

35+ - dist/build/TestStats/TestStats --plain

40−

36+ - dist/build/TestMx/TestMx --plain

41−notifications:

37+ - dist/build/TestTracing/TestTracing --plain

42− slack:

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

ChangeLog−66

@@ -1,69 +1,3 @@

1−[Unrealeased]

2−

3−*

4−

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

6−

7−* Added support for exceptions >= 0.10

8−

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

10−

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

12−

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

14−

15−* Fixed build errors with ghc-8.2.1.

16−

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

18−

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

20−

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

22−

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

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

25−* Expose the MonitorRef in the withMonitor call.

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

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

28−other packages. (#276)

29−* Add Ord instance to SpawnRef.

30−

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

32−

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

34−

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

36−

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

38−* Improve documentation of CQueue.

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

40−* Fix various warnings. (#292)

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

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

43−(#290)

44−

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

46−

47−* Fixup build errors.

48−

49−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3

50−

51−* Relax template-haskell upper bound.

52−

53−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2

54−

55−* Provide compatibility with ghc-8.0.1

56−* Remove dependency on ghc-prim.

57−* Don't throw exceptions asynchronously.

58−* Bump upper bounds of dependencies.

59−* Fix exception handling in callLocal.

60−* Have spawnLocal inherit the masking state of the caller.

61−* Have nsend send unencoded messages to local processes.

62−

63−2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1

64−

65−* Implement MonadCatch, MonadThrow, MonadMask for Process.

66−

672016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0

12016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0

69* Have nsendRemote skip the transport for local communication.

3* Have nsendRemote skip the transport for local communication.

benchmarks/Channels.hs+4−6

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

4import Control.Applicative

5import Control.Distributed.Process

6import Control.Distributed.Process.Node

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

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

8import Data.Binary (encode, decode)

9import qualified Data.ByteString.Lazy as BSL

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

36main :: IO ()

37main = do

38 [role, host, port] <- getArgs

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

39+ Right transport <- createTransport host port defaultTCPParameters

40− case trans of

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

40+ node <- newLocalNode transport initRemoteTable

42− runProcess node $ initialProcess role

41+ runProcess node $ initialProcess role

43− Left other -> error $ show other

benchmarks/Latency.hs+4−7

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

3import Control.Applicative

4import Control.Distributed.Process

5import Control.Distributed.Process.Node

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

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

7import Data.Binary (encode, decode)

8import qualified Data.ByteString.Lazy as BSL

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

31main :: IO ()

32main = do

33 [role, host, port] <- getArgs

34− trans <- createTransport

35− (defaultTCPAddr host port) defaultTCPParameters

34+ Right transport <- createTransport host port defaultTCPParameters

36− case trans of

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

35+ node <- newLocalNode transport initRemoteTable

38− runProcess node $ initialProcess role

36+ runProcess node $ initialProcess role

39− Left other -> error $ show other

benchmarks/ProcessRing.hs+2−3

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

12import Control.Distributed.Process hiding (catch)

13import Control.Distributed.Process.Node

14import Control.Exception (catch, SomeException)

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

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

16import System.Environment

17import System.Console.GetOpt

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

110 argv <- getArgs

111 (opt, _) <- parseArgv argv

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

113− Right transport <- createTransport

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

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

115 node <- newLocalNode transport initRemoteTable

114 node <- newLocalNode transport initRemoteTable

116 catch (void $ runProcess node $ initialProcess opt)

115 catch (void $ runProcess node $ initialProcess opt)

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

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

benchmarks/Spawns.hs+4−6

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

7import Control.Applicative

8import Control.Distributed.Process

9import Control.Distributed.Process.Node

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

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

11import Data.Binary (encode, decode)

12import qualified Data.ByteString.Lazy as BSL

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

42main :: IO ()

43main = do

44 [role, host, port] <- getArgs

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

45+ Right transport <- createTransport host port defaultTCPParameters

46− case trans of

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

46+ node <- newLocalNode transport initRemoteTable

48− runProcess node $ initialProcess role

47+ runProcess node $ initialProcess role

49− Left other -> error $ show other

benchmarks/Throughput.hs+4−6

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

6import Control.Applicative

7import Control.Distributed.Process

8import Control.Distributed.Process.Node

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

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

10import Data.Binary

11import qualified Data.ByteString.Lazy as BSL

12import Data.Typeable

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

67main :: IO ()

68main = do

69 [role, host, port] <- getArgs

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

70+ Right transport <- createTransport host port defaultTCPParameters

71− case trans of

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

71+ node <- newLocalNode transport initRemoteTable

73− runProcess node $ initialProcess role

72+ runProcess node $ initialProcess role

74− Left other -> error $ show other

distributed-process-tests/distributed-process-tests.cabal+28−41

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

1name: distributed-process-tests

2−version: 0.4.11

2+version: 0.4.5

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

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

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

6license: BSD3

7license-file: LICENSE

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

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

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

10copyright: Well-Typed LLP

11category: Control, Cloud Haskell

12build-type: Simple

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

26 Control.Distributed.Process.Tests.Tracing

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

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

29− ansi-terminal >= 0.5,

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

30− binary >= 0.5 && < 0.9,

30+ binary >= 0.5 && < 0.8,

31− bytestring >= 0.9 && < 0.12,

31+ bytestring >= 0.9 && < 0.11,

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

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

33 distributed-static,

34− exceptions >= 0.5,

35− HUnit >= 1.2 && < 1.7,

34+ HUnit >= 1.2 && < 1.4,

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

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

37− network >= 2.5 && < 2.9,

36+ network >= 2.5 && < 2.7,

38 random >= 1.0 && < 1.2,

37 random >= 1.0 && < 1.2,

39 rematch >= 0.1.2.1,

38 rematch >= 0.1.2.1,

40 setenv >= 0.1.1.3,

39 setenv >= 0.1.1.3,

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

49 DeriveDataTypeable,

48 DeriveDataTypeable,

50 DeriveGeneric,

49 DeriveGeneric,

51 GeneralizedNewtypeDeriving,

50 GeneralizedNewtypeDeriving,

51+ OverlappingInstances,

52 RankNTypes,

53 RecordWildCards,

54 ScopedTypeVariables

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

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

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

63 distributed-process-tests,

64− network >= 2.3 && < 2.9,

64+ network >= 2.3 && < 2.7,

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

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

66 network-transport-inmemory >= 0.5,

67 test-framework >= 0.6 && < 0.9

68 Extensions: CPP

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

76 if flag(tcp)

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

78 distributed-process-tests,

79− network >= 2.3 && < 2.9,

79+ network >= 2.3 && < 2.7,

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

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

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

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

82 test-framework >= 0.6 && < 0.9

83 else

84 Buildable: False

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

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

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

95 distributed-process-tests,

96− network >= 2.3 && < 2.9,

96+ network >= 2.3 && < 2.7,

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

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

98 network-transport-inmemory >= 0.5,

99 test-framework >= 0.6 && < 0.9

100 Extensions: CPP

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

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

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

109 distributed-process-tests,

110− network >= 2.3 && < 2.9,

110+ network >= 2.3 && < 2.7,

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

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

112 network-transport-inmemory >= 0.5,

113 test-framework >= 0.6 && < 0.9

114 Extensions: CPP

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

116 HS-Source-Dirs: tests

117

118+

118−Test-Suite TestMxInMemory

119+Test-Suite TestMx

119 Type: exitcode-stdio-1.0

120 Type: exitcode-stdio-1.0

120 Main-Is: runInMemory.hs

121 Main-Is: runInMemory.hs

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

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

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

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

123 distributed-process-tests,

124 distributed-process-tests,

124− network >= 2.3 && < 2.9,

125+ network >= 2.3 && < 2.7,

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

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

126 network-transport-inmemory >= 0.5,

127 network-transport-inmemory >= 0.5,

127 test-framework >= 0.6 && < 0.9

128 test-framework >= 0.6 && < 0.9

128 Extensions: CPP

129 Extensions: CPP

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

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

130 HS-Source-Dirs: tests

131 HS-Source-Dirs: tests

131

132

132−Test-Suite TestTracingInMemory

133+Test-Suite TestTracing

133 Type: exitcode-stdio-1.0

134 Type: exitcode-stdio-1.0

134 Main-Is: runInMemory.hs

135 Main-Is: runInMemory.hs

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

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

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

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

137 distributed-process-tests,

138 distributed-process-tests,

138− network >= 2.3 && < 2.9,

139+ network >= 2.3 && < 2.7,

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

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

140− network-transport-inmemory >= 0.5,

141− test-framework >= 0.6 && < 0.9

142− Extensions: CPP

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

144− HS-Source-Dirs: tests

145−

146−Test-Suite TestMxInTCP

147− Type: exitcode-stdio-1.0

148− Main-Is: runInMemory.hs

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

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

151− distributed-process-tests,

152− network >= 2.3 && < 2.9,

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

154 network-transport-inmemory >= 0.5,

141 network-transport-inmemory >= 0.5,

155 test-framework >= 0.6 && < 0.9

142 test-framework >= 0.6 && < 0.9

156 Extensions: CPP

143 Extensions: CPP

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

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

158 HS-Source-Dirs: tests

145 HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+250−488

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

25 )

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

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

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

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

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

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

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

31−import Control.Distributed.Process hiding

31+import Control.Distributed.Process

32− ( try

33− , catch

34− , finally

35− , mask

36− , onException

37− )

38import Control.Distributed.Process.Internal.Types

32import Control.Distributed.Process.Internal.Types

33+ ( NodeId(nodeAddress)

39− ( LocalNode(localEndPoint)

34+ , LocalNode(localEndPoint)

40 , ProcessExitException(..)

35 , ProcessExitException(..)

41 , nullProcessId

36 , nullProcessId

42 , createUnencodedMessage

37 , createUnencodedMessage

43 )

38 )

44import Control.Distributed.Process.Node

39import Control.Distributed.Process.Node

45−import Control.Distributed.Process.Debug

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

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

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

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

49−import Data.Maybe (isNothing, isJust)

41+

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

42+import Test.HUnit (Assertion, assertFailure)

51import Test.Framework (Test, testGroup)

43import Test.Framework (Test, testGroup)

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

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

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

45+import Control.Rematch hiding (match)

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

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

56newtype Ping = Ping ProcessId

48newtype Ping = Ping ProcessId

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

73forkTry :: IO () -> IO ThreadId

65forkTry :: IO () -> IO ThreadId

74forkTry p = do

66forkTry p = do

75 tid <- myThreadId

67 tid <- myThreadId

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

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

78-- | The ping server from the paper

70-- | The ping server from the paper

79ping :: Process ()

71ping :: Process ()

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

83 send partner (Ping self)

75 send partner (Ping self)

84 ping

76 ping

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

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

88−

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

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

91− where

92− checkPing (Ping _) = True

93−

94-- | Quick and dirty synchronous version of whereisRemoteAsync

78-- | Quick and dirty synchronous version of whereisRemoteAsync

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

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

96whereisRemote nid string = do

80whereisRemote nid string = do

97 whereisRemoteAsync nid string

81 whereisRemoteAsync nid string

98− receiveWait [

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

82+ WhereIsReply _ mPid <- expect

100− ]

101−

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

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

104−

105−waitForExit :: ProcessId -> Process DiedReason

106−waitForExit pid = monitor pid >>= waitForDown

107−

108−waitForDown :: MonitorRef -> Process DiedReason

109−waitForDown ref =

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

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

112−

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

114−syncBreakConnection breakConnection nid0 nid1 = do

115− m <- newEmptyMVar

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

117− runProcess nid0 $ do

118− them <- liftIO $ takeMVar m

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

120− _ <- monitorNode (localNodeId nid1)

121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

122− (nodeAddress $ localNodeId nid1)

123− NodeMonitorNotification _ _ _ <- expect

124− kill pinger "finished"

125− return ()

83+ return mPid

126

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

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

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

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

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

197 unmonitor ref

155 unmonitor ref

198 liftIO $ putMVar done ()

156 liftIO $ putMVar done ()

199 (False, ref) -> do

157 (False, ref) -> do

200− receiveWait [

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

158+ ProcessMonitorNotification ref' pid reason' <- expect

202− liftIO $ do

203− assertBool "Bad Monitor Signal"

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

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

205− mOrL && reason == reason')

206− putMVar done ())

160+ liftIO $ putMVar done ()

207− ]

208 )

161 )

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

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

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

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

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

212 liftIO $ putMVar done ()

164 liftIO $ putMVar done ()

213 )

165 )

214

166

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

239 pid <- getSelfPid

191 pid <- getSelfPid

240 replicateM_ numPings $ do

192 replicateM_ numPings $ do

241 send pingServer (Pong pid)

193 send pingServer (Pong pid)

242− p <- expectTimeout 3000000

194+ Ping _ <- expect

243− case p of

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

195+ return ()

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

246

196

247 putMVar clientDone ()

197 putMVar clientDone ()

248

198

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

329 runProcess localNode $ do

279 runProcess localNode $ do

330 monitor theirAddr

280 monitor theirAddr

331 -- wait for the process to die

281 -- wait for the process to die

332− expect :: Process ProcessMonitorNotification

282+ ProcessMonitorNotification _ _ _ <- expect

333 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

283 monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334

284

335 takeMVar done

285 takeMVar done

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

403 runProcess localNode $ do

353 runProcess localNode $ do

404 pid <- getSelfPid

354 pid <- getSelfPid

405 send mathServer (Add pid 1 2)

355 send mathServer (Add pid 1 2)

406− three <- expect :: Process Double

356+ 3 <- expect :: Process Double

407 send mathServer (Divide pid 8 2)

357 send mathServer (Divide pid 8 2)

408− four <- expect :: Process Double

358+ 4 <- expect :: Process Double

409 send mathServer (Divide pid 8 0)

359 send mathServer (Divide pid 8 0)

410− divByZ <- expect

360+ DivByZero <- expect

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

361+ liftIO $ putMVar clientDone ()

412

362

413− res <- takeMVar clientDone

363+ takeMVar clientDone

414− case res of

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

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

417

364

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

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

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

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

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

441 pid <- getSelfPid

388 pid <- getSelfPid

442 send server1 "Hi"

389 send server1 "Hi"

443 send server2 (Pong pid)

390 send server2 (Pong pid)

391+ Ping pid' <- expect

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

444− expectPing clientDone

393+ liftIO $ putMVar clientDone ()

445

394

446− verifyClient "Expected Ping from server" clientDone

395+ takeMVar clientDone

447

396

448-- | Test (non-zero) timeout

397-- | Test (non-zero) timeout

449testTimeout :: TestTransport -> Assertion

398testTimeout :: TestTransport -> Assertion

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

452 done <- newEmptyMVar

401 done <- newEmptyMVar

453

402

454 runProcess localNode $ do

403 runProcess localNode $ do

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

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

456− liftIO $ putMVar done $ res == Nothing

405+ liftIO $ putMVar done ()

457

406

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

407+ takeMVar done

459

408

460-- | Test zero timeout

409-- | Test zero timeout

461testTimeout0 :: TestTransport -> Assertion

410testTimeout0 :: TestTransport -> Assertion

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

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

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

484 replicateM_ 10000 $ send server "Irrelevant message"

433 replicateM_ 10000 $ send server "Irrelevant message"

485 send server (Pong pid)

434 send server (Pong pid)

435+ Ping _ <- expect

486− expectPing clientDone

436+ liftIO $ putMVar clientDone ()

487

437

488− verifyClient "Expected Ping from server" clientDone

438+ takeMVar clientDone

489

439

490-- | Test typed channels

440-- | Test typed channels

491testTypedChannels :: TestTransport -> Assertion

441testTypedChannels :: TestTransport -> Assertion

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

508 runProcess localNode $ do

458 runProcess localNode $ do

509 (clientSendPort, rport) <- newChan

459 (clientSendPort, rport) <- newChan

510 sendChan serverSendPort (clientSendPort, 5)

460 sendChan serverSendPort (clientSendPort, 5)

511− ch <- receiveChan rport

461+ False <- receiveChan rport

512− liftIO $ putMVar clientDone $ ch == False

462+ liftIO $ putMVar clientDone ()

513

463

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

464+ takeMVar clientDone

515

465

516-- | Test merging receive ports

466-- | Test merging receive ports

517testMergeChannels :: TestTransport -> Assertion

467testMergeChannels :: TestTransport -> Assertion

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

534 rs <- mapM charChannel "abc"

484 rs <- mapM charChannel "abc"

535 m <- mergePorts biased rs

485 m <- mergePorts biased rs

536 xs <- replicateM 9 $ receiveChan m

486 xs <- replicateM 9 $ receiveChan m

537− liftIO $ putMVar done $ xs == expected

487+ True <- return $ xs == expected

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

488+ liftIO $ putMVar done ()

489+ takeMVar done

539

490

540 -- Two layers of merging

491 -- Two layers of merging

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

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

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

546 ms <- mapM (mergePorts biasedInner) rss

497 ms <- mapM (mergePorts biasedInner) rss

547 m <- mergePorts biasedOuter ms

498 m <- mergePorts biasedOuter ms

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

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

549− liftIO $ putMVar done $ xs == expected

500+ True <- return $ xs == expected

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

501+ liftIO $ putMVar done ()

502+ takeMVar done

551

503

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

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

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

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

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

556 done <- newEmptyMVar

508 done <- newEmptyMVar

557

509

558 forkProcess localNode $ do

510 forkProcess localNode $ do

559− ss <- liftIO $ mapM readMVar vs

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

560− case ss of

561− [sa, sb, sc] ->

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

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

563− [ -- a, b, c

513+ [ -- a, b, c

564− (sa, 'a')

514+ (sa, 'a')

565− , (sb, 'b')

515+ , (sb, 'b')

566− , (sc, 'c')

516+ , (sc, 'c')

567− -- a, c, b

517+ -- a, c, b

568− , (sa, 'a')

518+ , (sa, 'a')

569− , (sc, 'c')

519+ , (sc, 'c')

570− , (sb, 'b')

520+ , (sb, 'b')

571− -- b, a, c

521+ -- b, a, c

572− , (sb, 'b')

522+ , (sb, 'b')

573− , (sa, 'a')

523+ , (sa, 'a')

574− , (sc, 'c')

524+ , (sc, 'c')

575− -- b, c, a

525+ -- b, c, a

576− , (sb, 'b')

526+ , (sb, 'b')

577− , (sc, 'c')

527+ , (sc, 'c')

578− , (sa, 'a')

528+ , (sa, 'a')

579− -- c, a, b

529+ -- c, a, b

580− , (sc, 'c')

530+ , (sc, 'c')

581− , (sa, 'a')

531+ , (sa, 'a')

582− , (sb, 'b')

532+ , (sb, 'b')

583− -- c, b, a

533+ -- c, b, a

584− , (sc, 'c')

534+ , (sc, 'c')

585− , (sb, 'b')

535+ , (sb, 'b')

586− , (sa, 'a')

536+ , (sa, 'a')

587− ]

537+ ]

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

589

538

590 forkProcess localNode $ do

539 forkProcess localNode $ do

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

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

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

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

593 m <- mergePorts biased rs

542 m <- mergePorts biased rs

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

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

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

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

545+ liftIO $ putMVar done ()

596

546

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

547+ takeMVar done

598

548

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

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

600 mergePorts True = mergePortsBiased

550 mergePorts True = mergePortsBiased

@@ -610,11 +560,19 @@ testMergeChannels TestTransport{..} = do

610testTerminate :: TestTransport -> Assertion

560testTerminate :: TestTransport -> Assertion

611testTerminate TestTransport{..} = do

561testTerminate TestTransport{..} = do

612 localNode <- newLocalNode testTransport initRemoteTable

562 localNode <- newLocalNode testTransport initRemoteTable

563+ done <- newEmptyMVar

564+

565+ pid <- forkProcess localNode $ do

566+ liftIO $ threadDelay 100000

567+ terminate

568+

613 runProcess localNode $ do

569 runProcess localNode $ do

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

570+ ref <- monitor pid

615− if either show show e == show ProcessTerminationException

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

616− then return ()

572+ True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException

617− else die "Unexpected result from terminate"

573+ liftIO $ putMVar done ()

574+

575+ takeMVar done

618

576

619testMonitorNode :: TestTransport -> Assertion

577testMonitorNode :: TestTransport -> Assertion

620testMonitorNode TestTransport{..} = do

578testMonitorNode TestTransport{..} = do

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

625

583

626 runProcess node2 $ do

584 runProcess node2 $ do

627 ref <- monitorNode (localNodeId node1)

585 ref <- monitorNode (localNodeId node1)

628− receiveWait [

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

586+ NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

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

631− ] >>= liftIO . putMVar done

588+ liftIO $ putMVar done ()

632

589

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

590+ takeMVar done

634

591

635testMonitorLiveNode :: TestTransport -> Assertion

592testMonitorLiveNode :: TestTransport -> Assertion

636testMonitorLiveNode TestTransport{..} = do

593testMonitorLiveNode TestTransport{..} = do

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

645 liftIO $ putMVar ready ()

602 liftIO $ putMVar ready ()

646 liftIO $ takeMVar readyr

603 liftIO $ takeMVar readyr

647 send p ()

604 send p ()

648− receiveWait [

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

605+ NodeMonitorNotification ref' nid _ <- expect

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

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

651− ] >>= liftIO . putMVar done

607+ liftIO $ putMVar done ()

652

608

653 takeMVar ready

609 takeMVar ready

654 closeLocalNode node1

610 closeLocalNode node1

655 putMVar readyr ()

611 putMVar readyr ()

656

612

657− verifyClient "Expected NodeMonitorNotification for LIVE node" done

613+ takeMVar done

658

614

659testMonitorChannel :: TestTransport -> Assertion

615testMonitorChannel :: TestTransport -> Assertion

660testMonitorChannel TestTransport{..} = do

616testMonitorChannel TestTransport{..} = do

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

664 pid <- forkProcess node1 $ do

620 pid <- forkProcess node1 $ do

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

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

666 ref <- monitorPort sport

622 ref <- monitorPort sport

667− receiveWait [

623+ PortMonitorNotification ref' port' reason <- expect

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

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

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

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

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

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

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

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

673− ] >>= liftIO . putMVar gotNotification

627+ liftIO $ putMVar gotNotification ()

674

628

675 runProcess node2 $ do

629 runProcess node2 $ do

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

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

677 send pid sport

631 send pid sport

678 liftIO $ threadDelay 100000

632 liftIO $ threadDelay 100000

679

633

680− verifyClient "Expected PortMonitorNotification" gotNotification

634+ takeMVar gotNotification

681

635

682testRegistry :: TestTransport -> Assertion

636testRegistry :: TestTransport -> Assertion

683testRegistry TestTransport{..} = do

637testRegistry TestTransport{..} = do

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

689

643

690 runProcess node $ do

644 runProcess node $ do

691 register "ping" pingServer

645 register "ping" pingServer

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

646+ Just pid <- whereis "ping"

647+ True <- return $ pingServer == pid

693 us <- getSelfPid

648 us <- getSelfPid

694 nsend "ping" (Pong us)

649 nsend "ping" (Pong us)

695− receiveWait [

650+ Ping pid' <- expect

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

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

697− ]

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

698− checkRegException "dead" Nothing deadProcess

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

699− checkRegException "ping" (Just pingServer) deadProcess

654+ True <- return $ x == pingServer

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

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

701 liftIO $ putMVar done ()

656 liftIO $ putMVar done ()

702

657

703 takeMVar done

658 takeMVar done

704

659

705− where

706− checkRegException name pid dead =

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

708−

709− checkReg name pid res =

710− case res of

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

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

713−

714testRegistryRemoteProcess :: TestTransport -> Assertion

660testRegistryRemoteProcess :: TestTransport -> Assertion

715testRegistryRemoteProcess TestTransport{..} = do

661testRegistryRemoteProcess TestTransport{..} = do

716 node1 <- newLocalNode testTransport initRemoteTable

662 node1 <- newLocalNode testTransport initRemoteTable

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

721

667

722 runProcess node2 $ do

668 runProcess node2 $ do

723 register "ping" pingServer

669 register "ping" pingServer

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

670+ Just pid <- whereis "ping"

671+ True <- return $ pingServer == pid

725 us <- getSelfPid

672 us <- getSelfPid

726 nsend "ping" (Pong us)

673 nsend "ping" (Pong us)

727− receiveWait [

674+ Ping pid' <- expect

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

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

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

676+ liftIO $ putMVar done ()

730− ]

731

677

732 takeMVar done

678 takeMVar done

733

679

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

735testRemoteRegistry TestTransport{..} = do

681testRemoteRegistry TestTransport{..} = do

736 node1 <- newLocalNode testTransport initRemoteTable

682 node1 <- newLocalNode testTransport initRemoteTable

737 node2 <- newLocalNode testTransport initRemoteTable

683 node2 <- newLocalNode testTransport initRemoteTable

684+ done <- newEmptyMVar

738

685

739 pingServer <- forkProcess node1 ping

686 pingServer <- forkProcess node1 ping

740 deadProcess <- forkProcess node1 (return ())

687 deadProcess <- forkProcess node1 (return ())

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

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

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

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

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

749

696

750− pid <- verifyWhereIsRemote nid1 "ping"

697+ Just pid <- whereisRemote nid1 "ping"

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

698+ True <- return $ pingServer == pid

752−

753 us <- getSelfPid

699 us <- getSelfPid

754 nsendRemote nid1 "ping" (Pong us)

700 nsendRemote nid1 "ping" (Pong us)

755− receiveWait [

701+ Ping pid' <- expect

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

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

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

758

703

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

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

760 -- in owner field.

705 -- in owner field.

761 registerRemoteAsync nid1 "dead" deadProcess

706 registerRemoteAsync nid1 "dead" deadProcess

707+ receiveWait [

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

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

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

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

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

765−

766 registerRemoteAsync nid1 "ping" deadProcess

710 registerRemoteAsync nid1 "ping" deadProcess

767 receiveWait [

711 receiveWait [

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

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

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

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

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

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

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

772−

773 unregisterRemoteAsync nid1 "dead"

715 unregisterRemoteAsync nid1 "dead"

774 receiveWait [

716 receiveWait [

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

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

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

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

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

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

720+ liftIO $ putMVar done ()

721+

722+ takeMVar done

778

723

779testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

724testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

780testRemoteRegistryRemoteProcess TestTransport{..} = do

725testRemoteRegistryRemoteProcess TestTransport{..} = do

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

790 receiveWait [

735 receiveWait [

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

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

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

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

793− pid <- verifyWhereIsRemote nid1 "ping"

738+ Just pid <- whereisRemote nid1 "ping"

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

739+ True <- return $ pingServer == pid

795 us <- getSelfPid

740 us <- getSelfPid

796 nsendRemote nid1 "ping" (Pong us)

741 nsendRemote nid1 "ping" (Pong us)

797− receiveWait [

742+ Ping pid' <- expect

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

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

799− ] >>= liftIO . putMVar done

744+ liftIO $ putMVar done ()

800

745

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

746+ takeMVar done

802

747

803testSpawnLocal :: TestTransport -> Assertion

748testSpawnLocal :: TestTransport -> Assertion

804testSpawnLocal TestTransport{..} = do

749testSpawnLocal TestTransport{..} = do

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

812 sport <- expect

757 sport <- expect

813 sendChan sport (1234 :: Int)

758 sendChan sport (1234 :: Int)

814

759

815− sport <- spawnChannelLocal $

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

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

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

762+ send us ()

817

763

818 send pid sport

764 send pid sport

765+ () <- expect

819− expect >>= liftIO . putMVar done

766+ liftIO $ putMVar done ()

820

767

821− res <- takeMVar done

768+ takeMVar done

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

823

769

824testSpawnAsyncStrictness :: TestTransport -> Assertion

770testSpawnAsyncStrictness :: TestTransport -> Assertion

825testSpawnAsyncStrictness TestTransport{..} = do

771testSpawnAsyncStrictness TestTransport{..} = do

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

848 liftIO $ putMVar processA us

794 liftIO $ putMVar processA us

849 msg1 <- expect

795 msg1 <- expect

850 msg2 <- expect

796 msg2 <- expect

851− liftIO $ do

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

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

853− putMVar sendTestOk ()

798+ liftIO $ putMVar sendTestOk ()

854

799

855 forkProcess node2 $ do

800 forkProcess node2 $ do

856 {-

801 {-

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

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

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

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

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

885

830

886− _ <- whereisRemote nid1 "a"

831+ Just _ <- whereisRemote nid1 "a"

887

832

888

833

889 -- Simulate network failure

834 -- Simulate network failure

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

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

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

903

848

904 -- Check

849 -- Check

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

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

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

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

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

908− verifyWhereIsRemote nid1 "c"

852+ Just _ <- whereisRemote nid1 "c"

909

853

910 liftIO $ putMVar registerTestOk ()

854 liftIO $ putMVar registerTestOk ()

911

855

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

946 isSorted _ = True

890 isSorted _ = True

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

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

948 -- the last message.

892 -- the last message.

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

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

894+ liftIO $ putMVar usendTestOk ()

950

895

951 forkProcess node2 $ do

896 forkProcess node2 $ do

952 them <- liftIO $ readMVar processA

897 them <- liftIO $ readMVar processA

953 getSelfPid >>= send them

898 getSelfPid >>= send them

954− expect :: Process ()

899+ () <- expect

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

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

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

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

957 usendPrim them i

902 usendPrim them i

958 liftIO (threadDelay 30000)

903 liftIO (threadDelay 30000)

959

904

960− res <- takeMVar usendTestOk

905+ takeMVar usendTestOk

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

962

906

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

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

964-- in between

908-- in between

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

984 runProcess localNode $ do

928 runProcess localNode $ do

985 pid <- getSelfPid

929 pid <- getSelfPid

986 send mathServer (Add pid 1 2)

930 send mathServer (Add pid 1 2)

987− three <- expect :: Process Double

931+ 3 <- expect :: Process Double

988 send mathServer (Divide pid 8 2)

932 send mathServer (Divide pid 8 2)

989− four <- expect :: Process Double

933+ 4 <- expect :: Process Double

990 send mathServer (Divide pid 8 0)

934 send mathServer (Divide pid 8 0)

991− divByZ <- expect

935+ DivByZero <- expect

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

936+ liftIO $ putMVar clientDone ()

993

937

994− res <- takeMVar clientDone

938+ takeMVar clientDone

995− case res of

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

997− _ -> error "Unexpected result"

998

939

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

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

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

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

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

1021 runProcess localNode $ do

962 runProcess localNode $ do

1022 pid <- getSelfPid

963 pid <- getSelfPid

1023 send mathServer (Add pid 1 2)

964 send mathServer (Add pid 1 2)

1024− three <- expect :: Process Double

965+ 3 <- expect :: Process Double

1025 send mathServer (Divide pid 8 2)

966 send mathServer (Divide pid 8 2)

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

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

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

968+ liftIO $ putMVar clientDone ()

1028−

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

1030

969

970+ takeMVar clientDone

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

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

1032 maybeForward s msg =

972 maybeForward s msg =

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

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

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

1055 Just _ -> die "NONSENSE")

995 Just _ -> die "NONSENSE")

1056 ]

996 ]

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

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

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

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

1059− liftIO $ do

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

1061− putMVar serverDone ()

999+ liftIO $ putMVar serverDone ()

1062 putMVar addr server

1000 putMVar addr server

1063

1001

1064 -- Client

1002 -- Client

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

1101 runProcess localNode $ do

1039 runProcess localNode $ do

1102 pid <- getSelfPid

1040 pid <- getSelfPid

1103 send server (pid, "foo")

1041 send server (pid, "foo")

1104− foo <- expect

1042+ "foo" <- expect

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

1106−

1107− send server (pid, "bar")

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

1109−

1110 send server (pid, "baz")

1043 send server (pid, "baz")

1111− baz <- expect

1044+ "baz" <- expect

1112−

1045+ send server (pid, "bar")

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

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

1047+ liftIO $ putMVar clientDone ()

1114−

1115− res <- takeMVar clientDone

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

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

1118

1048

1049+ takeMVar clientDone

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

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

1120 tryHandleMessage msg =

1051 tryHandleMessage msg =

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

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

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

1148 runProcess localNode $ do

1079 runProcess localNode $ do

1149 pid <- getSelfPid

1080 pid <- getSelfPid

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

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

1151− foo <- expect

1082+ "foo" <- expect

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

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

1153− baz <- expect

1084+ "baz" <- expect

1154− liftIO $ putMVar clientDone (foo, baz)

1085+ liftIO $ putMVar clientDone ()

1155

1086

1156− res <- takeMVar clientDone

1087+ takeMVar clientDone

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

1158

1088

1159-- Test 'receiveChanTimeout'

1089-- Test 'receiveChanTimeout'

1160testReceiveChanTimeout :: TestTransport -> Assertion

1090testReceiveChanTimeout :: TestTransport -> Assertion

1161testReceiveChanTimeout TestTransport{..} = do

1091testReceiveChanTimeout TestTransport{..} = do

1162 done <- newEmptyMVar

1092 done <- newEmptyMVar

1163− mvSender <- newEmptyMVar

1164 sendPort <- newEmptyMVar

1093 sendPort <- newEmptyMVar

1165

1094

1166 forkTry $ do

1095 forkTry $ do

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

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

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

1171 liftIO $ putMVar sendPort sp

1100 liftIO $ putMVar sendPort sp

1172

1101

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

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

1174− -- Nothing after the delay.

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

1176−

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

1178− liftIO $ putMVar mvSender ()

1179−

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

1181− -- 0.1 seconds

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

1103+ Nothing <- receiveChanTimeout 1000000 rp

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

1184

1104

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

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

1186− -- available, we get Nothing

1106+ Just True <- receiveChanTimeout 1000000 rp

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

1188

1107

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

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

1190− liftIO $ putMVar mvSender ()

1109+ Nothing <- receiveChanTimeout 0 rp

1191

1110

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

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

1193− fix $ \loop -> do

1194− liftIO $ threadDelay 100000

1112+ liftIO $ threadDelay 1000000

1195− mb <- receiveChanTimeout 0 rp

1113+ Just False <- receiveChanTimeout 0 rp

1196− case mb of

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

1198− _ -> loop

1199

1114

1200 liftIO $ putMVar done ()

1115 liftIO $ putMVar done ()

1201

1116

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

1204 runProcess localNode $ do

1119 runProcess localNode $ do

1205 sp <- liftIO $ readMVar sendPort

1120 sp <- liftIO $ readMVar sendPort

1206

1121

1207− liftIO $ takeMVar mvSender

1208− liftIO $ threadDelay 100000

1122+ liftIO $ threadDelay 1500000

1209 sendChan sp True

1123 sendChan sp True

1210

1124

1211− liftIO $ takeMVar mvSender

1125+ liftIO $ threadDelay 500000

1212 sendChan sp False

1126 sendChan sp False

1213

1127

1214 takeMVar done

1128 takeMVar done

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

1231

1145

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

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

1233

1147

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

1148+ True <- receiveChan rp1

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

1149+ False <- receiveChan rp1

1236

1150

1237 -- Test Applicative instance

1151 -- Test Applicative instance

1238

1152

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

1241

1155

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

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

1243

1157

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

1158+ 7 <- receiveChan rp2

1245

1159

1246 -- Test Alternative instance

1160 -- Test Alternative instance

1247

1161

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

1250

1164

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

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

1252

1166

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

1167+ False <- receiveChan rp3

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

1168+ True <- receiveChan rp3

1255

1169

1256 -- Test Monad instance

1170 -- Test Monad instance

1257

1171

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

1265 then rpInt

1179 then rpInt

1266 else return 7

1180 else return 7

1267

1181

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

1182+ 5 <- receiveChan rp4

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

1183+ 7 <- receiveChan rp4

1270

1184

1271 liftIO $ putMVar done ()

1185 liftIO $ putMVar done ()

1272

1186

1273 takeMVar done

1187 takeMVar done

1274

1188

1275−testChanLifecycle :: TestTransport -> Assertion

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

1277− result <- newEmptyMVar

1278− tchMV <- newEmptyMVar

1279− localNode <- newLocalNode testTransport initRemoteTable

1280− runProcess localNode $ do

1281−

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

1283− liftIO $ putMVar tchMV tCh

1284− expect :: Process ()

1285− let (sp, _) = tCh

1286− sendChan sp ()

1287− expect :: Process ()

1288−

1289− mRefPid <- monitor pid

1290−

1291− cPid <- spawnLocal $ do

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

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

1294− send pid ()

1295− -- say "told pid to continue"

1296− res <- receiveChanTimeout delay rp

1297− case res of

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

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

1300− pause 10000

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

1302− send pid ()

1303−

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

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

1306−

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

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

1309−

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

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

1312− recv <- receiveChanTimeout delay rp

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

1314− liftIO $ putMVar result $ isNothing recv

1315−

1316− mRefCPid <- monitor cPid

1317−

1318− receiveWait

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

1320− (\_ -> return ())

1321− ]

1322−

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

1324−

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

1326− sendChan sendPort ()

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

1328−

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

1330− send cPid ()

1331−

1332− receiveWait

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

1334− (\_ -> return ())

1335− ]

1336−

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

1338−

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

1340− testRes <- takeMVar result

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

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

1343−

1344−

1345testKillLocal :: TestTransport -> Assertion

1189testKillLocal :: TestTransport -> Assertion

1346testKillLocal TestTransport{..} = do

1190testKillLocal TestTransport{..} = do

1347 localNode <- newLocalNode testTransport initRemoteTable

1191 localNode <- newLocalNode testTransport initRemoteTable

1192+ done <- newEmptyMVar

1348

1193

1349 pid <- forkProcess localNode $ do

1194 pid <- forkProcess localNode $ do

1350 liftIO $ threadDelay 1000000

1195 liftIO $ threadDelay 1000000

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

1353 ref <- monitor pid

1198 ref <- monitor pid

1354 us <- getSelfPid

1199 us <- getSelfPid

1355 kill pid "TestKill"

1200 kill pid "TestKill"

1356− mn <- expect

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

1357− case mn of

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

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

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

1360− True -> return ()

1203+ liftIO $ putMVar done ()

1361− False -> die "Invalid ProcessMonitorNotification received"

1204+

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

1205+ takeMVar done

1363

1206

1364testKillRemote :: TestTransport -> Assertion

1207testKillRemote :: TestTransport -> Assertion

1365testKillRemote TestTransport{..} = do

1208testKillRemote TestTransport{..} = do

1366 node1 <- newLocalNode testTransport initRemoteTable

1209 node1 <- newLocalNode testTransport initRemoteTable

1367 node2 <- newLocalNode testTransport initRemoteTable

1210 node2 <- newLocalNode testTransport initRemoteTable

1211+ done <- newEmptyMVar

1368

1212

1369 pid <- forkProcess node1 $ do

1213 pid <- forkProcess node1 $ do

1370 liftIO $ threadDelay 1000000

1214 liftIO $ threadDelay 1000000

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

1373 ref <- monitor pid

1217 ref <- monitor pid

1374 us <- getSelfPid

1218 us <- getSelfPid

1375 kill pid "TestKill"

1219 kill pid "TestKill"

1376− mn <- expect

1377− case mn of

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

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

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

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

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

1222+ liftIO $ putMVar done ()

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

1223+

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

1224+ takeMVar done

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

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

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

1386− _ -> die "Received unexpected message"

1387

1225

1388testCatchesExit :: TestTransport -> Assertion

1226testCatchesExit :: TestTransport -> Assertion

1389testCatchesExit TestTransport{..} = do

1227testCatchesExit TestTransport{..} = do

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

1409 self <- getSelfPid

1247 self <- getSelfPid

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

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

1411 msg <- receiveWait [ matchMessage return ]

1249 msg <- receiveWait [ matchMessage return ]

1412− handleMessageIf msg

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

1413− (\() -> True)

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

1415− (const $ die "Expected Mismatch")

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

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

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

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

1418 return ()

1253 return ()

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

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

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

1458 `catchExit` \_from reason -> do

1293 `catchExit` \_from reason -> do

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

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

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

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

1461 liftIO $ putMVar done ()

1296 liftIO $ putMVar done ()

1462− if res

1463− then return ()

1464− else die "Something went horribly wrong"

1465

1297

1466 takeMVar done

1298 takeMVar done

1467

1299

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

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

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

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

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

1477 in do

1309 in do

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

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

1479 liftIO $ putMVar done ()

1311 liftIO $ putMVar done ()

1480− if res

1481− then return ()

1482− else die "Something went horribly wrong"

1483

1312

1484 takeMVar done

1313 takeMVar done

1485

1314

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

1495 pid <- forkProcess localNode $ do

1324 pid <- forkProcess localNode $ do

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

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

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

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

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

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

1499 liftIO $ putMVar supervisedDone ()

1328 liftIO $ putMVar supervisedDone ()

1500− if res

1501− then return ()

1502− else die "Something went horribly wrong"

1503

1329

1504 runProcess localNode $ do

1330 runProcess localNode $ do

1505 liftIO $ takeMVar handlerSetUp

1331 liftIO $ takeMVar handlerSetUp

1506 ref <- monitor pid

1332 ref <- monitor pid

1507 exit pid "TestExit"

1333 exit pid "TestExit"

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

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

1509− mn <- expect

1510− case mn of

1511− ProcessMonitorNotification ref' pid' DiedNormal -> do

1335+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

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

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

1513− liftIO $ putMVar supervisorDone ()

1337+ liftIO $ putMVar supervisorDone ()

1514− if res

1515− then return ()

1516− else die "Something went horribly wrong"

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

1518

1338

1519 takeMVar supervisedDone

1339 takeMVar supervisedDone

1520 takeMVar supervisorDone

1340 takeMVar supervisorDone

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

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

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

1531 `catchExit` \_from reason -> do

1351 `catchExit` \_from reason -> do

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

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

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

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

1534 liftIO $ putMVar supervisedDone ()

1354 liftIO $ putMVar supervisedDone ()

1535− if res

1536− then return ()

1537− else die "Something went horribly wrong"

1538

1355

1539 runProcess node2 $ do

1356 runProcess node2 $ do

1540 ref <- monitor pid

1357 ref <- monitor pid

1541 exit pid "TestExit"

1358 exit pid "TestExit"

1542− mn <- expect

1543− case mn of

1544− ProcessMonitorNotification ref' pid' DiedNormal -> do

1359+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

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

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

1546− liftIO $ putMVar supervisorDone ()

1361+ liftIO $ putMVar supervisorDone ()

1547− if res'

1548− then return ()

1549− else die "Something went horribly wrong"

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

1551

1362

1552 takeMVar supervisedDone

1363 takeMVar supervisedDone

1553 takeMVar supervisorDone

1364 takeMVar supervisorDone

1554

1365

1555−testRegistryMonitoring :: TestTransport -> Assertion

1556−testRegistryMonitoring TestTransport{..} = do

1557− node1 <- newLocalNode testTransport initRemoteTable

1558− node2 <- newLocalNode testTransport initRemoteTable

1559−

1560− let nid = localNodeId node2

1561− pid <- forkProcess node1 $ do

1562− self <- getSelfPid

1563− runUntilRegistered nid self

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

1565− expect :: Process ()

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

1567−

1568− runProcess node2 $ do

1569− register regName pid

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

1571− res <- whereis regName

1572− send pid ()

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

1574− us <- getSelfPid

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

1576−

1577−

1578− -- This delay isn't essential!

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

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

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

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

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

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

1585− void $ receiveTimeout 4000000 [ matchAny return ]

1586−

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

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

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

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

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

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

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

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

1595− -- in either case.

1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid

1597−

1598− regHere <- newEmptyMVar

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

1600− res <- takeMVar regHere

1601− case res of

1602− Nothing -> return ()

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

1604−

1605− where

1606− runUntilRegistered nid us = do

1607− whereisRemoteAsync nid regName

1608− receiveWait [

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

1610− (const $ return ())

1611− ]

1612−

1613− delayUntilMaybeUnregistered nid p = do

1614− whereisRemoteAsync nid regName

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

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

1617− (const $ return ())

1618− ]

1619− case res of

1620− Just () -> return ()

1621− Nothing -> delayUntilMaybeUnregistered nid p

1622−

1623− regName = "testRegisterRemote"

1624−

1625testUnsafeSend :: TestTransport -> Assertion

1366testUnsafeSend :: TestTransport -> Assertion

1626testUnsafeSend TestTransport{..} = do

1367testUnsafeSend TestTransport{..} = do

1627 serverAddr <- newEmptyMVar

1368 serverAddr <- newEmptyMVar

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

1637 void $ forkProcess localNode $ do

1378 void $ forkProcess localNode $ do

1638 serverPid <- liftIO $ takeMVar serverAddr

1379 serverPid <- liftIO $ takeMVar serverAddr

1639 getSelfPid >>= unsafeSend serverPid

1380 getSelfPid >>= unsafeSend serverPid

1381+ () <- expect

1640− expect >>= liftIO . putMVar clientDone

1382+ liftIO $ putMVar clientDone ()

1641

1383

1642 takeMVar clientDone

1384 takeMVar clientDone

1643

1385

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

1656 void $ forkProcess localNode $ do

1398 void $ forkProcess localNode $ do

1657 serverPid <- liftIO $ takeMVar serverAddr

1399 serverPid <- liftIO $ takeMVar serverAddr

1658 getSelfPid >>= unsafeUSend serverPid

1400 getSelfPid >>= unsafeUSend serverPid

1401+ () <- expect

1659− expect >>= liftIO . putMVar clientDone

1402+ liftIO $ putMVar clientDone ()

1660

1403

1661 takeMVar clientDone

1404 takeMVar clientDone

1662

1405

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

1667 localNode <- newLocalNode testTransport initRemoteTable

1410 localNode <- newLocalNode testTransport initRemoteTable

1668

1411

1669 pid <- forkProcess localNode $ do

1412 pid <- forkProcess localNode $ do

1413+ () <- expect

1670− expect >>= liftIO . putMVar clientDone

1414+ liftIO $ putMVar clientDone ()

1671

1415

1672 void $ runProcess localNode $ do

1416 void $ runProcess localNode $ do

1673 register "foobar" pid

1417 register "foobar" pid

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

1685 _ <- forkProcess localNode1 $ do

1429 _ <- forkProcess localNode1 $ do

1686 getSelfPid >>= register "foobar"

1430 getSelfPid >>= register "foobar"

1687 liftIO $ putMVar clientDone ()

1431 liftIO $ putMVar clientDone ()

1432+ () <- expect

1688− expect >>= liftIO . putMVar clientDone

1433+ liftIO $ putMVar clientDone ()

1689

1434

1690 takeMVar clientDone

1435 takeMVar clientDone

1691 void $ runProcess localNode2 $ do

1436 void $ runProcess localNode2 $ do

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

1709 serverPid <- liftIO $ takeMVar serverAddr

1454 serverPid <- liftIO $ takeMVar serverAddr

1710 (sp, rp) <- newChan

1455 (sp, rp) <- newChan

1711 unsafeSend serverPid sp

1456 unsafeSend serverPid sp

1712− receiveChan rp :: Process ()

1457+ () <- receiveChan rp

1713 liftIO $ putMVar clientDone ()

1458 liftIO $ putMVar clientDone ()

1714

1459

1715 takeMVar clientDone

1460 takeMVar clientDone

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

1723 runProcess node $ do

1468 runProcess node $ do

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

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

1725 liftIO $ putMVar result r

1470 liftIO $ putMVar result r

1726−

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

1471+ True <- takeMVar result

1472+ return ()

1728

1473

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

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

1730 ibox <- newIORef False

1475 ibox <- newIORef False

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

1741 (send keeper ())

1486 (send keeper ())

1742 caller <- expect

1487 caller <- expect

1743 exit caller "test"

1488 exit caller "test"

1744− expect :: Process ()

1489+ () <- expect

1745−

1490+ return ()

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

1491+ True <- readIORef ibox

1492+ return ()

1747

1493

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

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

1749 ibox2 <- newIORef False

1495 ibox2 <- newIORef False

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

1752 liftIO $ writeIORef ibox2 $ case r of

1498 liftIO $ writeIORef ibox2 $ case r of

1753 Left (ErrorCall "e") -> True

1499 Left (ErrorCall "e") -> True

1754 _ -> False

1500 _ -> False

1755−

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

1501+ True <- readIORef ibox

1502+ return ()

1757

1503

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

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

1759 ibox3 <- newIORef False

1505 ibox3 <- newIORef False

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

1770 liftIO $ putMVar result3 =<< readIORef ibox3

1516 liftIO $ putMVar result3 =<< readIORef ibox3

1771 worker <- expect

1517 worker <- expect

1772 send worker ()

1518 send worker ()

1773−

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

1519+ True <- takeMVar result3

1520+ return ()

1775

1521

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

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

1777 ibox4 <- newIORef False

1523 ibox4 <- newIORef False

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

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

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

1788 caller <- expect

1534 caller <- expect

1789 exit caller "hi!"

1535 exit caller "hi!"

1790−

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

1536+ True <- takeMVar result4

1537+ return ()

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

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

1793

1539

1540+

1541+

1542+

1543+

1794tests :: TestTransport -> IO [Test]

1544tests :: TestTransport -> IO [Test]

1795tests testtrans = return [

1545tests testtrans = return [

1796 testGroup "Basic features" [

1546 testGroup "Basic features" [

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

1814 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1564 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1815 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1565 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1816 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1566 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1818 , testCase "KillLocal" (testKillLocal testtrans)

1567 , testCase "KillLocal" (testKillLocal testtrans)

1819 , testCase "KillRemote" (testKillRemote testtrans)

1568 , testCase "KillRemote" (testKillRemote testtrans)

1820 , testCase "Die" (testDie testtrans)

1569 , testCase "Die" (testDie testtrans)

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

1824 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1573 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1825 , testCase "ExitLocal" (testExitLocal testtrans)

1574 , testCase "ExitLocal" (testExitLocal testtrans)

1826 , testCase "ExitRemote" (testExitRemote testtrans)

1575 , testCase "ExitRemote" (testExitRemote testtrans)

1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1828 , testCase "TextCallLocal" (testCallLocal testtrans)

1576 , testCase "TextCallLocal" (testCallLocal testtrans)

1829 -- Unsafe Primitives

1577 -- Unsafe Primitives

1830 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1578 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

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

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

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

1878 ]

1626 ]

1879 ]

1627 ]

1628+

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

1630+syncBreakConnection breakConnection nid0 nid1 = do

1631+ m <- newEmptyMVar

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

1633+ runProcess nid0 $ do

1634+ them <- liftIO $ takeMVar m

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

1636+ _ <- monitorNode (localNodeId nid1)

1637+ liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

1638+ (nodeAddress $ localNodeId nid1)

1639+ NodeMonitorNotification _ _ _ <- expect

1640+ kill pinger "finished"

1641+ return ()

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

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

169 node <- newLocalNode testTransport rtable

170 done <- newEmptyMVar

171 forkProcess node $ do

172− i <- join . unClosure $ factorialClosure 5

172+ 120 <- join . unClosure $ factorialClosure 5

173 liftIO $ putMVar done ()

174− if i == 720

175− then return ()

176− else error "Something went horribly wrong"

177 takeMVar done

174 takeMVar done

178

175

179testBind :: TestTransport -> RemoteTable -> Assertion

176testBind :: TestTransport -> RemoteTable -> Assertion

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

183 runProcess node $ do

180 runProcess node $ do

184 us <- getSelfPid

181 us <- getSelfPid

185 join . unClosure $ sendFac 6 us

182 join . unClosure $ sendFac 6 us

186− (i :: Int) <- expect

183+ (720 :: Int) <- expect

187 liftIO $ putMVar done ()

184 liftIO $ putMVar done ()

188− if i == 720

189− then return ()

190− else error "Something went horribly wrong"

191 takeMVar done

185 takeMVar done

192

186

193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

187testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

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

200 addr <- forkProcess node $ do

194 addr <- forkProcess node $ do

201 cl <- expect

195 cl <- expect

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

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

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

197+ 13 <- return $ fn 6

204 liftIO $ putMVar serverDone ()

198 liftIO $ putMVar serverDone ()

205 putMVar serverAddr addr

199 putMVar serverAddr addr

206

200

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

224 liftIO $ do

218 liftIO $ do

225 someMVar <- newEmptyMVar

219 someMVar <- newEmptyMVar

226 io someMVar

220 io someMVar

227− i <- readMVar someMVar

221+ 5 <- readMVar someMVar

228 putMVar serverDone ()

222 putMVar serverDone ()

229− if i == 5

230− then return ()

231− else error "Something went horribly wrong"

232 putMVar serverAddr addr

223 putMVar serverAddr addr

233

224

234 forkIO $ do

225 forkIO $ do

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

257 runProcess node $ do

248 runProcess node $ do

258 pid <- getSelfPid

249 pid <- getSelfPid

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

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

260− i <- expect :: Process Int

251+ 5 <- expect :: Process Int

261− if i == 5

262− then liftIO $ putMVar clientDone ()

252+ liftIO $ putMVar clientDone ()

263− else error "Something went horribly wrong"

264

253

265 takeMVar clientDone

254 takeMVar clientDone

266

255

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

280 pid <- getSelfPid

269 pid <- getSelfPid

281 pid' <- spawn nid (sendPidClosure pid)

270 pid' <- spawn nid (sendPidClosure pid)

282 pid'' <- expect

271 pid'' <- expect

283− if pid' == pid''

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

284− then liftIO $ putMVar clientDone ()

273+ liftIO $ putMVar clientDone ()

285− else error "Something went horribly wrong"

286

274

287 takeMVar clientDone

275 takeMVar clientDone

288

276

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

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

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

307 pid' <- expect :: Process ProcessId

295 pid' <- expect :: Process ProcessId

308 pid'' <- expect :: Process ProcessId

296 pid'' <- expect :: Process ProcessId

309− if pid' == pid''

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

310− then return ()

298+ return ()

311− else error "Something went horribly wrong"

312

299

313 where

300 where

314

301

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

318 wrapEP e =

305 wrapEP e =

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

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

320 healthy <- newIORef True

307 healthy <- newIORef True

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

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

322 }

309 }

323

310

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

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

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

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

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

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

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

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

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

329 writeIORef healthy False

315 writeIORef healthy False

330− testBreakConnection (NT.address e) remoteAddr

331 isHealthy <- readIORef healthy

316 isHealthy <- readIORef healthy

332 if isHealthy then s msg

317 if isHealthy then s msg

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

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

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

345 node <- newLocalNode testTransport rtable

330 node <- newLocalNode testTransport rtable

346 nid <- readMVar serverNodeAddr

331 nid <- readMVar serverNodeAddr

347 runProcess node $ do

332 runProcess node $ do

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

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

349− if a == 120

350− then liftIO $ putMVar clientDone ()

334+ liftIO $ putMVar clientDone ()

351− else error "something went horribly wrong"

352

335

353 takeMVar clientDone

336 takeMVar clientDone

354

337

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

365 node <- newLocalNode testTransport rtable

348 node <- newLocalNode testTransport rtable

366 nid <- readMVar serverNodeAddr

349 nid <- readMVar serverNodeAddr

367 runProcess node $ do

350 runProcess node $ do

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

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

369− if a == 120

370− then liftIO $ putMVar clientDone ()

352+ liftIO $ putMVar clientDone ()

371− else error "Something went horribly wrong"

372

353

373 takeMVar clientDone

354 takeMVar clientDone

374

355

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

379 runProcess node $ do

360 runProcess node $ do

380 us <- getSelfPid

361 us <- getSelfPid

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

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

382− a :: Int <- expect

363+ 120 :: Int <- expect

383− b :: Int <- expect

364+ 720 :: Int <- expect

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

385− then liftIO $ putMVar done ()

365+ liftIO $ putMVar done ()

386− else error "Something went horribly wrong"

387 takeMVar done

366 takeMVar done

388

367

389-- Test 'spawnSupervised'

368-- Test 'spawnSupervised'

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

412 throw supervisorDeath

391 throw supervisorDeath

413

392

414 forkProcess node2 $ do

393 forkProcess node2 $ do

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

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

416− case res of

417− [super, child] -> do

418− ref <- monitor child

395+ ref <- monitor child

419− self <- getSelfPid

396+ self <- getSelfPid

420− let waitForMOrL = do

397+ let waitForMOrL = do

421− liftIO $ threadDelay 10000

398+ liftIO $ threadDelay 10000

422− mpinfo <- getProcessInfo child

399+ mpinfo <- getProcessInfo child

423− case mpinfo of

400+ case mpinfo of

424− Nothing -> waitForMOrL

401+ Nothing -> waitForMOrL

425− Just pinfo ->

402+ Just pinfo ->

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

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

427− waitForMOrL

404+ waitForMOrL

428− liftIO $ putMVar linkUp ()

405+ liftIO $ putMVar linkUp ()

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

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

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

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

431− res' <- expect

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

432− case res' of

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

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

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

410+ && pid' == child

435− e == show (ProcessLinkException super

436− (DiedException (show supervisorDeath))))

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

437− then liftIO $ putMVar thirdProcessDone ()

412+ liftIO $ putMVar thirdProcessDone ()

438− else error "Something went horribly wrong"

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

440−

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

442

413

443 takeMVar thirdProcessDone

414 takeMVar thirdProcessDone

444 where

415 where

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

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

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

454 ProcessMonitorNotification ref' pid' _reason <- expect

425 ProcessMonitorNotification ref' pid' _reason <- expect

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

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

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

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

457− if res == True

458− then liftIO $ putMVar done ()

428+ liftIO $ putMVar done ()

459− else error "Something went horribly wrong"

460 takeMVar done

429 takeMVar done

461

430

462testClosureExpect :: TestTransport -> RemoteTable -> Assertion

431testClosureExpect :: TestTransport -> RemoteTable -> Assertion

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

468 us <- getSelfPid

437 us <- getSelfPid

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

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

470 send them (1234 :: Int)

439 send them (1234 :: Int)

471− (res :: Int) <- expect

440+ (1234 :: Int) <- expect

472− if res == 1234

473− then liftIO $ putMVar done ()

441+ liftIO $ putMVar done ()

474− else error "Something went horribly wrong"

475 takeMVar done

442 takeMVar done

476

443

477testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

444testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

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

496 done <- newEmptyMVar

463 done <- newEmptyMVar

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

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

498 forkProcess node1 $ do

465 forkProcess node1 $ do

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

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

500− if res == True

501− then liftIO $ putMVar done ()

467+ liftIO $ putMVar done ()

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

503 takeMVar done

468 takeMVar done

504

469

505testFib :: TestTransport -> RemoteTable -> Assertion

470testFib :: TestTransport -> RemoteTable -> Assertion

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

510 forkProcess (head nodes) $ do

475 forkProcess (head nodes) $ do

511 (sport, rport) <- newChan

476 (sport, rport) <- newChan

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

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

513− ff <- receiveChan rport :: Process Integer

478+ 55 <- receiveChan rport :: Process Integer

514 liftIO $ putMVar done ()

479 liftIO $ putMVar done ()

515− if ff /= 55

516− then die $ "Something went horribly wrong"

517− else return ()

518

480

519 takeMVar done

481 takeMVar done

520

482

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

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

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

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

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

524 let nid1 = localNodeId node1

486 let nid1 = localNodeId node1

525− -- nid2 = localNodeId node2

487+ nid2 = localNodeId node2

526 done <- newEmptyMVar

488 done <- newEmptyMVar

527 iv <- newMVar (0 :: Int)

489 iv <- newMVar (0 :: Int)

528

490

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

539 liftIO $ threadDelay 100000

501 liftIO $ threadDelay 100000

540

502

541 count <- liftIO $ takeMVar iv

503 count <- liftIO $ takeMVar iv

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

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

543

505

544 liftIO $ putMVar done ()

506 liftIO $ putMVar done ()

545− if res /= True

546− then error "Something went horribly wrong"

547− else return ()

548

507

549 takeMVar done

508 takeMVar done

550

509

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

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

20 -- ping !

21 , Ping(Ping)

22 , ping

23− , pause

24 , shouldBe

23 , shouldBe

25 , shouldMatch

24 , shouldMatch

26 , shouldContain

25 , shouldContain

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

74import Control.Concurrent.MVar

73import Control.Concurrent.MVar

75 ( putMVar

74 ( putMVar

76 )

75 )

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

76+import Control.Distributed.Process

78import Control.Distributed.Process.Node

77import Control.Distributed.Process.Node

79import Control.Distributed.Process.Serializable()

78import Control.Distributed.Process.Serializable()

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

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

82−import Control.Monad (forever, void)

81+import Control.Monad (forever)

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

84import Control.Monad.STM (atomically)

82import Control.Monad.STM (atomically)

85import Control.Rematch hiding (match)

83import Control.Rematch hiding (match)

86−import Control.Rematch.Run

84+import Control.Rematch.Run

87import Data.Binary

85import Data.Binary

88import Data.Typeable (Typeable)

86import Data.Typeable (Typeable)

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

91import Test.HUnit.Base (assertBool)

89import Test.HUnit.Base (assertBool)

93import GHC.Generics

91import GHC.Generics

94−import System.Timeout (timeout)

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

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

97type TestResult a = MVar a

94type TestResult a = MVar a

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

110

107

111instance Binary TestProcessControl where

108instance Binary TestProcessControl where

112

109

113−data Private = Private

114− deriving (Typeable, Generic)

115−instance Binary Private where

116−

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

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

118noop :: Process ()

111noop :: Process ()

119noop = return ()

112noop = return ()

120

113

121−pause :: Int -> Process ()

122−pause delay =

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

124−

125synchronisedAssertion :: Eq a

114synchronisedAssertion :: Eq a

126 => String

115 => String

127 -> LocalNode

116 -> LocalNode

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

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

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

235tryRunProcess node p = do

224tryRunProcess node p = do

236 tid <- liftIO myThreadId

225 tid <- liftIO myThreadId

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

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

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

239

227

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

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

241tryForkProcess node p = do

229tryForkProcess node p = do

242 tid <- liftIO myThreadId

230 tid <- liftIO myThreadId

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

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

232+

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

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

1−{-# LANGUAGE DeriveGeneric #-}

1+{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE ParallelListComp #-}

3−

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

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

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

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

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

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

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

7+import Control.Concurrent (threadDelay)

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

8+import Control.Distributed.Process

10− ( ProcessExitException(..)

11− , unsafeCreateUnencodedMessage

12− )

13import Control.Distributed.Process.Node

9import Control.Distributed.Process.Node

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

15− ( send

16− , nsend

17− , nsendRemote

18− , usend

19− , sendChan

20− )

21import Control.Distributed.Process.Management

10import Control.Distributed.Process.Management

22 ( MxEvent(..)

11 ( MxEvent(..)

23 , MxAgentId(..)

12 , MxAgentId(..)

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

32 , mxUpdateLocal

21 , mxUpdateLocal

33 , mxNotify

22 , mxNotify

34 , mxBroadcast

23 , mxBroadcast

24+ , mxGetId

25+ , mxGet

26+ , mxSet

27+ , mxClear

28+ , mxPurgeTable

29+ , mxDropTable

35 )

30 )

36−import Control.Monad (void, unless)

31+import Control.Monad (void)

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

38−import Control.Rematch (equalTo)

39import Data.Binary

32import Data.Binary

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

33+import Data.List (find, sort)

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

34+import Data.Maybe (isJust)

42import Data.Typeable

35import Data.Typeable

43−import GHC.Generics hiding (from)

36+import GHC.Generics

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

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

45import Prelude hiding (catch, log)

38import Prelude hiding (catch, log)

46#endif

39#endif

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

57instance Binary Publish where

50instance Binary Publish where

59−awaitExit :: ProcessId -> Process ()

60−awaitExit pid =

61− withMonitorRef pid $ \ref -> do

62− receiveWait

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

64− (\_ -> return ())

65− ]

66− where

67− withMonitorRef p = bracket (monitor p) unmonitor

68−

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

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

70testAgentBroadcast result = do

53testAgentBroadcast result = do

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

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

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

81 mxNotify ()

64 mxNotify ()

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

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

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

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

84− stash result =<< receiveChanTimeout 10000000 resultRP

67+ stash result =<< receiveChan resultRP

86 kill publisher "finished"

69 kill publisher "finished"

87 kill consumer "finished"

70 kill consumer "finished"

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

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

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

90testAgentDualInput result = do

73testAgentDualInput result = do

91 (sp, rp) <- newChan

74 (sp, rp) <- newChan

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

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

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

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

94 mxSetLocal . (+i) =<< mxGetLocal

77 mxSetLocal . (+i) =<< mxGetLocal

95 i' <- mxGetLocal

78 i' <- mxGetLocal

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

99 else mxReady)

82 else mxReady)

100 ]

83 ]

101

102− mRef <- monitor s

103−

104 mxNotify (1 :: Int)

85 mxNotify (1 :: Int)

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

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

106 mxNotify (2 :: Int)

87 mxNotify (2 :: Int)

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

108 mxNotify (5 :: Int)

89 mxNotify (5 :: Int)

109

110 stash result =<< receiveChanTimeout 10000000 rp

91 stash result =<< receiveChanTimeout 10000000 rp

111− died <- receiveTimeout 10000000 [

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

113− ]

114− died `shouldBe` equalTo (Just True)

115

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

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

117testAgentPrioritisation result = do

94testAgentPrioritisation result = do

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

123

100

124 let name = "prioritising-agent"

101 let name = "prioritising-agent"

125 (sp, rp) <- newChan

102 (sp, rp) <- newChan

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

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

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

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

128− mxUpdateLocal (s:)

105+ mxUpdateLocal ((s:))

129 st <- mxGetLocal

106 st <- mxGetLocal

130 case length st of

107 case length st of

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

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

132 mxDeactivate "finished"

109 mxDeactivate "finished"

133 _ -> mxReceive -- go to the mailbox

110 _ -> mxReceive -- go to the mailbox

134 )

111 )

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

139 mxNotify "fourth"

116 mxNotify "fourth"

140 nsend name "fifth"

117 nsend name "fifth"

141

118

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

119+ stash result . sort =<< receiveChan rp

143− awaitExit s

144

120

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

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

146testAgentMailboxHandling result = do

122testAgentMailboxHandling result = do

147 (sp, rp) <- newChan

123 (sp, rp) <- newChan

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

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

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

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

150 ]

126 ]

151

127

152− nsend "mailbox-agent" ()

128+ nsend "listener-agent" ()

153

129

154 stash result =<< receiveChanTimeout 1000000 rp

130 stash result =<< receiveChanTimeout 1000000 rp

155 kill agent "finished"

131 kill agent "finished"

156

132

157testAgentEventHandling :: TestResult Bool -> Process ()

133testAgentEventHandling :: TestResult Bool -> Process ()

158testAgentEventHandling result = do

134testAgentEventHandling result = do

159− us <- getSelfPid

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

161− timer <- spawnLocal $ do

162− pause (1000000 * 60 * 5)

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

164− stash result False

165− kill us "Test Timed Out"

166−

167 let initState = [] :: [MxEvent]

135 let initState = [] :: [MxEvent]

168− (rc, rs) <- newChan

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

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

170 (mxSink $ \ev -> do

137 (mxSink $ \ev -> do

171 st <- mxGetLocal

138 st <- mxGetLocal

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

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

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

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

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

176 _ -> return ()

143 _ -> return ()

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

144+ act >> mxReady),

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

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

179 st <- mxGetLocal

146 st <- mxGetLocal

180 let found =

147 let found =

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

194 mxReady)

161 mxReady)

195 ]

162 ]

196

163

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

164+ _ <- monitor agentPid

198− faff 2000000 rs

199−

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

165+ (sp, rp) <- newChan

201−

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

166+ pid <- spawnLocal $ sendChan sp ()

167+ () <- receiveChan rp

203

168

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

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

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

170+ -- higher probably that the agent has seen

206 monitor pid

171 monitor pid

207−

208− send pid ()

209− rct <- receiveChanTimeout 10000000 rp

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

211−

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

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

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

214−

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

216− faff 2000000 rs

217

173

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

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

219 mxNotify (MxSpawned pid, replyTo)

175 mxNotify (MxSpawned pid, replyTo)

220 mxNotify (MxProcessDied pid DiedNormal, replyTo)

176 mxNotify (MxProcessDied pid DiedNormal, replyTo)

221

177

222− seenAlive <- receiveChanTimeout 10000000 reply

178+ seenAlive <- receiveChan reply

223− seenDead <- receiveChanTimeout 10000000 reply

224−

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

226− kill timer "test-complete"

227− kill agentPid "test-complete"

228− where

229− faff delay port = do

230− res <- receiveChanTimeout delay port

231− unless (isNothing res) $ pause delay

232−

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

234−testMxRegEvents result = do

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

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

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

238− ensure (stash result ()) $ do

239− let label = "testMxRegEvents"

240− let agentLabel = "mxRegEvents-agent"

241− let delay = 1000000

242− (regChan, regSink) <- newChan

243− (unRegChan, unRegSink) <- newChan

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

245− mxSink $ \ev -> do

246− case ev of

247− MxRegistered pid label'

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

249− MxUnRegistered pid label'

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

251− _ -> return ()

252− mxReady

253− ]

254−

255− p1 <- spawnLocal expect

256− p2 <- spawnLocal expect

257−

258− register label p1

259− reg1 <- receiveChanTimeout delay regSink

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

261−

262− unregister label

263− unreg1 <- receiveChanTimeout delay unRegSink

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

265−

266− register label p2

267− reg2 <- receiveChanTimeout delay regSink

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

269−

270− reregister label p1

271− unreg2 <- receiveChanTimeout delay unRegSink

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

273−

274− reg3 <- receiveChanTimeout delay regSink

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

276−

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

278−

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

280−testMxRegMon remoteNode result = do

281− ensure (stash result ()) $ do

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

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

284− let label1 = "aaaaa"

285− let label2 = "bbbbb"

286− let isValid l = l == label1 || l == label2

287− let agentLabel = "mxRegMon-agent"

288− let delay = 1000000

289− (regChan, regSink) <- newChan

290− (unRegChan, unRegSink) <- newChan

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

292− mxSink $ \ev -> do

293− case ev of

294− MxRegistered pid label

295− | isValid label -> liftMX $ sendChan regChan (label, pid)

296− MxUnRegistered pid label

297− | isValid label -> liftMX $ sendChan unRegChan (label, pid)

298− _ -> return ()

299− mxReady

300− ]

301−

302− (sp, rp) <- newChan

303− liftIO $ forkProcess remoteNode $ do

304− getSelfPid >>= sendChan sp

305− expect :: Process ()

306−

307− p1 <- receiveChan rp

179+ seenDead <- receiveChan reply

308−

309− register label1 p1

310− reg1 <- receiveChanTimeout delay regSink

311− reg1 `shouldBe` equalTo (Just (label1, p1))

312−

313− register label2 p1

314− reg2 <- receiveChanTimeout delay regSink

315− reg2 `shouldBe` equalTo (Just (label2, p1))

316−

317− n1 <- whereis label1

318− n1 `shouldBe` equalTo (Just p1)

319−

320− n2 <- whereis label2

321− n2 `shouldBe` equalTo (Just p1)

322−

323− kill p1 "goodbye"

324−

325− unreg1 <- receiveChanTimeout delay unRegSink

326− unreg2 <- receiveChanTimeout delay unRegSink

327−

328− let evts = [unreg1, unreg2]

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

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

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

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

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

334−

335− kill agent "test-complete"

336−

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

338−ensure = flip finally

339−

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

341− -> Maybe LocalNode

342− -> Process ()

343−testNSend op n = do

344− us <- getSelfPid

345− let delay = 5000000

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

347− let isValid = isValidLabel n label

348−

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

350− register label p1

351− reg1 <- receiveChanTimeout delay sink

352− case reg1 of

353− Just (MxRegistered pd lb)

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

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

356−

357− op label ()

358−

359− sent <- receiveChanTimeout delay sink

360− case sent of

361− Just (MxSentToName lb by _)

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

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

364−

365− where

366− isValidLabel nd l1 l2

367− | l2 == l2 = True

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

369− | otherwise = False

370−

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

372− -> Maybe LocalNode

373− -> Process ()

374−testSend op n = do

375− us <- getSelfPid

376− let label = "testMxSend" ++ (show us)

377− testMxSend n label $ \p1 sink -> do

378− -- initiate a send

379− op p1 ()

380−

381− -- verify the management event

382− sent <- receiveChanTimeout 5000000 sink

383− case sent of

384− Just (MxSent pidTo pidFrom _)

385− | pidTo == p1 && pidFrom == us -> return True

386− _ -> return False

387−

388−testChan :: (SendPort () -> () -> Process ())

389− -> Maybe LocalNode

390− -> Process ()

391−testChan op n = testMxSend n "" $ \p1 sink -> do

392−

393− us <- getSelfPid

394− send p1 us

395−

396− cleared <- receiveChanTimeout 2000000 sink

397− case cleared of

398− Just (MxSent pidTo pidFrom _)

399− | pidTo == p1 && pidFrom == us -> return ()

400− _ -> die "Received uncleared Mx Event"

401−

402− chan <- receiveTimeout 5000000 [ match return ]

403− let ch' = fromMaybe (error "No reply chan received") chan

404−

405− -- initiate a send

406− op ch' ()

407−

408− -- verify the management event

409− sent <- receiveChanTimeout 5000000 sink

410− case sent of

411− Just (MxSentToPort sId spId _)

412− | sId == us && spId == sendPortId ch' -> return True

413− _ -> return False

414−

415−type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

416−

417−testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()

418−testMxSend mNode label test = do

419− us <- getSelfPid

420− (sp, rp) <- newChan

421− (chan, sink) <- newChan

422− agent <- mxAgent (MxAgentId $ agentLabel us) () [

423− mxSink $ \ev -> do

424− case ev of

425− m@(MxSentToPort _ cid _)

426− | cid /= sendPortId chan

427− && cid /= sendPortId sp -> liftMX $ sendChan chan m

428− m@(MxSent _ fromPid _)

429− | fromPid == us -> liftMX $ sendChan chan m

430− m@(MxSentToName _ fromPid _)

431− | fromPid == us -> liftMX $ sendChan chan m

432− m@(MxRegistered _ name)

433− | name == label -> liftMX $ sendChan chan m

434− _ -> return ()

435− mxReady

436− ]

437−

438− case mNode of

439− Nothing -> void $ spawnLocal (proc sp)

440− Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

441

180

442− p1 <- receiveChanTimeout 2000000 rp

181+ stash result $ seenAlive && seenDead

443− unless (isJust p1) $ die "Timed out waiting for ProcessId"

444− res <- try $ test (fromJust p1) sink

445

182

446− kill agent "bye"

183+testAgentPublication :: TestResult (Maybe Publish) -> Process ()

447− kill (fromJust p1) "bye"

184+testAgentPublication result = do

448−

185+ (syncChan, rp) <- newChan

449− case res of

186+ let ourId = MxAgentId "publication-agent"

450− Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

187+ agentPid <- mxAgent ourId () [

451− Right tr -> tr `shouldBe` equalTo True

188+ mxSink $ \() -> do

189+ selfId <- mxGetId

190+ liftMX $ mxSet selfId "publish" Publish >> sendChan syncChan ()

191+ mxReady

192+ ]

452

193

194+ mxNotify ()

195+ () <- receiveChan rp

453

196

454− where

197+ stash result =<< mxGet ourId "publish"

455− agentLabel s = "mx-unsafe-check-agent-" ++ show s

456− proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

457

198

458− go :: Maybe (ReceivePort ()) -> Process ()

199+ mref <- monitor agentPid

459− go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go

200+ kill agentPid "finished"

460− go c@(Just c') = receiveWait [ matchChan c' return ] >> go c

201+ receiveWait [

202+ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

203+ ((\_ -> return ()))

204+ ]

461

205

462− replyChannel p' = do

206+testAgentTableClear :: Int -> TestResult (Maybe Int, Maybe Int) -> Process ()

463− (s, r) <- newChan

207+testAgentTableClear val result =

464− send p' s

208+ let tId = (MxAgentId "agent-1")

465− return r

209+ tKey = "key-1" in do

210+ mxSet tId tKey val

211+ get1 <- mxGet tId tKey

212+ mxClear tId tKey

213+ get2 <- mxGet tId tKey

214+ stash result (get1, get2)

215+

216+testAgentTablePurge :: TestResult (Maybe Int) -> Process ()

217+testAgentTablePurge result =

218+ let tId = MxAgentId "agent-2"

219+ tKey = "key-2" in do

220+ mxSet tId tKey (12345 :: Int)

221+ mxPurgeTable tId

222+ stash result =<< mxGet tId tKey

223+

224+testAgentTableDelete :: Int

225+ -> TestResult (Maybe Int, Maybe Int, Maybe Int)

226+ -> Process ()

227+testAgentTableDelete val result =

228+ let tId = (MxAgentId "agent-3")

229+ tKey = "key-3" in do

230+ mxSet tId tKey val

231+ get1 <- mxGet tId tKey

232+ mxDropTable tId

233+ get2 <- mxGet tId tKey

234+ mxSet tId tKey val

235+ get3 <- mxGet tId tKey

236+ stash result (get1, get2, get3)

466

237

467tests :: TestTransport -> IO [Test]

238tests :: TestTransport -> IO [Test]

468tests TestTransport{..} = do

239tests TestTransport{..} = do

469 node1 <- newLocalNode testTransport initRemoteTable

240 node1 <- newLocalNode testTransport initRemoteTable

470− node2 <- newLocalNode testTransport initRemoteTable

471 return [

241 return [

472− testGroup "MxAgents" [

242+ testGroup "Mx Agents" [

473− testCase "EventHandling"

243+ testCase "Event Handling"

474− (delayedAssertion

244+ (delayedAssertion

475− "expected True, but events where not as expected"

245+ "expected True, but events where not as expected"

476− node1 True testAgentEventHandling)

246+ node1 True testAgentEventHandling)

477− , testCase "InterAgentBroadcast"

247+ , testCase "Inter-Agent Broadcast"

478− (delayedAssertion

248+ (delayedAssertion

479− "expected (), but no broadcast was received"

249+ "expected (), but no broadcast was received"

480− node1 (Just ()) testAgentBroadcast)

250+ node1 () testAgentBroadcast)

481− , testCase "AgentMailboxHandling"

251+ , testCase "Agent Mailbox Handling"

482− (delayedAssertion

252+ (delayedAssertion

483− "expected (Just ()), but no regular (mailbox) input was handled"

253+ "expected (Just ()), but no regular (mailbox) input was handled"

484− node1 (Just ()) testAgentMailboxHandling)

254+ node1 (Just ()) testAgentMailboxHandling)

485− , testCase "AgentDualInputHandling"

255+ , testCase "Agent Dual Input Handling"

486− (delayedAssertion

256+ (delayedAssertion

487− "expected sum = 15, but the result was Nothing"

257+ "expected sum = 15, but the result was Nothing"

488− node1 (Just 15 :: Maybe Int) testAgentDualInput)

258+ node1 (Just 15 :: Maybe Int) testAgentDualInput)

489− , testCase "AgentInputPrioritisation"

259+ , testCase "Agent Input Prioritisation"

490− (delayedAssertion

260+ (delayedAssertion

491− "expected [first, second, third, fourth, fifth], but result diverged"

261+ "expected [first, second, third, fourth, fifth], but result diverged"

492− node1 (sort ["first", "second",

262+ node1 (sort ["first", "second",

493− "third", "fourth",

263+ "third", "fourth",

494− "fifth"]) testAgentPrioritisation)

264+ "fifth"]) testAgentPrioritisation)

495− ]

265+ ],

496− , testGroup "MxEvents" [

266+ testGroup "Mx Global Properties" [

497− testCase "NameRegistrationEvents"

267+ testCase "Global Property Publication"

498− (delayedAssertion

268+ (delayedAssertion

499− "expected registration events to map to the correct ProcessId"

269+ "expected (Just Publish), but no table entry was found"

500− node1 () testMxRegEvents)

270+ node1 (Just Publish) testAgentPublication)

501− , testCase "PostDeathNameUnRegistrationEvents"

271+ , testCase "Clearing Global Properties"

272+ (delayedAssertion

273+ "expected (Just 1024, Nothing): invalid table entry found!"

274+ node1 (Just 1024, Nothing) (testAgentTableClear 1024))

275+ , testCase "Purging Global Tables"

276+ (delayedAssertion

277+ "expected Nothing, but a table entry was found"

278+ node1 Nothing testAgentTablePurge)

279+ , testCase "Deleting and (Re)Creating Global Tables"

502− (delayedAssertion

280+ (delayedAssertion

503− "expected process deaths to result in unregistration events"

281+ "expected (Just 15, Nothing, Just 15): invalid table entry found!"

504− node1 () (testMxRegMon node2))

282+ node1 (Just 15, Nothing, Just 15) (testAgentTableDelete 15))

505− , testGroup "SendEvents" $ buildTestCases node1 node2

283+ -- Wait for other tests to finish.

506− ]

284+ , testCase "Wait" $

507− ]

285+ threadDelay 100000

508− where

509− buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [

510− ("NSend", [

511− ("nsend", testNSend nsend)

512− , ("Unsafe.nsend", testNSend Unsafe.nsend)

513− , ("nsendRemote", testNSend (nsendRemote nid))

514− , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))

515− ])

516− , ("Send", [

517− ("send", testSend send)

518− , ("Unsafe.send", testSend Unsafe.send)

519− , ("usend", testSend usend)

520− , ("Unsafe.usend", testSend Unsafe.usend)

521− , ("sendChan", testChan sendChan)

522− , ("Unsafe.sendChan", testChan Unsafe.sendChan)

523− ])

524− , ("Forward", [

525− ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))

526− , ("uforward", testSend (\p m -> uforward (unsafeCreateUnencodedMessage m) p))

527− ])

528− ]

529−

530− build :: LocalNode

531− -> LocalNode

532− -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

533− -> [Test]

534− build n ln specs =

535− [ testGroup (intercalate "-" [groupName, caseSuffix]) [

536− testCase (intercalate "-" [caseName, caseSuffix])

537− (runProcess n (caseImpl caseNode))

538− | (caseName, caseImpl) <- groupCases

539− ]

540− | (groupName, groupCases) <- specs

541− , (caseSuffix, caseNode) <- [("RemotePid", Just ln), ("LocalPid", Nothing)]

542− ]

286+ ]]

distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs+12−8

@@ -1,4 +1,4 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}

2{-# OPTIONS_GHC -Wall #-}

4-- | XXX test doesn't work, because failure exceptions don't get propagated. The

@@ -10,12 +10,16 @@ import Network.Transport.Test (TestTransport(..))

11import Network.Transport (Transport)

12import Control.Distributed.Process

13+import Control.Distributed.Process.Closure

13import Control.Distributed.Process.Node

14import Control.Distributed.Process.Node

15import Control.Monad

16import Control.Monad

17+import Text.Printf

18+import Data.Binary

19+import Data.Typeable

17import Test.HUnit (Assertion, (@?=))

21import Test.HUnit (Assertion, (@?=))

18−import Test.Framework (Test)

22+import Test.Framework (Test, defaultMain)

19import Test.Framework.Providers.HUnit (testCase)

23import Test.Framework.Providers.HUnit (testCase)

21-- Tests:

25-- Tests:

@@ -42,7 +46,7 @@ recTest2 :: ReceivePort ()

42 -> SendPort String

46 -> SendPort String

43 -> ReceivePort String -> ReceivePort String

47 -> ReceivePort String -> ReceivePort String

44 -> Process ()

48 -> Process ()

45−recTest2 wait sync r1 _ = do

49+recTest2 wait sync r1 r2 = do

46 forever $ do

50 forever $ do

47 receiveChan wait

51 receiveChan wait

48 r <- receiveWait

52 r <- receiveWait

@@ -55,7 +59,7 @@ recTest3 :: ReceivePort ()

55 -> SendPort String

59 -> SendPort String

56 -> ReceivePort String -> ReceivePort String

60 -> ReceivePort String -> ReceivePort String

57 -> Process ()

61 -> Process ()

58−recTest3 wait sync r1 _ = do

62+recTest3 wait sync r1 r2 = do

59 forever $ do

63 forever $ do

60 receiveChan wait

64 receiveChan wait

61 r <- receiveWait

65 r <- receiveWait

@@ -68,7 +72,7 @@ recTest4 :: ReceivePort ()

68 -> SendPort String

72 -> SendPort String

69 -> ReceivePort String -> ReceivePort String

73 -> ReceivePort String -> ReceivePort String

70 -> Process ()

74 -> Process ()

71−recTest4 wait sync r1 _ = do

75+recTest4 wait sync r1 r2 = do

72 forever $ do

76 forever $ do

73 receiveChan wait

77 receiveChan wait

74 r <- receiveWait

78 r <- receiveWait

@@ -82,11 +86,11 @@ master :: Process ()

82master = do

86master = do

83 (waits,waitr) <- newChan

87 (waits,waitr) <- newChan

84 (syncs,syncr) <- newChan

88 (syncs,syncr) <- newChan

85− let go expected = do

89+ let go expect = do

86 sendChan waits ()

90 sendChan waits ()

87 r <- receiveChan syncr

91 r <- receiveChan syncr

88− liftIO $ print (r, expected, r == expected)

92+ liftIO $ print (r,expect, r == expect)

89− liftIO $ r @?= expected

93+ liftIO $ r @?= expect

91 liftIO $ putStrLn "---- Test 1 ----"

95 liftIO $ putStrLn "---- Test 1 ----"

92 (s1,r1) <- newChan

96 (s1,r1) <- newChan

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+7−11

@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)

30testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()

31testLocalDeadProcessInfo result = do

32− pid <- spawnLocal $ do (_ :: String) <- expect; return ()

32+ pid <- spawnLocal $ do "finish" <- expect; return ()

33 mref <- monitor pid

34 send pid "finish"

35 _ <- receiveWait [

@@ -52,10 +52,8 @@ testLocalLiveProcessInfo result = do

52 link self

53 mRef <- monitor self

54 stash mon mRef

55− res <- expect

55+ "die" <- expect

56− case res of

57− "die" -> return ()

56+ return ()

58− _ -> die $ "unexpected message received: " ++ res

60 monRef <- liftIO $ takeMVar mon

58 monRef <- liftIO $ takeMVar mon

@@ -86,9 +84,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

86 -- our send op shouldn't overtake link or monitor requests AFAICT

84 -- our send op shouldn't overtake link or monitor requests AFAICT

87 -- so a little table tennis should get us synchronised properly

85 -- so a little table tennis should get us synchronised properly

88 send serverPid (self, "ping")

86 send serverPid (self, "ping")

89− pong <- expect

87+ "pong" <- expect

90 pInfo <- getProcessInfo serverPid

88 pInfo <- getProcessInfo serverPid

91− stash result $ pong == "pong" && pInfo /= Nothing

89+ stash result $ pInfo /= Nothing

92 where

90 where

93 launchRemote :: MVar ProcessId -> IO ()

91 launchRemote :: MVar ProcessId -> IO ()

94 launchRemote locMV = do

92 launchRemote locMV = do

@@ -99,10 +97,8 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

99 _ <- receiveWait [

97 _ <- receiveWait [

100 match (\(pid, "ping") -> send pid "pong")

98 match (\(pid, "ping") -> send pid "pong")

101 ]

99 ]

102− res <- expect

100+ "stop" <- expect

103− case res of

104− "stop" -> return ()

101+ return ()

105− _ -> die $ "unexpected message received: " ++ res

106 return ()

102 return ()

107

103

108 withActiveRemote :: LocalNode

104 withActiveRemote :: LocalNode

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+11−23

@@ -125,11 +125,9 @@ testTraceSending result = do

125 (\ev ->

126 case ev of

127 (MxSent to from msg) -> do

128− mS <- unwrapMessage msg :: Process (Maybe String)

128+ (Just s) <- unwrapMessage msg :: Process (Maybe String)

129− case mS of

130− (Just s) -> do stash res (to == pid && from == self && s == "hello there")

129+ stash res (to == pid && from == self && s == "hello there")

131− stash res (to == pid && from == self)

130+ stash res (to == pid && from == self)

132− _ -> die "failed state invariant, message type unmatched..."

133 _ ->

131 _ ->

134 return ()) $ do

132 return ()) $ do

135 send pid "hello there"

133 send pid "hello there"

@@ -248,8 +246,12 @@ testRemoteTraceRelay TestTransport{..} result =

248 -- Here we set up that relay, and then wait for a signal

246 -- Here we set up that relay, and then wait for a signal

249 -- that the tracer (on node1) has seen the expected

247 -- that the tracer (on node1) has seen the expected

250 -- MxSpawned message, at which point we're finished

248 -- MxSpawned message, at which point we're finished

249+ (Just log') <- whereis "logger"

250+ pid <- liftIO $ forkProcess node2 $ do

251+ logRelay <- spawnLocal $ relay log'

252+ reregister "logger" logRelay

253+ getSelfNode >>= stash mvNid >> (expect :: Process ())

251

254

252− pid <- splinchLogger node2 mvNid

253 nid <- liftIO $ takeMVar mvNid

255 nid <- liftIO $ takeMVar mvNid

254 mref <- monitor pid

256 mref <- monitor pid

255 observedPid <- liftIO $ newEmptyMVar

257 observedPid <- liftIO $ newEmptyMVar

@@ -289,17 +291,6 @@ testRemoteTraceRelay TestTransport{..} result =

289 -- and just to be polite...

291 -- and just to be polite...

290 liftIO $ closeLocalNode node2

292 liftIO $ closeLocalNode node2

291

293

292− where

293− splinchLogger n2 mv = do

294− mLog <- whereis "logger"

295− case mLog of

296− Nothing -> die "no logger registered"

297− Just log' -> do liftIO $ forkProcess n2 $ do

298− logRelay <- spawnLocal $ relay log'

299− reregister "logger" logRelay

300− getSelfNode >>= stash mv >> (expect :: Process ())

301−

302−

303-- | Sets the value of an environment variable while executing the given IO

294-- | Sets the value of an environment variable while executing the given IO

304-- computation and restores the preceeding value upon completion.

295-- computation and restores the preceeding value upon completion.

305withEnv :: String -> String -> IO a -> IO a

296withEnv :: String -> String -> IO a -> IO a

@@ -328,12 +319,9 @@ testSystemLoggerMsg t action interestingMessage =

328 -- Wait for the trace message.

319 -- Wait for the trace message.

329 receiveWait [ matchIf interestingMessage' $ const $ return () ]

320 receiveWait [ matchIf interestingMessage' $ const $ return () ]

330 -- Only one interesting message should arrive.

321 -- Only one interesting message should arrive.

331− expectedTimeout <- receiveTimeout

322+ Nothing <- receiveTimeout 100000

332− 100000

333− [ matchIf interestingMessage' $ const $ return () ]

323+ [ matchIf interestingMessage' $ const $ return () ]

334− case expectedTimeout of

335− Nothing -> return ()

324+ return ()

336− Just _ -> die "Unexpected message arrived..."

337

325

338

326

339-- | Tests that one and only one trace message is produced when a message is

327-- | Tests that one and only one trace message is produced when a message is

distributed-process-tests/tests/runInMemory.hs+1

@@ -8,6 +8,7 @@ import Network.Transport.Test (TestTransport(..))

8import Network.Transport.InMemory

9import Test.Framework (defaultMainWithArgs)

11+import Control.Concurrent (threadDelay)

11import System.Environment (getArgs)

12import System.Environment (getArgs)

13main :: IO ()

14main :: IO ()

distributed-process-tests/tests/runTCP.hs+3−5

@@ -10,13 +10,11 @@ import Network.Transport.TCP

10 ( createTransportExposeInternals

11 , TransportInternals(socketBetween)

12 , defaultTCPParameters

13− , defaultTCPAddr

14 , TCPParameters(..)

13 , TCPParameters(..)

15 )

14 )

16import Test.Framework (defaultMainWithArgs)

15import Test.Framework (defaultMainWithArgs)

18import Control.Concurrent (threadDelay)

17import Control.Concurrent (threadDelay)

19−import Control.Exception (IOException, try)

20import System.Environment (getArgs)

18import System.Environment (getArgs)

21import System.IO

19import System.IO

@@ -25,13 +23,13 @@ main = do

25 hSetBuffering stdout LineBuffering

23 hSetBuffering stdout LineBuffering

26 hSetBuffering stderr LineBuffering

24 hSetBuffering stderr LineBuffering

27 Right (transport, internals) <-

25 Right (transport, internals) <-

28− createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")

26+ createTransportExposeInternals "127.0.0.1" "8080"

29 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

27 defaultTCPParameters { transportConnectTimeout = Just 3000000 }

30 ts <- tests TestTransport

28 ts <- tests TestTransport

31 { testTransport = transport

29 { testTransport = transport

32 , testBreakConnection = \addr1 addr2 -> do

30 , testBreakConnection = \addr1 addr2 -> do

33− esock <- try $ socketBetween internals addr1 addr2

31+ sock <- socketBetween internals addr1 addr2

34− either (\e -> const (return ()) (e :: IOException)) sClose esock

32+ sClose sock

35 threadDelay 10000

33 threadDelay 10000

36 }

34 }

37 args <- getArgs

35 args <- getArgs

distributed-process.cabal+38−51

@@ -1,12 +1,12 @@

1Name: distributed-process

2−Version: 0.7.4

2+Version: 0.6.0

3Cabal-Version: >=1.8

4Build-Type: Simple

5License: BSD3

6License-File: LICENSE

7Copyright: Well-Typed LLP, Tweag I/O Limited

8Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9−Maintainer: Tim Watson <watson.timothy@gmail.com>

9+Maintainer: Facundo Domínguez <facundo.dominguez@tweag.io>

10Stability: experimental

11Homepage: http://haskell-distributed.github.com/

12Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues

@@ -21,7 +21,7 @@ Description: This is an implementation of Cloud Haskell, as described in

22 You will probably also want to install a Cloud Haskell backend such

23 as distributed-process-simplelocalnet.

24−Tested-With: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 GHC==8.4.4

24+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2 GHC==7.6.2

25Category: Control

26extra-source-files: ChangeLog

@@ -41,26 +41,24 @@ flag old-locale

41 default: False

43Library

44− Build-Depends: base >= 4.6 && < 5,

44+ Build-Depends: base >= 4.4 && < 5,

45− binary >= 0.6.3 && < 0.10,

45+ binary >= 0.6.3 && < 0.8,

46 hashable >= 1.2.0.5 && < 1.3,

47− network-transport >= 0.4.1.0 && < 0.6,

47+ network-transport >= 0.4.1.0 && < 0.5,

48− stm >= 2.4 && < 2.6,

48+ stm >= 2.4 && < 2.5,

49− transformers >= 0.2 && < 0.6,

49+ transformers >= 0.2 && < 0.5,

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+ ghc-prim >= 0.2 && < 0.5,

54 distributed-static >= 0.2 && < 0.4,

55 distributed-static >= 0.2 && < 0.4,

55− rank1dynamic >= 0.1 && < 0.5,

56+ rank1dynamic >= 0.1 && < 0.4,

56− syb >= 0.3 && < 0.8,

57+ syb >= 0.3 && < 0.7,

57− exceptions >= 0.5,

58+ exceptions >= 0.5

58− containers >= 0.5 && < 0.7,

59− deepseq >= 1.3.0.1 && < 1.6

60 Exposed-modules: Control.Distributed.Process,

59 Exposed-modules: Control.Distributed.Process,

61 Control.Distributed.Process.Closure,

60 Control.Distributed.Process.Closure,

62 Control.Distributed.Process.Debug,

61 Control.Distributed.Process.Debug,

63− Control.Distributed.Process.Internal.BiMultiMap,

64 Control.Distributed.Process.Internal.Closure.BuiltIn,

62 Control.Distributed.Process.Internal.Closure.BuiltIn,

65 Control.Distributed.Process.Internal.Closure.Explicit,

63 Control.Distributed.Process.Internal.Closure.Explicit,

66 Control.Distributed.Process.Internal.CQueue,

64 Control.Distributed.Process.Internal.CQueue,

@@ -78,6 +76,7 @@ Library

78 Control.Distributed.Process.UnsafePrimitives

76 Control.Distributed.Process.UnsafePrimitives

79 Control.Distributed.Process.Management.Internal.Agent,

77 Control.Distributed.Process.Management.Internal.Agent,

80 Control.Distributed.Process.Management.Internal.Bus,

78 Control.Distributed.Process.Management.Internal.Bus,

79+ Control.Distributed.Process.Management.Internal.Table,

81 Control.Distributed.Process.Management.Internal.Types,

80 Control.Distributed.Process.Management.Internal.Types,

82 Control.Distributed.Process.Management.Internal.Trace.Primitives,

81 Control.Distributed.Process.Management.Internal.Trace.Primitives,

83 Control.Distributed.Process.Management.Internal.Trace.Remote,

82 Control.Distributed.Process.Management.Internal.Trace.Remote,

@@ -85,33 +84,21 @@ Library

85 Control.Distributed.Process.Management.Internal.Trace.Tracer

84 Control.Distributed.Process.Management.Internal.Trace.Tracer

86 ghc-options: -Wall

85 ghc-options: -Wall

87 HS-Source-Dirs: src

86 HS-Source-Dirs: src

88− other-extensions: BangPatterns

87+ if impl(ghc <= 7.4.2)

89− CPP

88+ Build-Depends: containers >= 0.4 && < 0.5,

90− DeriveDataTypeable

89+ deepseq == 1.3.0.0

91− DeriveFunctor

90+ else

92− DeriveGeneric

91+ Build-Depends: containers >= 0.4 && < 0.6,

93− ExistentialQuantification

92+ deepseq >= 1.3.0.1 && < 1.6

94− FlexibleInstances

95− GADTs

96− GeneralizedNewtypeDeriving

97− KindSignatures

98− MagicHash

99− PatternGuards

100− RankNTypes

101− RecordWildCards

102− ScopedTypeVariables

103− StandaloneDeriving

104− TypeFamilies

105− TypeSynonymInstances

106− UnboxedTuples

107− UndecidableInstances

108 if flag(old-locale)

93 if flag(old-locale)

109 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

94 Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

110 else

95 else

111 Build-Depends: time >= 1.5

96 Build-Depends: time >= 1.5

112 if flag(th)

97 if flag(th)

113− other-extensions: TemplateHaskell

98+ if impl(ghc <= 7.4.2)

99+ Build-Depends: template-haskell >= 2.7 && < 2.8

100+ else

114− Build-Depends: template-haskell >= 2.6

101+ Build-Depends: template-haskell >= 2.6 && < 2.11

115 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

102 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

116 CPP-Options: -DTemplateHaskellSupport

103 CPP-Options: -DTemplateHaskellSupport

117

104

@@ -119,50 +106,50 @@ Library

119

106

120benchmark distributed-process-throughput

107benchmark distributed-process-throughput

121 Type: exitcode-stdio-1.0

108 Type: exitcode-stdio-1.0

122− Build-Depends: base >= 4.6 && < 5,

109+ Build-Depends: base >= 4.4 && < 5,

123 distributed-process,

110 distributed-process,

124− network-transport-tcp >= 0.3 && < 0.7,

111+ network-transport-tcp >= 0.3 && < 0.6,

125 bytestring >= 0.9 && < 0.11,

112 bytestring >= 0.9 && < 0.11,

126− binary >= 0.6.3 && < 0.10

113+ binary >= 0.6.3 && < 0.8

127 Main-Is: benchmarks/Throughput.hs

114 Main-Is: benchmarks/Throughput.hs

128 ghc-options: -Wall

115 ghc-options: -Wall

129

116

130benchmark distributed-process-latency

117benchmark distributed-process-latency

131 Type: exitcode-stdio-1.0

118 Type: exitcode-stdio-1.0

132− Build-Depends: base >= 4.6 && < 5,

119+ Build-Depends: base >= 4.4 && < 5,

133 distributed-process,

120 distributed-process,

134− network-transport-tcp >= 0.3 && < 0.7,

121+ network-transport-tcp >= 0.3 && < 0.6,

135 bytestring >= 0.9 && < 0.11,

122 bytestring >= 0.9 && < 0.11,

136− binary >= 0.6.3 && < 0.10

123+ binary >= 0.6.3 && < 0.8

137 Main-Is: benchmarks/Latency.hs

124 Main-Is: benchmarks/Latency.hs

138 ghc-options: -Wall

125 ghc-options: -Wall

139

126

140benchmark distributed-process-channels

127benchmark distributed-process-channels

141 Type: exitcode-stdio-1.0

128 Type: exitcode-stdio-1.0

142− Build-Depends: base >= 4.6 && < 5,

129+ Build-Depends: base >= 4.4 && < 5,

143 distributed-process,

130 distributed-process,

144− network-transport-tcp >= 0.3 && < 0.7,

131+ network-transport-tcp >= 0.3 && < 0.6,

145 bytestring >= 0.9 && < 0.11,

132 bytestring >= 0.9 && < 0.11,

146− binary >= 0.6.3 && < 0.10

133+ binary >= 0.6.3 && < 0.8

147 Main-Is: benchmarks/Channels.hs

134 Main-Is: benchmarks/Channels.hs

148 ghc-options: -Wall

135 ghc-options: -Wall

149

136

150benchmark distributed-process-spawns

137benchmark distributed-process-spawns

151 Type: exitcode-stdio-1.0

138 Type: exitcode-stdio-1.0

152− Build-Depends: base >= 4.6 && < 5,

139+ Build-Depends: base >= 4.4 && < 5,

153 distributed-process,

140 distributed-process,

154− network-transport-tcp >= 0.3 && < 0.7,

141+ network-transport-tcp >= 0.3 && < 0.6,

155 bytestring >= 0.9 && < 0.11,

142 bytestring >= 0.9 && < 0.11,

156− binary >= 0.6.3 && < 0.10

143+ binary >= 0.6.3 && < 0.8

157 Main-Is: benchmarks/Spawns.hs

144 Main-Is: benchmarks/Spawns.hs

158 ghc-options: -Wall

145 ghc-options: -Wall

159

146

160benchmark distributed-process-ring

147benchmark distributed-process-ring

161 Type: exitcode-stdio-1.0

148 Type: exitcode-stdio-1.0

162− Build-Depends: base >= 4.6 && < 5,

149+ Build-Depends: base >= 4.4 && < 5,

163 distributed-process,

150 distributed-process,

164− network-transport-tcp >= 0.3 && < 0.7,

151+ network-transport-tcp >= 0.3 && < 0.6,

165 bytestring >= 0.9 && < 0.11,

152 bytestring >= 0.9 && < 0.11,

166− binary >= 0.6.3 && < 0.10

153+ binary >= 0.6.3 && < 0.8

167 Main-Is: benchmarks/ProcessRing.hs

154 Main-Is: benchmarks/ProcessRing.hs

168 ghc-options: -Wall -threaded -O2 -rtsopts

155 ghc-options: -Wall -threaded -O2 -rtsopts

src/Control/Distributed/Process.hs+4−28

@@ -102,7 +102,6 @@ module Control.Distributed.Process

102 , monitorPort

103 , unmonitor

104 , withMonitor

105− , withMonitor_

106 , MonitorRef -- opaque

105 , MonitorRef -- opaque

107 , ProcessLinkException(..)

106 , ProcessLinkException(..)

108 , NodeLinkException(..)

107 , NodeLinkException(..)

@@ -163,7 +162,6 @@ module Control.Distributed.Process

163import Control.Monad.IO.Class (liftIO)

162import Control.Monad.IO.Class (liftIO)

164import Control.Applicative

163import Control.Applicative

165import Control.Monad.Reader (ask)

164import Control.Monad.Reader (ask)

166−import Control.Concurrent (killThread)

167import Control.Concurrent.MVar

165import Control.Concurrent.MVar

168 ( MVar

166 ( MVar

169 , newEmptyMVar

167 , newEmptyMVar

@@ -198,7 +196,6 @@ import Control.Distributed.Process.Internal.Types

198 , RegisterReply(..)

196 , RegisterReply(..)

199 , LocalProcess(processNode)

197 , LocalProcess(processNode)

200 , Message

198 , Message

201− , localProcessWithId

202 )

199 )

203import Control.Distributed.Process.Serializable (Serializable)

200import Control.Distributed.Process.Serializable (Serializable)

204import Control.Distributed.Process.Internal.Primitives

201import Control.Distributed.Process.Internal.Primitives

@@ -270,7 +267,6 @@ import Control.Distributed.Process.Internal.Primitives

270 , monitorPort

267 , monitorPort

271 , unmonitor

268 , unmonitor

272 , withMonitor

269 , withMonitor

273− , withMonitor_

274 -- Logging

270 -- Logging

275 , say

271 , say

276 -- Registry

272 -- Registry

@@ -307,10 +303,6 @@ import Control.Distributed.Process.Internal.Primitives

307 , reconnectPort

303 , reconnectPort

308 )

304 )

309import Control.Distributed.Process.Node (forkProcess)

305import Control.Distributed.Process.Node (forkProcess)

310−import Control.Distributed.Process.Internal.Types

311− ( processThread

312− , withValidLocalState

313− )

314import Control.Distributed.Process.Internal.Spawn

306import Control.Distributed.Process.Internal.Spawn

315 ( -- Spawning Processes/Channels

307 ( -- Spawning Processes/Channels

316 spawn

308 spawn

@@ -327,10 +319,6 @@ import Prelude

327#else

319#else

328import Prelude hiding (catch)

320import Prelude hiding (catch)

329#endif

321#endif

330−import qualified Control.Exception as Exception (onException)

331−import Data.Accessor ((^.))

332−import Data.Foldable (forM_)

333−

334

322

335-- INTERNAL NOTES

323-- INTERNAL NOTES

336--

324--

@@ -428,20 +416,8 @@ spawnChannelLocal proc = do

428-- Silently dropping messages may not always be the best approach.

416-- Silently dropping messages may not always be the best approach.

429callLocal :: Process a -> Process a

417callLocal :: Process a -> Process a

430callLocal proc = Catch.mask $ \release -> do

418callLocal proc = Catch.mask $ \release -> do

431− mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

419+ mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

432 child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

420 child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

433− lproc <- ask

421+ rs <- liftIO (takeMVar mv) `Catch.onException`

434− liftIO $ do

422+ (kill child "exception in parent process" >> liftIO (takeMVar mv))

435− rs <- Exception.onException (takeMVar mv) $ Catch.uninterruptibleMask_ $

436− -- Exceptions need to be prevented from interrupting the clean up or

437− -- the original exception which caused entering the handler could be

438− -- forgotten. For instance, this could have a problematic effect

439− -- when the original exception was meant to kill the thread and the

440− -- second exception doesn't (like the exception thrown by

441− -- 'System.Timeout.timeout').

442− do mchildThreadId <- withValidLocalState (processNode lproc) $

443− \vst -> return $ fmap processThread $

444− vst ^. localProcessWithId (processLocalId child)

445− forM_ mchildThreadId killThread

446− takeMVar mv

447− either Catch.throwM return rs

423+ either Catch.throwM return rs

src/Control/Distributed/Process/Debug.hs+7−3

@@ -141,14 +141,17 @@ module Control.Distributed.Process.Debug

141 )

142 where

143

144−import Control.Applicative

144+import Control.Applicative ((<$>))

145import Control.Distributed.Process.Internal.Primitives

146 ( proxy

147+ , finally

147 , die

148 , die

148 , whereis

149 , whereis

149 , send

150 , send

150 , receiveWait

151 , receiveWait

151 , matchIf

152 , matchIf

153+ , finally

154+ , try

152 , monitor

155 , monitor

153 )

156 )

154import Control.Distributed.Process.Internal.Types

157import Control.Distributed.Process.Internal.Types

@@ -193,11 +196,12 @@ import Control.Exception (SomeException)

193

196

194import Control.Monad.IO.Class (liftIO)

197import Control.Monad.IO.Class (liftIO)

195import Control.Monad.Reader (ask)

198import Control.Monad.Reader (ask)

196−import Control.Monad.Catch (finally, try)

197

199

198import Data.Binary()

200import Data.Binary()

199

201

202+#if ! MIN_VERSION_base(4,6,0)

200−import Prelude

203+import Prelude hiding (catch)

204+#endif

201

205

202--------------------------------------------------------------------------------

206--------------------------------------------------------------------------------

203-- Debugging/Tracing API --

207-- Debugging/Tracing API --

src/Control/Distributed/Process/Internal/BiMultiMap.hsdeleted−135

@@ -1,135 +0,0 @@

1−-- | This is an implementation of bidirectional multimaps.

2−module Control.Distributed.Process.Internal.BiMultiMap

3− ( BiMultiMap

4− , empty

5− , singleton

6− , size

7− , insert

8− , lookupBy1st

9− , lookupBy2nd

10− , delete

11− , deleteAllBy1st

12− , deleteAllBy2nd

13− , partitionWithKeyBy1st

14− , partitionWithKeyBy2nd

15− , flip

16− ) where

17−

18−import Data.List (foldl')

19−import Data.Map.Strict (Map)

20−import qualified Data.Map.Strict as Map

21−import Data.Set (Set)

22−import qualified Data.Set as Set

23−import Prelude hiding (flip, lookup)

24−

25−-- | A bidirectional multimaps @BiMultiMap a b v@ is a set of triplets of type

26−-- @(a, b, v)@.

27−--

28−-- It is possible to lookup values by using either @a@ or @b@ as keys.

29−--

30−data BiMultiMap a b v = BiMultiMap !(Map a (Set (b, v))) !(Map b (Set (a, v)))

31−

32−-- The bidirectional multimap is implemented with a pair of multimaps.

33−--

34−-- Each multimap represents a set of triples, and one invariant is that both

35−-- multimaps should represent exactly the same set of triples.

36−--

37−-- Each of the multimaps, however, uses a different component of the triplets

38−-- as key. This allows to do efficient deletions by any of the two components.

39−

40−-- | The empty bidirectional multimap.

41−empty :: BiMultiMap a b v

42−empty = BiMultiMap Map.empty Map.empty

43−

44−-- | A bidirectional multimap containing a single triplet.

45−singleton :: (Ord a, Ord b, Ord v) => a -> b -> v -> BiMultiMap a b v

46−singleton a b v = insert a b v empty

47−

48−-- | Yields the amount of triplets in the multimap.

49−size :: BiMultiMap a b v -> Int

50−size (BiMultiMap m _) = foldl' (+) 0 $ map Set.size $ Map.elems m

51−

52−-- | Inserts a triplet in the multimap.

53−insert :: (Ord a, Ord b, Ord v)

54− => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

55−insert a b v (BiMultiMap m r) =

56− BiMultiMap (Map.insertWith (\_new old -> Set.insert (b, v) old)

57− a

58− (Set.singleton (b, v))

59− m)

60− (Map.insertWith (\_new old -> Set.insert (a, v) old)

61− b

62− (Set.singleton (a, v))

63− r)

64−

65−-- | Looks up all the triplets whose first component is the given value.

66−lookupBy1st :: Ord a => a -> BiMultiMap a b v -> Set (b, v)

67−lookupBy1st a (BiMultiMap m _) = maybe Set.empty id $ Map.lookup a m

68−

69−-- | Looks up all the triplets whose second component is the given value.

70−lookupBy2nd :: Ord b => b -> BiMultiMap a b v -> Set (a, v)

71−lookupBy2nd b = lookupBy1st b . flip

72−

73−-- | Deletes a triplet. It yields the original multimap if the triplet is

74−-- not present.

75−delete :: (Ord a, Ord b, Ord v)

76− => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v

77−delete a b v (BiMultiMap m r) =

78− let m' = Map.update (nothingWhen Set.null . Set.delete (b, v)) a m

79− r' = Map.update (nothingWhen Set.null . Set.delete (a, v)) b r

80− in BiMultiMap m' r'

81−

82−-- | Deletes all triplets whose first component is the given value.

83−deleteAllBy1st :: (Ord a, Ord b, Ord v) => a -> BiMultiMap a b v -> BiMultiMap a b v

84−deleteAllBy1st a (BiMultiMap m r) =

85− let (mm, m') = Map.updateLookupWithKey (\_ _ -> Nothing) a m

86− r' = case mm of

87− Nothing -> r

88− Just mb -> reverseDelete a (Set.toList mb) r

89− in BiMultiMap m' r'

90−

91−-- | Like 'deleteAllBy1st' but deletes by the second component of the triplets.

92−deleteAllBy2nd :: (Ord a, Ord b, Ord v)

93− => b -> BiMultiMap a b v -> BiMultiMap a b v

94−deleteAllBy2nd b = flip . deleteAllBy1st b . flip

95−

96−-- | Yields the triplets satisfying the given predicate, and a multimap

97−-- with all this triplets removed.

98−partitionWithKeyBy1st :: (Ord a, Ord b, Ord v)

99− => (a -> Set (b, v) -> Bool) -> BiMultiMap a b v

100− -> (Map a (Set (b, v)), BiMultiMap a b v)

101−partitionWithKeyBy1st p (BiMultiMap m r) =

102− let (m0, m1) = Map.partitionWithKey p m

103− r1 = foldl' (\rr (a, mb) -> reverseDelete a (Set.toList mb) rr) r $

104− Map.toList m0

105− in (m0, BiMultiMap m1 r1)

106−

107−-- | Like 'partitionWithKeyBy1st' but the predicates takes the second component

108−-- of the triplets as first argument.

109−partitionWithKeyBy2nd :: (Ord a, Ord b, Ord v)

110− => (b -> Set (a, v) -> Bool) -> BiMultiMap a b v

111− -> (Map b (Set (a, v)), BiMultiMap a b v)

112−partitionWithKeyBy2nd p b = let (m, b') = partitionWithKeyBy1st p $ flip b

113− in (m, flip b')

114−

115−-- | Exchange the first and the second components of all triplets.

116−flip :: BiMultiMap a b v -> BiMultiMap b a v

117−flip (BiMultiMap m r) = BiMultiMap r m

118−

119−-- Internal functions

120−

121−-- | @reverseDelete a bs m@ removes from @m@ all the triplets wich have @a@ as

122−-- first component and second and third components in @bs@.

123−--

124−-- The @m@ map is in reversed form, meaning that the second component of the

125−-- triplets is used as key.

126−reverseDelete :: (Ord a, Ord b, Ord v)

127− => a -> [(b, v)] -> Map b (Set (a, v)) -> Map b (Set (a, v))

128−reverseDelete a bs r = foldl' (\rr (b, v) -> Map.update (rmb v) b rr) r bs

129− where

130− rmb v = nothingWhen Set.null . Set.delete (a, v)

131−

132−-- | @nothingWhen p a@ is @Just a@ when @a@ satisfies predicate @p@.

133−-- Yields @Nothing@ otherwise.

134−nothingWhen :: (a -> Bool) -> a -> Maybe a

135−nothingWhen p a = if p a then Nothing else Just a

src/Control/Distributed/Process/Internal/CQueue.hs+2−31

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

1{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards, ScopedTypeVariables, RankNTypes #-}

3{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards, ScopedTypeVariables, RankNTypes #-}

@@ -47,8 +46,8 @@ import Control.Distributed.Process.Internal.StrictList

47import Data.Maybe (fromJust)

46import Data.Maybe (fromJust)

48import Data.Traversable (traverse)

47import Data.Traversable (traverse)

49import GHC.MVar (MVar(MVar))

48import GHC.MVar (MVar(MVar))

50−import GHC.IO (IO(IO), unIO)

49+import GHC.IO (IO(IO))

51−import GHC.Exts (mkWeak#)

50+import GHC.Prim (mkWeak#)

52import GHC.Weak (Weak(Weak))

51import GHC.Weak (Weak(Weak))

54-- We use a TCHan rather than a Chan so that we have a non-blocking read

53-- We use a TCHan rather than a Chan so that we have a non-blocking read

@@ -76,25 +75,13 @@ data BlockSpec =

76 | Blocking

75 | Blocking

77 | Timeout Int

76 | Timeout Int

79−-- Match operations

80−--

81−-- They can be either a message match or a channel match.

82data MatchOn m a

78data MatchOn m a

83 = MatchMsg (m -> Maybe a)

79 = MatchMsg (m -> Maybe a)

84 | MatchChan (STM a)

80 | MatchChan (STM a)

85 deriving (Functor)

81 deriving (Functor)

87−-- Lists of chunks of matches

88−--

89−-- Two consecutive chunks never have the same kind of matches. i.e. if one chunk

90−-- contains message matches then the next one must contain channel matches and

91−-- viceversa.

92type MatchChunks m a = [Either [m -> Maybe a] [STM a]]

83type MatchChunks m a = [Either [m -> Maybe a] [STM a]]

94−-- Splits a list of matches into chunks.

95−--

96−-- > concatMap (either (map MatchMsg) (map MatchChan)) . chunkMatches == id

97−--

98chunkMatches :: [MatchOn m a] -> MatchChunks m a

85chunkMatches :: [MatchOn m a] -> MatchChunks m a

99chunkMatches [] = []

86chunkMatches [] = []

100chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest

87chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest

@@ -102,7 +89,6 @@ chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest

102chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest

89chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest

103 where (chk, rest) = spanMatchChan ms

90 where (chk, rest) = spanMatchChan ms

104

105−-- | @spanMatchMsg = first (map (\(MatchMsg x) -> x)) . span isMatchMsg@

106spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a])

92spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a])

107spanMatchMsg [] = ([],[])

93spanMatchMsg [] = ([],[])

108spanMatchMsg (m : ms)

94spanMatchMsg (m : ms)

@@ -110,7 +96,6 @@ spanMatchMsg (m : ms)

110 | otherwise = ([], m:ms)

96 | otherwise = ([], m:ms)

111 where !(msgs,rest) = spanMatchMsg ms

97 where !(msgs,rest) = spanMatchMsg ms

112

113−-- | @spanMatchMsg = first (map (\(MatchChan x) -> x)) . span isMatchChan@

114spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a])

99spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a])

115spanMatchChan [] = ([],[])

100spanMatchChan [] = ([],[])

116spanMatchChan (m : ms)

101spanMatchChan (m : ms)

@@ -142,7 +127,6 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus

142 -- Decrement counter is smth is returned from the queue,

127 -- Decrement counter is smth is returned from the queue,

143 -- this is safe to use as method is called under a mask

128 -- this is safe to use as method is called under a mask

144 -- and there is no 'unmasked' operation inside

129 -- and there is no 'unmasked' operation inside

145− decrementJust :: IO (Maybe (Either a a)) -> IO (Maybe a)

146 decrementJust f =

130 decrementJust f =

147 traverse (either return (\x -> decrement >> return x)) =<< f

131 traverse (either return (\x -> decrement >> return x)) =<< f

148 decrement = atomically $ modifyTVar' size pred

132 decrement = atomically $ modifyTVar' size pred

@@ -159,10 +143,6 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus

159 arr' <- grabNew arr

143 arr' <- grabNew arr

160 goCheck chunks arr'

144 goCheck chunks arr'

161

145

162− -- Yields the value of the first succesful STM transaction as

163− -- @Just (Left v)@. If all transactions fail, yields the value of the second

164− -- argument.

165− waitChans :: [STM a] -> STM (Maybe (Either a a)) -> STM (Maybe (Either a a))

166 waitChans ports on_block =

146 waitChans ports on_block =

167 foldr orElse on_block (map (fmap (Just . Left)) ports)

147 foldr orElse on_block (map (fmap (Just . Left)) ports)

168

148

@@ -171,10 +151,6 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus

171 -- mailbox. For channel matches, we do a non-blocking check at

151 -- mailbox. For channel matches, we do a non-blocking check at

172 -- this point.

152 -- this point.

173 --

153 --

174− -- Yields @Just (Left a)@ when a channel is matched, @Just (Right a)@

175− -- when a message is matched and @Nothing@ when there are no messages and we

176− -- aren't blocking.

177− --

178 goCheck :: MatchChunks m a

154 goCheck :: MatchChunks m a

179 -> StrictList m -- messages to check, in this order

155 -> StrictList m -- messages to check, in this order

180 -> IO (Maybe (Either a a))

156 -> IO (Maybe (Either a a))

@@ -273,7 +249,6 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus

273 checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)

249 checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)

274 checkArrived matches list = go list Nil

250 checkArrived matches list = go list Nil

275 where

251 where

276− -- @go xs ys@ searches for a message match in @append xs ys@

277 go Nil Nil = (Nil, Nothing)

252 go Nil Nil = (Nil, Nothing)

278 go Nil r = go r Nil

253 go Nil r = go r Nil

279 go (Append xs ys) tl = go xs (append ys tl)

254 go (Append xs ys) tl = go xs (append ys tl)

@@ -290,11 +265,7 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus

290-- | Weak reference to a CQueue

265-- | Weak reference to a CQueue

291mkWeakCQueue :: CQueue a -> IO () -> IO (Weak (CQueue a))

266mkWeakCQueue :: CQueue a -> IO () -> IO (Weak (CQueue a))

292mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _ _) f = IO $ \s ->

267mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _ _) f = IO $ \s ->

293−#if MIN_VERSION_base(4,9,0)

294− case mkWeak# m# m (unIO f) s of (# s1, w #) -> (# s1, Weak w #)

295−#else

296 case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)

268 case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)

297−#endif

298

269

299queueSize :: CQueue a -> IO Int

270queueSize :: CQueue a -> IO Int

300queueSize (CQueue _ _ size) = readTVarIO size

271queueSize (CQueue _ _ size) = readTVarIO size

src/Control/Distributed/Process/Internal/Closure/Explicit.hs+2−1

@@ -6,6 +6,7 @@

6 , UndecidableInstances

7 , KindSignatures

8 , GADTs

9+ , OverlappingInstances

9 , EmptyDataDecls

10 , EmptyDataDecls

10 , DeriveDataTypeable #-}

11 , DeriveDataTypeable #-}

11module Control.Distributed.Process.Internal.Closure.Explicit

12module Control.Distributed.Process.Internal.Closure.Explicit

@@ -108,7 +109,7 @@ instance Binary EndOfTuple where

108class Curry a b | a -> b where

109class Curry a b | a -> b where

109 curryFun :: a -> b

110 curryFun :: a -> b

110

111

111−instance Curry ((a, EndOfTuple) -> b) (a -> b) where

112+instance Curry ((a,EndOfTuple) -> b) (a -> b) where

112 curryFun f = \x -> f (x,undefined)

113 curryFun f = \x -> f (x,undefined)

113

114

114instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where

115instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where

src/Control/Distributed/Process/Internal/Closure/TH.hs+7−15

@@ -29,14 +29,11 @@ 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)

32 , Pred

33 , Pred

33−#if MIN_VERSION_template_haskell(2,10,0)

34− , conT

35− , appT

36−#else

37− , classP

38#endif

34#endif

39 , varT

35 , varT

36+ , classP

40 -- Lifted constructors

37 -- Lifted constructors

41 -- .. Literals

38 -- .. Literals

42 , stringL

39 , stringL

@@ -74,6 +71,10 @@ import Control.Distributed.Process.Serializable

74 )

71 )

75import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

72import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

74+#if MIN_VERSION_template_haskell(2,10,0)

75+type Pred = Type

76+#endif

77+

77--------------------------------------------------------------------------------

78--------------------------------------------------------------------------------

78-- User-level API --

79-- User-level API --

79--------------------------------------------------------------------------------

80--------------------------------------------------------------------------------

@@ -260,12 +261,7 @@ generateStatic n xs typ = do

260 ]

261 ]

261 where

262 where

262 typeable :: TyVarBndr -> Q Pred

263 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

267− classP (mkName "Typeable") [varT (tyVarBndrName tv)]

264+ typeable tv = classP (mkName "Typeable") [varT (tyVarBndrName tv)]

268−#endif

269

265

270-- | Generate a serialization dictionary with name 'n' for type 'typ'

266-- | Generate a serialization dictionary with name 'n' for type 'typ'

271generateDict :: Name -> Type -> Q [Dec]

267generateDict :: Name -> Type -> Q [Dec]

@@ -303,11 +299,7 @@ getType :: Name -> Q (Name, Type)

303getType name = do

299getType name = do

304 info <- reify name

300 info <- reify name

305 case info of

301 case info of

306−#if MIN_VERSION_template_haskell(2,11,0)

307− VarI origName typ _ -> return (origName, typ)

308−#else

309 VarI origName typ _ _ -> return (origName, typ)

302 VarI origName typ _ _ -> return (origName, typ)

310−#endif

311 _ -> fail $ show name ++ " not found"

303 _ -> fail $ show name ++ " not found"

312

304

313-- | Variation on 'funD' which takes a single expression to define the function

305-- | Variation on 'funD' which takes a single expression to define the function

src/Control/Distributed/Process/Internal/Messaging.hs+2−2

@@ -30,7 +30,7 @@ import qualified Network.Transport as NT

30 , close

31 )

32import Control.Distributed.Process.Internal.Types

33− ( LocalNode(localEndPoint, localCtrlChan)

33+ ( LocalNode(localState, localEndPoint, localCtrlChan)

34 , withValidLocalState

35 , modifyValidLocalState

36 , modifyValidLocalState_

@@ -201,7 +201,7 @@ sendCtrlMsg mNid signal = do

201 liftIO $ writeChan (localCtrlChan (processNode proc)) $! msg

202 Just nid ->

203 liftIO $ sendBinary (processNode proc)

204− (NodeIdentifier (processNodeId $ processId proc))

204+ (ProcessIdentifier (processId proc))

205 (NodeIdentifier nid)

206 WithImplicitReconnect

207 msg

src/Control/Distributed/Process/Internal/Primitives.hs+58−130

@@ -76,11 +76,8 @@ module Control.Distributed.Process.Internal.Primitives

76 , unlink

77 , monitor

78 , unmonitor

79− , unmonitorAsync

80 , withMonitor

79 , withMonitor

81− , withMonitor_

82 -- * Logging

80 -- * Logging

83− , SayMessage(..)

84 , say

81 , say

85 -- * Registry

82 -- * Registry

86 , register

83 , register

@@ -128,9 +125,8 @@ module Control.Distributed.Process.Internal.Primitives

128import Prelude hiding (catch)

125import Prelude hiding (catch)

129#endif

126#endif

130

127

131−import Data.Binary (Binary(..), Put, Get, decode)

128+import Data.Binary (decode)

132−import Data.Time.Clock (getCurrentTime, UTCTime(..))

129+import Data.Time.Clock (getCurrentTime)

133−import Data.Time.Calendar (Day(..))

134import Data.Time.Format (formatTime)

130import Data.Time.Format (formatTime)

135#if MIN_VERSION_time(1,5,0)

131#if MIN_VERSION_time(1,5,0)

136import Data.Time.Format (defaultTimeLocale)

132import Data.Time.Format (defaultTimeLocale)

@@ -138,7 +134,7 @@ import Data.Time.Format (defaultTimeLocale)

138import System.Locale (defaultTimeLocale)

134import System.Locale (defaultTimeLocale)

139#endif

135#endif

140import System.Timeout (timeout)

136import System.Timeout (timeout)

141−import Control.Monad (when, void)

137+import Control.Monad (when)

142import Control.Monad.Reader (ask)

138import Control.Monad.Reader (ask)

143import Control.Monad.IO.Class (liftIO)

139import Control.Monad.IO.Class (liftIO)

144import Control.Monad.Catch

140import Control.Monad.Catch

@@ -188,7 +184,6 @@ import Control.Distributed.Process.Internal.Types

188 , SpawnRef(..)

184 , SpawnRef(..)

189 , ProcessSignal(..)

185 , ProcessSignal(..)

190 , NodeMonitorNotification(..)

186 , NodeMonitorNotification(..)

191− , ProcessMonitorNotification(..)

192 , monitorCounter

187 , monitorCounter

193 , spawnCounter

188 , spawnCounter

194 , SendPort(..)

189 , SendPort(..)

@@ -254,15 +249,17 @@ send them msg = do

254 node = processNode proc

249 node = processNode proc

255 nodeId = localNodeId node

250 nodeId = localNodeId node

256 destNode = (processNodeId them) in do

251 destNode = (processNodeId them) in do

252+ case destNode == nodeId of

253+ True -> sendLocal them msg

254+ False -> liftIO $ sendMessage (processNode proc)

255+ (ProcessIdentifier (processId proc))

256+ (ProcessIdentifier them)

257+ NoImplicitReconnect

258+ msg

259+ -- We do not fire the trace event until after the sending is complete;

260+ -- In the remote case, 'sendMessage' can block in the networking stack.

257 liftIO $ traceEvent (localEventBus node)

261 liftIO $ traceEvent (localEventBus node)

258 (MxSent them us (createUnencodedMessage msg))

262 (MxSent them us (createUnencodedMessage msg))

259− if destNode == nodeId

260− then sendLocal them msg

261− else liftIO $ sendMessage (processNode proc)

262− (ProcessIdentifier (processId proc))

263− (ProcessIdentifier them)

264− NoImplicitReconnect

265− msg

266

263

267-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

264-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

268-- and (in the case when the destination process resides on the same local

265-- and (in the case when the destination process resides on the same local

@@ -282,12 +279,9 @@ unsafeSend = Unsafe.send

282--

279--

283usend :: Serializable a => ProcessId -> a -> Process ()

280usend :: Serializable a => ProcessId -> a -> Process ()

284usend them msg = do

281usend them msg = do

285− proc <- ask

282+ here <- getSelfNode

286 let there = processNodeId them

283 let there = processNodeId them

287− let (us, node) = (processId proc, processNode proc)

284+ if here == there

288− let msg' = wrapMessage msg

289− liftIO $ traceEvent (localEventBus node) (MxSent them us msg')

290− if localNodeId (processNode proc) == there

291 then sendLocal them msg

285 then sendLocal them msg

292 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

286 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

293 (createMessage msg)

287 (createMessage msg)

@@ -307,13 +301,7 @@ expect = receiveWait [match return]

307-- Channels --

301-- Channels --

308--------------------------------------------------------------------------------

302--------------------------------------------------------------------------------

309

303

310−-- | Create a new typed channel, bound to the calling Process

304+-- | Create a new typed channel

311−--

312−-- Note that the channel is bound to the lifecycle of the process that evaluates

313−-- this function, such that when it dies/exits, the channel will no longer

314−-- function, but will remain accessible. Thus reading from the ReceivePort will

315−-- fail silently thereafter, blocking indefinitely (unless a timeout is used).

316−--

317newChan :: Serializable a => Process (SendPort a, ReceivePort a)

305newChan :: Serializable a => Process (SendPort a, ReceivePort a)

318newChan = do

306newChan = do

319 proc <- ask

307 proc <- ask

@@ -341,16 +329,13 @@ newChan = do

341sendChan :: Serializable a => SendPort a -> a -> Process ()

329sendChan :: Serializable a => SendPort a -> a -> Process ()

342sendChan (SendPort cid) msg = do

330sendChan (SendPort cid) msg = do

343 proc <- ask

331 proc <- ask

344− let node = processNode proc

345− pid = processId proc

346− us = localNodeId node

332+ let node = localNodeId (processNode proc)

347− them = processNodeId (sendPortProcessId cid) in do

333+ destNode = processNodeId (sendPortProcessId cid) in do

348− liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)

349− case them == us of

334+ case destNode == node of

350 True -> sendChanLocal cid msg

335 True -> sendChanLocal cid msg

351 False -> do

336 False -> do

352− liftIO $ sendBinary node

337+ liftIO $ sendBinary (processNode proc)

353− (ProcessIdentifier pid)

338+ (ProcessIdentifier (processId proc))

354 (SendPortIdentifier cid)

339 (SendPortIdentifier cid)

355 NoImplicitReconnect

340 NoImplicitReconnect

356 msg

341 msg

@@ -411,11 +396,8 @@ newtype Match b = Match { unMatch :: MatchOn Message (Process b) }

411receiveWait :: [Match b] -> Process b

396receiveWait :: [Match b] -> Process b

412receiveWait ms = do

397receiveWait ms = do

413 queue <- processQueue <$> ask

398 queue <- processQueue <$> ask

414− mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)

399+ Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)

415− case mProc of

416− Just proc' -> proc'

400+ proc

417− Nothing -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "

418− ++ "in the absence of a timeout value."

419

401

420-- | Like 'receiveWait' but with a timeout.

402-- | Like 'receiveWait' but with a timeout.

421--

403--

@@ -494,14 +476,17 @@ forward msg them = do

494 us = processId proc

476 us = processId proc

495 nid = localNodeId node

477 nid = localNodeId node

496 destNode = (processNodeId them) in do

478 destNode = (processNodeId them) in do

497− liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

498− if destNode == nid

479+ case destNode == nid of

499− then sendCtrlMsg Nothing (LocalSend them msg)

480+ True -> sendCtrlMsg Nothing (LocalSend them msg)

500− else liftIO $ sendPayload (processNode proc)

481+ False -> liftIO $ sendPayload (processNode proc)

501− (ProcessIdentifier (processId proc))

482+ (ProcessIdentifier (processId proc))

502− (ProcessIdentifier them)

483+ (ProcessIdentifier them)

503− NoImplicitReconnect

484+ NoImplicitReconnect

504− (messageToPayload msg)

485+ (messageToPayload msg)

486+ -- We do not fire the trace event until after the sending is complete;

487+ -- In the remote case, 'sendMessage' can block in the networking stack.

488+ liftIO $ traceEvent (localEventBus node)

489+ (MxSent them us msg)

505

490

506-- | Forward a raw 'Message' to the given 'ProcessId'.

491-- | Forward a raw 'Message' to the given 'ProcessId'.

507--

492--

@@ -515,10 +500,14 @@ uforward msg them = do

515 us = processId proc

500 us = processId proc

516 nid = localNodeId node

501 nid = localNodeId node

517 destNode = (processNodeId them) in do

502 destNode = (processNodeId them) in do

518− liftIO $ traceEvent (localEventBus node) (MxSent them us msg)

519− if destNode == nid

503+ case destNode == nid of

520− then sendCtrlMsg Nothing (LocalSend them msg)

504+ True -> sendCtrlMsg Nothing (LocalSend them msg)

521− else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg

505+ False -> sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them)

506+ msg

507+ -- We do not fire the trace event until after the sending is complete;

508+ -- In the remote case, 'sendCtrlMsg' can block in the networking stack.

509+ liftIO $ traceEvent (localEventBus node)

510+ (MxSent them us msg)

522

511

523-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

512-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

524-- 'Serializable' - like the datum they contain - but also note, deserialising

513-- 'Serializable' - like the datum they contain - but also note, deserialising

@@ -896,19 +885,12 @@ monitor = monitor' . ProcessIdentifier

896-- @withMonitor@ returns, there might still be unreceived monitor

885-- @withMonitor@ returns, there might still be unreceived monitor

897-- messages in the queue.

886-- messages in the queue.

898--

887--

899−withMonitor :: ProcessId -> (MonitorRef -> Process a) -> Process a

888+withMonitor :: ProcessId -> Process a -> Process a

900−withMonitor pid = bracket (monitor pid) unmonitor

889+withMonitor pid code = bracket (monitor pid) unmonitor (\_ -> code)

901−

890+ -- unmonitor blocks waiting for the response, so there's a possibility

902−-- | Establishes temporary monitoring of another process.

891+ -- that an exception might interrupt withMonitor before the unmonitor

903−--

892+ -- has completed. I think that's better than making the unmonitor

904−-- @withMonitor_ pid code@ sets up monitoring of @pid@ for the duration

893+ -- uninterruptible.

905−-- of @code@. Note: although monitoring is no longer active when

906−-- @withMonitor_@ returns, there might still be unreceived monitor

907−-- messages in the queue.

908−--

909−-- Since 0.6.1

910−withMonitor_ :: ProcessId -> Process a -> Process a

911−withMonitor_ p = withMonitor p . const

912

894

913-- | Remove a link

895-- | Remove a link

914--

896--

@@ -946,21 +928,12 @@ unlinkPort sport = do

946-- | Remove a monitor

928-- | Remove a monitor

947--

929--

948-- This has the same synchronous/asynchronous nature as 'unlink'.

930-- This has the same synchronous/asynchronous nature as 'unlink'.

949−--

950−-- ProcessMonitorNotification messages for the given MonitorRef are removed from

951−-- the mailbox.

952unmonitor :: MonitorRef -> Process ()

931unmonitor :: MonitorRef -> Process ()

953unmonitor ref = do

932unmonitor ref = do

954 unmonitorAsync ref

933 unmonitorAsync ref

955 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

934 receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)

956 (\_ -> return ())

935 (\_ -> return ())

957 ]

936 ]

958− -- Discard the notification if any. With the current NC implementation at most

959− -- one notification is in the mailbox for any given ref.

960− void $ receiveTimeout 0

961− [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == ref)

962− (const $ return ())

963− ]

964

937

965--------------------------------------------------------------------------------

938--------------------------------------------------------------------------------

966-- Exception handling --

939-- Exception handling --

@@ -974,7 +947,7 @@ catch = Catch.catch

974-- | Lift 'Control.Exception.try'

947-- | Lift 'Control.Exception.try'

975try :: Exception e => Process a -> Process (Either e a)

948try :: Exception e => Process a -> Process (Either e a)

976try = Catch.try

949try = Catch.try

977−{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}

950+{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}

978

951

979-- | Lift 'Control.Exception.mask'

952-- | Lift 'Control.Exception.mask'

980mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

953mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

@@ -1086,52 +1059,17 @@ unlinkPortAsync (SendPort cid) =

1086-- Logging --

1059-- Logging --

1087--------------------------------------------------------------------------------

1060--------------------------------------------------------------------------------

1088

1061

1089−data SayMessage = SayMessage { sayTime :: UTCTime

1090− , sayProcess :: ProcessId

1091− , sayMessage :: String }

1092− deriving (Typeable)

1093−

1094−-- There is sadly no Show UTCTime instance

1095−instance Show SayMessage where

1096− showsPrec p msg =

1097− showParen (p >= 11)

1098− $ showString "SayMessage "

1099− . showString (formatTime defaultTimeLocale "%c" (sayTime msg))

1100− . showChar ' '

1101− . showsPrec 11 (sayProcess msg) . showChar ' '

1102− . showsPrec 11 (sayMessage msg) . showChar ' '

1103−

1104−instance Binary SayMessage where

1105− put s = do

1106− putUTCTime (sayTime s)

1107− put (sayProcess s)

1108− put (sayMessage s)

1109− get = SayMessage <$> getUTCTime <*> get <*> get

1110−

1111−-- Sadly there is no Binary UTCTime instance

1112−putUTCTime :: UTCTime -> Put

1113−putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do

1114− put day

1115− put (toRational tod)

1116−

1117−getUTCTime :: Get UTCTime

1118−getUTCTime = do

1119− day <- get

1120− tod <- get

1121− return $! UTCTime (ModifiedJulianDay day)

1122− (fromRational tod)

1123−

1124-- | Log a string

1062-- | Log a string

1125--

1063--

1126−-- @say message@ sends a message of type 'SayMessage' with the current time and

1064+-- @say message@ sends a message (time, pid of the current process, message)

1127−-- 'ProcessId' of the current process to the process registered as @logger@. By

1065+-- to the process registered as 'logger'. By default, this process simply

1128−-- default, this process simply sends the string to @stderr@. Individual Cloud

1066+-- sends the string to 'stderr'. Individual Cloud Haskell backends might

1129−-- Haskell backends might replace this with a different logger process, however.

1067+-- replace this with a different logger process, however.

1130say :: String -> Process ()

1068say :: String -> Process ()

1131say string = do

1069say string = do

1132 now <- liftIO getCurrentTime

1070 now <- liftIO getCurrentTime

1133 us <- getSelfPid

1071 us <- getSelfPid

1134− nsend "logger" (SayMessage now us string)

1072+ nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

1135

1073

1136--------------------------------------------------------------------------------

1074--------------------------------------------------------------------------------

1137-- Registry --

1075-- Registry --

@@ -1227,12 +1165,8 @@ whereisRemoteAsync nid label = do

1227

1165

1228-- | Named send to a process in the local registry (asynchronous)

1166-- | Named send to a process in the local registry (asynchronous)

1229nsend :: Serializable a => String -> a -> Process ()

1167nsend :: Serializable a => String -> a -> Process ()

1230−nsend label msg = do

1168+nsend label msg =

1231− proc <- ask

1232− let msg' = createUnencodedMessage msg

1233− liftIO $ traceEvent (localEventBus (processNode proc))

1234− (MxSentToName label (processId proc) msg')

1235− sendCtrlMsg Nothing (NamedSend label msg')

1169+ sendCtrlMsg Nothing (NamedSend label (createMessage msg))

1236

1170

1237-- | Named send to a process in the local registry (asynchronous).

1171-- | Named send to a process in the local registry (asynchronous).

1238-- This function makes /no/ attempt to serialize and (in the case when the

1172-- This function makes /no/ attempt to serialize and (in the case when the

@@ -1244,15 +1178,9 @@ unsafeNSend = Unsafe.nsend

1244-- | Named send to a process in a remote registry (asynchronous)

1178-- | Named send to a process in a remote registry (asynchronous)

1245nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1179nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

1246nsendRemote nid label msg = do

1180nsendRemote nid label msg = do

1247− proc <- ask

1181+ here <- getSelfNode

1248− let us = processId proc

1249− let node = processNode proc

1250− if localNodeId node == nid

1251− then nsend label msg

1182+ if here == nid then nsend label msg

1252− else let lbl = label ++ "@" ++ show nid in do

1253− liftIO $ traceEvent (localEventBus node)

1254− (MxSentToName lbl us (wrapMessage msg))

1255− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1183+ else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

1256

1184

1257-- | Named send to a process in a remote registry (asynchronous)

1185-- | Named send to a process in a remote registry (asynchronous)

1258-- This function makes /no/ attempt to serialize and (in the case when the

1186-- This function makes /no/ attempt to serialize and (in the case when the

src/Control/Distributed/Process/Internal/Spawn.hs+3−3

@@ -43,7 +43,7 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

43 )

44import Control.Distributed.Process.Internal.Primitives

45 ( -- Basic messaging

46− usend

46+ send

47 , expect

48 , receiveWait

49 , match

@@ -71,7 +71,7 @@ spawn nid proc = do

71 receiveWait [

72 matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do

73 unmonitor mRef

74− usend pid ()

74+ send pid ()

75 return pid

76 , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) $ \_ ->

77 return (nullProcessId nid)

@@ -118,7 +118,7 @@ call dict nid proc = do

118 cpDelayed us (returnCP sdictUnit ())

119 )

120 mResult <- receiveWait

121− [ match $ \a -> usend pid () >> return (Right a)

121+ [ match $ \a -> send pid () >> return (Right a)

122 , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

123 (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

124 ]

src/Control/Distributed/Process/Internal/StrictMVar.hs+4−8

@@ -36,8 +36,8 @@ import qualified Control.Concurrent.MVar as MVar

36#endif

37 )

38import GHC.MVar (MVar(MVar))

39−import GHC.IO (IO(IO), unIO)

39+import GHC.IO (IO(IO))

40−import GHC.Exts (mkWeak#)

40+import GHC.Prim (mkWeak#)

41import GHC.Weak (Weak(Weak))

43newtype StrictMVar a = StrictMVar (MVar.MVar a)

@@ -85,9 +85,5 @@ modifyMVarMasked (StrictMVar v) f =

85 evaluateFst (x, y) = evaluate x >> return (x, y)

87mkWeakMVar :: StrictMVar a -> IO () -> IO (Weak (StrictMVar a))

88−mkWeakMVar q@(StrictMVar (MVar m#)) f = IO $ \s ->

88+mkWeakMVar m@(StrictMVar (MVar m#)) f = IO $ \s ->

89−#if MIN_VERSION_base(4,9,0)

90− case mkWeak# m# q (unIO f) s of (# s', w #) -> (# s', Weak w #)

91−#else

92− case mkWeak# m# q f s of (# s', w #) -> (# s', Weak w #)

89+ case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)

93−#endif

src/Control/Distributed/Process/Internal/Types.hs+1−9

@@ -366,14 +366,6 @@ instance MonadCatch Process where

366 lproc <- ask

367 liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

368instance MonadMask Process where

369−#if MIN_VERSION_exceptions(0,10,0)

370− generalBracket acquire release inner = do

371− lproc <- ask

372− liftIO $

373− generalBracket (runLocalProcess lproc acquire)

374− (\a e -> runLocalProcess lproc $ release a e)

375− (runLocalProcess lproc . inner)

376−#endif

377 mask p = do

369 mask p = do

378 lproc <- ask

370 lproc <- ask

379 liftIO $ mask $ \restore ->

371 liftIO $ mask $ \restore ->

@@ -637,7 +629,7 @@ newtype DidUnlinkPort = DidUnlinkPort SendPortId

637

629

638-- | 'SpawnRef' are used to return pids of spawned processes

630-- | 'SpawnRef' are used to return pids of spawned processes

639newtype SpawnRef = SpawnRef Int32

631newtype SpawnRef = SpawnRef Int32

640− deriving (Show, Binary, Typeable, Eq, Ord)

632+ deriving (Show, Binary, Typeable, Eq)

641

633

642-- | (Asynchronius) reply from 'spawn'

634-- | (Asynchronius) reply from 'spawn'

643data DidSpawn = DidSpawn SpawnRef ProcessId

635data DidSpawn = DidSpawn SpawnRef ProcessId

src/Control/Distributed/Process/Internal/WeakTQueue.hs+2−7

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE MagicHash, UnboxedTuples #-}

2{-# LANGUAGE MagicHash, UnboxedTuples #-}

4-- | Clone of Control.Concurrent.STM.TQueue with support for mkWeakTQueue

3-- | Clone of Control.Concurrent.STM.TQueue with support for mkWeakTQueue

@@ -23,8 +22,8 @@ module Control.Distributed.Process.Internal.WeakTQueue (

23import Prelude hiding (read)

22import Prelude hiding (read)

24import GHC.Conc

23import GHC.Conc

25import Data.Typeable (Typeable)

24import Data.Typeable (Typeable)

26−import GHC.IO (IO(IO), unIO)

25+import GHC.IO (IO(IO))

27−import GHC.Exts (mkWeak#)

26+import GHC.Prim (mkWeak#)

28import GHC.Weak (Weak(Weak))

27import GHC.Weak (Weak(Weak))

30--------------------------------------------------------------------------------

29--------------------------------------------------------------------------------

@@ -100,8 +99,4 @@ isEmptyTQueue (TQueue read write) = do

100

101mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a))

100mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a))

102mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->

101mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->

103−#if MIN_VERSION_base(4,9,0)

104− case mkWeak# write# q (unIO f) s of (# s', w #) -> (# s', Weak w #)

105−#else

106 case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)

102 case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)

107−#endif

src/Control/Distributed/Process/Management.hs+83−41

@@ -76,40 +76,6 @@

76--

77-- * Whether messages will be taken from the mailbox first, or the event bus.

78--

79−-- Since the event bus uses STM broadcast channels to communicate with agents,

80−-- no message written to the bus successfully can be lost.

81−--

82−-- Agents can also receive messages via their mailboxes - these are subject to

83−-- the same guarantees as all inter-process message sending.

84−--

85−-- Messages dispatched on an STM broadcast channel (i.e., management event bus)

86−-- are guaranteed to be delivered with the same FIFO ordering guarantees that

87−-- exist between two communicating processes, such that communication from the

88−-- node controller's threads (i.e., MxEvent's) will never be re-ordered, but

89−-- messages dispatched to the event bus by other processes (including, but not

90−-- limited to agents) are only guaranteed to be ordered between one sender and

91−-- one receiver.

92−--

93−-- No guarantee exists for the ordering in which messages sent to an agent's

94−-- mailbox will be delivered, vs messages dispatched via the event bus.

95−--

96−-- Because of the above, there are no ordering guarantees for messages sent

97−-- between agents, or for processes to agents, except for those that apply to

98−-- messages sent between regular processes, since agents are

99−-- implemented as such.

100−--

101−-- The event bus is serial and single threaded. Anything that is published by

102−-- the node controller will be seen in FIFO order. There are no ordering

103−-- guarantees pertaining to entries published to the event bus by other

104−-- processes or agents.

105−--

106−-- It should not be possible to see, for example, an @MxReceived@ before the

107−-- corresponding @MxSent@ event, since the places where we issue the @MxSent@

108−-- write directly to the event bus (using STM) in the calling (green) thread,

109−-- before dispatching instructions to the node controller to perform the

110−-- necessary routing to deliver the message to a process (or registered name,

111−-- or typed channel) locally or remotely.

112−--

113-- [Management Data API]

79-- [Management Data API]

114--

80--

115-- Both management agents and clients of the API have access to a variety of

81-- Both management agents and clients of the API have access to a variety of

@@ -117,8 +83,28 @@

117-- system information. Agents maintain their own internal state privately (via a

83-- system information. Agents maintain their own internal state privately (via a

118-- state transformer - see 'mxGetLocal' et al), however it is possible for

84-- state transformer - see 'mxGetLocal' et al), however it is possible for

119-- agents to share additional data with each other (and the outside world)

85-- agents to share additional data with each other (and the outside world)

120−-- using whatever mechanism the user wishes, e.g., acidstate, or shared memory

86+-- using /data tables/.

121−-- primitives.

87+--

88+-- Each agent is assigned its own data table, which acts as a shared map, where

89+-- the keys are @String@s and the values are @Serializable@ datum of whatever

90+-- type the agent or its clients stores.

91+--

92+-- Because an agent's /data table/ stores its values in raw 'Message' format,

93+-- it works effectively as an /un-typed dictionary/, into which data of varying

94+-- types can be fed and later retrieved. The upside of this is that different

95+-- keys can be mapped to various types without any additional work on the part

96+-- of the developer. The downside is that the code reading these values must

97+-- know in advance what type(s) to expect, and the API provides no additional

98+-- support for handling that.

99+--

100+-- Publishing is accomplished using the 'mxPublish' and 'mxSet' APIs, whilst

101+-- querying and deletion are handled by 'mxGet', 'mxClear', 'mxPurgeTable' and

102+-- 'mxDropTable' respectively.

103+--

104+-- When a management agent terminates, their tables are left in memory despite

105+-- termination, such that an agent may resume its role (by restarting) or have

106+-- its 'MxAgentId' taken over by another subsequent agent, leaving the data

107+-- originally captured in place.

122--

108--

123-- [Defining Agents]

109-- [Defining Agents]

124--

110--

@@ -178,6 +164,8 @@

178-- > monitorNames = getSelfPid >>= nsend "name-monitor"

164-- > monitorNames = getSelfPid >>= nsend "name-monitor"

179-- > monitorNames2 = getSelfPid >>= mxNotify

165-- > monitorNames2 = getSelfPid >>= mxNotify

180--

166--

167+-- For some real-world examples, see the distributed-process-platform package.

168+--

181-- [Performance, Stablity and Scalability]

169-- [Performance, Stablity and Scalability]

182--

170--

183-- /Management Agents/ offer numerous advantages over regular processes:

171-- /Management Agents/ offer numerous advantages over regular processes:

@@ -206,6 +194,10 @@

206-- the event bus /and/ their own mailboxes, plus searching through the set of

194-- the event bus /and/ their own mailboxes, plus searching through the set of

207-- event sinks (for each agent) to determine the right handler for the event.

195-- event sinks (for each agent) to determine the right handler for the event.

208--

196--

197+-- Each management agent requires not only its own @Process@ (in which the agent

198+-- code is run), but also a peer process that provides its /data table/. These

199+-- data tables also have to be coordinated and manaaged on each agent's behalf.

200+--

209-- [Architecture Overview]

201-- [Architecture Overview]

210--

202--

211-- The architecture of the management event bus is internal and subject to

203-- The architecture of the management event bus is internal and subject to

@@ -272,9 +264,16 @@ module Control.Distributed.Process.Management

272 , mxGetLocal

264 , mxGetLocal

273 , mxUpdateLocal

265 , mxUpdateLocal

274 , liftMX

266 , liftMX

267+ -- * Mx Data API

268+ , mxPublish

269+ , mxSet

270+ , mxGet

271+ , mxClear

272+ , mxPurgeTable

273+ , mxDropTable

275 ) where

274 ) where

276

275

277−import Control.Applicative

276+import Control.Applicative ((<$>))

278import Control.Concurrent.STM (atomically)

277import Control.Concurrent.STM (atomically)

279import Control.Concurrent.STM.TChan

278import Control.Concurrent.STM.TChan

280 ( readTChan

279 ( readTChan

@@ -282,10 +281,14 @@ import Control.Concurrent.STM.TChan

282 , TChan

281 , TChan

283 )

282 )

284import Control.Distributed.Process.Internal.Primitives

283import Control.Distributed.Process.Internal.Primitives

284+ ( newChan

285+ , nsend

285− ( receiveWait

286+ , receiveWait

287+ , matchChan

286 , matchAny

288 , matchAny

287 , matchSTM

289 , matchSTM

288 , unwrapMessage

290 , unwrapMessage

291+ , onException

289 , register

292 , register

290 , whereis

293 , whereis

291 , die

294 , die

@@ -300,26 +303,26 @@ import Control.Distributed.Process.Internal.Types

300 , unsafeCreateUnencodedMessage

303 , unsafeCreateUnencodedMessage

301 )

304 )

302import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

305import Control.Distributed.Process.Management.Internal.Bus (publishEvent)

306+import qualified Control.Distributed.Process.Management.Internal.Table as Table

303import Control.Distributed.Process.Management.Internal.Types

307import Control.Distributed.Process.Management.Internal.Types

304 ( MxAgentId(..)

308 ( MxAgentId(..)

305 , MxAgent(..)

309 , MxAgent(..)

306 , MxAction(..)

310 , MxAction(..)

307 , ChannelSelector(..)

311 , ChannelSelector(..)

308 , MxAgentState(..)

312 , MxAgentState(..)

313+ , MxAgentStart(..)

309 , MxSink

314 , MxSink

310 , MxEvent(..)

315 , MxEvent(..)

311 )

316 )

312import Control.Distributed.Process.Serializable (Serializable)

317import Control.Distributed.Process.Serializable (Serializable)

313import Control.Monad.IO.Class (liftIO)

318import Control.Monad.IO.Class (liftIO)

314import Control.Monad.Reader (ask)

319import Control.Monad.Reader (ask)

315−import Control.Monad.Catch (onException)

316import qualified Control.Monad.State as ST

320import qualified Control.Monad.State as ST

317 ( get

321 ( get

318 , modify

322 , modify

319 , lift

323 , lift

320 , runStateT

324 , runStateT

321 )

325 )

322−import Prelude

323

326

324-- | Publishes an arbitrary @Serializable@ message to the management event bus.

327-- | Publishes an arbitrary @Serializable@ message to the management event bus.

325-- Note that /no attempt is made to force the argument/, therefore it is very

328-- Note that /no attempt is made to force the argument/, therefore it is very

@@ -331,6 +334,42 @@ mxNotify msg = do

331 bus <- localEventBus . processNode <$> ask

334 bus <- localEventBus . processNode <$> ask

332 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

335 liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg

333

336

337+-- | Publish an arbitrary @Message@ as a property in the management database.

338+--

339+-- For publishing @Serializable@ data, use 'mxSet' instead.

340+--

341+mxPublish :: MxAgentId -> String -> Message -> Process ()

342+mxPublish a k v = Table.set k v (Table.MxForAgent a)

343+

344+-- | Sets an arbitrary @Serializable@ datum against a key in the management

345+-- database. Note that /no attempt is made to force the argument/, therefore

346+-- it is very important that you do not pass unevaluated thunks that might

347+-- crash some other, arbitrary process (or management agent!) that obtains

348+-- and attempts to force the value later on.

349+--

350+mxSet :: Serializable a => MxAgentId -> String -> a -> Process ()

351+mxSet mxId key msg = do

352+ Table.set key (unsafeCreateUnencodedMessage msg) (Table.MxForAgent mxId)

353+

354+-- | Fetches a property from the management database for the given key.

355+-- If the property is not set, or does not match the expected type when

356+-- typechecked (at runtime), returns @Nothing@.

357+mxGet :: Serializable a => MxAgentId -> String -> Process (Maybe a)

358+mxGet = Table.fetch . Table.MxForAgent

359+

360+-- | Clears a property from the management database using the given key.

361+-- If the key does not exist in the database, this is a noop.

362+mxClear :: MxAgentId -> String -> Process ()

363+mxClear mxId key = Table.clear key (Table.MxForAgent mxId)

364+

365+-- | Purges a table in the management database of all its stored properties.

366+mxPurgeTable :: MxAgentId -> Process ()

367+mxPurgeTable = Table.purge . Table.MxForAgent

368+

369+-- | Deletes a table from the management database.

370+mxDropTable :: MxAgentId -> Process ()

371+mxDropTable = Table.delete . Table.MxForAgent

372+

334--------------------------------------------------------------------------------

373--------------------------------------------------------------------------------

335-- API for writing user defined management extensions (i.e., agents) --

374-- API for writing user defined management extensions (i.e., agents) --

336--------------------------------------------------------------------------------

375--------------------------------------------------------------------------------

@@ -450,7 +489,10 @@ mxAgentWithFinalize mxId initState handlers dtor = do

450 return pid

489 return pid

451 where

490 where

452 start (sendTChan, recvTChan) = do

491 start (sendTChan, recvTChan) = do

492+ (sp, rp) <- newChan

493+ nsend Table.mxTableCoordinator (MxAgentStart sp mxId)

494+ tablePid <- receiveWait [ matchChan rp (\(p :: ProcessId) -> return p) ]

453− let nState = MxAgentState mxId sendTChan initState

495+ let nState = MxAgentState mxId sendTChan tablePid initState

454 runAgent dtor handlers InputChan recvTChan nState

496 runAgent dtor handlers InputChan recvTChan nState

455

497

456 runAgent :: MxAgent s ()

498 runAgent :: MxAgent s ()

src/Control/Distributed/Process/Management/Internal/Agent.hs+1−2

@@ -3,7 +3,7 @@

4module Control.Distributed.Process.Management.Internal.Agent where

6−import Control.Applicative

6+import Control.Applicative ((<$>))

7import Control.Concurrent (forkIO)

8import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)

9import Control.Concurrent.STM (atomically)

@@ -44,7 +44,6 @@ import Control.Monad (void)

44import Control.Monad.IO.Class (liftIO)

45import Control.Monad.Reader (ask)

46import GHC.Weak (Weak, deRefWeak)

47−import Prelude

49--------------------------------------------------------------------------------

48--------------------------------------------------------------------------------

50-- Agent Controller Implementation --

49-- Agent Controller Implementation --

src/Control/Distributed/Process/Management/Internal/Table.hsnew file+222

@@ -0,0 +1,222 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE RecordWildCards #-}

7+module Control.Distributed.Process.Management.Internal.Table

8+ ( MxTableRequest(..)

9+ , MxTableId(..)

10+ , mxTableCoordinator

11+ , startTableCoordinator

12+ , delete

13+ , purge

14+ , clear

15+ , set

16+ , get

17+ , fetch

18+ ) where

19+

20+import Control.Distributed.Process.Internal.Primitives

21+ ( receiveWait

22+ , receiveChan

23+ , match

24+ , matchAny

25+ , matchIf

26+ , matchChan

27+ , send

28+ , nsend

29+ , sendChan

30+ , getSelfPid

31+ , link

32+ , monitor

33+ , unwrapMessage

34+ , newChan

35+ , withMonitor

36+ )

37+import Control.Distributed.Process.Internal.Types

38+ ( Process

39+ , ProcessId

40+ , ProcessMonitorNotification(..)

41+ , SendPort

42+ , ReceivePort

43+ , Message

44+ , unsafeCreateUnencodedMessage

45+ )

46+import Control.Distributed.Process.Management.Internal.Types

47+ ( MxTableId(..)

48+ , MxAgentId(..)

49+ , MxAgentStart(..)

50+ , Fork)

51+import Control.Distributed.Process.Serializable (Serializable)

52+import Control.Monad.IO.Class (liftIO)

53+import Data.Accessor (Accessor, accessor, (^=), (^:))

54+import Data.Binary (Binary)

55+import Data.Map (Map)

56+import qualified Data.Map as Map

57+import Data.Typeable (Typeable)

58+

59+import GHC.Generics

60+

61+-- An extremely lightweight shared Map implementation, for use

62+-- by /management agents/ and their cohorts. Each agent is assigned

63+-- a table, into which any serializable @Message@ can be inserted.

64+-- Data are inserted, removed and searched for via their key, which

65+-- is a string. Tables can be purged, values can be set, fetched or

66+-- cleared/removed.

67+--

68+

69+data MxTableRequest =

70+ Delete

71+ | Purge

72+ | Clear !String

73+ | Set !String !Message

74+ | Get !String !(SendPort (Maybe Message)) -- see [note: un-typed send port]

75+ deriving (Typeable, Generic)

76+instance Binary MxTableRequest where

77+

78+data MxTableState = MxTableState { _name :: !String

79+ , _entries :: !(Map String Message)

80+ }

81+

82+type MxTables = Map MxAgentId ProcessId

83+

84+mxTableCoordinator :: String

85+mxTableCoordinator = "mx.table.coordinator"

86+

87+delete :: MxTableId -> Process ()

88+delete = sendReq Delete

89+

90+purge :: MxTableId -> Process ()

91+purge = sendReq Purge

92+

93+clear :: String -> MxTableId -> Process ()

94+clear k = sendReq (Clear k)

95+

96+set :: String -> Message -> MxTableId -> Process ()

97+set k v = sendReq (Set k v)

98+

99+fetch :: forall a. (Serializable a)

100+ => MxTableId

101+ -> String

102+ -> Process (Maybe a)

103+fetch (MxForPid pid) key = get pid key

104+fetch mxId@(MxForAgent _) key = do

105+ (sp, rp) <- newChan :: Process (SendPort (Maybe Message),

106+ ReceivePort (Maybe Message))

107+ sendReq (Get key sp) mxId

108+ receiveChan rp >>= maybe (return Nothing)

109+ (unwrapMessage :: Message -> Process (Maybe a))

110+

111+-- [note: un-typed send port]

112+-- Here, fetch uses a typed channel over a raw Message to obtain

113+-- its result, so type checking is deferred until receipt and will

114+-- be handled in the caller's thread. This is necessary because

115+-- the server portion of the code knows nothing about the types

116+-- involved, nor should it, since these tables can be used to

117+-- store arbitrary serializable data.

118+

119+get :: forall a. (Serializable a)

120+ => ProcessId

121+ -> String

122+ -> Process (Maybe a)

123+get pid key = do

124+ safeFetch pid key >>= maybe (return Nothing)

125+ (unwrapMessage :: Message -> Process (Maybe a))

126+

127+safeFetch :: ProcessId -> String -> Process (Maybe Message)

128+safeFetch pid key = do

129+ (sp, rp) <- newChan

130+ send pid $ Get key sp

131+ withMonitor pid $ do

132+ receiveWait [

133+ matchChan rp return

134+ , matchIf (\(ProcessMonitorNotification _ pid' _) -> pid' == pid)

135+ (\_ -> return $ Just (unsafeCreateUnencodedMessage ()))

136+ ]

137+

138+sendReq :: MxTableRequest -> MxTableId -> Process ()

139+sendReq req tid = (resolve tid) req

140+

141+resolve :: Serializable a => MxTableId -> (a -> Process ())

142+resolve (MxForAgent agent) = \msg -> nsend mxTableCoordinator (agent, msg)

143+resolve (MxForPid pid) = \msg -> send pid msg

144+

145+startTableCoordinator :: Fork -> Process ()

146+startTableCoordinator fork = run Map.empty

147+ where

148+ run :: MxTables -> Process ()

149+ run tables =

150+ receiveWait [

151+ -- note that this state change can race with MxAgentStart requests

152+ match (\(ProcessMonitorNotification _ pid _) -> do

153+ return $ Map.filter (/= pid) tables)

154+ , match (\(MxAgentStart ch agent) -> do

155+ lookupAgent tables agent >>= \(p, t) -> do

156+ sendChan ch p >> return t)

157+ , match (\req@(agent, tReq :: MxTableRequest) -> do

158+ case tReq of

159+ Get k sp -> do

160+ lookupAgent tables agent >>= \(p, t) -> do

161+ safeFetch p k >>= sendChan sp >> return t

162+ _ -> do

163+ handleRequest tables req)

164+ , matchAny (\_ -> return tables) -- unrecognised messages are dropped

165+ ] >>= run

166+

167+ handleRequest :: MxTables

168+ -> (MxAgentId, MxTableRequest)

169+ -> Process MxTables

170+ handleRequest tables' (agent, req) = do

171+ lookupAgent tables' agent >>= \(p, t) -> send p req >> return t

172+

173+ lookupAgent :: MxTables -> MxAgentId -> Process (ProcessId, MxTables)

174+ lookupAgent tables' agentId' = do

175+ case Map.lookup agentId' tables' of

176+ Nothing -> launchNew agentId' tables'

177+ Just p -> return (p, tables')

178+

179+ launchNew :: MxAgentId

180+ -> MxTables

181+ -> Process (ProcessId, MxTables)

182+ launchNew mxId tblMap = do

183+ let initState = MxTableState { _name = (agentId mxId)

184+ , _entries = Map.empty

185+ }

186+ (pid, _) <- spawnSup $ tableHandler initState

187+ return $ (pid, mxId `seq` pid `seq` Map.insert mxId pid tblMap)

188+

189+ spawnSup proc = do

190+ us <- getSelfPid

191+ -- we need to use that passed in "fork", in order to

192+ -- break an import cycle with Node.hs courtesy of the

193+ -- management agent, API and tracing modules

194+ them <- liftIO $ fork $ link us >> proc

195+ ref <- monitor them

196+ return (them, ref)

197+

198+tableHandler :: MxTableState -> Process ()

199+tableHandler state = do

200+ ns <- receiveWait [

201+ match (handleTableRequest state)

202+ , matchAny (\_ -> return (Just state))

203+ ]

204+ case ns of

205+ Nothing -> return ()

206+ Just s' -> tableHandler s'

207+ where

208+ handleTableRequest _ Delete = return Nothing

209+ handleTableRequest st Purge = return $ Just $ (entries ^= Map.empty) $ st

210+ handleTableRequest st (Clear k) = return $ Just $ (entries ^: (k `seq` Map.delete k)) $ st

211+ handleTableRequest st (Set k v) = return $ Just $ (entries ^: (k `seq` v `seq` Map.insert k v)) st

212+ handleTableRequest st (Get k c) = getEntry k c st >> return (Just st)

213+

214+getEntry :: String

215+ -> SendPort (Maybe Message)

216+ -> MxTableState

217+ -> Process ()

218+getEntry k m MxTableState{..} = do

219+ sendChan m =<< return (Map.lookup k _entries)

220+

221+entries :: Accessor MxTableState (Map String Message)

222+entries = accessor _entries (\ls st -> st { _entries = ls })

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+3−10

@@ -28,12 +28,11 @@ module Control.Distributed.Process.Management.Internal.Trace.Primitives

28 , withRegisteredTracer

29 ) where

31−import Control.Applicative

31+import Control.Applicative ((<$>))

32import Control.Distributed.Process.Internal.Primitives

33 ( whereis

34 , newChan

35 , receiveChan

36− , die

37 )

36 )

38import Control.Distributed.Process.Management.Internal.Trace.Types

37import Control.Distributed.Process.Management.Internal.Trace.Types

39 ( TraceArg(..)

38 ( TraceArg(..)

@@ -68,7 +67,6 @@ import Control.Monad.IO.Class (liftIO)

68import Control.Monad.Reader (ask)

67import Control.Monad.Reader (ask)

70import qualified Data.Set as Set (fromList)

69import qualified Data.Set as Set (fromList)

71−import Prelude

73--------------------------------------------------------------------------------

71--------------------------------------------------------------------------------

74-- Main API --

72-- Main API --

@@ -169,11 +167,6 @@ withRegisteredTracer act = do

169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

167 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

170 currentTracer <- receiveChan rp

168 currentTracer <- receiveChan rp

171 case currentTracer of

169 case currentTracer of

172− Nothing -> do mTP <- whereis "tracer.initial"

170+ Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

173− -- NB: this should NOT ever happen, but forcing pattern matches

174− -- is not considered cool in later versions of MonadFail

175− case mTP of

176− Just p' -> act p'

177− Nothing -> die $ "System Invariant Violation: Tracer Process "

178− ++ "Name Not Found (whereis tracer.initial)"

179 (Just p) -> act p

171 (Just p) -> act p

172+

src/Control/Distributed/Process/Management/Internal/Trace/Types.hs+10

@@ -43,6 +43,7 @@ import Control.Distributed.Process.Serializable

43import Data.Binary

44import Data.List (intersperse)

45import Data.Set (Set)

46+import qualified Data.Set as Set (fromList)

46import Data.Typeable

47import Data.Typeable

47import GHC.Generics

48import GHC.Generics

@@ -157,3 +158,12 @@ getTraceFlags t s = publishEvent t (unsafeCreateUnencodedMessage s)

157

158

158getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

159getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()

159getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)

160getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)

161+

162+class Traceable a where

163+ uod :: [a] -> TraceSubject

164+

165+instance Traceable ProcessId where

166+ uod = TraceProcs . Set.fromList

167+

168+instance Traceable String where

169+ uod = TraceNames . Set.fromList

src/Control/Distributed/Process/Management/Internal/Types.hs+19−9

@@ -1,13 +1,16 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE StandaloneDeriving #-}

2{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE DeriveGeneric #-}

5{-# LANGUAGE DeriveGeneric #-}

5module Control.Distributed.Process.Management.Internal.Types

6module Control.Distributed.Process.Management.Internal.Types

6 ( MxAgentId(..)

7 ( MxAgentId(..)

8+ , MxTableId(..)

7 , MxAgentState(..)

9 , MxAgentState(..)

8 , MxAgent(..)

10 , MxAgent(..)

9 , MxAction(..)

11 , MxAction(..)

10 , ChannelSelector(..)

12 , ChannelSelector(..)

13+ , MxAgentStart(..)

11 , Fork

14 , Fork

12 , MxSink

15 , MxSink

13 , MxEvent(..)

16 , MxEvent(..)

@@ -21,8 +24,8 @@ import Control.Concurrent.STM

21import Control.Distributed.Process.Internal.Types

24import Control.Distributed.Process.Internal.Types

22 ( Process

25 ( Process

23 , ProcessId

26 , ProcessId

24− , SendPortId

25 , Message

27 , Message

28+ , SendPort

26 , DiedReason

29 , DiedReason

27 , NodeId

30 , NodeId

28 )

31 )

@@ -31,7 +34,6 @@ import qualified Control.Monad.State as ST

31 ( MonadState

34 ( MonadState

32 , StateT

35 , StateT

33 )

36 )

34−import Control.Monad.Fix (MonadFix)

35import Data.Binary

37import Data.Binary

36import Data.Typeable (Typeable)

38import Data.Typeable (Typeable)

37import GHC.Generics

39import GHC.Generics

@@ -58,14 +60,8 @@ data MxEvent =

58 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

60 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

59 | MxSent ProcessId ProcessId Message

61 | MxSent ProcessId ProcessId Message

60 -- ^ fired whenever a message is sent from a local process

62 -- ^ fired whenever a message is sent from a local process

61− | MxSentToName String ProcessId Message

62− -- ^ fired whenever a named send occurs

63− | MxSentToPort ProcessId SendPortId Message

64− -- ^ fired whenever a sendChan occurs

65 | MxReceived ProcessId Message

63 | MxReceived ProcessId Message

66 -- ^ fired whenever a message is received by a local process

64 -- ^ fired whenever a message is received by a local process

67− | MxReceivedPort SendPortId Message

68− -- ^ fired whenever a message is received via a typed channel

69 | MxConnected ConnectionId EndPointAddress

65 | MxConnected ConnectionId EndPointAddress

70 -- ^ fired when a network-transport connection is first established

66 -- ^ fired when a network-transport connection is first established

71 | MxDisconnected ConnectionId EndPointAddress

67 | MxDisconnected ConnectionId EndPointAddress

@@ -104,10 +100,17 @@ type Fork = (Process () -> IO ProcessId)

104newtype MxAgentId = MxAgentId { agentId :: String }

100newtype MxAgentId = MxAgentId { agentId :: String }

105 deriving (Typeable, Binary, Eq, Ord)

101 deriving (Typeable, Binary, Eq, Ord)

106

102

103+data MxTableId =

104+ MxForAgent !MxAgentId

105+ | MxForPid !ProcessId

106+ deriving (Typeable, Generic)

107+instance Binary MxTableId where

108+

107data MxAgentState s = MxAgentState

109data MxAgentState s = MxAgentState

108 {

110 {

109 mxAgentId :: !MxAgentId

111 mxAgentId :: !MxAgentId

110 , mxBus :: !(TChan Message)

112 , mxBus :: !(TChan Message)

113+ , mxSharedTable :: !ProcessId

111 , mxLocalState :: !s

114 , mxLocalState :: !s

112 }

115 }

113

116

@@ -120,12 +123,19 @@ newtype MxAgent s a =

120 } deriving ( Functor

123 } deriving ( Functor

121 , Monad

124 , Monad

122 , MonadIO

125 , MonadIO

123− , MonadFix

124 , ST.MonadState (MxAgentState s)

126 , ST.MonadState (MxAgentState s)

125 , Typeable

127 , Typeable

126 , Applicative

128 , Applicative

127 )

129 )

128

130

131+data MxAgentStart = MxAgentStart

132+ {

133+ mxAgentTableChan :: SendPort ProcessId

134+ , mxAgentIdStart :: MxAgentId

135+ }

136+ deriving (Typeable, Generic)

137+instance Binary MxAgentStart where

138+

129data ChannelSelector = InputChan | Mailbox

139data ChannelSelector = InputChan | Mailbox

130

140

131-- | Represents the actions a management agent can take

141-- | Represents the actions a management agent can take

src/Control/Distributed/Process/Node.hs+90−163

@@ -5,7 +5,6 @@

5{-# LANGUAGE BangPatterns #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE RecordWildCards #-}

8−{-# LANGUAGE MagicHash #-}

10-- | Local nodes

9-- | Local nodes

11--

10--

@@ -21,6 +20,10 @@ module Control.Distributed.Process.Node

22-- TODO: Calls to 'sendBinary' and co (by the NC) may stall the node controller.

21-- TODO: Calls to 'sendBinary' and co (by the NC) may stall the node controller.

23+#if ! MIN_VERSION_base(4,6,0)

24+import Prelude hiding (catch)

25+#endif

26+

24import System.IO (fixIO, hPutStrLn, stderr)

27import System.IO (fixIO, hPutStrLn, stderr)

25import System.Mem.Weak (Weak, deRefWeak)

28import System.Mem.Weak (Weak, deRefWeak)

26import qualified Data.ByteString.Lazy as BSL (fromChunks)

29import qualified Data.ByteString.Lazy as BSL (fromChunks)

@@ -28,39 +31,28 @@ import Data.Binary (decode)

28import Data.Map (Map)

31import Data.Map (Map)

29import qualified Data.Map as Map

32import qualified Data.Map as Map

30 ( empty

33 ( empty

31− , delete

32 , toList

34 , toList

33 , fromList

35 , fromList

34− , insert

36+ , filter

35− , lookup

36− , partition

37 , partitionWithKey

38 , elems

39 , size

40 , filterWithKey

41 , foldlWithKey

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

49import Data.Set (Set)

43import Data.Set (Set)

50import qualified Data.Set as Set

44import qualified Data.Set as Set

51 ( empty

45 ( empty

52 , insert

46 , insert

53 , delete

47 , delete

54− , map

55 , member

48 , member

56 , toList

49 , toList

57− , union

58 )

50 )

59import Data.Foldable (forM_)

51import Data.Foldable (forM_)

60import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

52import Data.Maybe (isJust, fromJust, isNothing, catMaybes)

61import Data.Typeable (Typeable)

53import Data.Typeable (Typeable)

62import Control.Category ((>>>))

54import Control.Category ((>>>))

63−import Control.Applicative

55+import Control.Applicative (Applicative, (<$>))

64import Control.Monad (void, when, join)

56import Control.Monad (void, when, join)

65import Control.Monad.IO.Class (MonadIO, liftIO)

57import Control.Monad.IO.Class (MonadIO, liftIO)

66import Control.Monad.State.Strict (MonadState, StateT, evalStateT, gets)

58import Control.Monad.State.Strict (MonadState, StateT, evalStateT, gets)

@@ -68,12 +60,11 @@ import qualified Control.Monad.State.Strict as StateT (get, put)

68import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)

60import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)

69import Control.Exception

61import Control.Exception

70 ( throwIO

62 ( throwIO

63+ , AsyncException(ThreadKilled)

71 , SomeException

64 , SomeException

72 , Exception

65 , Exception

73 , throwTo

66 , throwTo

74 , uninterruptibleMask_

67 , uninterruptibleMask_

75− , getMaskingState

76− , MaskingState(..)

77 )

68 )

78import qualified Control.Exception as Exception

69import qualified Control.Exception as Exception

79 ( Handler(..)

70 ( Handler(..)

@@ -81,13 +72,12 @@ import qualified Control.Exception as Exception

81 , catches

72 , catches

82 , finally

73 , finally

83 )

74 )

84−import Control.Concurrent (forkIO, killThread)

75+import Control.Concurrent (forkIO, forkIOWithUnmask, killThread, myThreadId)

85−import Control.Distributed.Process.Internal.BiMultiMap (BiMultiMap)

86−import qualified Control.Distributed.Process.Internal.BiMultiMap as BiMultiMap

87import Control.Distributed.Process.Internal.StrictMVar

76import Control.Distributed.Process.Internal.StrictMVar

88 ( newMVar

77 ( newMVar

89 , withMVar

78 , withMVar

90 , modifyMVarMasked

79 , modifyMVarMasked

80+ , modifyMVar_

91 , modifyMVar

81 , modifyMVar

92 , newEmptyMVar

82 , newEmptyMVar

93 , putMVar

83 , putMVar

@@ -177,17 +167,19 @@ import Control.Distributed.Process.Internal.Types

177 , RegisterReply(..)

167 , RegisterReply(..)

178 , WhereIsReply(..)

168 , WhereIsReply(..)

179 , payloadToMessage

169 , payloadToMessage

170+ , messageToPayload

180 , createUnencodedMessage

171 , createUnencodedMessage

181 , unsafeCreateUnencodedMessage

172 , unsafeCreateUnencodedMessage

182 , runLocalProcess

173 , runLocalProcess

183 , firstNonReservedProcessId

174 , firstNonReservedProcessId

184− , ImplicitReconnect(WithImplicitReconnect)

175+ , ImplicitReconnect(WithImplicitReconnect,NoImplicitReconnect)

185 )

176 )

186import Control.Distributed.Process.Management.Internal.Agent

177import Control.Distributed.Process.Management.Internal.Agent

187 ( mxAgentController

178 ( mxAgentController

188 )

179 )

189−import Control.Distributed.Process.Management.Internal.Types

180+import qualified Control.Distributed.Process.Management.Internal.Table as Table

190− ( MxEvent(..)

181+ ( mxTableCoordinator

182+ , startTableCoordinator

191 )

183 )

192import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace

184import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace

193 ( remoteTable

185 ( remoteTable

@@ -201,9 +193,13 @@ import Control.Distributed.Process.Management.Internal.Trace.Types

201 , traceLogFmt

193 , traceLogFmt

202 , enableTrace

194 , enableTrace

203 )

195 )

196+import Control.Distributed.Process.Management.Internal.Types

197+ ( MxEvent(..)

198+ )

204import Control.Distributed.Process.Serializable (Serializable)

199import Control.Distributed.Process.Serializable (Serializable)

205import Control.Distributed.Process.Internal.Messaging

200import Control.Distributed.Process.Internal.Messaging

206 ( sendBinary

201 ( sendBinary

202+ , sendPayload

207 , closeImplicitReconnections

203 , closeImplicitReconnections

208 , impliesDeathOf

204 , impliesDeathOf

209 )

205 )

@@ -212,11 +208,8 @@ import Control.Distributed.Process.Internal.Primitives

212 , receiveWait

208 , receiveWait

213 , match

209 , match

214 , sendChan

210 , sendChan

211+ , try

215 , unwrapMessage

212 , unwrapMessage

216− , monitor

217− , unmonitorAsync

218− , getSelfNode

219− , SayMessage(..)

220 )

213 )

221import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

214import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

222import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

215import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

@@ -225,20 +218,7 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a

225 ( mapMaybe

218 ( mapMaybe

226 , mapDefault

219 , mapDefault

227 )

220 )

228−import Control.Monad.Catch (try)

229−import GHC.IO (IO(..), unsafeUnmask)

230−import GHC.Base ( maskAsyncExceptions# )

231−

232import Unsafe.Coerce

221import Unsafe.Coerce

233−import Prelude

234−

235−-- Remove these definitions when the fix for

236−-- https://ghc.haskell.org/trac/ghc/ticket/10149

237−-- is included in all supported compilers:

238−block :: IO a -> IO a

239−block (IO io) = IO $ maskAsyncExceptions# io

240−unblock :: IO a -> IO a

241−unblock = unsafeUnmask

242

222

243--------------------------------------------------------------------------------

223--------------------------------------------------------------------------------

244-- Initialization --

224-- Initialization --

@@ -324,6 +304,8 @@ startServiceProcesses node = do

324 -- before /that/ process has started - this is a totally harmless race

304 -- before /that/ process has started - this is a totally harmless race

325 -- however, so we deliberably ignore it

305 -- however, so we deliberably ignore it

326 startDefaultTracer node

306 startDefaultTracer node

307+ tableCoordinatorPid <- fork $ Table.startTableCoordinator fork

308+ runProcess node $ register Table.mxTableCoordinator tableCoordinatorPid

327 logger <- forkProcess node loop

309 logger <- forkProcess node loop

328 runProcess node $ do

310 runProcess node $ do

329 register "logger" logger

311 register "logger" logger

@@ -332,11 +314,12 @@ startServiceProcesses node = do

332 -- process which uses 'send' or other primitives which are traced.

314 -- process which uses 'send' or other primitives which are traced.

333 register "trace.logger" logger

315 register "trace.logger" logger

334 where

316 where

317+ fork = forkProcess node

318+

335 loop = do

319 loop = do

336 receiveWait

320 receiveWait

337− [ match $ \(SayMessage time pid string) -> do

321+ [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do

338− let time' = formatTime defaultTimeLocale "%c" time

339− liftIO . hPutStrLn stderr $ time' ++ " " ++ show pid ++ ": " ++ string

322+ liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

340 loop

323 loop

341 , match $ \((time, string) :: (String, String)) -> do

324 , match $ \((time, string) :: (String, String)) -> do

342 -- this is a 'trace' message from the local node tracer

325 -- this is a 'trace' message from the local node tracer

@@ -378,14 +361,11 @@ runProcess node proc = do

378

361

379-- | Spawn a new process on a local node

362-- | Spawn a new process on a local node

380forkProcess :: LocalNode -> Process () -> IO ProcessId

363forkProcess :: LocalNode -> Process () -> IO ProcessId

381−forkProcess node proc = do

364+forkProcess node proc =

382− ms <- getMaskingState

383− modifyMVarMasked (localState node) (startProcess ms)

365+ modifyMVarMasked (localState node) startProcess

384 where

366 where

385− startProcess :: MaskingState

386− -> LocalNodeState

387− -> IO (LocalNodeState, ProcessId)

367+ startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)

388− startProcess ms (LocalNodeValid vst) = do

368+ startProcess (LocalNodeValid vst) = do

389 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter

369 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter

390 , lpidUnique = vst ^. localPidUnique

370 , lpidUnique = vst ^. localPidUnique

391 }

371 }

@@ -407,13 +387,7 @@ forkProcess node proc = do

407 , processThread = tid

387 , processThread = tid

408 , processNode = node

388 , processNode = node

409 }

389 }

410− -- Rewrite this code when this is fixed:

411− -- https://ghc.haskell.org/trac/ghc/ticket/10149

412− let unmask = case ms of

413− Unmasked -> unblock

414− MaskedInterruptible -> block

415− MaskedUninterruptible -> id

416− tid' <- uninterruptibleMask_ $ forkIO $ do

390+ tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do

417 reason <- Exception.catches

391 reason <- Exception.catches

418 (unmask $ runLocalProcess lproc proc >> return DiedNormal)

392 (unmask $ runLocalProcess lproc proc >> return DiedNormal)

419 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do

393 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do

@@ -459,7 +433,7 @@ forkProcess node proc = do

459 $ vst

433 $ vst

460 , pid

434 , pid

461 )

435 )

462− startProcess _ LocalNodeClosed =

436+ startProcess LocalNodeClosed =

463 throwIO $ NodeClosedException $ localNodeId node

437 throwIO $ NodeClosedException $ localNodeId node

464

438

465 cleanupProcess :: ProcessId

439 cleanupProcess :: ProcessId

@@ -492,7 +466,7 @@ type IncomingConnection = (NT.EndPointAddress, IncomingTarget)

492data IncomingTarget =

466data IncomingTarget =

493 Uninit

467 Uninit

494 | ToProc ProcessId (Weak (CQueue Message))

468 | ToProc ProcessId (Weak (CQueue Message))

495− | ToChan SendPortId TypedChannel

469+ | ToChan TypedChannel

496 | ToNode

470 | ToNode

497

471

498data ConnectionState = ConnectionState {

472data ConnectionState = ConnectionState {

@@ -534,8 +508,7 @@ handleIncomingMessages node = go initConnectionState

534 . (incomingFrom theirAddr ^: Set.insert cid)

508 . (incomingFrom theirAddr ^: Set.insert cid)

535 $ st

509 $ st

536 )

510 )

537− else invalidRequest cid st $

511+ else invalidRequest cid st

538− "attempt to connect with unsupported reliability " ++ show rel

539 NT.Received cid payload ->

512 NT.Received cid payload ->

540 case st ^. incomingAt cid of

513 case st ^. incomingAt cid of

541 Just (_, ToProc pid weakQueue) -> do

514 Just (_, ToProc pid weakQueue) -> do

@@ -547,17 +520,13 @@ handleIncomingMessages node = go initConnectionState

547 enqueue queue msg -- 'enqueue' is strict

520 enqueue queue msg -- 'enqueue' is strict

548 trace node (MxReceived pid msg)

521 trace node (MxReceived pid msg)

549 go st

522 go st

550− Just (_, ToChan chId (TypedChannel chan')) -> do

523+ Just (_, ToChan (TypedChannel chan')) -> do

551 mChan <- deRefWeak chan'

524 mChan <- deRefWeak chan'

552 -- If mChan is Nothing, the process has given up the read end of

525 -- If mChan is Nothing, the process has given up the read end of

553 -- the channel and we simply ignore the incoming message

526 -- the channel and we simply ignore the incoming message

554− forM_ mChan $ \chan -> do

527+ forM_ mChan $ \chan -> atomically $

555− msg' <- atomically $ do

556− msg <- return $! decode (BSL.fromChunks payload)

557− -- We make sure the message is fully decoded when it is enqueued

528+ -- We make sure the message is fully decoded when it is enqueued

558− writeTQueue chan msg

529+ writeTQueue chan $! decode (BSL.fromChunks payload)

559− return msg

560− trace node $ MxReceivedPort chId $ unsafeCreateUnencodedMessage msg'

561 go st

530 go st

562 Just (_, ToNode) -> do

531 Just (_, ToNode) -> do

563 let ctrlMsg = decode . BSL.fromChunks $ payload

532 let ctrlMsg = decode . BSL.fromChunks $ payload

@@ -572,9 +541,7 @@ handleIncomingMessages node = go initConnectionState

572 Just proc ->

541 Just proc ->

573 go (incomingAt cid ^= Just (src, ToProc pid (processWeakQ proc)) $ st)

542 go (incomingAt cid ^= Just (src, ToProc pid (processWeakQ proc)) $ st)

574 Nothing ->

543 Nothing ->

575− -- incoming attempt to connect to unknown process - might

544+ invalidRequest cid st

576− -- be dead already

577− go (incomingAt cid ^= Nothing $ st)

578 SendPortIdentifier chId -> do

545 SendPortIdentifier chId -> do

579 let lcid = sendPortLocalId chId

546 let lcid = sendPortLocalId chId

580 lpid = processLocalId (sendPortProcessId chId)

547 lpid = processLocalId (sendPortProcessId chId)

@@ -584,30 +551,21 @@ handleIncomingMessages node = go initConnectionState

584 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

551 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

585 case mChannel of

552 case mChannel of

586 Just channel ->

553 Just channel ->

587− go (incomingAt cid ^= Just (src, ToChan chId channel) $ st)

554+ go (incomingAt cid ^= Just (src, ToChan channel) $ st)

588 Nothing ->

555 Nothing ->

589− invalidRequest cid st $

556+ invalidRequest cid st

590− "incoming attempt to connect to unknown channel of"

591− ++ " process " ++ show (sendPortProcessId chId)

592 Nothing ->

557 Nothing ->

593− -- incoming attempt to connect to channel of unknown

558+ invalidRequest cid st

594− -- process - might be dead already

595− go (incomingAt cid ^= Nothing $ st)

596 NodeIdentifier nid ->

559 NodeIdentifier nid ->

597 if nid == localNodeId node

560 if nid == localNodeId node

598 then go (incomingAt cid ^= Just (src, ToNode) $ st)

561 then go (incomingAt cid ^= Just (src, ToNode) $ st)

599− else invalidRequest cid st $

562+ else invalidRequest cid st

600− "incoming attempt to connect to a different node -"

601− ++ " I'm " ++ show (localNodeId node)

602− ++ " but the remote peer wants to connect to "

603− ++ show nid

604 Nothing ->

563 Nothing ->

605 invalidRequest cid st

564 invalidRequest cid st

606− "message received from an unknown connection"

607 NT.ConnectionClosed cid ->

565 NT.ConnectionClosed cid ->

608 case st ^. incomingAt cid of

566 case st ^. incomingAt cid of

609 Nothing ->

567 Nothing ->

610− invalidRequest cid st "closed unknown connection"

568+ invalidRequest cid st

611 Just (src, _) -> do

569 Just (src, _) -> do

612 trace node (MxDisconnected cid src)

570 trace node (MxDisconnected cid src)

613 go ( (incomingAt cid ^= Nothing)

571 go ( (incomingAt cid ^= Nothing)

@@ -638,16 +596,14 @@ handleIncomingMessages node = go initConnectionState

638 -- and we just give up

596 -- and we just give up

639 fail "Cloud Haskell fatal error: received unexpected multicast"

597 fail "Cloud Haskell fatal error: received unexpected multicast"

640

598

641− invalidRequest :: NT.ConnectionId -> ConnectionState -> String -> IO ()

599+ invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()

642− invalidRequest cid st msg = do

600+ invalidRequest cid st = do

643 -- TODO: We should treat this as a fatal error on the part of the remote

601 -- TODO: We should treat this as a fatal error on the part of the remote

644 -- node. That is, we should report the remote node as having died, and we

602 -- node. That is, we should report the remote node as having died, and we

645 -- should close incoming connections (this requires a Transport layer

603 -- should close incoming connections (this requires a Transport layer

646 -- extension).

604 -- extension).

647− traceEventFmtIO node "" [ TraceStr $ " [network] invalid request"

605+ traceEventFmtIO node "" [(TraceStr " [network] invalid request: "),

648− ++ " (" ++ msg ++ "): "

649− , (Trace cid)

606+ (Trace cid)]

650− ]

651 go ( incomingAt cid ^= Nothing

607 go ( incomingAt cid ^= Nothing

652 $ st

608 $ st

653 )

609 )

@@ -670,9 +626,9 @@ runNodeController node =

670

626

671data NCState = NCState

627data NCState = NCState

672 { -- Mapping from remote processes to linked local processes

628 { -- Mapping from remote processes to linked local processes

673− _links :: !(BiMultiMap Identifier ProcessId ())

629+ _links :: !(Map Identifier (Set ProcessId))

674 -- Mapping from remote processes to monitoring local processes

630 -- Mapping from remote processes to monitoring local processes

675− , _monitors :: !(BiMultiMap Identifier ProcessId MonitorRef)

631+ , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))

676 -- Process registry: names and where they live, mapped to the PIDs

632 -- Process registry: names and where they live, mapped to the PIDs

677 , _registeredHere :: !(Map String ProcessId)

633 , _registeredHere :: !(Map String ProcessId)

678 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

634 , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

@@ -688,8 +644,8 @@ newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

688 )

644 )

689

645

690initNCState :: NCState

646initNCState :: NCState

691−initNCState = NCState { _links = BiMultiMap.empty

647+initNCState = NCState { _links = Map.empty

692− , _monitors = BiMultiMap.empty

648+ , _monitors = Map.empty

693 , _registeredHere = Map.empty

649 , _registeredHere = Map.empty

694 , _registeredOnNodes = Map.empty

650 , _registeredOnNodes = Map.empty

695 }

651 }

@@ -832,8 +788,8 @@ ncEffectMonitor from them mRef = do

832 case (shouldLink, isLocal node (ProcessIdentifier from)) of

788 case (shouldLink, isLocal node (ProcessIdentifier from)) of

833 (True, _) -> -- [Unified: first rule]

789 (True, _) -> -- [Unified: first rule]

834 case mRef of

790 case mRef of

835− Just ref -> modify' $ monitors ^: BiMultiMap.insert them from ref

791+ Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)

836− Nothing -> modify' $ links ^: BiMultiMap.insert them from ()

792+ Nothing -> modify' $ linksFor them ^: Set.insert from

837 (False, True) -> -- [Unified: second rule]

793 (False, True) -> -- [Unified: second rule]

838 notifyDied from them DiedUnknownId mRef

794 notifyDied from them DiedUnknownId mRef

839 (False, False) -> -- [Unified: third rule]

795 (False, False) -> -- [Unified: third rule]

@@ -857,7 +813,7 @@ ncEffectUnlink from them = do

857 postAsMessage from $ DidUnlinkNode nid

813 postAsMessage from $ DidUnlinkNode nid

858 SendPortIdentifier cid ->

814 SendPortIdentifier cid ->

859 postAsMessage from $ DidUnlinkPort cid

815 postAsMessage from $ DidUnlinkPort cid

860− modify' $ links ^: BiMultiMap.delete them from ()

816+ modify' $ linksFor them ^: Set.delete from

861

817

862-- [Unified: Table 11]

818-- [Unified: Table 11]

863ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

819ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

@@ -865,7 +821,7 @@ ncEffectUnmonitor from ref = do

865 node <- ask

821 node <- ask

866 when (isLocal node (ProcessIdentifier from)) $

822 when (isLocal node (ProcessIdentifier from)) $

867 postAsMessage from $ DidUnmonitor ref

823 postAsMessage from $ DidUnmonitor ref

868− modify' $ monitors ^: BiMultiMap.delete (monitorRefIdent ref) from ref

824+ modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)

869

825

870-- [Unified: Table 12]

826-- [Unified: Table 12]

871ncEffectDied :: Identifier -> DiedReason -> NC ()

827ncEffectDied :: Identifier -> DiedReason -> NC ()

@@ -880,7 +836,7 @@ ncEffectDied ident reason = do

880 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

836 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

881

837

882 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

838 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

883− forM_ uss $ \(us, _) ->

839+ forM_ uss $ \us ->

884 when (localOnly <= isLocal node (ProcessIdentifier us)) $

840 when (localOnly <= isLocal node (ProcessIdentifier us)) $

885 notifyDied us them reason Nothing

841 notifyDied us them reason Nothing

886

842

@@ -889,35 +845,9 @@ ncEffectDied ident reason = do

889 when (localOnly <= isLocal node (ProcessIdentifier us)) $

845 when (localOnly <= isLocal node (ProcessIdentifier us)) $

890 notifyDied us them reason (Just ref)

846 notifyDied us them reason (Just ref)

891

847

892− -- Notify remote nodes that the process died so it can be removed from monitor

893− -- lists.

894− mapM_ (forwardDeath node) $

895− [ nid | ProcessIdentifier pid <- [ident]

896− , i <- Set.toList $ Set.union

897− (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedLinks)

898− (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedMons)

899− , let nid = nodeOf i

900− , nid /= localNodeId node

901− ]

902−

903− -- Delete monitors in the local node.

904− let deleteDeads :: (Ord a, Ord v)

905− => BiMultiMap a ProcessId v -> BiMultiMap a ProcessId v

906− deleteDeads = case ident of

907− -- deleteAllBy2nd is faster than partitionWithKeyBy2nd

908− ProcessIdentifier pid -> BiMultiMap.deleteAllBy2nd pid

909− _ -> snd . BiMultiMap.partitionWithKeyBy2nd

910− (\pid _ -> ident `impliesDeathOf` ProcessIdentifier pid)

911− unaffectedLinks' = deleteDeads unaffectedLinks

912− unaffectedMons' = deleteDeads unaffectedMons

913−

914− modify' $ (links ^= unaffectedLinks') . (monitors ^= unaffectedMons')

848+ modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)

915−

849+

916− -- we now consider all labels for this identifier unregistered

917− let toDrop pid = not $ ident `impliesDeathOf` ProcessIdentifier pid

850+ modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)

918− (keepNames, dropNames) <- Map.partition toDrop <$> gets (^. registeredHere)

919− mapM_ (\(p, l) -> liftIO $ trace node (MxUnRegistered l p)) (Map.toList dropNames)

920− modify' $ registeredHere ^= keepNames

921

851

922 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

852 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

923 mapM (\(pid,nidlist) ->

853 mapM (\(pid,nidlist) ->

@@ -925,12 +855,12 @@ ncEffectDied ident reason = do

925 True ->

855 True ->

926 do forM_ nidlist $ \(nid,_) ->

856 do forM_ nidlist $ \(nid,_) ->

927 when (not $ isLocal node (NodeIdentifier nid))

857 when (not $ isLocal node (NodeIdentifier nid))

928− (forwardDeath node nid)

858+ (forwardNameDeath node nid)

929 return Nothing

859 return Nothing

930 False -> return $ Just (pid,nidlist) )

860 False -> return $ Just (pid,nidlist) )

931 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

861 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

932 where

862 where

933− forwardDeath node nid = ncSendToNode nid

863+ forwardNameDeath node nid = ncSendToNode nid

934 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

864 NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)

935 , ctrlMsgSignal = Died ident reason

865 , ctrlMsgSignal = Died ident reason

936 }

866 }

@@ -969,11 +899,7 @@ ncEffectRegister from label atnode mPid reregistration = do

969 do modify' $ registeredHereFor label ^= mPid

899 do modify' $ registeredHereFor label ^= mPid

970 updateRemote node currentVal mPid

900 updateRemote node currentVal mPid

971 case mPid of

901 case mPid of

972− (Just p) -> do

973− if reregistration

974− then liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

975− else return ()

976− liftIO $ trace node (MxRegistered p label)

902+ (Just p) -> liftIO $ trace node (MxRegistered p label)

977 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

903 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

978 newVal <- gets (^. registeredHereFor label)

904 newVal <- gets (^. registeredHereFor label)

979 ncSendToProcess from $ unsafeCreateUnencodedMessage $

905 ncSendToProcess from $ unsafeCreateUnencodedMessage $

@@ -1054,12 +980,11 @@ ncEffectLocalPortSend from msg = do

1054 -- If ch is Nothing, the process has given up the read end of

980 -- If ch is Nothing, the process has given up the read end of

1055 -- the channel and we simply ignore the incoming message - this

981 -- the channel and we simply ignore the incoming message - this

1056 ch <- deRefWeak chan'

982 ch <- deRefWeak chan'

1057− forM_ ch $ \chan -> deliverChan node from msg chan

983+ forM_ ch $ \chan -> deliverChan msg chan

1058− where deliverChan :: forall a . LocalNode -> SendPortId -> Message -> TQueue a -> IO ()

984+ where deliverChan :: forall a . Message -> TQueue a -> IO ()

1059− deliverChan n p (UnencodedMessage _ raw) chan' = do

985+ deliverChan (UnencodedMessage _ raw) chan' =

1060 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

986 atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)

1061− trace n (MxReceivedPort p $ unsafeCreateUnencodedMessage raw)

1062− deliverChan _ _ (EncodedMessage _ _) _ =

987+ deliverChan (EncodedMessage _ _) _ =

1063 -- this will not happen unless someone screws with Primitives.hs

988 -- this will not happen unless someone screws with Primitives.hs

1064 error "invalid local channel delivery"

989 error "invalid local channel delivery"

1065

990

@@ -1089,10 +1014,9 @@ ncEffectGetInfo from pid =

1089 case mProc of

1014 case mProc of

1090 Nothing -> dispatch (isLocal node (ProcessIdentifier from))

1015 Nothing -> dispatch (isLocal node (ProcessIdentifier from))

1091 from (ProcessInfoNone DiedUnknownId)

1016 from (ProcessInfoNone DiedUnknownId)

1092− Just proc -> do

1017+ Just proc -> do

1093− itsLinks <- Set.map fst . BiMultiMap.lookupBy1st them <$>

1018+ itsLinks <- gets (^. linksFor them)

1094− gets (^. links)

1019+ itsMons <- gets (^. monitorsFor them)

1095− itsMons <- BiMultiMap.lookupBy1st them <$> gets (^. monitors)

1096 registered <- gets (^. registeredHere)

1020 registered <- gets (^. registeredHere)

1097 size <- liftIO $ queueSize $ processQueue $ proc

1021 size <- liftIO $ queueSize $ processQueue $ proc

1098

1022

@@ -1103,10 +1027,10 @@ ncEffectGetInfo from pid =

1103 infoNode = (processNodeId pid)

1027 infoNode = (processNodeId pid)

1104 , infoRegisteredNames = reg

1028 , infoRegisteredNames = reg

1105 , infoMessageQueueLength = size

1029 , infoMessageQueueLength = size

1106− , infoMonitors = Set.toList itsMons

1030+ , infoMonitors = Set.toList itsMons

1107− , infoLinks = Set.toList itsLinks

1031+ , infoLinks = Set.toList itsLinks

1108 }

1032 }

1109− where dispatch :: (Serializable a)

1033+ where dispatch :: (Serializable a, Show a)

1110 => Bool

1034 => Bool

1111 -> ProcessId

1035 -> ProcessId

1112 -> a

1036 -> a

@@ -1128,8 +1052,8 @@ ncEffectGetNodeStats from _nid = do

1128 NodeStats {

1052 NodeStats {

1129 nodeStatsNode = localNodeId node

1053 nodeStatsNode = localNodeId node

1130 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1054 , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere

1131− , nodeStatsMonitors = BiMultiMap.size $ ncState ^. monitors

1055+ , nodeStatsMonitors = Map.size $ ncState ^. monitors

1132− , nodeStatsLinks = BiMultiMap.size $ ncState ^. links

1056+ , nodeStatsLinks = Map.size $ ncState ^. links

1133 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1057 , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)

1134 }

1058 }

1135 postAsMessage from stats

1059 postAsMessage from stats

@@ -1234,26 +1158,25 @@ throwException :: Exception e => ProcessId -> e -> NC ()

1234throwException pid e = do

1158throwException pid e = do

1235 node <- ask

1159 node <- ask

1236 -- throwTo blocks until the exception is received by the target thread.

1160 -- throwTo blocks until the exception is received by the target thread.

1237− -- We cannot easily make it happen asynchronpusly because then 'unlink'

1161+ -- We fork a helper thread to avoid blocking the node controller.

1238− -- semantics would break.

1239− liftIO $ withLocalProc node pid $ \p -> throwTo (processThread p) e

1162+ liftIO $ withLocalProc node pid $ \p -> void $ forkIO $ throwTo (processThread p) e

1240

1163

1241withLocalProc :: LocalNode -> ProcessId -> (LocalProcess -> IO ()) -> IO ()

1164withLocalProc :: LocalNode -> ProcessId -> (LocalProcess -> IO ()) -> IO ()

1242withLocalProc node pid p =

1165withLocalProc node pid p =

1243 -- By [Unified: table 6, rule missing_process] messages to dead processes

1166 -- By [Unified: table 6, rule missing_process] messages to dead processes

1244 -- can silently be dropped

1167 -- can silently be dropped

1245 let lpid = processLocalId pid in do

1168 let lpid = processLocalId pid in do

1246− join $ withValidLocalState node $ \vst ->

1169+ withValidLocalState node $ \vst ->

1247− return $ forM_ (vst ^. localProcessWithId lpid) p

1170+ forM_ (vst ^. localProcessWithId lpid) p

1248

1171

1249--------------------------------------------------------------------------------

1172--------------------------------------------------------------------------------

1250-- Accessors --

1173-- Accessors --

1251--------------------------------------------------------------------------------

1174--------------------------------------------------------------------------------

1252

1175

1253−links :: Accessor NCState (BiMultiMap Identifier ProcessId ())

1176+links :: Accessor NCState (Map Identifier (Set ProcessId))

1254links = accessor _links (\ls st -> st { _links = ls })

1177links = accessor _links (\ls st -> st { _links = ls })

1255

1178

1256−monitors :: Accessor NCState (BiMultiMap Identifier ProcessId MonitorRef)

1179+monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

1257monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1180monitors = accessor _monitors (\ms st -> st { _monitors = ms })

1258

1181

1259registeredHere :: Accessor NCState (Map String ProcessId)

1182registeredHere :: Accessor NCState (Map String ProcessId)

@@ -1262,6 +1185,12 @@ registeredHere = accessor _registeredHere (\ry st -> st { _registeredHere = ry }

1262registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1185registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

1263registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1186registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

1264

1187

1188+linksFor :: Identifier -> Accessor NCState (Set ProcessId)

1189+linksFor ident = links >>> DAC.mapDefault Set.empty ident

1190+

1191+monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

1192+monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

1193+

1265registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1194registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

1266registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1195registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

1267

1196

@@ -1288,12 +1217,10 @@ registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident

1288-- * the notifications for typed channels to that process.

1217-- * the notifications for typed channels to that process.

1289--

1218--

1290-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1219-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

1291−splitNotif :: (Ord a, Ord v)

1292− => Identifier

1220+splitNotif :: Identifier

1293− -> BiMultiMap Identifier a v

1221+ -> Map Identifier a

1294− -> (Map Identifier (Set (a,v)), BiMultiMap Identifier a v)

1222+ -> (Map Identifier a, Map Identifier a)

1295−splitNotif ident =

1223+splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)

1296− BiMultiMap.partitionWithKeyBy1st (\k !_v -> ident `impliesDeathOf` k)

1297

1224

1298--------------------------------------------------------------------------------

1225--------------------------------------------------------------------------------

1299-- Auxiliary --

1226-- Auxiliary --

src/Control/Distributed/Process/Serializable.hs+18−6

@@ -1,8 +1,8 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE UndecidableInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE CPP #-}

6module Control.Distributed.Process.Serializable

7 ( Serializable

8 , encodeFingerprint

@@ -17,17 +17,25 @@ module Control.Distributed.Process.Serializable

18import Data.Binary (Binary)

20+#if MIN_VERSION_base(4,7,0)

20−import Data.Typeable (Typeable, typeRepFingerprint, typeOf)

21+import Data.Typeable (Typeable)

22+import Data.Typeable.Internal (TypeRep(TypeRep), typeOf)

23+#else

24+import Data.Typeable (Typeable(..))

25+import Data.Typeable.Internal (TypeRep(TypeRep))

26+#endif

22import Numeric (showHex)

28import Numeric (showHex)

23import Control.Exception (throw)

29import Control.Exception (throw)

24import GHC.Fingerprint.Type (Fingerprint(..))

30import GHC.Fingerprint.Type (Fingerprint(..))

25import Data.ByteString (ByteString)

31import Data.ByteString (ByteString)

26import qualified Data.ByteString as BS

32import qualified Data.ByteString as BS

27−import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr )

33+import qualified Data.ByteString.Internal as BSI ( unsafeCreate

34+ , inlinePerformIO

35+ , toForeignPtr

36+ )

28import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

37import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

29import Foreign.ForeignPtr (withForeignPtr)

38import Foreign.ForeignPtr (withForeignPtr)

30−import System.IO.Unsafe (unsafePerformIO)

32-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

40-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

33data SerializableDict a where

41data SerializableDict a where

@@ -55,7 +63,7 @@ decodeFingerprint :: ByteString -> Fingerprint

55decodeFingerprint bs

63decodeFingerprint bs

56 | BS.length bs /= sizeOfFingerprint =

64 | BS.length bs /= sizeOfFingerprint =

57 throw $ userError "decodeFingerprint: Invalid length"

65 throw $ userError "decodeFingerprint: Invalid length"

58− | otherwise = unsafePerformIO $ do

66+ | otherwise = BSI.inlinePerformIO $ do

59 let (fp, offset, _) = BSI.toForeignPtr bs

67 let (fp, offset, _) = BSI.toForeignPtr bs

60 withForeignPtr fp $ \p -> peekByteOff p offset

68 withForeignPtr fp $ \p -> peekByteOff p offset

@@ -65,7 +73,11 @@ sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

66-- | The fingerprint of the typeRep of the argument

74-- | The fingerprint of the typeRep of the argument

67fingerprint :: Typeable a => a -> Fingerprint

75fingerprint :: Typeable a => a -> Fingerprint

76+#if MIN_VERSION_base(4,8,0)

77+fingerprint a = let TypeRep fp _ _ _ = typeOf a in fp

78+#else

68−fingerprint = typeRepFingerprint . typeOf

79+fingerprint a = let TypeRep fp _ _ = typeOf a in fp

80+#endif

70-- | Show fingerprint (for debugging purposes)

82-- | Show fingerprint (for debugging purposes)

71showFingerprint :: Fingerprint -> ShowS

83showFingerprint :: Fingerprint -> ShowS

src/Control/Distributed/Process/UnsafePrimitives.hs+33−82

@@ -32,24 +32,7 @@

32-- the /normal/ strategy).

33--

34-- Use of the functions in this module can potentially change the runtime

35−-- behaviour of your application. In addition, messages passed between Cloud

36−-- Haskell processes are written to a tracing infrastructure on the local node,

37−-- to provide improved introspection and debugging facilities for complex actor

38−-- based systems. This module makes no attempt to force evaluation in these

39−-- cases either, thus evaluation problems in passed data structures could not

40−-- only crash your processes, but could also bring down critical internal

41−-- services on which the node relies to function correctly.

42−--

43−-- If you wish to repudiate such issues, you are advised to consider the use

44−-- of NFSerialisable in the distributed-process-extras package, which type

45−-- class brings NFData into scope along with Serializable, such that we can

46−-- force evaluation. Intended for use with modules such as this one, this

47−-- approach guarantees correct evaluatedness in terms of @NFData@. Please note

48−-- however, that we /cannot/ guarantee that an @NFData@ instance will behave the

49−-- same way as a @Binary@ one with regards evaluation, so it is still possible

50−-- to introduce unexpected behaviour by using /unsafe/ primitives in this way.

51−--

52−-- You have been warned!

35+-- behaviour of your application. You have been warned!

53--

36--

54-- This module is exported so that you can replace the use of Cloud Haskell's

37-- This module is exported so that you can replace the use of Cloud Haskell's

55-- /safe/ messaging primitives. If you want to use both variants, then you can

38-- /safe/ messaging primitives. If you want to use both variants, then you can

@@ -72,12 +55,7 @@ import Control.Distributed.Process.Internal.Messaging

72 , sendBinary

55 , sendBinary

73 , sendCtrlMsg

56 , sendCtrlMsg

74 )

57 )

75−import Control.Distributed.Process.Management.Internal.Types

58+

76− ( MxEvent(..)

77− )

78−import Control.Distributed.Process.Management.Internal.Trace.Types

79− ( traceEvent

80− )

81import Control.Distributed.Process.Internal.Types

59import Control.Distributed.Process.Internal.Types

82 ( ProcessId(..)

60 ( ProcessId(..)

83 , NodeId(..)

61 , NodeId(..)

@@ -101,48 +79,34 @@ import Control.Monad.Reader (ask)

101

102-- | Named send to a process in the local registry (asynchronous)

80-- | Named send to a process in the local registry (asynchronous)

103nsend :: Serializable a => String -> a -> Process ()

81nsend :: Serializable a => String -> a -> Process ()

104−nsend label msg = do

82+nsend label msg =

105− proc <- ask

106− let us = processId proc

107− let msg' = wrapMessage msg

108− -- see [note: tracing]

109− liftIO $ traceEvent (localEventBus (processNode proc))

110− (MxSentToName label us msg')

111− sendCtrlMsg Nothing (NamedSend label msg')

83+ sendCtrlMsg Nothing (NamedSend label (unsafeCreateUnencodedMessage msg))

112

113-- | Named send to a process in a remote registry (asynchronous)

85-- | Named send to a process in a remote registry (asynchronous)

114nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

86nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

115nsendRemote nid label msg = do

87nsendRemote nid label msg = do

116 proc <- ask

88 proc <- ask

117− let us = processId proc

118− let node = processNode proc

119− if localNodeId node == nid

89+ if localNodeId (processNode proc) == nid

120 then nsend label msg

90 then nsend label msg

121− else

122− let lbl = label ++ "@" ++ show nid in do

123− -- see [note: tracing] NB: this is a remote call to another NC...

124− liftIO $ traceEvent (localEventBus node)

125− (MxSentToName lbl us (wrapMessage msg))

126− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

91+ else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

127

128-- | Send a message

93-- | Send a message

129send :: Serializable a => ProcessId -> a -> Process ()

94send :: Serializable a => ProcessId -> a -> Process ()

130send them msg = do

95send them msg = do

131 proc <- ask

96 proc <- ask

132 let node = localNodeId (processNode proc)

97 let node = localNodeId (processNode proc)

133− destNode = (processNodeId them)

98+ destNode = (processNodeId them) in do

134− us = (processId proc)

135− msg' = wrapMessage msg in do

136− -- see [note: tracing]

137− liftIO $ traceEvent (localEventBus (processNode proc))

138− (MxSent them us msg')

139− if destNode == node

99+ case destNode == node of

100+ True -> unsafeSendLocal them msg

101+ False -> liftIO $ sendMessage (processNode proc)

102+ (ProcessIdentifier (processId proc))

103+ (ProcessIdentifier them)

104+ NoImplicitReconnect

105+ msg

106+ where

107+ unsafeSendLocal :: (Serializable a) => ProcessId -> a -> Process ()

108+ unsafeSendLocal pid msg' =

140− then sendCtrlMsg Nothing $ LocalSend them msg'

109+ sendCtrlMsg Nothing $ LocalSend pid (unsafeCreateUnencodedMessage msg')

141− else liftIO $ sendMessage (processNode proc)

142− (ProcessIdentifier (processId proc))

143− (ProcessIdentifier them)

144− NoImplicitReconnect

145− msg

146

110

147-- | Send a message unreliably.

111-- | Send a message unreliably.

148--

112--

@@ -157,43 +121,30 @@ usend :: Serializable a => ProcessId -> a -> Process ()

157usend them msg = do

121usend them msg = do

158 proc <- ask

122 proc <- ask

159 let there = processNodeId them

123 let there = processNodeId them

160− let (us, node) = (processId proc, processNode proc)

161− let msg' = wrapMessage msg

162− -- see [note: tracing]

163− liftIO $ traceEvent (localEventBus node) (MxSent them us msg')

164 if localNodeId (processNode proc) == there

124 if localNodeId (processNode proc) == there

165− then sendCtrlMsg Nothing $ LocalSend them msg'

125+ then sendCtrlMsg Nothing $

126+ LocalSend them (unsafeCreateUnencodedMessage msg)

166 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

127 else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)

167 (createMessage msg)

128 (createMessage msg)

168

129

169−-- [note: tracing]

170−-- Note that tracing writes to the local node's control channel, and this

171−-- module explicitly specifies to its clients that it does unsafe message

172−-- encoding. The same is true for the messages it puts onto the Management

173−-- event bus, however we do *not* want unevaluated thunks hitting the event

174−-- bus control thread. Hence the word /Unsafe/ in this module's name!

175−--

176−

177-- | Send a message on a typed channel

130-- | Send a message on a typed channel

178sendChan :: Serializable a => SendPort a -> a -> Process ()

131sendChan :: Serializable a => SendPort a -> a -> Process ()

179sendChan (SendPort cid) msg = do

132sendChan (SendPort cid) msg = do

180 proc <- ask

133 proc <- ask

181− let node = processNode proc

182− pid = processId proc

183− us = localNodeId node

134+ let node = localNodeId (processNode proc)

184− them = processNodeId (sendPortProcessId cid)

135+ destNode = processNodeId (sendPortProcessId cid) in do

185− msg' = wrapMessage msg in do

136+ case destNode == node of

186− liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid msg')

187− if them == us

188− then unsafeSendChanLocal cid msg' -- NB: we wrap to P.Message !!!

137+ True -> unsafeSendChanLocal cid msg

138+ False -> do

189− else liftIO $ sendBinary node

139+ liftIO $ sendBinary (processNode proc)

190− (ProcessIdentifier pid)

140+ (ProcessIdentifier (processId proc))

191− (SendPortIdentifier cid)

141+ (SendPortIdentifier cid)

192− NoImplicitReconnect

142+ NoImplicitReconnect

193− msg

143+ msg

194 where

144 where

195− unsafeSendChanLocal :: SendPortId -> Message -> Process ()

145+ unsafeSendChanLocal :: (Serializable a) => SendPortId -> a -> Process ()

146+ unsafeSendChanLocal spId msg' =

196− unsafeSendChanLocal p m = sendCtrlMsg Nothing $ LocalPortSend p m

147+ sendCtrlMsg Nothing $ LocalPortSend spId (unsafeCreateUnencodedMessage msg')

197

148

198-- | Create an unencoded @Message@ for any @Serializable@ type.

149-- | Create an unencoded @Message@ for any @Serializable@ type.

199wrapMessage :: Serializable a => a -> Message

150wrapMessage :: Serializable a => a -> Message

stack-ghc-7.10.3.yamldeleted−21

@@ -1,21 +0,0 @@

1−resolver: nightly-2016-03-08

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−- location:

7− git: https://github.com/haskell-distributed/network-transport-tcp.git

8− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9− extra-dep: true

10−

11−extra-deps:

12−- rank1dynamic-0.4.0

13−- distributed-static-0.3.8

14−- network-transport-0.5.2

15−- network-transport-inmemory-0.5.2

16−- rematch-0.2.0.0

17−- exceptions-0.8.2.1 # test dependency

18−

19−flags:

20− distributed-process-tests:

21− tcp: true

stack-ghc-8.0.2.yamldeleted−23

@@ -1,23 +0,0 @@

1−resolver: lts-9.21

2−# added -location for network-transport-tcp-0.6.0

3−# since c7fd79 broke the client facing API for createTransport :/

4−

5−packages:

6−- '.'

7−- distributed-process-tests/

8−- location:

9− git: https://github.com/haskell-distributed/network-transport-tcp.git

10− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11− extra-dep: true

12−

13−extra-deps:

14−- rank1dynamic-0.4.0

15−- distributed-static-0.3.8

16−- network-transport-0.5.2

17−- network-transport-inmemory-0.5.2

18−- rematch-0.2.0.0

19−# - exceptions-0.8.2.1 # test dependency

20−

21−flags:

22− distributed-process-tests:

23− tcp: true

stack-ghc-8.2.2.yamldeleted−21

@@ -1,21 +0,0 @@

1−resolver: lts-11.22

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−- location:

7− git: https://github.com/haskell-distributed/network-transport-tcp.git

8− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9− extra-dep: true

10−

11−extra-deps:

12−- rank1dynamic-0.4.0

13−- distributed-static-0.3.8

14−- network-transport-0.5.2

15−- network-transport-inmemory-0.5.2

16−- rematch-0.2.0.0

17−# - exceptions-0.8.2.1 # test dependency

18−

19−flags:

20− distributed-process-tests:

21− tcp: true

stack-ghc-8.4.4.yamldeleted−20

@@ -1,20 +0,0 @@

1−resolver: lts-12.18

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−- location:

7− git: https://github.com/haskell-distributed/network-transport-tcp.git

8− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

9− extra-dep: true

10−

11−extra-deps:

12−- rank1dynamic-0.4.0

13−- distributed-static-0.3.8

14−- network-transport-0.5.2

15−- network-transport-inmemory-0.5.2

16−- rematch-0.2.0.0

17−

18−flags:

19− distributed-process-tests:

20− tcp: true

stack-nightly.yamldeleted−26

@@ -1,26 +0,0 @@

1−resolver: nightly

2−

3−packages:

4−- '.'

5−- distributed-process-tests/

6−- location:

7− git: https://github.com/haskell-distributed/distributed-static.git

8− commit: c51e6aadd3a44c044e96a8e986c11d3a94b45b11

9− extra-dep: true

10−- location:

11− git: https://github.com/haskell-distributed/network-transport-tcp.git

12− commit: d58250e2388b86a1865ac4139373cbdc106e72e1

13− extra-dep: true

14−- location:

15− git: https://github.com/haskell-distributed/network-transport-inmemory.git

16− commit: 0ce97924f15a8c1570b2355151834305c9bd2a28

17− extra-dep: true

18−

19−extra-deps:

20−- rank1dynamic-0.4.0

21−- network-transport-0.5.2

22−- rematch-0.2.0.0

23−

24−flags:

25− distributed-process-tests:

26− tcp: true

stack.yaml+5−14

@@ -1,22 +1,13 @@

1−resolver: lts-12.18 # Use GHC 8.4.4

1+resolver: nightly-2015-10-09

2−

3−# TODO: we can enable nightly-2018-11-11 once PR #319 is merged

4−

5packages:

2packages:

6- '.'

3- '.'

7- distributed-process-tests/

4- distributed-process-tests/

8−- location:

9− git: https://github.com/haskell-distributed/network-transport-tcp.git

10− commit: d87d6f55697a94a1fbf211ff9c1bb769a1e129cd

11− extra-dep: true

12−

13extra-deps:

5extra-deps:

14−- rank1dynamic-0.4.0

15−- distributed-static-0.3.8

6+- distributed-static-0.3.2.0

16−- network-transport-0.5.2

7+- network-transport-tcp-0.4.2

17−- network-transport-inmemory-0.5.2

8+- network-transport-inmemory-0.5.0

9+- rank1dynamic-0.3.1.0

18- rematch-0.2.0.0

10- rematch-0.2.0.0

19−

20flags:

11flags:

21 distributed-process-tests:

12 distributed-process-tests:

22 tcp: true

13 tcp: true