master..41118a9 · distributed-process

git.iko.soy/distributed-process

138 files changed+13336−14134

unifiedsplit

.gitignore+12−3

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

1+tags

2+TAGS

13dist/

2−.cabal-sandbox

3−cabal.sandbox.config

4−.stack*

4+\#*#

5+*~

6+*.aux

7+*.hp

8+*.hi

9+*.o

10+*.prof

11+*.ps

12+*.swp

13+cabal-dev

.travis.ymldeleted−43

@@ -1,43 +0,0 @@

1−language: c

2−

3−sudo: false

4−

5−matrix:

6− include:

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

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

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

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

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

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

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

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

15−

16−cache:

17− directories:

18− - $HOME/.stack

19−

20−before_install:

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

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

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

24− stack --version

25−

26−install:

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

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

29−

30−script:

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

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

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

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

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

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

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

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

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

40−

41−notifications:

42− slack:

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

CONTRIBUTING.mddeleted−1

@@ -1 +0,0 @@

1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.

ChangeLogdeleted−236

@@ -1,236 +0,0 @@

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−

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

68−

69−* Have nsendRemote skip the transport for local communication.

70−* Unsafe primitives for usend and nsendRemote.

71−* Stop using the transport for local communication.

72−* Skip the transport for whereisRemoteAsync and registerRemoteAsync.

73−* Have nsendRemote skip the transport for local communication.

74−* Have runProcess forward exceptions.

75−* Reimport distributed-process-tests. d-p and d-p-test now can be kept in

76−sync.

77−* Add a stack.yaml file for building tests and d-p all at once conveniently.

78−* Implement unreliable forward (uforward).

79−* Add Functor instance for Match data type

80−* Have `spawnAsync` not use the transport in the local case.

81−* Fix monitor race in 'call'.

82−* Add compatibility with ghc-7.10: support new typeable, loosen deps, write

83−proper NFData instances, support new TH.

84−* Kill processes on a local node upon closeLocalNode.

85−* Fix getNodeStats function, see DP-97

86−* Return size of the queue in ProcessInfo.

87−* Implement unreliable send (usend).

88−* Implement MonadFix instance for Process.

89−* Introduce callLocal primitive.

90−* Prevent message loss due to timeouts in CQueue.

91−* More informative ProcessRegistrationException. Now includes the identifier

92−of the process that owns the name, if any.

93−* Avoid message loop between threads when tracing received messages.

94−

95−2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5

96−

97−* Fix dependencies.

98−* Add compatibility with GHC-7.10.

99−* Fix various race conditions (DP-99, DP-103).

100−

101−2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.5.2

102−

103−* Fix docstring for `register`

104−* Added Data instance to ProcessId, LocalProcessId and NodeId

105−* Add static serialiation dictionary for 'Static', for completeness

106−* Add Closure static serialization dictionary

107−* Replacement for modifyMVarMasked for GHC <= 7.4

108−* Document the use of built-in trace flags

109−* Make forkProcess exception-safe

110−* Make -Wall clean

111−

112−2014-08-13 Tim Watson <watson.timothy@gmail.com> 0.5.1

113−

114−* Fix cabal docs (thanks Markus Barenhoff)

115−* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)

116−

117−2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.5.0

118−

119−* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file

120−* Race condition in local monitoring when using call

121−* mask now works correctly if unmask is called by another process

122−* Improve efficiency of local message passing

123−* nsend uses local communication channels

124−* Link Node Controller and Network Listener

125−* Label spawned processes using labelThread

126−* Relaxed upper bound on syb in the cabal manifest

127−* Bump binary version to include 0.7.*

128−* Exposed process info

129−* Exposed node statistics

130−* Moved tests to https://github.com/haskell-distributed/distributed-process-tests

131−* Added "polymorphic expect"

132−* Exposed Message type and broaden scope of polymorphic expect

133−* Added Management API (for working with internal/system events)

134−* Tracing can no longer be disabled

135−* We now report node statistics for monitoring/management

136−* Node.runProcess now propagates exceptions to its caller

137−* Added simple micro benchmarks

138−

139−2013-01-27 Tim Watson <watson.timothy@gmail.com> 0.4.2

140−

141−* Improved exception handling for deferred type checked exit reasons

142−* Add matchChan primitive (thanks Simon Marlow)

143−* Expose deferred message handling/checking for AbstractMessage

144−* Add `getProcessInfo' API

145−* Add `trace' API backed by the GHC eventlog

146−

147−2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.4.1

148−

149−* Make behaviour of 'register' more Erlang-like (register will now fail if the

150−name is already registered). Patch by Jeff Epstein.

151−* Functor, Applicative, Alternative and Monad instances for ReceivePort

152−* Add support for receiveChanTimeout

153−* Improved documentation

154−* Avoid name clashes in the TH generation for closures

155−* Relax package bounds to allow for Binary 0.6

156−

157−2012-10-23 Edsko de Vries <edsko@well-typed.com> 0.4.0.2

158−

159−* Fix race condition in spawn

160−

161−2012-10-04 Edsko de Vries <edsko@well-typed.com> 0.4.0.1

162−

163−* Relax package boundaries

164−

165−2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.4.0

166−

167−* Improved treatment of network failure, using new failure semantics of

168−Network.Transport.

169−* Make NodeId Typeable

170−* Extend Template Haskell support with "remotableDec" so that you can refer to

171−$(mkClosure 'f) within the body of "f".

172−* Fix bug in spawnChannelLocal

173−* Numerous memory leaks plugged

174−* Relax upper bound on dependency on 'network'

175−* New primitive 'matchAny'

176−* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync')

177−

178−2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1

179−

180−* Fix memory leaks

181−* Make Template Haskell support optional

182−* Relax dependency constraints

183−

184−2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0

185−

186−* Extract 'static' into a separate package (C.D.Static)

187−* Use new package rank1dynamic to proper runtime checks for polymorphic values

188−

189−2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0

190−

191−* Expose the constructors of Closure

192−* Add instance (Typeable a => Serializable (Static a)) and make sure we only

193−use the internal representation of Static where really necessary

194−* Improved docs

195−

196−2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

197−

198−* Add exception handling primitives

199−* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on

200−MVar' exception would be thrown.

201−

202−2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

203−

204−* Bugfix in the node controller

205−(one way this bug materialized: when using the SimpleLocalnet backend,

206−slave nodes could not be reused)

207−* Improved documentation in Control.Distributed.Process.Closure

208−

209−2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3

210−

211−* Improve docs

212−* Local versions of spawn

213−

214−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2

215−

216−* Base 4.6 compatibility

217−* Relax constraints on bytestring and containers

218−

219−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1

220−

221−* Relax upper bound on 'time' dependency

222−

223−2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1

224−

225−* Complete redesign of the underlying implementation of static values and

226−closures.

227−

228−* Add support for 'spawnChannel'

229−

230−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

231−

232−* Bugfix: Continue processing messages when a connection breaks.

233−

234−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

235−

236−* Initial release.

README.md+24−11

@@ -1,16 +1,29 @@

1−# distributed-process

2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)

3−[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)

1+Haskell Distributed Project

2+===========================

5−This repository is part of Cloud Haskell.

4+This repository holds an implementation of [Cloud Haskell][1].

7−See http://haskell-distributed.github.com for documentation, user guides,

8−tutorials and assistance.

6+At present, this repository hosts

10−## Getting Help / Raising Issues

8+* network-transport

9+* network-transport-tcp

10+* network-transport-inmemory (incomplete)

11+* distributed-process

12+* distributed-process-simplelocalnet

13+* azure-service-api (skeleton only)

1114

12−Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.

15+For more detailed information about the interfaces provided by these packages,

16+please refer to the [distributed-process repository wiki][2]. People who wish

17+to get started with Cloud Haskell should cabal install

18+distributed-process and possibly distributed-process-simplelocalnet and refer

19+to the corresponding Haddock documentation ([Control.Distributed.Process][3],

20+[Control.Distributed.Process.Closure][4],

21+[Control.Distributed.Process.Node][5], and

22+[Control.Distributed.Process.Backend.SimpleLocalnet[6]).

1323

14−## License

15−

16−This package is made available under a 3-clause BSD-style license.

24+[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf

25+[2]: https://github.com/haskell-distributed/distributed-process/wiki

26+[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html

27+[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html

28+[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html

29+[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html

azure-service-api/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Edsko de Vries nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs → azure-service-api/Setup.hsrenamed

The content is the same.

azure-service-api/azure-service-api.cabalnew file+40

@@ -0,0 +1,40 @@

1+-- Initial azure-service-api.cabal generated by cabal init. For further

2+-- documentation, see http://haskell.org/cabal/users-guide/

4+Name: azure-service-api

5+Version: 0.1.0.0

6+Synopsis: Haskell bindings for the Azure Service Management API

7+-- description:

8+Homepage: github.com/haskell-distributed/azure-service-api

9+License: BSD3

10+License-File: LICENSE

11+Author: Edsko de Vries

12+Maintainer: edsko@well-typed.com

13+Copyright: Well-Typed LLP

14+Category: Network

15+Build-Type: Simple

16+Cabal-Version: >=1.8

17+

18+Library

19+ Exposed-Modules: Network.Azure.ServiceManagement

20+ Build-Depends: base ==4.5.*,

21+ tls >= 1.0,

22+ tls-extra

23+ HS-Source-Dirs: src

24+ ghc-options: -Wall

25+

26+Executable hs-azure-service-api

27+ Main-Is: src/Network/Azure/ServiceManagement/CommandLine.hs

28+ Build-Depends: base ==4.5.*,

29+ tls >= 1.0,

30+ tls-extra,

31+ azure-service-api,

32+ cprng-aes,

33+ network,

34+ certificate,

35+ bytestring,

36+ filepath,

37+ libssh2,

38+ utf8-string

39+ Extensions: ScopedTypeVariables

40+ ghc-options: -Wall -rtsopts

azure-service-api/src/Network/Azure/ServiceManagement.hsnew file+8

@@ -0,0 +1,8 @@

1+module Network.Azure.ServiceManagement

2+ (

3+ -- * Re-export functionality from TLS

4+ fileReadCertificate

5+ , fileReadPrivateKey

6+ ) where

8+import Network.TLS.Extra

azure-service-api/src/Network/Azure/ServiceManagement/CommandLine.hsnew file+216

@@ -0,0 +1,216 @@

1+-- Base

2+import Prelude hiding (catch)

3+import System.Environment (getArgs, getEnv)

4+import System.IO (IOMode(ReadWriteMode), hClose)

5+import System.FilePath ((</>), takeFileName)

6+import Data.IORef (IORef, writeIORef, readIORef, newIORef)

7+import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, putStrLn)

8+import Control.Exception (SomeException, catch)

10+-- SSL

11+import qualified Crypto.Random.AESCtr as RNG (makeSystem)

12+import Network.Azure.ServiceManagement

13+ ( fileReadCertificate

14+ , fileReadPrivateKey

15+ )

16+import Network.Socket

17+ ( socket

18+ , Family(AF_INET)

19+ , SocketType(Stream)

20+ , defaultProtocol

21+ , SockAddr(SockAddrInet)

22+ , connect

23+ , sClose

24+ , socketToHandle

25+ , HostName

26+ , PortNumber

27+ )

28+import Network.BSD (getHostByName, hostAddresses)

29+import Network.TLS

30+ ( contextNewOnHandle

31+ , Params

32+ , Context

33+ , defaultLogging

34+ , loggingPacketSent

35+ , loggingPacketRecv

36+ , onCertificateRequest

37+ , onCertificatesRecv

38+ , pLogging

39+ , pCertificates

40+ , pCiphers

41+ , pConnectVersion

42+ , pAllowedVersions

43+ , setSessionManager

44+ , defaultParamsClient

45+ , updateClientParams

46+ , clientWantSessionResume

47+ , Version(TLS10, TLS11, TLS12)

48+ , SessionManager(sessionEstablish, sessionResume, sessionInvalidate)

49+ , SessionID

50+ , SessionData

51+ , PrivateKey

52+ , handshake

53+ , sendData

54+ , recvData'

55+ , bye

56+ )

57+import Network.TLS.Extra

58+ ( certificateVerifyChain

59+ , ciphersuite_all

60+ )

61+import Data.Certificate.X509 (X509)

62+

63+-- SSH

64+import Network.SSH.Client.LibSSH2

65+ ( withSSH2

66+ , scpReceiveFile

67+ , scpSendFile

68+ , checkHost

69+ , withSession

70+ , readAllChannel

71+ )

72+import Network.SSH.Client.LibSSH2.Foreign

73+ ( initialize

74+ , exit

75+ , publicKeyAuthFile

76+ , channelExecute

77+ )

78+import Codec.Binary.UTF8.String (decodeString)

79+

80+main :: IO ()

81+main = do

82+ args <- getArgs

83+ case args of

84+ ["azure", subscriptionId, pathToCert, pathToKey] ->

85+ tryConnectToAzure subscriptionId pathToCert pathToKey

86+ ["command", user, host, port, cmd] ->

87+ runCommand user host (read port) cmd

88+ ["send", user, host, port, path] ->

89+ sendFile user host (read port) path

90+ ["receive", user, host, port, path] ->

91+ receiveFile user host (read port) path

92+ _ ->

93+ putStrLn "Invalid command line arguments"

94+

95+--------------------------------------------------------------------------------

96+-- Taken from libssh2/ssh-client --

97+--------------------------------------------------------------------------------

98+

99+runCommand login host port command =

100+ ssh login host port $ \ch -> do

101+ channelExecute ch command

102+ result <- readAllChannel ch

103+ let r = decodeString result

104+ print (length result)

105+ print (length r)

106+ putStrLn r

107+

108+sendFile login host port path = do

109+ initialize True

110+ home <- getEnv "HOME"

111+ let known_hosts = home </> ".ssh" </> "known_hosts"

112+ public = home </> ".ssh" </> "id_rsa.pub"

113+ private = home </> ".ssh" </> "id_rsa"

114+

115+ withSession host port $ \_ s -> do

116+ r <- checkHost s host port known_hosts

117+ print r

118+ publicKeyAuthFile s login public private ""

119+ sz <- scpSendFile s 0o644 path (takeFileName path)

120+ putStrLn $ "Sent: " ++ show sz ++ " bytes."

121+ exit

122+

123+receiveFile login host port path = do

124+ initialize True

125+ home <- getEnv "HOME"

126+ let known_hosts = home </> ".ssh" </> "known_hosts"

127+ public = home </> ".ssh" </> "id_rsa.pub"

128+ private = home </> ".ssh" </> "id_rsa"

129+

130+ withSession host port $ \_ s -> do

131+ r <- checkHost s host port known_hosts

132+ print r

133+ publicKeyAuthFile s login public private ""

134+ sz <- scpReceiveFile s (takeFileName path) path

135+ putStrLn $ "Received: " ++ show sz ++ " bytes."

136+ exit

137+

138+ssh login host port actions = do

139+ initialize True

140+ home <- getEnv "HOME"

141+ let known_hosts = home </> ".ssh" </> "known_hosts"

142+ public = home </> ".ssh" </> "id_rsa.pub"

143+ private = home </> ".ssh" </> "id_rsa"

144+ withSSH2 known_hosts public private login host port $ actions

145+ exit

146+

147+--------------------------------------------------------------------------------

148+-- Taken from tls-debug/src/SimpleClient.hs --

149+--------------------------------------------------------------------------------

150+

151+tryConnectToAzure :: String -> String -> String -> IO ()

152+tryConnectToAzure subscriptionId pathToCert pathToKey = do

153+ cert <- fileReadCertificate pathToCert

154+ key <- fileReadPrivateKey pathToKey

155+ sessionState <- newIORef undefined

156+ let hostname = "management.core.windows.net"

157+ let port = 443

158+ runTLS (getDefaultParams sessionState [(cert, Just key)]) hostname port $ \ctx -> do

159+ handshake ctx

160+ sendData ctx $ BSLC.pack $ concat

161+ [ "GET /" ++ subscriptionId ++ "/services/hostedservices HTTP/1.1\r\n"

162+ , "host: " ++ hostname ++ "\r\n"

163+ , "content-type: application/xml\r\n"

164+ , "x-ms-version: 2010-10-28\r\n"

165+ , "\r\n"

166+ ]

167+ d <- recvData' ctx

168+ bye ctx

169+ BSLC.putStrLn d

170+

171+runTLS :: Params -> HostName -> PortNumber -> (Context -> IO a) -> IO ()

172+runTLS params hostname portNumber f = do

173+ rng <- RNG.makeSystem

174+ he <- getHostByName hostname

175+ sock <- socket AF_INET Stream defaultProtocol

176+ let sockaddr = SockAddrInet portNumber (head $ hostAddresses he)

177+ catch (connect sock sockaddr)

178+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e))

179+ dsth <- socketToHandle sock ReadWriteMode

180+ ctx <- contextNewOnHandle dsth params rng

181+ _ <- f ctx

182+ hClose dsth

183+

184+getDefaultParams :: IORef (SessionID, SessionData)

185+ -> [(X509, Maybe PrivateKey)]

186+ -> Params

187+getDefaultParams sessionState certs =

188+ updateClientParams setCParams $ setSessionManager (SessionRef sessionState) $ defaultParamsClient

189+ { pConnectVersion = TLS10

190+ , pAllowedVersions = [TLS10,TLS11,TLS12]

191+ , pCiphers = ciphersuite_all

192+ , pCertificates = certs

193+ , pLogging = logging

194+ , onCertificatesRecv = crecv

195+ }

196+ where

197+ setCParams cparams = cparams { clientWantSessionResume = Nothing

198+ , onCertificateRequest = creq

199+ }

200+ logging = defaultLogging

201+ { loggingPacketSent = putStrLn . ("debug: >> " ++)

202+ , loggingPacketRecv = putStrLn . ("debug: << " ++)

203+ }

204+ crecv = certificateVerifyChain

205+ creq _ = return certs

206+

207+data SessionRef = SessionRef (IORef (SessionID, SessionData))

208+

209+instance SessionManager SessionRef where

210+ sessionEstablish (SessionRef ref) sid sdata =

211+ writeIORef ref (sid,sdata)

212+ sessionResume (SessionRef ref) sid = do

213+ (s, d) <- readIORef ref

214+ if s == sid then return (Just d) else return Nothing

215+ sessionInvalidate _ _ =

216+ return ()

benchmarks/Channels.hsdeleted−43

@@ -1,43 +0,0 @@

1−-- | Like Latency, but creating lots of channels

2−import System.Environment

3−import Control.Monad

4−import Control.Applicative

5−import Control.Distributed.Process

6−import Control.Distributed.Process.Node

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

8−import Data.Binary (encode, decode)

9−import qualified Data.ByteString.Lazy as BSL

10−

11−pingServer :: Process ()

12−pingServer = forever $ do

13− them <- expect

14− sendChan them ()

15− -- TODO: should this be automatic?

16− reconnectPort them

17−

18−pingClient :: Int -> ProcessId -> Process ()

19−pingClient n them = do

20− replicateM_ n $ do

21− (sc, rc) <- newChan :: Process (SendPort (), ReceivePort ())

22− send them sc

23− receiveChan rc

24− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

25−

26−initialProcess :: String -> Process ()

27−initialProcess "SERVER" = do

28− us <- getSelfPid

29− liftIO $ BSL.writeFile "pingServer.pid" (encode us)

30− pingServer

31−initialProcess "CLIENT" = do

32− n <- liftIO $ getLine

33− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

34− pingClient (read n) them

35−

36−main :: IO ()

37−main = do

38− [role, host, port] <- getArgs

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

40− case trans of

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

42− runProcess node $ initialProcess role

43− Left other -> error $ show other

benchmarks/Latency.hsdeleted−39

@@ -1,39 +0,0 @@

1−import System.Environment

2−import Control.Monad

3−import Control.Applicative

4−import Control.Distributed.Process

5−import Control.Distributed.Process.Node

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

7−import Data.Binary (encode, decode)

8−import qualified Data.ByteString.Lazy as BSL

9−

10−pingServer :: Process ()

11−pingServer = forever $ do

12− them <- expect

13− send them ()

14−

15−pingClient :: Int -> ProcessId -> Process ()

16−pingClient n them = do

17− us <- getSelfPid

18− replicateM_ n $ send them us >> (expect :: Process ())

19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

20−

21−initialProcess :: String -> Process ()

22−initialProcess "SERVER" = do

23− us <- getSelfPid

24− liftIO $ BSL.writeFile "pingServer.pid" (encode us)

25− pingServer

26−initialProcess "CLIENT" = do

27− n <- liftIO $ getLine

28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

29− pingClient (read n) them

30−

31−main :: IO ()

32−main = do

33− [role, host, port] <- getArgs

34− trans <- createTransport

35− (defaultTCPAddr host port) defaultTCPParameters

36− case trans of

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

38− runProcess node $ initialProcess role

39− Left other -> error $ show other

benchmarks/ProcessRing.hsdeleted−117

@@ -1,117 +0,0 @@

1−{- ProcessRing benchmarks.

2−

3−To run the benchmarks, select a value for the ring size (sz) and

4−the number of times to send a message around the ring

5−

6−-}

7−

8−{-# LANGUAGE BangPatterns #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−

11−import Control.Monad

12−import Control.Distributed.Process hiding (catch)

13−import Control.Distributed.Process.Node

14−import Control.Exception (catch, SomeException)

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

16−import System.Environment

17−import System.Console.GetOpt

18−

19−data Options = Options

20− { optRingSize :: Int

21− , optIterations :: Int

22− , optForward :: Bool

23− , optParallel :: Bool

24− , optUnsafe :: Bool

25− } deriving Show

26−

27−initialProcess :: Options -> Process ()

28−initialProcess op =

29− let ringSz = optRingSize op

30− msgCnt = optIterations op

31− fwd = optForward op

32− unsafe = optUnsafe op

33− msg = ("foobar", "baz")

34− in do

35− self <- getSelfPid

36− ring <- makeRing fwd unsafe ringSz self

37− forM_ [1..msgCnt] (\_ -> send ring msg)

38− collect msgCnt

39− where relay fsend pid = do

40− msg <- expect :: Process (String, String)

41− fsend pid msg

42− relay fsend pid

43−

44− forward' pid =

45− receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid

46−

47− makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId

48− makeRing !f !u !n !pid

49− | n == 0 = go f u pid

50− | otherwise = go f u pid >>= makeRing f u (n - 1)

51−

52− go :: Bool -> Bool -> ProcessId -> Process ProcessId

53− go False False next = spawnLocal $ relay send next

54− go False True next = spawnLocal $ relay unsafeSend next

55− go True _ next = spawnLocal $ forward' next

56−

57− collect :: Int -> Process ()

58− collect !n

59− | n == 0 = return ()

60− | otherwise = do

61− receiveWait [

62− matchIf (\(a, b) -> a == "foobar" && b == "baz")

63− (\_ -> return ())

64− , matchAny (\_ -> error "unexpected input!")

65− ]

66− collect (n - 1)

67−

68−defaultOptions :: Options

69−defaultOptions = Options

70− { optRingSize = 10

71− , optIterations = 100

72− , optForward = False

73− , optParallel = False

74− , optUnsafe = False

75− }

76−

77−options :: [OptDescr (Options -> Options)]

78−options =

79− [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"

80− , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"

81− , Option ['f'] ["forward"]

82− (NoArg (\opts -> opts { optForward = True }))

83− "use `forward' instead of send - default = False"

84− , Option ['u'] ["unsafe-send"]

85− (NoArg (\opts -> opts { optUnsafe = True }))

86− "use 'unsafeSend' (ignored with -f) - default = False"

87− , Option ['p'] ["parallel"]

88− (NoArg (\opts -> opts { optParallel = True }))

89− "send in parallel and consume sequentially - default = False"

90− ]

91−

92−optMsgCnt :: Maybe String -> Options -> Options

93−optMsgCnt Nothing opts = opts

94−optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }

95−

96−optSz :: Maybe String -> Options -> Options

97−optSz Nothing opts = opts

98−optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }

99−

100−parseArgv :: [String] -> IO (Options, [String])

101−parseArgv argv = do

102− pn <- getProgName

103− case getOpt Permute options argv of

104− (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)

105− (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))

106− where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"

107−

108−main :: IO ()

109−main = do

110− argv <- getArgs

111− (opt, _) <- parseArgv argv

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

113− Right transport <- createTransport

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

115− node <- newLocalNode transport initRemoteTable

116− catch (void $ runProcess node $ initialProcess opt)

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

benchmarks/Spawns.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−-- | Like Throughput, but send every ping from a different process

4−-- (i.e., require a lightweight connection per ping)

5−import System.Environment

6−import Control.Monad

7−import Control.Applicative

8−import Control.Distributed.Process

9−import Control.Distributed.Process.Node

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

11−import Data.Binary (encode, decode)

12−import qualified Data.ByteString.Lazy as BSL

13−

14−counter :: Process ()

15−counter = go 0

16− where

17− go :: Int -> Process ()

18− go !n = do

19− b <- expect

20− case b of

21− Nothing -> go (n + 1)

22− Just them -> send them n >> go 0

23−

24−count :: Int -> ProcessId -> Process ()

25−count n them = do

26− us <- getSelfPid

27− replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)

28− send them (Just us)

29− n' <- expect

30− liftIO $ print (n == n')

31−

32−initialProcess :: String -> Process ()

33−initialProcess "SERVER" = do

34− us <- getSelfPid

35− liftIO $ BSL.writeFile "counter.pid" (encode us)

36− counter

37−initialProcess "CLIENT" = do

38− n <- liftIO $ getLine

39− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

40− count (read n) them

41−

42−main :: IO ()

43−main = do

44− [role, host, port] <- getArgs

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

46− case trans of

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

48− runProcess node $ initialProcess role

49− Left other -> error $ show other

benchmarks/Throughput.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−

4−import System.Environment

5−import Control.Monad

6−import Control.Applicative

7−import Control.Distributed.Process

8−import Control.Distributed.Process.Node

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

10−import Data.Binary

11−import qualified Data.ByteString.Lazy as BSL

12−import Data.Typeable

13−

14−data SizedList a = SizedList { size :: Int , elems :: [a] }

15− deriving (Typeable)

16−

17−instance Binary a => Binary (SizedList a) where

18− put (SizedList sz xs) = put sz >> mapM_ put xs

19− get = do

20− sz <- get

21− xs <- getMany sz

22− return (SizedList sz xs)

23−

24−-- Copied from Data.Binary

25−getMany :: Binary a => Int -> Get [a]

26−getMany = go []

27− where

28− go xs 0 = return $! reverse xs

29− go xs i = do x <- get

30− x `seq` go (x:xs) (i-1)

31−{-# INLINE getMany #-}

32−

33−nats :: Int -> SizedList Int

34−nats = \n -> SizedList n (aux n)

35− where

36− aux 0 = []

37− aux n = n : aux (n - 1)

38−

39−counter :: Process ()

40−counter = go 0

41− where

42− go :: Int -> Process ()

43− go !n =

44− receiveWait

45− [ match $ \xs -> go (n + size (xs :: SizedList Int))

46− , match $ \them -> send them n >> go 0

47− ]

48−

49−count :: (Int, Int) -> ProcessId -> Process ()

50−count (packets, sz) them = do

51− us <- getSelfPid

52− replicateM_ packets $ send them (nats sz)

53− send them us

54− n' <- expect

55− liftIO $ print (packets * sz, n' == packets * sz)

56−

57−initialProcess :: String -> Process ()

58−initialProcess "SERVER" = do

59− us <- getSelfPid

60− liftIO $ BSL.writeFile "counter.pid" (encode us)

61− counter

62−initialProcess "CLIENT" = do

63− n <- liftIO getLine

64− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

65− count (read n) them

66−

67−main :: IO ()

68−main = do

69− [role, host, port] <- getArgs

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

71− case trans of

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

73− runProcess node $ initialProcess role

74− Left other -> error $ show other

benchmarks/erlang/latency.erldeleted−35

@@ -1,35 +0,0 @@

1−-module(latency).

2−

3−-export([server/0, client/2, start_server/0, start_client/2]).

4−

5−forever(What) ->

6− What(),

7− forever(What).

8−

9−replicate(0, _) ->

10− ok;

11−replicate(N, What) ->

12− What(),

13− replicate(N - 1, What).

14−

15−server() ->

16− forever(fun () ->

17− receive

18− Them -> Them ! pong

19− end

20− end).

21−

22−client(N, Them) ->

23− replicate(N, fun() ->

24− {pingServer, Them} ! self(),

25− receive

26− pong -> ok

27− end

28− end),

29− io:format("Did ~B pings", [N]).

30−

31−start_server() ->

32− register(pingServer, spawn(latency, server, [])).

33−

34−start_client(N, Them) ->

35− client(N, Them).

benchmarks/erlang/ring.erldeleted−62

@@ -1,62 +0,0 @@

1−%% can be run via escript if desired...

2−-module(ring).

3−

4−-export([main/1]).

5−

6−-record(opts, {

7− ring_size = 1 :: non_neg_integer(),

8− iterations = 1 :: non_neg_integer()

9−}).

10−

11−main(Argv) when is_list(Argv) ->

12− Opts = parse_args(Argv),

13− {Time, ok} = timer:tc(fun() -> run(Opts) end),

14− io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).

15−

16−run(#opts{ ring_size=RingSize, iterations=SendCount }) ->

17− Self = self(),

18− Msg = {"foobar", "baz"},

19− Pid = make_ring(RingSize, Self),

20− [Pid ! Msg || _ <- lists:seq(1, SendCount)],

21− collect(SendCount).

22−

23−collect(0) ->

24− ok;

25−collect(N) ->

26− receive

27− {"foobar", "baz"} -> collect(N - 1);

28− Other -> exit({unexpected_message, Other})

29− end.

30−

31−-spec(make_ring(integer(), pid()) -> pid()).

32−make_ring(0, NextPid) ->

33− go(NextPid);

34−make_ring(NumProcs, NextPid) ->

35− make_ring(NumProcs - 1, go(NextPid)).

36−

37−-spec(go(pid()) -> pid()).

38−go(NextPid) ->

39− spawn(fun() -> relay(NextPid) end).

40−

41−-spec(relay(pid()) -> no_return()).

42−relay(NextPid) ->

43− receive

44− {_, _}=Msg -> NextPid ! Msg, relay(NextPid)

45− end.

46−

47−-spec(parse_args([string()]) -> #opts{}).

48−parse_args(Argv) ->

49− lists:foldl(fun parse_args/2, #opts{}, Argv).

50−

51−parse_args(("-r" ++ Val), Opts) ->

52− Sz = check_positive(ring_size, list_to_integer(Val)),

53− Opts#opts{ ring_size = Sz };

54−parse_args(("-i" ++ Val), Opts) ->

55− Iter = check_positive(iterations, list_to_integer(Val)),

56− Opts#opts{ iterations = Iter }.

57−

58−check_positive(K, N) when N < 1 ->

59− io:format("~p must be >= 1~n", [K]),

60− error({K, N});

61−check_positive(_, N) ->

62− N.

benchmarks/erlang/throughput.erldeleted−39

@@ -1,39 +0,0 @@

1−-module(throughput).

2−

3−-export([start_counter/0, start_count/3, counter/0, count/3, nats/1]).

4−

5−nats(0) ->

6− [];

7−nats(N) ->

8− [N | nats(N - 1)].

9−

10−counter() ->

11− counter(0).

12−

13−counter(N) ->

14− receive

15− {count, List} ->

16− counter(N + length(List));

17− {get, Them} ->

18− Them ! N,

19− counter(0)

20− end.

21−

22−replicate(0, _) ->

23− ok;

24−replicate(N, What) ->

25− What(),

26− replicate(N - 1, What).

27−

28−count(Packets, Size, Them) ->

29− replicate(Packets, fun() -> {counter, Them} ! {count, nats(Size)} end),

30− {counter, Them} ! {get, self()},

31− receive

32− N -> io:format("Did ~B pings", [N])

33− end.

34−

35−start_counter() ->

36− register(counter, spawn(throughput, counter, [])).

37−

38−start_count(Packets, Size, Them) ->

39− count(Packets, Size, Them).

benchmarks/remote/Latency.hsdeleted−32

@@ -1,32 +0,0 @@

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

2−

3−import Control.Monad

4−import Control.Applicative

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

6−import qualified Data.ByteString.Lazy as BSL

7−import Data.Binary (encode, decode)

8−import Remote

9−

10−pingServer :: ProcessM ()

11−pingServer = forever $ do

12− them <- expect

13− send them ()

14−

15−pingClient :: Int -> ProcessId -> ProcessM ()

16−pingClient n them = do

17− us <- getSelfPid

18− replicateM_ n $ send them us >> (expect :: ProcessM ())

19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

20−

21−initialProcess :: String -> ProcessM ()

22−initialProcess "SERVER" = do

23− us <- getSelfPid

24− liftIO $ BSL.writeFile "pingServer.pid" (encode us)

25− pingServer

26−initialProcess "CLIENT" = do

27− n <- liftIO $ getLine

28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

29− pingClient (read n) them

30−

31−main :: IO ()

32−main = remoteInit (Just "config") [] initialProcess

benchmarks/remote/Throughput.hsdeleted−39

@@ -1,39 +0,0 @@

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

2−

3−import Control.Monad

4−import Control.Applicative

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

6−import qualified Data.ByteString.Lazy as BSL

7−import Data.Binary (encode, decode)

8−import Remote

9−

10−counter :: ProcessM ()

11−counter = go 0

12− where

13− go :: Int -> ProcessM ()

14− go !n = do

15− b <- expect

16− case b of

17− Nothing -> go (n + 1)

18− Just them -> send them n >> go 0

19−

20−count :: Int -> ProcessId -> ProcessM ()

21−count n them = do

22− us <- getSelfPid

23− replicateM_ n $ send them (Nothing :: Maybe ProcessId)

24− send them (Just us)

25− n' <- expect

26− liftIO $ print (n == n')

27−

28−initialProcess :: String -> ProcessM ()

29−initialProcess "SERVER" = do

30− us <- getSelfPid

31− liftIO $ BSL.writeFile "counter.pid" (encode us)

32− counter

33−initialProcess "CLIENT" = do

34− n <- liftIO $ getLine

35− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

36− count (read n) them

37−

38−main :: IO ()

39−main = remoteInit (Just "config") [] initialProcess

distributed-process-simplelocalnet/ChangeLognew file+15

@@ -0,0 +1,15 @@

1+2012-07-17 Edsko de Vries <edsko@well-typed.com> 0.2.0.3

3+* Improve documentation

5+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2

7+* Relax contraints on bytestring and containers

9+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

10+

11+* Bugfix: Documentation referred to old module name

12+

13+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

14+

15+* Initial release.

distributed-process-tests/LICENSE → distributed-process-simplelocalnet/LICENSErenamed

The content is the same.

distributed-process-tests/Setup.hs → distributed-process-simplelocalnet/Setup.hsrenamed

The content is the same.

distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabalnew file+63

@@ -0,0 +1,63 @@

1+Name: distributed-process-simplelocalnet

2+Version: 0.2.0.3

3+Cabal-Version: >=1.8

4+Build-Type: Simple

5+License: BSD3

6+License-File: LICENSE

7+Copyright: Well-Typed LLP

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

9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com

10+Stability: experimental

11+Homepage: http://github.com/haskell-distributed/distributed-process

12+Bug-Reports: mailto:edsko@well-typed.com

13+Synopsis: Simple zero-configuration backend for Cloud Haskell

14+Description: Simple backend based on the TCP transport which offers node

15+ discovery based on UDP multicast. This is a zero-configuration

16+ backend designed to get you going with Cloud Haskell quickly

17+ without imposing any structure on your application.

18+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2

19+Category: Control

20+

21+Source-Repository head

22+ Type: git

23+ Location: https://github.com/haskell-distributed/distributed-process

24+ SubDir: distributed-process-simplelocalnet

25+

26+Library

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

28+ bytestring >= 0.9 && < 0.11,

29+ network >= 2.3 && < 2.4,

30+ network-multicast >= 0.0 && < 0.1,

31+ data-accessor >= 0.2 && < 0.3,

32+ binary >= 0.5 && < 0.6,

33+ containers >= 0.4 && < 0.6,

34+ transformers >= 0.2 && < 0.4,

35+ network-transport >= 0.2 && < 0.3,

36+ network-transport-tcp >= 0.2 && < 0.3,

37+ distributed-process >= 0.2 && < 0.3

38+ Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet,

39+ Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast

40+ Extensions: RankNTypes,

41+ DeriveDataTypeable

42+ ghc-options: -Wall

43+ HS-Source-Dirs: src

44+

45+-- Not a proper test, but we want to use cabal to compile it

46+Test-Suite TestSimpleLocalnet

47+ Type: exitcode-stdio-1.0

48+ Main-Is: TestSimpleLocalnet.hs

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

50+ bytestring >= 0.9 && < 0.11,

51+ network >= 2.3 && < 2.4,

52+ network-multicast >= 0.0 && < 0.1,

53+ data-accessor >= 0.2 && < 0.3,

54+ binary >= 0.5 && < 0.6,

55+ containers >= 0.4 && < 0.6,

56+ transformers >= 0.2 && < 0.4,

57+ network-transport >= 0.2 && < 0.3,

58+ network-transport-tcp >= 0.2 && < 0.3,

59+ distributed-process >= 0.2 && < 0.3

60+ Extensions: RankNTypes,

61+ DeriveDataTypeable

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

63+ HS-Source-Dirs: tests src

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hsnew file+332

@@ -0,0 +1,332 @@

1+-- | Simple backend based on the TCP transport which offers node discovery

2+-- based on UDP multicast. This is a zero-configuration backend designed to

3+-- get you going with Cloud Haskell quickly without imposing any structure

4+-- on your application.

5+--

6+-- To simplify getting started we provide special support for /master/ and

7+-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions

8+-- is completely optional; you can use the local backend without making use

9+-- of the predefined master and slave nodes.

10+--

11+-- [Minimal example]

12+--

13+-- > import System.Environment (getArgs)

14+-- > import Control.Distributed.Process

15+-- > import Control.Distributed.Process.Node (initRemoteTable)

16+-- > import Control.Distributed.Process.Backend.SimpleLocalnet

17+-- >

18+-- > master :: Backend -> [NodeId] -> Process ()

19+-- > master backend slaves = do

20+-- > -- Do something interesting with the slaves

21+-- > liftIO . putStrLn $ "Slaves: " ++ show slaves

22+-- > -- Terminate the slaves when the master terminates (this is optional)

23+-- > terminateAllSlaves backend

24+-- >

25+-- > main :: IO ()

26+-- > main = do

27+-- > args <- getArgs

28+-- >

29+-- > case args of

30+-- > ["master", host, port] -> do

31+-- > backend <- initializeBackend host port initRemoteTable

32+-- > startMaster backend (master backend)

33+-- > ["slave", host, port] -> do

34+-- > backend <- initializeBackend host port initRemoteTable

35+-- > startSlave backend

36+--

37+-- [Compiling and Running]

38+--

39+-- Save to @example.hs@ and compile using

40+--

41+-- > ghc -threaded example.hs

42+--

43+-- Fire up some slave nodes (for the example, we run them on a single machine):

44+--

45+-- > ./example slave localhost 8080 &

46+-- > ./example slave localhost 8081 &

47+-- > ./example slave localhost 8082 &

48+-- > ./example slave localhost 8083 &

49+--

50+-- And start the master node:

51+--

52+-- > ./example master localhost 8084

53+--

54+-- which should then output:

55+--

56+-- > Slaves: [nid://localhost:8083:0,nid://localhost:8082:0,nid://localhost:8081:0,nid://localhost:8080:0]

57+--

58+-- at which point the slaves should exit.

59+--

60+-- To run the example on multiple machines, you could run

61+--

62+-- > ./example slave 198.51.100.1 8080 &

63+-- > ./example slave 198.51.100.2 8080 &

64+-- > ./example slave 198.51.100.3 8080 &

65+-- > ./example slave 198.51.100.4 8080 &

66+--

67+-- on four different machines (with IP addresses 198.51.100.1..4), and run the

68+-- master on a fifth node (or on any of the four machines that run the slave

69+-- nodes).

70+--

71+-- It is important that every node has a unique (hostname, port number) pair,

72+-- and that the hostname you use to initialize the node can be resolved by

73+-- peer nodes. In other words, if you start a node and pass hostname @localhost@

74+-- then peer nodes won't be able to reach it because @localhost@ will resolve

75+-- to a different IP address for them.

76+{-# OPTIONS_GHC -fno-warn-orphans #-}

77+module Control.Distributed.Process.Backend.SimpleLocalnet

78+ ( -- * Initialization

79+ Backend(..)

80+ , initializeBackend

81+ -- * Slave nodes

82+ , startSlave

83+ , terminateSlave

84+ , findSlaves

85+ , terminateAllSlaves

86+ -- * Master nodes

87+ , startMaster

88+ ) where

89+

90+import System.IO (fixIO)

91+import Data.Maybe (catMaybes)

92+import Data.Binary (Binary(get, put), getWord8, putWord8)

93+import Data.Accessor (Accessor, accessor, (^:), (^.))

94+import Data.Set (Set)

95+import qualified Data.Set as Set (insert, empty, toList)

96+import Data.Foldable (forM_)

97+import Data.Typeable (Typeable)

98+import Control.Applicative ((<$>))

99+import Control.Exception (throw)

100+import Control.Monad (forever, forM)

101+import Control.Monad.IO.Class (liftIO)

102+import Control.Concurrent (forkIO, threadDelay, ThreadId)

103+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)

104+import Control.Distributed.Process

105+ ( RemoteTable

106+ , NodeId

107+ , Process

108+ , WhereIsReply(..)

109+ , whereis

110+ , whereisRemoteAsync

111+ , registerRemote

112+ , getSelfPid

113+ , register

114+ , expect

115+ , nsendRemote

116+ , receiveWait

117+ , matchIf

118+ , processNodeId

119+ )

120+import qualified Control.Distributed.Process.Node as Node

121+ ( LocalNode

122+ , newLocalNode

123+ , localNodeId

124+ , runProcess

125+ )

126+import qualified Network.Transport.TCP as NT

127+ ( createTransport

128+ , defaultTCPParameters

129+ )

130+import qualified Network.Transport as NT (Transport)

131+import qualified Network.Socket as N (HostName, ServiceName, SockAddr)

132+import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)

133+

134+-- | Local backend

135+data Backend = Backend {

136+ -- | Create a new local node

137+ newLocalNode :: IO Node.LocalNode

138+ -- | @findPeers t@ broadcasts a /who's there?/ message on the local

139+ -- network, waits 't' msec, and then collects and returns the answers.

140+ -- You can use this to dynamically discover peer nodes.

141+ , findPeers :: Int -> IO [NodeId]

142+ -- | Make sure that all log messages are printed by the logger on the

143+ -- current node

144+ , redirectLogsHere :: Process ()

145+ }

146+

147+data BackendState = BackendState {

148+ _localNodes :: [Node.LocalNode]

149+ , _peers :: Set NodeId

150+ , discoveryDaemon :: ThreadId

151+ }

152+

153+-- | Initialize the backend

154+initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend

155+initializeBackend host port rtable = do

156+ mTransport <- NT.createTransport host port NT.defaultTCPParameters

157+ (recv, send) <- initMulticast "224.0.0.99" 9999 1024

158+ (_, backendState) <- fixIO $ \ ~(tid, _) -> do

159+ backendState <- newMVar BackendState

160+ { _localNodes = []

161+ , _peers = Set.empty

162+ , discoveryDaemon = tid

163+ }

164+ tid' <- forkIO $ peerDiscoveryDaemon backendState recv send

165+ return (tid', backendState)

166+ case mTransport of

167+ Left err -> throw err

168+ Right transport ->

169+ let backend = Backend {

170+ newLocalNode = apiNewLocalNode transport rtable backendState

171+ , findPeers = apiFindPeers send backendState

172+ , redirectLogsHere = apiRedirectLogsHere backend

173+ }

174+ in return backend

175+

176+-- | Create a new local node

177+apiNewLocalNode :: NT.Transport

178+ -> RemoteTable

179+ -> MVar BackendState

180+ -> IO Node.LocalNode

181+apiNewLocalNode transport rtable backendState = do

182+ localNode <- Node.newLocalNode transport rtable

183+ modifyMVar_ backendState $ return . (localNodes ^: (localNode :))

184+ return localNode

185+

186+-- | Peer discovery

187+apiFindPeers :: (PeerDiscoveryMsg -> IO ())

188+ -> MVar BackendState

189+ -> Int

190+ -> IO [NodeId]

191+apiFindPeers send backendState delay = do

192+ send PeerDiscoveryRequest

193+ threadDelay delay

194+ Set.toList . (^. peers) <$> readMVar backendState

195+

196+data PeerDiscoveryMsg =

197+ PeerDiscoveryRequest

198+ | PeerDiscoveryReply NodeId

199+

200+instance Binary PeerDiscoveryMsg where

201+ put PeerDiscoveryRequest = putWord8 0

202+ put (PeerDiscoveryReply nid) = putWord8 1 >> put nid

203+ get = do

204+ header <- getWord8

205+ case header of

206+ 0 -> return PeerDiscoveryRequest

207+ 1 -> PeerDiscoveryReply <$> get

208+ _ -> fail "PeerDiscoveryMsg.get: invalid"

209+

210+-- | Respond to peer discovery requests sent by other nodes

211+peerDiscoveryDaemon :: MVar BackendState

212+ -> IO (PeerDiscoveryMsg, N.SockAddr)

213+ -> (PeerDiscoveryMsg -> IO ())

214+ -> IO ()

215+peerDiscoveryDaemon backendState recv send = forever go

216+ where

217+ go = do

218+ (msg, _) <- recv

219+ case msg of

220+ PeerDiscoveryRequest -> do

221+ nodes <- (^. localNodes) <$> readMVar backendState

222+ forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId

223+ PeerDiscoveryReply nid ->

224+ modifyMVar_ backendState $ return . (peers ^: Set.insert nid)

225+

226+--------------------------------------------------------------------------------

227+-- Back-end specific primitives --

228+--------------------------------------------------------------------------------

229+

230+-- | Make sure that all log messages are printed by the logger on this node

231+apiRedirectLogsHere :: Backend -> Process ()

232+apiRedirectLogsHere backend = do

233+ mLogger <- whereis "logger"

234+ forM_ mLogger $ \logger -> do

235+ nids <- liftIO $ findPeers backend 1000000

236+ forM_ nids $ \nid -> registerRemote nid "logger" logger

237+

238+--------------------------------------------------------------------------------

239+-- Slaves --

240+--------------------------------------------------------------------------------

241+

242+-- | Messages to slave nodes

243+--

244+-- This datatype is not exposed; instead, we expose primitives for dealing

245+-- with slaves.

246+data SlaveControllerMsg =

247+ SlaveTerminate

248+ deriving (Typeable, Show)

249+

250+instance Binary SlaveControllerMsg where

251+ put SlaveTerminate = putWord8 0

252+ get = do

253+ header <- getWord8

254+ case header of

255+ 0 -> return SlaveTerminate

256+ _ -> fail "SlaveControllerMsg.get: invalid"

257+

258+-- | Calling 'slave' sets up a new local node and then waits. You start

259+-- processes on the slave by calling 'spawn' from other nodes.

260+--

261+-- This function does not return. The only way to exit the slave is to CTRL-C

262+-- the process or call terminateSlave from another node.

263+startSlave :: Backend -> IO ()

264+startSlave backend = do

265+ node <- newLocalNode backend

266+ Node.runProcess node slaveController

267+

268+-- | The slave controller interprets 'SlaveControllerMsg's

269+slaveController :: Process ()

270+slaveController = do

271+ pid <- getSelfPid

272+ register "slaveController" pid

273+ go

274+ where

275+ go = do

276+ msg <- expect

277+ case msg of

278+ SlaveTerminate -> return ()

279+

280+-- | Terminate the slave at the given node ID

281+terminateSlave :: NodeId -> Process ()

282+terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate

283+

284+-- | Find slave nodes

285+findSlaves :: Backend -> Process [NodeId]

286+findSlaves backend = do

287+ nodes <- liftIO $ findPeers backend 1000000

288+ -- Fire of asynchronous requests for the slave controller

289+ forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController"

290+ -- Wait for the replies

291+ catMaybes <$> forM nodes (\_ ->

292+ receiveWait

293+ [ matchIf (\(WhereIsReply label _) -> label == "slaveController")

294+ (\(WhereIsReply _ mPid) -> return (processNodeId <$> mPid))

295+ ])

296+

297+-- | Terminate all slaves

298+terminateAllSlaves :: Backend -> Process ()

299+terminateAllSlaves backend = do

300+ slaves <- findSlaves backend

301+ forM_ slaves terminateSlave

302+ liftIO $ threadDelay 1000000

303+

304+--------------------------------------------------------------------------------

305+-- Master nodes

306+--------------------------------------------------------------------------------

307+

308+-- | 'startMaster' finds all slaves currently available on the local network

309+-- (which should therefore be started first), redirects all log messages to

310+-- itself, and then calls the specified process, passing the list of slaves

311+-- nodes.

312+--

313+-- Terminates when the specified process terminates. If you want to terminate

314+-- the slaves when the master terminates, you should manually call

315+-- 'terminateAllSlaves'.

316+startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()

317+startMaster backend proc = do

318+ node <- newLocalNode backend

319+ Node.runProcess node $ do

320+ slaves <- findSlaves backend

321+ redirectLogsHere backend

322+ proc slaves

323+

324+--------------------------------------------------------------------------------

325+-- Accessors --

326+--------------------------------------------------------------------------------

327+

328+localNodes :: Accessor BackendState [Node.LocalNode]

329+localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })

330+

331+peers :: Accessor BackendState (Set NodeId)

332+peers = accessor _peers (\ps st -> st { _peers = ps })

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hsnew file+126

@@ -0,0 +1,126 @@

1+-- | Multicast utilities

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) where

5+import Data.Function (on)

6+import Data.Map (Map)

7+import qualified Data.Map as Map (empty)

8+import Data.Binary (Binary, decode, encode)

9+import Data.IORef (IORef, newIORef, readIORef, modifyIORef)

10+import qualified Data.ByteString as BSS (ByteString, concat)

11+import qualified Data.ByteString.Lazy as BSL

12+ ( ByteString

13+ , empty

14+ , append

15+ , fromChunks

16+ , toChunks

17+ , length

18+ , splitAt

19+ )

20+import Data.Accessor (Accessor, (^:), (^.), (^=))

21+import qualified Data.Accessor.Container as DAC (mapDefault)

22+import Control.Applicative ((<$>))

23+import Network.Socket (HostName, PortNumber, Socket, SockAddr)

24+import qualified Network.Socket.ByteString as NBS (recvFrom, sendManyTo)

25+import Network.Transport.Internal (decodeInt32, encodeInt32)

26+import Network.Multicast (multicastSender, multicastReceiver)

27+

28+--------------------------------------------------------------------------------

29+-- Top-level API --

30+--------------------------------------------------------------------------------

31+

32+-- | Given a hostname and a port number, initialize the multicast system.

33+--

34+-- Note: it is important that you never send messages larger than the maximum

35+-- message size; if you do, all subsequent communication will probably fail.

36+--

37+-- Returns a reader and a writer.

38+--

39+-- NOTE: By rights the two functions should be "locally" polymorphic in 'a',

40+-- but this requires impredicative types.

41+initMulticast :: forall a. Binary a

42+ => HostName -- ^ Multicast IP

43+ -> PortNumber -- ^ Port number

44+ -> Int -- ^ Maximum message size

45+ -> IO (IO (a, SockAddr), a -> IO ())

46+initMulticast host port bufferSize = do

47+ (sendSock, sendAddr) <- multicastSender host port

48+ readSock <- multicastReceiver host port

49+ st <- newIORef Map.empty

50+ return (recvBinary readSock st bufferSize, writer sendSock sendAddr)

51+ where

52+ writer :: forall a. Binary a => Socket -> SockAddr -> a -> IO ()

53+ writer sock addr val = do

54+ let bytes = encode val

55+ len = encodeInt32 (BSL.length bytes)

56+ NBS.sendManyTo sock (len : BSL.toChunks bytes) addr

57+

58+--------------------------------------------------------------------------------

59+-- UDP multicast read, dealing with multiple senders --

60+--------------------------------------------------------------------------------

61+

62+type UDPState = Map SockAddr BSL.ByteString

63+

64+-- TODO: This is inefficient and an orphan instance.

65+-- Requested official instance (https://github.com/haskell/network/issues/38)

66+instance Ord SockAddr where

67+ compare = compare `on` show

68+

69+bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString

70+bufferFor = DAC.mapDefault BSL.empty

71+

72+bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState

73+bufferAppend addr bytes =

74+ bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])

75+

76+recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr)

77+recvBinary sock st bufferSize = do

78+ (bytes, addr) <- recvWithLength sock st bufferSize

79+ return (decode bytes, addr)

80+

81+recvWithLength :: Socket

82+ -> IORef UDPState

83+ -> Int

84+ -> IO (BSL.ByteString, SockAddr)

85+recvWithLength sock st bufferSize = do

86+ (len, addr) <- recvExact sock 4 st bufferSize

87+ let n = decodeInt32 . BSS.concat . BSL.toChunks $ len

88+ bytes <- recvExactFrom addr sock n st bufferSize

89+ return (bytes, addr)

90+

91+-- Receive all bytes currently in the buffer

92+recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr

93+recvAll sock st bufferSize = do

94+ (bytes, addr) <- NBS.recvFrom sock bufferSize

95+ modifyIORef st $ bufferAppend addr bytes

96+ return addr

97+

98+recvExact :: Socket

99+ -> Int

100+ -> IORef UDPState

101+ -> Int

102+ -> IO (BSL.ByteString, SockAddr)

103+recvExact sock n st bufferSize = do

104+ addr <- recvAll sock st bufferSize

105+ bytes <- recvExactFrom addr sock n st bufferSize

106+ return (bytes, addr)

107+

108+recvExactFrom :: SockAddr

109+ -> Socket

110+ -> Int

111+ -> IORef UDPState

112+ -> Int

113+ -> IO BSL.ByteString

114+recvExactFrom addr sock n st bufferSize = go

115+ where

116+ go :: IO BSL.ByteString

117+ go = do

118+ accAddr <- (^. bufferFor addr) <$> readIORef st

119+ if BSL.length accAddr >= fromIntegral n

120+ then do

121+ let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr

122+ modifyIORef st $ bufferFor addr ^= accAddr'

123+ return bytes

124+ else do

125+ _ <- recvAll sock st bufferSize

126+ go

distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hsnew file+24

@@ -0,0 +1,24 @@

1+import System.Environment (getArgs, getProgName)

2+import Control.Distributed.Process (NodeId, Process, liftIO)

3+import Control.Distributed.Process.Node (initRemoteTable)

4+import Control.Distributed.Process.Backend.SimpleLocalnet

6+master :: Backend -> [NodeId] -> Process ()

7+master backend slaves = do

8+ liftIO . putStrLn $ "Slaves: " ++ show slaves

9+ terminateAllSlaves backend

10+

11+main :: IO ()

12+main = do

13+ prog <- getProgName

14+ args <- getArgs

15+

16+ case args of

17+ ["master", host, port] -> do

18+ backend <- initializeBackend host port initRemoteTable

19+ startMaster backend (master backend)

20+ ["slave", host, port] -> do

21+ backend <- initializeBackend host port initRemoteTable

22+ startSlave backend

23+ _ ->

24+ putStrLn $ "usage: " ++ prog ++ " (master | slave) host port"

distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hsnew file+11

@@ -0,0 +1,11 @@

1+#!/bin/bash

2+TestSimpleLocalnet=dist/build/TestSimpleLocalnet/TestSimpleLocalnet

3+$TestSimpleLocalnet slave 127.0.0.1 8080 &

4+sleep 1

5+$TestSimpleLocalnet slave 127.0.0.1 8081 &

6+sleep 1

7+$TestSimpleLocalnet slave 127.0.0.1 8082 &

8+sleep 1

9+$TestSimpleLocalnet slave 127.0.0.1 8083 &

10+sleep 1

11+$TestSimpleLocalnet master 127.0.0.1 8084

distributed-process-tests/.gitignoredeleted−4

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

1−dist/

2−.cabal-sandbox

3−cabal.sandbox.config

4−.stack*

distributed-process-tests/CONTRIBUTING.mddeleted−1

@@ -1 +0,0 @@

1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.

distributed-process-tests/README.mddeleted−14

@@ -1,14 +0,0 @@

1−# distributed-process-tests

2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process-tests.png)](http://travis-ci.org/haskell-distributed/distributed-process-tests)

3−[![Release](https://img.shields.io/hackage/v/distributed-process-tests.svg)](https://hackage.haskell.org/package/distributed-process-tests)

4−

5−See http://haskell-distributed.github.com for documentation, user guides,

6−tutorials and assistance.

7−

8−## Getting Help / Raising Issues

9−

10−Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-tests/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.

11−

12−## License

13−

14−This package is made available under a 3-clause BSD-style license.

distributed-process-tests/distributed-process-tests.cabaldeleted−158

@@ -1,158 +0,0 @@

1−name: distributed-process-tests

2−version: 0.4.11

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

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

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

6−license: BSD3

7−license-file: LICENSE

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

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

10−copyright: Well-Typed LLP

11−category: Control, Cloud Haskell

12−build-type: Simple

13−cabal-version: >=1.8

14−

15−flag tcp

16− Description: build and run TCP tests

17− Default: False

18−

19−library

20− exposed-modules: Network.Transport.Test

21− Control.Distributed.Process.Tests.CH

22− Control.Distributed.Process.Tests.Closure

23− Control.Distributed.Process.Tests.Mx

24− Control.Distributed.Process.Tests.Receive

25− Control.Distributed.Process.Tests.Stats

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,

30− binary >= 0.5 && < 0.9,

31− bytestring >= 0.9 && < 0.12,

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

33− distributed-static,

34− exceptions >= 0.5,

35− HUnit >= 1.2 && < 1.7,

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

37− network >= 2.5 && < 2.9,

38− random >= 1.0 && < 1.2,

39− rematch >= 0.1.2.1,

40− setenv >= 0.1.1.3,

41− test-framework >= 0.6 && < 0.9,

42− test-framework-hunit >= 0.2.0 && < 0.4,

43− stm

44− hs-source-dirs: src

45− ghc-options: -Wall -fno-warn-unused-do-bind

46− extensions: CPP,

47− ExistentialQuantification,

48− FlexibleInstances,

49− DeriveDataTypeable,

50− DeriveGeneric,

51− GeneralizedNewtypeDeriving,

52− RankNTypes,

53− RecordWildCards,

54− ScopedTypeVariables

55− if impl(ghc <= 7.4.2)

56− Build-Depends: ghc-prim == 0.2.0.0

57−

58−Test-Suite TestCHInMemory

59− Type: exitcode-stdio-1.0

60− Main-Is: runInMemory.hs

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,

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

66− network-transport-inmemory >= 0.5,

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

68− Extensions: CPP

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

70− HS-Source-Dirs: tests

71−

72−Test-Suite TestCHInTCP

73− Type: exitcode-stdio-1.0

74− Main-Is: runTCP.hs

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

76− if flag(tcp)

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

78− distributed-process-tests,

79− network >= 2.3 && < 2.9,

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

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

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

83− else

84− Buildable: False

85− Extensions: CPP

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

87− HS-Source-Dirs: tests

88−

89−

90−Test-Suite TestClosure

91− Type: exitcode-stdio-1.0

92− Main-Is: runInMemory.hs

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,

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

98− network-transport-inmemory >= 0.5,

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

100− Extensions: CPP

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

102− HS-Source-Dirs: tests

103−

104−Test-Suite TestStats

105− Type: exitcode-stdio-1.0

106− Main-Is: runInMemory.hs

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,

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

112− network-transport-inmemory >= 0.5,

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

114− Extensions: CPP

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

116− HS-Source-Dirs: tests

117−

118−Test-Suite TestMxInMemory

119− Type: exitcode-stdio-1.0

120− Main-Is: runInMemory.hs

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

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

123− distributed-process-tests,

124− network >= 2.3 && < 2.9,

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

126− network-transport-inmemory >= 0.5,

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

128− Extensions: CPP

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

130− HS-Source-Dirs: tests

131−

132−Test-Suite TestTracingInMemory

133− Type: exitcode-stdio-1.0

134− Main-Is: runInMemory.hs

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

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

137− distributed-process-tests,

138− network >= 2.3 && < 2.9,

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

140− network-transport-inmemory >= 0.5,

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

142− Extensions: CPP

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

144− HS-Source-Dirs: tests

145−

146−Test-Suite TestMxInTCP

147− Type: exitcode-stdio-1.0

148− Main-Is: runInMemory.hs

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

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

151− distributed-process-tests,

152− network >= 2.3 && < 2.9,

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

154− network-transport-inmemory >= 0.5,

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

156− Extensions: CPP

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

158− HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hsdeleted−1879

@@ -1,1879 +0,0 @@

1−module Control.Distributed.Process.Tests.CH (tests) where

2−

3−#if ! MIN_VERSION_base(4,6,0)

4−import Prelude hiding (catch)

5−#endif

6−

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

8−

9−import Data.Binary (Binary(..))

10−import Data.Typeable (Typeable)

11−import Data.Foldable (forM_)

12−import Data.Function (fix)

13−import Data.IORef

14− ( readIORef

15− , writeIORef

16− , newIORef

17− )

18−import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)

19−import Control.Concurrent.MVar

20− ( MVar

21− , newEmptyMVar

22− , putMVar

23− , takeMVar

24− , readMVar

25− )

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

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

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

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

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

31−import Control.Distributed.Process hiding

32− ( try

33− , catch

34− , finally

35− , mask

36− , onException

37− )

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

39− ( LocalNode(localEndPoint)

40− , ProcessExitException(..)

41− , nullProcessId

42− , createUnencodedMessage

43− )

44−import 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)

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

49−import Data.Maybe (isNothing, isJust)

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

51−import Test.Framework (Test, testGroup)

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

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

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

55−

56−newtype Ping = Ping ProcessId

57− deriving (Typeable, Binary, Show)

58−

59−newtype Pong = Pong ProcessId

60− deriving (Typeable, Binary, Show)

61−

62−--------------------------------------------------------------------------------

63−-- Supporting definitions --

64−--------------------------------------------------------------------------------

65−

66−expectThat :: a -> Matcher a -> Assertion

67−expectThat a matcher = case res of

68− MatchSuccess -> return ()

69− (MatchFailure msg) -> assertFailure msg

70− where res = runMatch matcher a

71−

72−-- | Like fork, but throw exceptions in the child thread to the parent

73−forkTry :: IO () -> IO ThreadId

74−forkTry p = do

75− tid <- myThreadId

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

77−

78−-- | The ping server from the paper

79−ping :: Process ()

80−ping = do

81− Pong partner <- expect

82− self <- getSelfPid

83− send partner (Ping self)

84− ping

85−

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

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

96−whereisRemote nid string = do

97− whereisRemoteAsync nid string

98− receiveWait [

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

100− ]

101−

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

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

104−

105−waitForExit :: ProcessId -> Process DiedReason

106−waitForExit pid = monitor pid >>= waitForDown

107−

108−waitForDown :: MonitorRef -> Process DiedReason

109−waitForDown ref =

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

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

112−

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

114−syncBreakConnection breakConnection nid0 nid1 = do

115− m <- newEmptyMVar

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

117− runProcess nid0 $ do

118− them <- liftIO $ takeMVar m

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

120− _ <- monitorNode (localNodeId nid1)

121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

122− (nodeAddress $ localNodeId nid1)

123− NodeMonitorNotification _ _ _ <- expect

124− kill pinger "finished"

125− return ()

126−

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

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

129−data DivByZero = DivByZero deriving (Typeable)

130−

131−instance Binary Add where

132− put (Add pid x y) = put pid >> put x >> put y

133− get = Add <$> get <*> get <*> get

134−

135−instance Binary Divide where

136− put (Divide pid x y) = put pid >> put x >> put y

137− get = Divide <$> get <*> get <*> get

138−

139−instance Binary DivByZero where

140− put DivByZero = return ()

141− get = return DivByZero

142−

143−-- The math server from the paper

144−math :: Process ()

145−math = do

146− receiveWait

147− [ match (\(Add pid x y) -> send pid (x + y))

148− , matchIf (\(Divide _ _ y) -> y /= 0)

149− (\(Divide pid x y) -> send pid (x / y))

150− , match (\(Divide pid _ _) -> send pid DivByZero)

151− ]

152− math

153−

154−-- | Monitor or link to a remote node

155−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link

156− -> ProcessId -- ^ Process to monitor/link to

157− -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up

158− -> Process (Maybe MonitorRef)

159−monitorOrLink mOrL pid mSignal = do

160− result <- if mOrL then Just <$> monitor pid

161− else link pid >> return Nothing

162− -- Monitor is asynchronous, which usually does not matter but if we want a

163− -- *specific* signal then it does. Therefore we wait until the MonitorRef is

164− -- listed in the ProcessInfo and hope that this means the monitor has been set

165− -- up.

166− forM_ mSignal $ \signal -> do

167− self <- getSelfPid

168− spawnLocal $ do

169− let waitForMOrL = do

170− liftIO $ threadDelay 100000

171− mpinfo <- getProcessInfo pid

172− case mpinfo of

173− Nothing -> waitForMOrL

174− Just pinfo ->

175− if mOrL then

176− unless (result == lookup self (infoMonitors pinfo)) waitForMOrL

177− else

178− unless (elem self $ infoLinks pinfo) waitForMOrL

179− waitForMOrL

180− liftIO $ putMVar signal ()

181− return result

182−

183−monitorTestProcess :: ProcessId -- Process to monitor/link to

184− -> Bool -- 'True' for monitor, 'False' for link

185− -> Bool -- Should we unmonitor?

186− -> DiedReason -- Expected cause of death

187− -> Maybe (MVar ()) -- Signal for 'monitor set up'

188− -> MVar () -- Signal for successful termination

189− -> Process ()

190−monitorTestProcess theirAddr mOrL un reason monitorSetup done =

191− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup

192− case (un, mRef) of

193− (True, Nothing) -> do

194− unlink theirAddr

195− liftIO $ putMVar done ()

196− (True, Just ref) -> do

197− unmonitor ref

198− liftIO $ putMVar done ()

199− (False, ref) -> do

200− receiveWait [

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

202− liftIO $ do

203− assertBool "Bad Monitor Signal"

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

205− mOrL && reason == reason')

206− putMVar done ())

207− ]

208− )

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

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

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

212− liftIO $ putMVar done ()

213− )

214−

215−--------------------------------------------------------------------------------

216−-- The tests proper --

217−--------------------------------------------------------------------------------

218−

219−-- | Basic ping test

220−testPing :: TestTransport -> Assertion

221−testPing TestTransport{..} = do

222− serverAddr <- newEmptyMVar

223− clientDone <- newEmptyMVar

224−

225− -- Server

226− forkIO $ do

227− localNode <- newLocalNode testTransport initRemoteTable

228− addr <- forkProcess localNode ping

229− putMVar serverAddr addr

230−

231− -- Client

232− forkIO $ do

233− localNode <- newLocalNode testTransport initRemoteTable

234− pingServer <- readMVar serverAddr

235−

236− let numPings = 10000

237−

238− runProcess localNode $ do

239− pid <- getSelfPid

240− replicateM_ numPings $ do

241− send pingServer (Pong pid)

242− p <- expectTimeout 3000000

243− case p of

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

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

246−

247− putMVar clientDone ()

248−

249− takeMVar clientDone

250−

251−-- | Monitor a process on an unreachable node

252−testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion

253−testMonitorUnreachable TestTransport{..} mOrL un = do

254− deadProcess <- newEmptyMVar

255− done <- newEmptyMVar

256−

257− forkIO $ do

258− localNode <- newLocalNode testTransport initRemoteTable

259− addr <- forkProcess localNode expect

260− closeLocalNode localNode

261− putMVar deadProcess addr

262−

263− forkIO $ do

264− localNode <- newLocalNode testTransport initRemoteTable

265− theirAddr <- readMVar deadProcess

266− runProcess localNode $

267− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done

268−

269− takeMVar done

270−

271−-- | Monitor a process which terminates normally

272−testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion

273−testMonitorNormalTermination TestTransport{..} mOrL un = do

274− monitorSetup <- newEmptyMVar

275− monitoredProcess <- newEmptyMVar

276− done <- newEmptyMVar

277−

278− forkIO $ do

279− localNode <- newLocalNode testTransport initRemoteTable

280− addr <- forkProcess localNode $

281− liftIO $ readMVar monitorSetup

282− putMVar monitoredProcess addr

283−

284− forkIO $ do

285− localNode <- newLocalNode testTransport initRemoteTable

286− theirAddr <- readMVar monitoredProcess

287− runProcess localNode $

288− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done

289−

290− takeMVar done

291−

292−-- | Monitor a process which terminates abnormally

293−testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion

294−testMonitorAbnormalTermination TestTransport{..} mOrL un = do

295− monitorSetup <- newEmptyMVar

296− monitoredProcess <- newEmptyMVar

297− done <- newEmptyMVar

298−

299− let err = userError "Abnormal termination"

300−

301− forkIO $ do

302− localNode <- newLocalNode testTransport initRemoteTable

303− addr <- forkProcess localNode . liftIO $ do

304− readMVar monitorSetup

305− throwIO err

306− putMVar monitoredProcess addr

307−

308− forkIO $ do

309− localNode <- newLocalNode testTransport initRemoteTable

310− theirAddr <- readMVar monitoredProcess

311− runProcess localNode $

312− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done

313−

314− takeMVar done

315−

316−-- | Monitor a local process that is already dead

317−testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion

318−testMonitorLocalDeadProcess TestTransport{..} mOrL un = do

319− processAddr <- newEmptyMVar

320− localNode <- newLocalNode testTransport initRemoteTable

321− done <- newEmptyMVar

322−

323− forkIO $ do

324− addr <- forkProcess localNode $ return ()

325− putMVar processAddr addr

326−

327− forkIO $ do

328− theirAddr <- readMVar processAddr

329− runProcess localNode $ do

330− monitor theirAddr

331− -- wait for the process to die

332− expect :: Process ProcessMonitorNotification

333− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334−

335− takeMVar done

336−

337−-- | Monitor a remote process that is already dead

338−testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion

339−testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do

340− processDead <- newEmptyMVar

341− processAddr <- newEmptyMVar

342− done <- newEmptyMVar

343−

344− forkIO $ do

345− localNode <- newLocalNode testTransport initRemoteTable

346− addr <- forkProcess localNode . liftIO $ putMVar processDead ()

347− putMVar processAddr addr

348−

349− forkIO $ do

350− localNode <- newLocalNode testTransport initRemoteTable

351− theirAddr <- readMVar processAddr

352− readMVar processDead

353− runProcess localNode $ do

354− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

355−

356− takeMVar done

357−

358−-- | Monitor a process that becomes disconnected

359−testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion

360−testMonitorDisconnect TestTransport{..} mOrL un = do

361− processAddr <- newEmptyMVar

362− processAddr2 <- newEmptyMVar

363− monitorSetup <- newEmptyMVar

364− done <- newEmptyMVar

365−

366− forkIO $ do

367− localNode <- newLocalNode testTransport initRemoteTable

368− addr <- forkProcess localNode $ expect

369− addr2 <- forkProcess localNode $ return ()

370− putMVar processAddr addr

371− readMVar monitorSetup

372− NT.closeEndPoint (localEndPoint localNode)

373− putMVar processAddr2 addr2

374−

375− forkIO $ do

376− localNode <- newLocalNode testTransport initRemoteTable

377− theirAddr <- readMVar processAddr

378− forkProcess localNode $ do

379− lc <- liftIO $ readMVar processAddr2

380− send lc ()

381− runProcess localNode $ do

382− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done

383−

384− takeMVar done

385−

386−-- | Test the math server (i.e., receiveWait)

387−testMath :: TestTransport -> Assertion

388−testMath TestTransport{..} = do

389− serverAddr <- newEmptyMVar

390− clientDone <- newEmptyMVar

391−

392− -- Server

393− forkIO $ do

394− localNode <- newLocalNode testTransport initRemoteTable

395− addr <- forkProcess localNode math

396− putMVar serverAddr addr

397−

398− -- Client

399− forkIO $ do

400− localNode <- newLocalNode testTransport initRemoteTable

401− mathServer <- readMVar serverAddr

402−

403− runProcess localNode $ do

404− pid <- getSelfPid

405− send mathServer (Add pid 1 2)

406− three <- expect :: Process Double

407− send mathServer (Divide pid 8 2)

408− four <- expect :: Process Double

409− send mathServer (Divide pid 8 0)

410− divByZ <- expect

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

412−

413− res <- takeMVar clientDone

414− case res of

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

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

417−

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

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

420−-- the same remote node (we're checking that the remote node did not die)

421−testSendToTerminated :: TestTransport -> Assertion

422−testSendToTerminated TestTransport{..} = do

423− serverAddr1 <- newEmptyMVar

424− serverAddr2 <- newEmptyMVar

425− clientDone <- newEmptyMVar

426−

427− forkIO $ do

428− terminated <- newEmptyMVar

429− localNode <- newLocalNode testTransport initRemoteTable

430− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()

431− addr2 <- forkProcess localNode $ ping

432− readMVar terminated

433− putMVar serverAddr1 addr1

434− putMVar serverAddr2 addr2

435−

436− forkIO $ do

437− localNode <- newLocalNode testTransport initRemoteTable

438− server1 <- readMVar serverAddr1

439− server2 <- readMVar serverAddr2

440− runProcess localNode $ do

441− pid <- getSelfPid

442− send server1 "Hi"

443− send server2 (Pong pid)

444− expectPing clientDone

445−

446− verifyClient "Expected Ping from server" clientDone

447−

448−-- | Test (non-zero) timeout

449−testTimeout :: TestTransport -> Assertion

450−testTimeout TestTransport{..} = do

451− localNode <- newLocalNode testTransport initRemoteTable

452− done <- newEmptyMVar

453−

454− runProcess localNode $ do

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

456− liftIO $ putMVar done $ res == Nothing

457−

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

459−

460−-- | Test zero timeout

461−testTimeout0 :: TestTransport -> Assertion

462−testTimeout0 TestTransport{..} = do

463− serverAddr <- newEmptyMVar

464− clientDone <- newEmptyMVar

465−

466− forkIO $ do

467− localNode <- newLocalNode testTransport initRemoteTable

468− addr <- forkProcess localNode $ do

469− -- Variation on the venerable ping server which uses a zero timeout

470− partner <- fix $ \loop ->

471− receiveTimeout 0 [match (\(Pong partner) -> return partner)]

472− >>= maybe (liftIO (threadDelay 100000) >> loop) return

473− self <- getSelfPid

474− send partner (Ping self)

475− putMVar serverAddr addr

476−

477− forkIO $ do

478− localNode <- newLocalNode testTransport initRemoteTable

479− server <- readMVar serverAddr

480− runProcess localNode $ do

481− pid <- getSelfPid

482− -- Send a bunch of messages. A large number of messages that the server

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

484− replicateM_ 10000 $ send server "Irrelevant message"

485− send server (Pong pid)

486− expectPing clientDone

487−

488− verifyClient "Expected Ping from server" clientDone

489−

490−-- | Test typed channels

491−testTypedChannels :: TestTransport -> Assertion

492−testTypedChannels TestTransport{..} = do

493− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))

494− clientDone <- newEmptyMVar

495−

496− forkIO $ do

497− localNode <- newLocalNode testTransport initRemoteTable

498− forkProcess localNode $ do

499− (serverSendPort, rport) <- newChan

500− liftIO $ putMVar serverChannel serverSendPort

501− (clientSendPort, i) <- receiveChan rport

502− sendChan clientSendPort (even i)

503− return ()

504−

505− forkIO $ do

506− localNode <- newLocalNode testTransport initRemoteTable

507− serverSendPort <- readMVar serverChannel

508− runProcess localNode $ do

509− (clientSendPort, rport) <- newChan

510− sendChan serverSendPort (clientSendPort, 5)

511− ch <- receiveChan rport

512− liftIO $ putMVar clientDone $ ch == False

513−

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

515−

516−-- | Test merging receive ports

517−testMergeChannels :: TestTransport -> Assertion

518−testMergeChannels TestTransport{..} = do

519− localNode <- newLocalNode testTransport initRemoteTable

520− testFlat localNode True "aaabbbccc"

521− testFlat localNode False "abcabcabc"

522− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"

523− testNested localNode True False "adgadgadgbehbehbehcficficfi"

524− testNested localNode False True "abcabcabcdefdefdefghighighi"

525− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"

526− testBlocked localNode True

527− testBlocked localNode False

528− where

529− -- Single layer of merging

530− testFlat :: LocalNode -> Bool -> String -> IO ()

531− testFlat localNode biased expected = do

532− done <- newEmptyMVar

533− forkProcess localNode $ do

534− rs <- mapM charChannel "abc"

535− m <- mergePorts biased rs

536− xs <- replicateM 9 $ receiveChan m

537− liftIO $ putMVar done $ xs == expected

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

539−

540− -- Two layers of merging

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

542− testNested localNode biasedInner biasedOuter expected = do

543− done <- newEmptyMVar

544− forkProcess localNode $ do

545− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]

546− ms <- mapM (mergePorts biasedInner) rss

547− m <- mergePorts biasedOuter ms

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

549− liftIO $ putMVar done $ xs == expected

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

551−

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

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

554− testBlocked localNode biased = do

555− vs <- replicateM 3 newEmptyMVar

556− done <- newEmptyMVar

557−

558− forkProcess localNode $ do

559− ss <- liftIO $ mapM readMVar vs

560− case ss of

561− [sa, sb, sc] ->

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

563− [ -- a, b, c

564− (sa, 'a')

565− , (sb, 'b')

566− , (sc, 'c')

567− -- a, c, b

568− , (sa, 'a')

569− , (sc, 'c')

570− , (sb, 'b')

571− -- b, a, c

572− , (sb, 'b')

573− , (sa, 'a')

574− , (sc, 'c')

575− -- b, c, a

576− , (sb, 'b')

577− , (sc, 'c')

578− , (sa, 'a')

579− -- c, a, b

580− , (sc, 'c')

581− , (sa, 'a')

582− , (sb, 'b')

583− -- c, b, a

584− , (sc, 'c')

585− , (sb, 'b')

586− , (sa, 'a')

587− ]

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

589−

590− forkProcess localNode $ do

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

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

593− m <- mergePorts biased rs

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

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

596−

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

598−

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

600− mergePorts True = mergePortsBiased

601− mergePorts False = mergePortsRR

602−

603− charChannel :: Char -> Process (ReceivePort Char)

604− charChannel c = do

605− (sport, rport) <- newChan

606− replicateM_ 3 $ sendChan sport c

607− liftIO $ threadDelay 10000 -- Make sure messages have been sent

608− return rport

609−

610−testTerminate :: TestTransport -> Assertion

611−testTerminate TestTransport{..} = do

612− localNode <- newLocalNode testTransport initRemoteTable

613− runProcess localNode $ do

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

615− if either show show e == show ProcessTerminationException

616− then return ()

617− else die "Unexpected result from terminate"

618−

619−testMonitorNode :: TestTransport -> Assertion

620−testMonitorNode TestTransport{..} = do

621− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

622− done <- newEmptyMVar

623−

624− closeLocalNode node1

625−

626− runProcess node2 $ do

627− ref <- monitorNode (localNodeId node1)

628− receiveWait [

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

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

631− ] >>= liftIO . putMVar done

632−

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

634−

635−testMonitorLiveNode :: TestTransport -> Assertion

636−testMonitorLiveNode TestTransport{..} = do

637− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

638− ready <- newEmptyMVar

639− readyr <- newEmptyMVar

640− done <- newEmptyMVar

641−

642− p <- forkProcess node1 $ return ()

643− forkProcess node2 $ do

644− ref <- monitorNode (localNodeId node1)

645− liftIO $ putMVar ready ()

646− liftIO $ takeMVar readyr

647− send p ()

648− receiveWait [

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

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

651− ] >>= liftIO . putMVar done

652−

653− takeMVar ready

654− closeLocalNode node1

655− putMVar readyr ()

656−

657− verifyClient "Expected NodeMonitorNotification for LIVE node" done

658−

659−testMonitorChannel :: TestTransport -> Assertion

660−testMonitorChannel TestTransport{..} = do

661− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

662− gotNotification <- newEmptyMVar

663−

664− pid <- forkProcess node1 $ do

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

666− ref <- monitorPort sport

667− receiveWait [

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

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

673− ] >>= liftIO . putMVar gotNotification

674−

675− runProcess node2 $ do

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

677− send pid sport

678− liftIO $ threadDelay 100000

679−

680− verifyClient "Expected PortMonitorNotification" gotNotification

681−

682−testRegistry :: TestTransport -> Assertion

683−testRegistry TestTransport{..} = do

684− node <- newLocalNode testTransport initRemoteTable

685− done <- newEmptyMVar

686−

687− pingServer <- forkProcess node ping

688− deadProcess <- forkProcess node (return ())

689−

690− runProcess node $ do

691− register "ping" pingServer

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

693− us <- getSelfPid

694− nsend "ping" (Pong us)

695− receiveWait [

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

697− ]

698− checkRegException "dead" Nothing deadProcess

699− checkRegException "ping" (Just pingServer) deadProcess

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

701− liftIO $ putMVar done ()

702−

703− takeMVar done

704−

705− where

706− checkRegException name pid dead =

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

708−

709− checkReg name pid res =

710− case res of

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

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

713−

714−testRegistryRemoteProcess :: TestTransport -> Assertion

715−testRegistryRemoteProcess TestTransport{..} = do

716− node1 <- newLocalNode testTransport initRemoteTable

717− node2 <- newLocalNode testTransport initRemoteTable

718− done <- newEmptyMVar

719−

720− pingServer <- forkProcess node1 ping

721−

722− runProcess node2 $ do

723− register "ping" pingServer

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

725− us <- getSelfPid

726− nsend "ping" (Pong us)

727− receiveWait [

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

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

730− ]

731−

732− takeMVar done

733−

734−testRemoteRegistry :: TestTransport -> Assertion

735−testRemoteRegistry TestTransport{..} = do

736− node1 <- newLocalNode testTransport initRemoteTable

737− node2 <- newLocalNode testTransport initRemoteTable

738−

739− pingServer <- forkProcess node1 ping

740− deadProcess <- forkProcess node1 (return ())

741−

742− runProcess node2 $ do

743− let nid1 = localNodeId node1

744− registerRemoteAsync nid1 "ping" pingServer

745− receiveWait [

746− matchIf (\(RegisterReply label' _ (Just pid)) ->

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

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

749−

750− pid <- verifyWhereIsRemote nid1 "ping"

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

752−

753− us <- getSelfPid

754− nsendRemote nid1 "ping" (Pong us)

755− receiveWait [

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

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

758−

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

760− -- in owner field.

761− registerRemoteAsync nid1 "dead" deadProcess

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

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

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

765−

766− registerRemoteAsync nid1 "ping" deadProcess

767− receiveWait [

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

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

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

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

772−

773− unregisterRemoteAsync nid1 "dead"

774− receiveWait [

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

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

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

778−

779−testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

780−testRemoteRegistryRemoteProcess TestTransport{..} = do

781− node1 <- newLocalNode testTransport initRemoteTable

782− node2 <- newLocalNode testTransport initRemoteTable

783− done <- newEmptyMVar

784−

785− pingServer <- forkProcess node2 ping

786−

787− runProcess node2 $ do

788− let nid1 = localNodeId node1

789− registerRemoteAsync nid1 "ping" pingServer

790− receiveWait [

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

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

793− pid <- verifyWhereIsRemote nid1 "ping"

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

795− us <- getSelfPid

796− nsendRemote nid1 "ping" (Pong us)

797− receiveWait [

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

799− ] >>= liftIO . putMVar done

800−

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

802−

803−testSpawnLocal :: TestTransport -> Assertion

804−testSpawnLocal TestTransport{..} = do

805− node <- newLocalNode testTransport initRemoteTable

806− done <- newEmptyMVar

807−

808− runProcess node $ do

809− us <- getSelfPid

810−

811− pid <- spawnLocal $ do

812− sport <- expect

813− sendChan sport (1234 :: Int)

814−

815− sport <- spawnChannelLocal $

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

817−

818− send pid sport

819− expect >>= liftIO . putMVar done

820−

821− res <- takeMVar done

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

823−

824−testSpawnAsyncStrictness :: TestTransport -> Assertion

825−testSpawnAsyncStrictness TestTransport{..} = do

826− node <- newLocalNode testTransport initRemoteTable

827− done <- newEmptyMVar

828−

829− runProcess node $ do

830− here <-getSelfNode

831−

832− ev <- try $ spawnAsync here (error "boom")

833− liftIO $ case ev of

834− Right _ -> putMVar done (error "Exception didn't fire")

835− Left (_::SomeException) -> putMVar done (return ())

836−

837− join $ takeMVar done

838−

839−testReconnect :: TestTransport -> Assertion

840−testReconnect TestTransport{..} = do

841− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

842− let nid1 = localNodeId node1

843− processA <- newEmptyMVar

844− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar

845−

846− forkProcess node1 $ do

847− us <- getSelfPid

848− liftIO $ putMVar processA us

849− msg1 <- expect

850− msg2 <- expect

851− liftIO $ do

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

853− putMVar sendTestOk ()

854−

855− forkProcess node2 $ do

856− {-

857− - Make sure there is no implicit reconnect on normal message sending

858− -}

859−

860− them <- liftIO $ readMVar processA

861− send them "message 1" >> liftIO (threadDelay 100000)

862−

863− -- Simulate network failure

864− liftIO $ syncBreakConnection testBreakConnection node1 node2

865−

866−

867− -- Should not arrive

868− send them "message 2"

869−

870− -- Should arrive

871− reconnect them

872− send them "message 3"

873−

874− liftIO $ takeMVar sendTestOk

875−

876− {-

877− - Test that there *is* implicit reconnect on node controller messages

878− -}

879−

880− us <- getSelfPid

881− registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous

882− receiveWait [

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

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

885−

886− _ <- whereisRemote nid1 "a"

887−

888−

889− -- Simulate network failure

890− liftIO $ syncBreakConnection testBreakConnection node1 node2

891−

892− -- This will happen due to implicit reconnect

893− registerRemoteAsync nid1 "b" us

894− receiveWait [

895− matchIf (\(RegisterReply label' _ _) -> "b" == label')

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

897−

898− -- Should happen

899− registerRemoteAsync nid1 "c" us

900− receiveWait [

901− matchIf (\(RegisterReply label' _ _) -> "c" == label')

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

903−

904− -- Check

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

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

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

908− verifyWhereIsRemote nid1 "c"

909−

910− liftIO $ putMVar registerTestOk ()

911−

912− takeMVar registerTestOk

913−

914−-- | Tests that unreliable messages arrive sorted even when there are connection

915−-- failures.

916−testUSend :: (ProcessId -> Int -> Process ())

917− -> TestTransport -> Int -> Assertion

918−testUSend usendPrim TestTransport{..} numMessages = do

919− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

920− let nid1 = localNodeId node1

921− nid2 = localNodeId node2

922− processA <- newEmptyMVar

923− usendTestOk <- newEmptyMVar

924−

925− forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do

926− us <- getSelfPid

927− liftIO $ putMVar processA us

928− them <- expect

929− send them ()

930− _ <- monitor them

931− let -- Collects messages from 'them' until the sender dies.

932− -- Disconnection notifications are ignored.

933− receiveMessages :: Process [Int]

934− receiveMessages = receiveWait

935− [ match $ \mn -> case mn of

936− ProcessMonitorNotification _ _ DiedDisconnect -> do

937− monitor them

938− receiveMessages

939− _ -> return []

940− , match $ \i -> fmap (i :) receiveMessages

941− ]

942− msgs <- receiveMessages

943− let -- Checks that the input list is sorted.

944− isSorted :: [Int] -> Bool

945− isSorted (x : xs@(y : _)) = x <= y && isSorted xs

946− isSorted _ = True

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

948− -- the last message.

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

950−

951− forkProcess node2 $ do

952− them <- liftIO $ readMVar processA

953− getSelfPid >>= send them

954− expect :: Process ()

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

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

957− usendPrim them i

958− liftIO (threadDelay 30000)

959−

960− res <- takeMVar usendTestOk

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

962−

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

964−-- in between

965−testMatchAny :: TestTransport -> Assertion

966−testMatchAny TestTransport{..} = do

967− proxyAddr <- newEmptyMVar

968− clientDone <- newEmptyMVar

969−

970− -- Math server

971− forkIO $ do

972− localNode <- newLocalNode testTransport initRemoteTable

973− mathServer <- forkProcess localNode math

974− proxyServer <- forkProcess localNode $ forever $ do

975− msg <- receiveWait [ matchAny return ]

976− forward msg mathServer

977− putMVar proxyAddr proxyServer

978−

979− -- Client

980− forkIO $ do

981− localNode <- newLocalNode testTransport initRemoteTable

982− mathServer <- readMVar proxyAddr

983−

984− runProcess localNode $ do

985− pid <- getSelfPid

986− send mathServer (Add pid 1 2)

987− three <- expect :: Process Double

988− send mathServer (Divide pid 8 2)

989− four <- expect :: Process Double

990− send mathServer (Divide pid 8 0)

991− divByZ <- expect

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

993−

994− res <- takeMVar clientDone

995− case res of

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

997− _ -> error "Unexpected result"

998−

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

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

1001−testMatchAnyHandle :: TestTransport -> Assertion

1002−testMatchAnyHandle TestTransport{..} = do

1003− proxyAddr <- newEmptyMVar

1004− clientDone <- newEmptyMVar

1005−

1006− -- Math server

1007− forkIO $ do

1008− localNode <- newLocalNode testTransport initRemoteTable

1009− mathServer <- forkProcess localNode math

1010− proxyServer <- forkProcess localNode $ forever $ do

1011− receiveWait [

1012− matchAny (maybeForward mathServer)

1013− ]

1014− putMVar proxyAddr proxyServer

1015−

1016− -- Client

1017− forkIO $ do

1018− localNode <- newLocalNode testTransport initRemoteTable

1019− mathServer <- readMVar proxyAddr

1020−

1021− runProcess localNode $ do

1022− pid <- getSelfPid

1023− send mathServer (Add pid 1 2)

1024− three <- expect :: Process Double

1025− send mathServer (Divide pid 8 2)

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

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

1028−

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

1030−

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

1032− maybeForward s msg =

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

1034−

1035−testMatchAnyNoHandle :: TestTransport -> Assertion

1036−testMatchAnyNoHandle TestTransport{..} = do

1037− addr <- newEmptyMVar

1038− clientDone <- newEmptyMVar

1039− serverDone <- newEmptyMVar

1040−

1041− -- Math server

1042− forkIO $ do

1043− localNode <- newLocalNode testTransport initRemoteTable

1044− server <- forkProcess localNode $ forever $ do

1045− receiveWait [

1046− matchAnyIf

1047− -- the condition has type `Add -> Bool`

1048− (\(Add _ _ _) -> True)

1049− -- the match `AbstractMessage -> Process ()` will succeed!

1050− (\m -> do

1051− -- `String -> Process ()` does *not* match the input types however

1052− r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))

1053− case r of

1054− Nothing -> return ()

1055− Just _ -> die "NONSENSE")

1056− ]

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

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

1059− liftIO $ do

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

1061− putMVar serverDone ()

1062− putMVar addr server

1063−

1064− -- Client

1065− forkIO $ do

1066− localNode <- newLocalNode testTransport initRemoteTable

1067− server <- readMVar addr

1068−

1069− runProcess localNode $ do

1070− pid <- getSelfPid

1071− send server (Add pid 1 2)

1072− -- we only care about the client having sent a message, so we're done

1073− liftIO $ putMVar clientDone ()

1074−

1075− takeMVar clientDone

1076− takeMVar serverDone

1077−

1078−-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests

1079−-- unless the text body @/= "bar"@ - this case should time out rather than

1080−-- removing the message from the process mailbox.

1081−testMatchAnyIf :: TestTransport -> Assertion

1082−testMatchAnyIf TestTransport{..} = do

1083− echoAddr <- newEmptyMVar

1084− clientDone <- newEmptyMVar

1085−

1086− -- echo server

1087− forkIO $ do

1088− localNode <- newLocalNode testTransport initRemoteTable

1089− echoServer <- forkProcess localNode $ forever $ do

1090− receiveWait [

1091− matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")

1092− tryHandleMessage

1093− ]

1094− putMVar echoAddr echoServer

1095−

1096− -- Client

1097− forkIO $ do

1098− localNode <- newLocalNode testTransport initRemoteTable

1099− server <- readMVar echoAddr

1100−

1101− runProcess localNode $ do

1102− pid <- getSelfPid

1103− send server (pid, "foo")

1104− 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")

1111− baz <- expect

1112−

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

1114−

1115− res <- takeMVar clientDone

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

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

1118−

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

1120− tryHandleMessage msg =

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

1122− -> do { send pid m; return () })

1123−

1124−testMatchMessageWithUnwrap :: TestTransport -> Assertion

1125−testMatchMessageWithUnwrap TestTransport{..} = do

1126− echoAddr <- newEmptyMVar

1127− clientDone <- newEmptyMVar

1128−

1129− -- echo server

1130− forkIO $ do

1131− localNode <- newLocalNode testTransport initRemoteTable

1132− echoServer <- forkProcess localNode $ forever $ do

1133− msg <- receiveWait [

1134− matchMessage (\(m :: Message) -> do

1135− return m)

1136− ]

1137− unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))

1138− case unwrapped of

1139− (Just (p, msg')) -> forward msg' p

1140− Nothing -> die "unable to unwrap the message"

1141− putMVar echoAddr echoServer

1142−

1143− -- Client

1144− forkIO $ do

1145− localNode <- newLocalNode testTransport initRemoteTable

1146− server <- readMVar echoAddr

1147−

1148− runProcess localNode $ do

1149− pid <- getSelfPid

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

1151− foo <- expect

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

1153− baz <- expect

1154− liftIO $ putMVar clientDone (foo, baz)

1155−

1156− res <- takeMVar clientDone

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

1158−

1159−-- Test 'receiveChanTimeout'

1160−testReceiveChanTimeout :: TestTransport -> Assertion

1161−testReceiveChanTimeout TestTransport{..} = do

1162− done <- newEmptyMVar

1163− mvSender <- newEmptyMVar

1164− sendPort <- newEmptyMVar

1165−

1166− forkTry $ do

1167− localNode <- newLocalNode testTransport initRemoteTable

1168− runProcess localNode $ do

1169− -- Create a typed channel

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

1171− liftIO $ putMVar sendPort sp

1172−

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

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

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

1184−

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

1186− -- available, we get Nothing

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

1188−

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

1190− liftIO $ putMVar mvSender ()

1191−

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

1193− fix $ \loop -> do

1194− liftIO $ threadDelay 100000

1195− mb <- receiveChanTimeout 0 rp

1196− case mb of

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

1198− _ -> loop

1199−

1200− liftIO $ putMVar done ()

1201−

1202− forkTry $ do

1203− localNode <- newLocalNode testTransport initRemoteTable

1204− runProcess localNode $ do

1205− sp <- liftIO $ readMVar sendPort

1206−

1207− liftIO $ takeMVar mvSender

1208− liftIO $ threadDelay 100000

1209− sendChan sp True

1210−

1211− liftIO $ takeMVar mvSender

1212− sendChan sp False

1213−

1214− takeMVar done

1215−

1216−-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan

1217−testReceiveChanFeatures :: TestTransport -> Assertion

1218−testReceiveChanFeatures TestTransport{..} = do

1219− done <- newEmptyMVar

1220−

1221− forkTry $ do

1222− localNode <- newLocalNode testTransport initRemoteTable

1223− runProcess localNode $ do

1224− (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)

1225− (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

1226−

1227− -- Test Functor instance

1228−

1229− sendChan spInt 2

1230− sendChan spBool False

1231−

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

1233−

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

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

1236−

1237− -- Test Applicative instance

1238−

1239− sendChan spInt 3

1240− sendChan spInt 4

1241−

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

1243−

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

1245−

1246− -- Test Alternative instance

1247−

1248− sendChan spInt 3

1249− sendChan spBool True

1250−

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

1252−

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

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

1255−

1256− -- Test Monad instance

1257−

1258− sendChan spBool True

1259− sendChan spBool False

1260− sendChan spInt 5

1261−

1262− let rp4 :: ReceivePort Int

1263− rp4 = do b <- rpBool

1264− if b

1265− then rpInt

1266− else return 7

1267−

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

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

1270−

1271− liftIO $ putMVar done ()

1272−

1273− takeMVar done

1274−

1275−testChanLifecycle :: TestTransport -> Assertion

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

1277− result <- newEmptyMVar

1278− tchMV <- newEmptyMVar

1279− localNode <- newLocalNode testTransport initRemoteTable

1280− runProcess localNode $ do

1281−

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

1283− liftIO $ putMVar tchMV tCh

1284− expect :: Process ()

1285− let (sp, _) = tCh

1286− sendChan sp ()

1287− expect :: Process ()

1288−

1289− mRefPid <- monitor pid

1290−

1291− cPid <- spawnLocal $ do

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

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

1294− send pid ()

1295− -- say "told pid to continue"

1296− res <- receiveChanTimeout delay rp

1297− case res of

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

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

1300− pause 10000

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

1302− send pid ()

1303−

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

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

1306−

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

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

1309−

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

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

1312− recv <- receiveChanTimeout delay rp

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

1314− liftIO $ putMVar result $ isNothing recv

1315−

1316− mRefCPid <- monitor cPid

1317−

1318− receiveWait

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

1320− (\_ -> return ())

1321− ]

1322−

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

1324−

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

1326− sendChan sendPort ()

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

1328−

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

1330− send cPid ()

1331−

1332− receiveWait

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

1334− (\_ -> return ())

1335− ]

1336−

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

1338−

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

1340− testRes <- takeMVar result

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

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

1343−

1344−

1345−testKillLocal :: TestTransport -> Assertion

1346−testKillLocal TestTransport{..} = do

1347− localNode <- newLocalNode testTransport initRemoteTable

1348−

1349− pid <- forkProcess localNode $ do

1350− liftIO $ threadDelay 1000000

1351−

1352− runProcess localNode $ do

1353− ref <- monitor pid

1354− us <- getSelfPid

1355− kill pid "TestKill"

1356− mn <- 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

1360− True -> return ()

1361− False -> die "Invalid ProcessMonitorNotification received"

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

1363−

1364−testKillRemote :: TestTransport -> Assertion

1365−testKillRemote TestTransport{..} = do

1366− node1 <- newLocalNode testTransport initRemoteTable

1367− node2 <- newLocalNode testTransport initRemoteTable

1368−

1369− pid <- forkProcess node1 $ do

1370− liftIO $ threadDelay 1000000

1371−

1372− runProcess node2 $ do

1373− ref <- monitor pid

1374− us <- getSelfPid

1375− kill pid "TestKill"

1376− mn <- expect

1377− case mn of

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

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

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

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

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

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

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

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

1386− _ -> die "Received unexpected message"

1387−

1388−testCatchesExit :: TestTransport -> Assertion

1389−testCatchesExit TestTransport{..} = do

1390− localNode <- newLocalNode testTransport initRemoteTable

1391− done <- newEmptyMVar

1392−

1393− _ <- forkProcess localNode $ do

1394− (die ("foobar", 123 :: Int))

1395− `catchesExit` [

1396− (\_ m -> handleMessage m (\(_ :: String) -> return ()))

1397− , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))

1398− , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)

1399− -> (liftIO $ putMVar done ()) >> return ()))

1400− ]

1401−

1402− takeMVar done

1403−

1404−testHandleMessageIf :: TestTransport -> Assertion

1405−testHandleMessageIf TestTransport{..} = do

1406− localNode <- newLocalNode testTransport initRemoteTable

1407− done <- newEmptyMVar

1408− _ <- forkProcess localNode $ do

1409− self <- getSelfPid

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

1411− msg <- receiveWait [ matchMessage return ]

1412− handleMessageIf msg

1413− (\() -> True)

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

1415− (const $ die "Expected Mismatch")

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

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

1418− return ()

1419−

1420− result <- takeMVar done

1421− expectThat result $ equalTo (5, 10)

1422−

1423−testCatches :: TestTransport -> Assertion

1424−testCatches TestTransport{..} = do

1425− localNode <- newLocalNode testTransport initRemoteTable

1426− done <- newEmptyMVar

1427−

1428− _ <- forkProcess localNode $ do

1429− node <- getSelfNode

1430− (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))

1431− `catches` [

1432− Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())

1433− ]

1434−

1435− takeMVar done

1436−

1437−testMaskRestoreScope :: TestTransport -> Assertion

1438−testMaskRestoreScope TestTransport{..} = do

1439− localNode <- newLocalNode testTransport initRemoteTable

1440− parentPid <- newEmptyMVar :: IO (MVar ProcessId)

1441− spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)

1442−

1443− void $ runProcess localNode $ mask $ \unmask -> do

1444− getSelfPid >>= liftIO . putMVar parentPid

1445− void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)

1446−

1447− parent <- liftIO $ takeMVar parentPid

1448− child <- liftIO $ takeMVar spawnedPid

1449− expectThat parent $ isNot $ equalTo child

1450−

1451−testDie :: TestTransport -> Assertion

1452−testDie TestTransport{..} = do

1453− localNode <- newLocalNode testTransport initRemoteTable

1454− done <- newEmptyMVar

1455−

1456− _ <- forkProcess localNode $ do

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

1458− `catchExit` \_from reason -> do

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

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

1461− liftIO $ putMVar done ()

1462− if res

1463− then return ()

1464− else die "Something went horribly wrong"

1465−

1466− takeMVar done

1467−

1468−testPrettyExit :: TestTransport -> Assertion

1469−testPrettyExit TestTransport{..} = do

1470− localNode <- newLocalNode testTransport initRemoteTable

1471− done <- newEmptyMVar

1472−

1473− _ <- forkProcess localNode $ do

1474− (die "timeout")

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

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

1477− in do

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

1479− liftIO $ putMVar done ()

1480− if res

1481− then return ()

1482− else die "Something went horribly wrong"

1483−

1484− takeMVar done

1485−

1486−testExitLocal :: TestTransport -> Assertion

1487−testExitLocal TestTransport{..} = do

1488− localNode <- newLocalNode testTransport initRemoteTable

1489− supervisedDone <- newEmptyMVar

1490− supervisorDone <- newEmptyMVar

1491− -- XXX: we guarantee that exception handler will be set up

1492− -- regardless if forkProcess preserve masking state or not.

1493− handlerSetUp <- newEmptyMVar

1494−

1495− pid <- forkProcess localNode $ do

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

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

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

1499− liftIO $ putMVar supervisedDone ()

1500− if res

1501− then return ()

1502− else die "Something went horribly wrong"

1503−

1504− runProcess localNode $ do

1505− liftIO $ takeMVar handlerSetUp

1506− ref <- monitor pid

1507− exit pid "TestExit"

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

1509− mn <- expect

1510− case mn of

1511− ProcessMonitorNotification ref' pid' DiedNormal -> do

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

1513− liftIO $ putMVar supervisorDone ()

1514− if res

1515− then return ()

1516− else die "Something went horribly wrong"

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

1518−

1519− takeMVar supervisedDone

1520− takeMVar supervisorDone

1521−

1522−testExitRemote :: TestTransport -> Assertion

1523−testExitRemote TestTransport{..} = do

1524− node1 <- newLocalNode testTransport initRemoteTable

1525− node2 <- newLocalNode testTransport initRemoteTable

1526− supervisedDone <- newEmptyMVar

1527− supervisorDone <- newEmptyMVar

1528−

1529− pid <- forkProcess node1 $ do

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

1531− `catchExit` \_from reason -> do

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

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

1534− liftIO $ putMVar supervisedDone ()

1535− if res

1536− then return ()

1537− else die "Something went horribly wrong"

1538−

1539− runProcess node2 $ do

1540− ref <- monitor pid

1541− exit pid "TestExit"

1542− mn <- expect

1543− case mn of

1544− ProcessMonitorNotification ref' pid' DiedNormal -> do

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

1546− liftIO $ putMVar supervisorDone ()

1547− if res'

1548− then return ()

1549− else die "Something went horribly wrong"

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

1551−

1552− takeMVar supervisedDone

1553− takeMVar supervisorDone

1554−

1555−testRegistryMonitoring :: TestTransport -> Assertion

1556−testRegistryMonitoring TestTransport{..} = do

1557− node1 <- newLocalNode testTransport initRemoteTable

1558− node2 <- newLocalNode testTransport initRemoteTable

1559−

1560− let nid = localNodeId node2

1561− pid <- forkProcess node1 $ do

1562− self <- getSelfPid

1563− runUntilRegistered nid self

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

1565− expect :: Process ()

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

1567−

1568− runProcess node2 $ do

1569− register regName pid

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

1571− res <- whereis regName

1572− send pid ()

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

1574− us <- getSelfPid

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

1576−

1577−

1578− -- This delay isn't essential!

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

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

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

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

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

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

1585− void $ receiveTimeout 4000000 [ matchAny return ]

1586−

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

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

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

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

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

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

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

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

1595− -- in either case.

1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid

1597−

1598− regHere <- newEmptyMVar

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

1600− res <- takeMVar regHere

1601− case res of

1602− Nothing -> return ()

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

1604−

1605− where

1606− runUntilRegistered nid us = do

1607− whereisRemoteAsync nid regName

1608− receiveWait [

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

1610− (const $ return ())

1611− ]

1612−

1613− delayUntilMaybeUnregistered nid p = do

1614− whereisRemoteAsync nid regName

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

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

1617− (const $ return ())

1618− ]

1619− case res of

1620− Just () -> return ()

1621− Nothing -> delayUntilMaybeUnregistered nid p

1622−

1623− regName = "testRegisterRemote"

1624−

1625−testUnsafeSend :: TestTransport -> Assertion

1626−testUnsafeSend TestTransport{..} = do

1627− serverAddr <- newEmptyMVar

1628− clientDone <- newEmptyMVar

1629−

1630− localNode <- newLocalNode testTransport initRemoteTable

1631− void $ forkProcess localNode $ do

1632− self <- getSelfPid

1633− liftIO $ putMVar serverAddr self

1634− clientAddr <- expect

1635− unsafeSend clientAddr ()

1636−

1637− void $ forkProcess localNode $ do

1638− serverPid <- liftIO $ takeMVar serverAddr

1639− getSelfPid >>= unsafeSend serverPid

1640− expect >>= liftIO . putMVar clientDone

1641−

1642− takeMVar clientDone

1643−

1644−testUnsafeUSend :: TestTransport -> Assertion

1645−testUnsafeUSend TestTransport{..} = do

1646− serverAddr <- newEmptyMVar

1647− clientDone <- newEmptyMVar

1648−

1649− localNode <- newLocalNode testTransport initRemoteTable

1650− void $ forkProcess localNode $ do

1651− self <- getSelfPid

1652− liftIO $ putMVar serverAddr self

1653− clientAddr <- expect

1654− unsafeUSend clientAddr ()

1655−

1656− void $ forkProcess localNode $ do

1657− serverPid <- liftIO $ takeMVar serverAddr

1658− getSelfPid >>= unsafeUSend serverPid

1659− expect >>= liftIO . putMVar clientDone

1660−

1661− takeMVar clientDone

1662−

1663−testUnsafeNSend :: TestTransport -> Assertion

1664−testUnsafeNSend TestTransport{..} = do

1665− clientDone <- newEmptyMVar

1666−

1667− localNode <- newLocalNode testTransport initRemoteTable

1668−

1669− pid <- forkProcess localNode $ do

1670− expect >>= liftIO . putMVar clientDone

1671−

1672− void $ runProcess localNode $ do

1673− register "foobar" pid

1674− unsafeNSend "foobar" ()

1675−

1676− takeMVar clientDone

1677−

1678−testUnsafeNSendRemote :: TestTransport -> Assertion

1679−testUnsafeNSendRemote TestTransport{..} = do

1680− clientDone <- newEmptyMVar

1681−

1682− localNode1 <- newLocalNode testTransport initRemoteTable

1683− localNode2 <- newLocalNode testTransport initRemoteTable

1684−

1685− _ <- forkProcess localNode1 $ do

1686− getSelfPid >>= register "foobar"

1687− liftIO $ putMVar clientDone ()

1688− expect >>= liftIO . putMVar clientDone

1689−

1690− takeMVar clientDone

1691− void $ runProcess localNode2 $ do

1692− unsafeNSendRemote (localNodeId localNode1) "foobar" ()

1693−

1694− takeMVar clientDone

1695−

1696−testUnsafeSendChan :: TestTransport -> Assertion

1697−testUnsafeSendChan TestTransport{..} = do

1698− serverAddr <- newEmptyMVar

1699− clientDone <- newEmptyMVar

1700−

1701− localNode <- newLocalNode testTransport initRemoteTable

1702− void $ forkProcess localNode $ do

1703− self <- getSelfPid

1704− liftIO $ putMVar serverAddr self

1705− sp <- expect

1706− unsafeSendChan sp ()

1707−

1708− void $ forkProcess localNode $ do

1709− serverPid <- liftIO $ takeMVar serverAddr

1710− (sp, rp) <- newChan

1711− unsafeSend serverPid sp

1712− receiveChan rp :: Process ()

1713− liftIO $ putMVar clientDone ()

1714−

1715− takeMVar clientDone

1716−

1717−testCallLocal :: TestTransport -> Assertion

1718−testCallLocal TestTransport{..} = do

1719− node <- newLocalNode testTransport initRemoteTable

1720−

1721− -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.

1722− result <- newEmptyMVar

1723− runProcess node $ do

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

1725− liftIO $ putMVar result r

1726−

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

1728−

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

1730− ibox <- newIORef False

1731− runProcess node $ do

1732− keeper <- getSelfPid

1733− spawnLocal $ do

1734− caller <- getSelfPid

1735− send keeper caller

1736− onException

1737− (callLocal $ do

1738− onException (do send keeper caller

1739− expect)

1740− (do liftIO $ writeIORef ibox True))

1741− (send keeper ())

1742− caller <- expect

1743− exit caller "test"

1744− expect :: Process ()

1745−

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

1747−

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

1749− ibox2 <- newIORef False

1750− runProcess node $ do

1751− r <- try (callLocal $ error "e" >> return ())

1752− liftIO $ writeIORef ibox2 $ case r of

1753− Left (ErrorCall "e") -> True

1754− _ -> False

1755−

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

1757−

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

1759− ibox3 <- newIORef False

1760− result3 <- newEmptyMVar

1761− runProcess node $ do

1762− keeper <- getSelfPid

1763− spawnLocal $ do

1764− callLocal $

1765− (do us <- getSelfPid

1766− send keeper us

1767− () <- expect

1768− liftIO yield)

1769− `finally` (liftIO $ writeIORef ibox3 True)

1770− liftIO $ putMVar result3 =<< readIORef ibox3

1771− worker <- expect

1772− send worker ()

1773−

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

1775−

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

1777− ibox4 <- newIORef False

1778− result4 <- newEmptyMVar

1779− runProcess node $ do

1780− keeper <- getSelfPid

1781− spawnLocal $ do

1782− caller <- getSelfPid

1783− callLocal

1784− ((do send keeper caller

1785− expect)

1786− `finally` (liftIO $ writeIORef ibox4 True))

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

1788− caller <- expect

1789− exit caller "hi!"

1790−

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

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

1793−

1794−tests :: TestTransport -> IO [Test]

1795−tests testtrans = return [

1796− testGroup "Basic features" [

1797− testCase "Ping" (testPing testtrans)

1798− , testCase "Math" (testMath testtrans)

1799− , testCase "Timeout" (testTimeout testtrans)

1800− , testCase "Timeout0" (testTimeout0 testtrans)

1801− , testCase "SendToTerminated" (testSendToTerminated testtrans)

1802− , testCase "TypedChannnels" (testTypedChannels testtrans)

1803− , testCase "Terminate" (testTerminate testtrans)

1804− , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)

1805− , testCase "RemoteRegistry" (testRemoteRegistry testtrans)

1806− , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)

1807− , testCase "SpawnLocal" (testSpawnLocal testtrans)

1808− , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)

1809− , testCase "HandleMessageIf" (testHandleMessageIf testtrans)

1810− , testCase "MatchAny" (testMatchAny testtrans)

1811− , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)

1812− , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)

1813− , testCase "MatchAnyIf" (testMatchAnyIf testtrans)

1814− , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1815− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1816− , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1818− , testCase "KillLocal" (testKillLocal testtrans)

1819− , testCase "KillRemote" (testKillRemote testtrans)

1820− , testCase "Die" (testDie testtrans)

1821− , testCase "PrettyExit" (testPrettyExit testtrans)

1822− , testCase "CatchesExit" (testCatchesExit testtrans)

1823− , testCase "Catches" (testCatches testtrans)

1824− , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1825− , testCase "ExitLocal" (testExitLocal testtrans)

1826− , testCase "ExitRemote" (testExitRemote testtrans)

1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1828− , testCase "TextCallLocal" (testCallLocal testtrans)

1829− -- Unsafe Primitives

1830− , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1831− , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)

1832− , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)

1833− , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)

1834− , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)

1835− -- usend

1836− , testCase "USend" (testUSend usend testtrans 50)

1837− , testCase "UForward"

1838− (testUSend (\p m -> uforward (createUnencodedMessage m) p)

1839− testtrans 50

1840− )

1841− ]

1842− , testGroup "Monitoring and Linking" [

1843− -- Monitoring processes

1844− --

1845− -- The "missing" combinations in the list below don't make much sense, as

1846− -- we cannot guarantee that the monitor reply or link exception will not

1847− -- happen before the unmonitor or unlink

1848− testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)

1849− , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)

1850− , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)

1851− , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)

1852− , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)

1853− , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)

1854− , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)

1855− , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)

1856− , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)

1857− , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)

1858− , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)

1859− , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)

1860− , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)

1861− , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)

1862− , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)

1863− , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)

1864− , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)

1865− -- Monitoring nodes and channels

1866− , testCase "MonitorNode" (testMonitorNode testtrans)

1867− , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)

1868− , testCase "MonitorChannel" (testMonitorChannel testtrans)

1869− -- Reconnect

1870− ]

1871−

1872− -- Tests that fail occasionally and should be revised

1873− , testGroup "Flaky" [

1874− testCase "Reconnect" (testReconnect testtrans)

1875− , testCase "Registry" (testRegistry testtrans)

1876− , testCase "MergeChannels" (testMergeChannels testtrans)

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

1878− ]

1879− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hsdeleted−589

@@ -1,589 +0,0 @@

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

2−module Control.Distributed.Process.Tests.Closure (tests) where

3−

4−import Network.Transport.Test (TestTransport(..))

5−

6−import Data.ByteString.Lazy (empty)

7−import Data.IORef

8−import Data.Typeable (Typeable)

9−import Data.Maybe

10−import Control.Monad (join, replicateM, forever, replicateM_, void, when, unless)

11−import Control.Exception (IOException, throw)

12−import Control.Concurrent (forkIO, threadDelay)

13−import Control.Concurrent.MVar

14− ( MVar

15− , newEmptyMVar

16− , readMVar

17− , takeMVar

18− , putMVar

19− , modifyMVar_

20− , newMVar

21− )

22−import Control.Applicative ((<$>))

23−import System.Random (randomIO)

24−import Control.Distributed.Process

25−import Control.Distributed.Process.Closure

26−import Control.Distributed.Process.Node

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

28− ( NodeId(nodeAddress)

29− , createMessage

30− , messageToPayload

31− )

32−import Control.Distributed.Static (staticLabel, staticClosure)

33−import qualified Network.Transport as NT

34−

35−import Test.HUnit (Assertion)

36−import Test.Framework (Test)

37−import Test.Framework.Providers.HUnit (testCase)

38−

39−--------------------------------------------------------------------------------

40−-- Supporting definitions --

41−--------------------------------------------------------------------------------

42−

43−quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)

44−quintuple a b c d e = (a, b, c, d, e)

45−

46−sdictInt :: SerializableDict Int

47−sdictInt = SerializableDict

48−

49−factorial :: Int -> Process Int

50−factorial 0 = return 1

51−factorial n = (n *) <$> factorial (n - 1)

52−

53−addInt :: Int -> Int -> Int

54−addInt x y = x + y

55−

56−putInt :: Int -> MVar Int -> IO ()

57−putInt = flip putMVar

58−

59−sendPid :: ProcessId -> Process ()

60−sendPid toPid = do

61− fromPid <- getSelfPid

62− send toPid fromPid

63−

64−wait :: Int -> Process ()

65−wait = liftIO . threadDelay

66−

67−expectUnit :: Process ()

68−expectUnit = expect

69−

70−isPrime :: Integer -> Process Bool

71−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]

72− where

73− sieve :: [Integer] -> [Integer]

74− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]

75− sieve [] = error "Uh oh -- we've run out of primes"

76−

77−-- | First argument indicates empty closure environment

78−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()

79−typedPingServer () rport = forever $ do

80− sport <- receiveChan rport

81− sendChan sport ()

82−

83−signal :: ProcessId -> Process ()

84−signal pid = send pid ()

85−

86−remotable [ 'factorial

87− , 'addInt

88− , 'putInt

89− , 'sendPid

90− , 'sdictInt

91− , 'wait

92− , 'expectUnit

93− , 'typedPingServer

94− , 'isPrime

95− , 'quintuple

96− , 'signal

97− ]

98−

99−randomElement :: [a] -> IO a

100−randomElement xs = do

101− ix <- randomIO

102− return (xs !! (ix `mod` length xs))

103−

104−remotableDecl [

105− [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;

106− dfib (_, reply, 0) = sendChan reply 0

107− dfib (_, reply, 1) = sendChan reply 1

108− dfib (nids, reply, n) = do

109− nid1 <- liftIO $ randomElement nids

110− nid2 <- liftIO $ randomElement nids

111− (sport, rport) <- newChan

112− spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)

113− spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)

114− n1 <- receiveChan rport

115− n2 <- receiveChan rport

116− sendChan reply $ n1 + n2

117− |]

118− ]

119−

120−-- Just try creating a static polymorphic value

121−staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)

122− => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))

123−staticQuintuple = $(mkStatic 'quintuple)

124−

125−factorialClosure :: Int -> Closure (Process Int)

126−factorialClosure = $(mkClosure 'factorial)

127−

128−addIntClosure :: Int -> Closure (Int -> Int)

129−addIntClosure = $(mkClosure 'addInt)

130−

131−putIntClosure :: Int -> Closure (MVar Int -> IO ())

132−putIntClosure = $(mkClosure 'putInt)

133−

134−sendPidClosure :: ProcessId -> Closure (Process ())

135−sendPidClosure = $(mkClosure 'sendPid)

136−

137−sendFac :: Int -> ProcessId -> Closure (Process ())

138−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid

139−

140−factorialOf :: Closure (Int -> Process Int)

141−factorialOf = staticClosure $(mkStatic 'factorial)

142−

143−factorial' :: Int -> Closure (Process Int)

144−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf

145−

146−waitClosure :: Int -> Closure (Process ())

147−waitClosure = $(mkClosure 'wait)

148−

149−simulateNetworkFailure :: TestTransport -> LocalNode -> LocalNode -> Process ()

150−simulateNetworkFailure TestTransport{..} from to = liftIO $ do

151− m <- newEmptyMVar

152− _ <- forkProcess to $ getSelfPid >>= liftIO . putMVar m

153− runProcess from $ do

154− them <- liftIO $ takeMVar m

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

156− _ <- monitorNode (localNodeId to)

157− liftIO $ testBreakConnection (nodeAddress $ localNodeId from)

158− (nodeAddress $ localNodeId to)

159− NodeMonitorNotification _ _ _ <- expect

160− kill pinger "finished"

161− return ()

162−

163−--------------------------------------------------------------------------------

164−-- The tests proper --

165−--------------------------------------------------------------------------------

166−

167−testUnclosure :: TestTransport -> RemoteTable -> Assertion

168−testUnclosure TestTransport{..} rtable = do

169− node <- newLocalNode testTransport rtable

170− done <- newEmptyMVar

171− forkProcess node $ do

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

178−

179−testBind :: TestTransport -> RemoteTable -> Assertion

180−testBind TestTransport{..} rtable = do

181− node <- newLocalNode testTransport rtable

182− done <- newEmptyMVar

183− runProcess node $ do

184− us <- getSelfPid

185− join . unClosure $ sendFac 6 us

186− (i :: Int) <- expect

187− liftIO $ putMVar done ()

188− if i == 720

189− then return ()

190− else error "Something went horribly wrong"

191− takeMVar done

192−

193−testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

194−testSendPureClosure TestTransport{..} rtable = do

195− serverAddr <- newEmptyMVar

196− serverDone <- newEmptyMVar

197−

198− forkIO $ do

199− node <- newLocalNode testTransport rtable

200− addr <- forkProcess node $ do

201− cl <- expect

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

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

204− liftIO $ putMVar serverDone ()

205− putMVar serverAddr addr

206−

207− forkIO $ do

208− node <- newLocalNode testTransport rtable

209− theirAddr <- readMVar serverAddr

210− runProcess node $ send theirAddr (addIntClosure 7)

211−

212− takeMVar serverDone

213−

214−testSendIOClosure :: TestTransport -> RemoteTable -> Assertion

215−testSendIOClosure TestTransport{..} rtable = do

216− serverAddr <- newEmptyMVar

217− serverDone <- newEmptyMVar

218−

219− forkIO $ do

220− node <- newLocalNode testTransport rtable

221− addr <- forkProcess node $ do

222− cl <- expect

223− io <- unClosure cl :: Process (MVar Int -> IO ())

224− liftIO $ do

225− someMVar <- newEmptyMVar

226− io someMVar

227− i <- readMVar someMVar

228− putMVar serverDone ()

229− if i == 5

230− then return ()

231− else error "Something went horribly wrong"

232− putMVar serverAddr addr

233−

234− forkIO $ do

235− node <- newLocalNode testTransport rtable

236− theirAddr <- readMVar serverAddr

237− runProcess node $ send theirAddr (putIntClosure 5)

238−

239− takeMVar serverDone

240−

241−testSendProcClosure :: TestTransport -> RemoteTable -> Assertion

242−testSendProcClosure TestTransport{..} rtable = do

243− serverAddr <- newEmptyMVar

244− clientDone <- newEmptyMVar

245−

246− forkIO $ do

247− node <- newLocalNode testTransport rtable

248− addr <- forkProcess node $ do

249− cl <- expect

250− pr <- unClosure cl :: Process (Int -> Process ())

251− pr 5

252− putMVar serverAddr addr

253−

254− forkIO $ do

255− node <- newLocalNode testTransport rtable

256− theirAddr <- readMVar serverAddr

257− runProcess node $ do

258− pid <- getSelfPid

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

260− i <- expect :: Process Int

261− if i == 5

262− then liftIO $ putMVar clientDone ()

263− else error "Something went horribly wrong"

264−

265− takeMVar clientDone

266−

267−testSpawn :: TestTransport -> RemoteTable -> Assertion

268−testSpawn TestTransport{..} rtable = do

269− serverNodeAddr <- newEmptyMVar

270− clientDone <- newEmptyMVar

271−

272− forkIO $ do

273− node <- newLocalNode testTransport rtable

274− putMVar serverNodeAddr (localNodeId node)

275−

276− forkIO $ do

277− node <- newLocalNode testTransport rtable

278− nid <- readMVar serverNodeAddr

279− runProcess node $ do

280− pid <- getSelfPid

281− pid' <- spawn nid (sendPidClosure pid)

282− pid'' <- expect

283− if pid' == pid''

284− then liftIO $ putMVar clientDone ()

285− else error "Something went horribly wrong"

286−

287− takeMVar clientDone

288−

289−-- | Tests that spawn executes the supplied closure even if the caller dies

290−-- immediately after calling spawn.

291−--

292−-- This situation is of interest because the implementation of spawn has the

293−-- remote peer monitor the caller. See DP-99.

294−--

295−-- The condition is tested by using a transport which refuses to send to the

296−-- remote peer the message that it is waiting to stop monitoring the caller,

297−-- namely @()@.

298−--

299−testSpawnRace :: TestTransport -> RemoteTable -> Assertion

300−testSpawnRace TestTransport{..} rtable = do

301− node1 <- newLocalNode (wrapTransport testTransport) rtable

302− node2 <- newLocalNode testTransport rtable

303−

304− runProcess node1 $ do

305− pid <- getSelfPid

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

307− pid' <- expect :: Process ProcessId

308− pid'' <- expect :: Process ProcessId

309− if pid' == pid''

310− then return ()

311− else error "Something went horribly wrong"

312−

313− where

314−

315− wrapTransport (NT.Transport ne ct) = NT.Transport (fmap (fmap wrapEP) ne) ct

316−

317− wrapEP :: NT.EndPoint -> NT.EndPoint

318− wrapEP e =

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

320− healthy <- newIORef True

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

322− }

323−

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

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

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

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

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

329− writeIORef healthy False

330− testBreakConnection (NT.address e) remoteAddr

331− isHealthy <- readIORef healthy

332− if isHealthy then s msg

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

334−

335−testCall :: TestTransport -> RemoteTable -> Assertion

336−testCall TestTransport{..} rtable = do

337− serverNodeAddr <- newEmptyMVar

338− clientDone <- newEmptyMVar

339−

340− forkIO $ do

341− node <- newLocalNode testTransport rtable

342− putMVar serverNodeAddr (localNodeId node)

343−

344− forkIO $ do

345− node <- newLocalNode testTransport rtable

346− nid <- readMVar serverNodeAddr

347− runProcess node $ do

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

349− if a == 120

350− then liftIO $ putMVar clientDone ()

351− else error "something went horribly wrong"

352−

353− takeMVar clientDone

354−

355−testCallBind :: TestTransport -> RemoteTable -> Assertion

356−testCallBind TestTransport{..} rtable = do

357− serverNodeAddr <- newEmptyMVar

358− clientDone <- newEmptyMVar

359−

360− forkIO $ do

361− node <- newLocalNode testTransport rtable

362− putMVar serverNodeAddr (localNodeId node)

363−

364− forkIO $ do

365− node <- newLocalNode testTransport rtable

366− nid <- readMVar serverNodeAddr

367− runProcess node $ do

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

369− if a == 120

370− then liftIO $ putMVar clientDone ()

371− else error "Something went horribly wrong"

372−

373− takeMVar clientDone

374−

375−testSeq :: TestTransport -> RemoteTable -> Assertion

376−testSeq TestTransport{..} rtable = do

377− node <- newLocalNode testTransport rtable

378− done <- newEmptyMVar

379− runProcess node $ do

380− us <- getSelfPid

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

382− a :: Int <- expect

383− b :: Int <- expect

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

385− then liftIO $ putMVar done ()

386− else error "Something went horribly wrong"

387− takeMVar done

388−

389−-- Test 'spawnSupervised'

390−--

391−-- Set up a supervisor, spawn a child, then have a third process monitor the

392−-- child. The supervisor then throws an exception, the child dies because it

393−-- was linked to the supervisor, and the third process notices that the child

394−-- dies.

395−testSpawnSupervised :: TestTransport -> RemoteTable -> Assertion

396−testSpawnSupervised TestTransport{..} rtable = do

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

398− [superPid, childPid] <- replicateM 2 $ newEmptyMVar

399− thirdProcessDone <- newEmptyMVar

400− linkUp <- newEmptyMVar

401−

402− forkProcess node1 $ do

403− us <- getSelfPid

404− liftIO $ putMVar superPid us

405− (child, _ref) <- spawnSupervised (localNodeId node2)

406− (sendPidClosure us `seqCP` $(mkStaticClosure 'expectUnit))

407− _ <- expect :: Process ProcessId

408−

409− liftIO $ do putMVar childPid child

410− -- Give the child a chance to link to us

411− takeMVar linkUp

412− throw supervisorDeath

413−

414− forkProcess node2 $ do

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

416− case res of

417− [super, child] -> do

418− ref <- monitor child

419− self <- getSelfPid

420− let waitForMOrL = do

421− liftIO $ threadDelay 10000

422− mpinfo <- getProcessInfo child

423− case mpinfo of

424− Nothing -> waitForMOrL

425− Just pinfo ->

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

427− waitForMOrL

428− liftIO $ putMVar linkUp ()

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

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

431− res' <- expect

432− case res' of

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

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

435− e == show (ProcessLinkException super

436− (DiedException (show supervisorDeath))))

437− then liftIO $ putMVar thirdProcessDone ()

438− else error "Something went horribly wrong"

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

440−

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

442−

443− takeMVar thirdProcessDone

444− where

445− supervisorDeath :: IOException

446− supervisorDeath = userError "Supervisor died"

447−

448−testSpawnInvalid :: TestTransport -> RemoteTable -> Assertion

449−testSpawnInvalid TestTransport{..} rtable = do

450− node <- newLocalNode testTransport rtable

451− done <- newEmptyMVar

452− forkProcess node $ do

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

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

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

457− if res == True

458− then liftIO $ putMVar done ()

459− else error "Something went horribly wrong"

460− takeMVar done

461−

462−testClosureExpect :: TestTransport -> RemoteTable -> Assertion

463−testClosureExpect TestTransport{..} rtable = do

464− node <- newLocalNode testTransport rtable

465− done <- newEmptyMVar

466− runProcess node $ do

467− nodeId <- getSelfNode

468− us <- getSelfPid

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

470− send them (1234 :: Int)

471− (res :: Int) <- expect

472− if res == 1234

473− then liftIO $ putMVar done ()

474− else error "Something went horribly wrong"

475− takeMVar done

476−

477−testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

478−testSpawnChannel TestTransport{..} rtable = do

479− done <- newEmptyMVar

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

481−

482− forkProcess node1 $ do

483− pingServer <- spawnChannel

484− (sdictSendPort sdictUnit)

485− (localNodeId node2)

486− ($(mkClosure 'typedPingServer) ())

487− (sendReply, receiveReply) <- newChan

488− sendChan pingServer sendReply

489− receiveChan receiveReply

490− liftIO $ putMVar done ()

491−

492− takeMVar done

493−

494−testTDict :: TestTransport -> RemoteTable -> Assertion

495−testTDict TestTransport{..} rtable = do

496− done <- newEmptyMVar

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

498− forkProcess node1 $ do

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

500− if res == True

501− then liftIO $ putMVar done ()

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

503− takeMVar done

504−

505−testFib :: TestTransport -> RemoteTable -> Assertion

506−testFib TestTransport{..} rtable = do

507− nodes <- replicateM 4 $ newLocalNode testTransport rtable

508− done <- newEmptyMVar

509−

510− forkProcess (head nodes) $ do

511− (sport, rport) <- newChan

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

513− ff <- receiveChan rport :: Process Integer

514− liftIO $ putMVar done ()

515− if ff /= 55

516− then die $ "Something went horribly wrong"

517− else return ()

518−

519− takeMVar done

520−

521−testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion

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

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

524− let nid1 = localNodeId node1

525− -- nid2 = localNodeId node2

526− done <- newEmptyMVar

527− iv <- newMVar (0 :: Int)

528−

529− incr <- forkProcess node1 $ forever $ do

530− () <- expect

531− liftIO $ modifyMVar_ iv (return . (+ 1))

532−

533− forkProcess node2 $ do

534− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)

535− simulateNetworkFailure testtrans node2 node1

536− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)

537− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)

538−

539− liftIO $ threadDelay 100000

540−

541− count <- liftIO $ takeMVar iv

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

543−

544− liftIO $ putMVar done ()

545− if res /= True

546− then error "Something went horribly wrong"

547− else return ()

548−

549− takeMVar done

550−

551−-- | 'spawn' used to ave a race condition which would be triggered if the

552−-- spawning process terminates immediately after spawning

553−testSpawnTerminate :: TestTransport -> RemoteTable -> Assertion

554−testSpawnTerminate TestTransport{..} rtable = do

555− slave <- newLocalNode testTransport rtable

556− master <- newLocalNode testTransport rtable

557− masterDone <- newEmptyMVar

558−

559− runProcess master $ do

560− us <- getSelfPid

561− replicateM_ 1000 . spawnLocal . void . spawn (localNodeId slave) $ $(mkClosure 'signal) us

562− replicateM_ 1000 $ (expect :: Process ())

563− liftIO $ putMVar masterDone ()

564−

565− takeMVar masterDone

566−

567−tests :: TestTransport -> IO [Test]

568−tests testtrans = do

569− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable

570− return

571− [ testCase "Unclosure" (testUnclosure testtrans rtable)

572− , testCase "Bind" (testBind testtrans rtable)

573− , testCase "SendPureClosure" (testSendPureClosure testtrans rtable)

574− , testCase "SendIOClosure" (testSendIOClosure testtrans rtable)

575− , testCase "SendProcClosure" (testSendProcClosure testtrans rtable)

576− , testCase "Spawn" (testSpawn testtrans rtable)

577− , testCase "SpawnRace" (testSpawnRace testtrans rtable)

578− , testCase "Call" (testCall testtrans rtable)

579− , testCase "CallBind" (testCallBind testtrans rtable)

580− , testCase "Seq" (testSeq testtrans rtable)

581− , testCase "SpawnSupervised" (testSpawnSupervised testtrans rtable)

582− , testCase "SpawnInvalid" (testSpawnInvalid testtrans rtable)

583− , testCase "ClosureExpect" (testClosureExpect testtrans rtable)

584− , testCase "SpawnChannel" (testSpawnChannel testtrans rtable)

585− , testCase "TDict" (testTDict testtrans rtable)

586− , testCase "Fib" (testFib testtrans rtable)

587− , testCase "SpawnTerminate" (testSpawnTerminate testtrans rtable)

588− , testCase "SpawnReconnect" (testSpawnReconnect testtrans rtable)

589− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hsdeleted−243

@@ -1,243 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE CPP #-}

5−

6−-----------------------------------------------------------------------------

7−-- |

8−-- Module : Control.Distributed.Process.Tests.Internal.Utils

9−-- Copyright : (c) Tim Watson, Jeff Epstein 2013

10−-- License : BSD3 (see the file LICENSE)

11−--

12−-- Maintainer : Tim Watson

13−-- Stability : experimental

14−-- Portability : non-portable (requires concurrency)

15−--

16−-- This module provides basic building blocks for testing Cloud Haskell programs.

17−-----------------------------------------------------------------------------

18−module Control.Distributed.Process.Tests.Internal.Utils

19− ( TestResult

20− -- ping !

21− , Ping(Ping)

22− , ping

23− , pause

24− , shouldBe

25− , shouldMatch

26− , shouldContain

27− , shouldNotContain

28− , expectThat

29− , synchronisedAssertion

30− -- test process utilities

31− , TestProcessControl

32− , startTestProcess

33− , runTestProcess

34− , testProcessGo

35− , testProcessStop

36− , testProcessReport

37− , delayedAssertion

38− , assertComplete

39− -- logging

40− , Logger()

41− , newLogger

42− , putLogMsg

43− , stopLogger

44− -- runners

45− , tryRunProcess

46− , tryForkProcess

47− , noop

48− , stash

49− ) where

50−

51−#if ! MIN_VERSION_base(4,6,0)

52−import Prelude hiding (catch)

53−#endif

54−import Control.Concurrent

55− ( ThreadId

56− , myThreadId

57− , forkIO

58− )

59−import Control.Concurrent.STM

60− ( TQueue

61− , newTQueueIO

62− , readTQueue

63− , writeTQueue

64− )

65−import Control.Concurrent.MVar

66− ( MVar

67− , newEmptyMVar

68− , takeMVar

69− )

70−

71−import Control.Concurrent

72− ( throwTo

73− )

74−import Control.Concurrent.MVar

75− ( putMVar

76− )

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

78−import Control.Distributed.Process.Node

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

80−

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

82−import Control.Monad (forever, void)

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

84−import Control.Monad.STM (atomically)

85−import Control.Rematch hiding (match)

86−import Control.Rematch.Run

87−import Data.Binary

88−import Data.Typeable (Typeable)

89−

90−import Test.HUnit (Assertion, assertFailure)

91−import Test.HUnit.Base (assertBool)

92−

93−import GHC.Generics

94−import System.Timeout (timeout)

95−

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

97−type TestResult a = MVar a

98−

99−-- | A simple @Ping@ signal

100−data Ping = Ping

101− deriving (Typeable, Generic, Eq, Show)

102−instance Binary Ping where

103−

104−ping :: ProcessId -> Process ()

105−ping pid = send pid Ping

106−

107−-- | Control signals used to manage /test processes/

108−data TestProcessControl = Stop | Go | Report ProcessId

109− deriving (Typeable, Generic)

110−

111−instance Binary TestProcessControl where

112−

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.

118−noop :: Process ()

119−noop = return ()

120−

121−pause :: Int -> Process ()

122−pause delay =

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

124−

125−synchronisedAssertion :: Eq a

126− => String

127− -> LocalNode

128− -> a

129− -> (TestResult a -> Process ())

130− -> MVar ()

131− -> Assertion

132−synchronisedAssertion note localNode expected testProc lock = do

133− result <- newEmptyMVar

134− _ <- forkProcess localNode $ do

135− acquire lock

136− finally (testProc result)

137− (release lock)

138− assertComplete note result expected

139− where acquire lock' = liftIO $ takeMVar lock'

140− release lock' = liftIO $ putMVar lock' ()

141−

142−stash :: TestResult a -> a -> Process ()

143−stash mvar x = liftIO $ putMVar mvar x

144−

145−expectThat :: a -> Matcher a -> Process ()

146−expectThat a matcher = case res of

147− MatchSuccess -> return ()

148− (MatchFailure msg) -> liftIO $ assertFailure msg

149− where res = runMatch matcher a

150−

151−shouldBe :: a -> Matcher a -> Process ()

152−shouldBe = expectThat

153−

154−shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()

155−shouldContain xs x = expectThat xs $ hasItem (equalTo x)

156−

157−shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()

158−shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))

159−

160−shouldMatch :: a -> Matcher a -> Process ()

161−shouldMatch = expectThat

162−

163−-- | Run the supplied @testProc@ using an @MVar@ to collect and assert

164−-- against its result. Uses the supplied @note@ if the assertion fails.

165−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->

166− (TestResult a -> Process ()) -> Assertion

167−delayedAssertion note localNode expected testProc = do

168− result <- newEmptyMVar

169− _ <- forkProcess localNode $ testProc result

170− assertComplete note result expected

171−

172−-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@

173−assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

174−assertComplete msg mv a = do

175− b <- takeMVar mv

176− assertBool msg (a == b)

177−

178−-- synchronised logging

179−

180−data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }

181−

182−-- | Create a new Logger.

183−-- Logger uses a 'TQueue' to receive and process messages on a worker thread.

184−newLogger :: IO Logger

185−newLogger = do

186− tid <- liftIO $ myThreadId

187− q <- liftIO $ newTQueueIO

188− _ <- forkIO $ logger q

189− return $ Logger tid q

190− where logger q' = forever $ do

191− msg <- atomically $ readTQueue q'

192− putStrLn msg

193−

194−-- | Send a message to the Logger

195−putLogMsg :: Logger -> String -> Process ()

196−putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg

197−

198−-- | Stop the worker thread for the given Logger

199−stopLogger :: Logger -> IO ()

200−stopLogger = (flip throwTo) ThreadKilled . _tid

201−

202−-- | Starts a test process on the local node.

203−startTestProcess :: Process () -> Process ProcessId

204−startTestProcess proc =

205− spawnLocal $ do

206− getSelfPid >>= register "test-process"

207− runTestProcess proc

208−

209−-- | Runs a /test process/ around the supplied @proc@, which is executed

210−-- whenever the outer process loop receives a 'Go' signal.

211−runTestProcess :: Process () -> Process ()

212−runTestProcess proc = do

213− ctl <- expect

214− case ctl of

215− Stop -> return ()

216− Go -> proc >> runTestProcess proc

217− Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc

218−

219−-- | Tell a /test process/ to continue executing

220−testProcessGo :: ProcessId -> Process ()

221−testProcessGo pid = send pid Go

222−

223−-- | Tell a /test process/ to stop (i.e., 'terminate')

224−testProcessStop :: ProcessId -> Process ()

225−testProcessStop pid = send pid Stop

226−

227−-- | Tell a /test process/ to send a report (message)

228−-- back to the calling process

229−testProcessReport :: ProcessId -> Process ()

230−testProcessReport pid = do

231− self <- getSelfPid

232− send pid $ Report self

233−

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

235−tryRunProcess node p = do

236− tid <- liftIO myThreadId

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

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

239−

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

241−tryForkProcess node p = do

242− tid <- liftIO myThreadId

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

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hsdeleted−542

@@ -1,542 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE ParallelListComp #-}

3−

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

5−

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

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

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

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

10− ( ProcessExitException(..)

11− , unsafeCreateUnencodedMessage

12− )

13−import Control.Distributed.Process.Node

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

15− ( send

16− , nsend

17− , nsendRemote

18− , usend

19− , sendChan

20− )

21−import Control.Distributed.Process.Management

22− ( MxEvent(..)

23− , MxAgentId(..)

24− , mxAgent

25− , mxSink

26− , mxReady

27− , mxReceive

28− , mxDeactivate

29− , liftMX

30− , mxGetLocal

31− , mxSetLocal

32− , mxUpdateLocal

33− , mxNotify

34− , mxBroadcast

35− )

36−import Control.Monad (void, unless)

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

38−import Control.Rematch (equalTo)

39−import Data.Binary

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

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

42−import Data.Typeable

43−import GHC.Generics hiding (from)

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

45−import Prelude hiding (catch, log)

46−#endif

47−

48−import Test.Framework

49− ( Test

50− , testGroup

51− )

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

53−

54−data Publish = Publish

55− deriving (Typeable, Generic, Eq)

56−

57−instance Binary Publish where

58−

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

70−testAgentBroadcast result = do

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

72−

73− publisher <- mxAgent (MxAgentId "publisher-agent") () [

74− mxSink $ \() -> mxBroadcast Publish >> mxReady

75− ]

76−

77− consumer <- mxAgent (MxAgentId "consumer-agent") () [

78− mxSink $ \Publish -> (liftMX $ sendChan resultSP ()) >> mxReady

79− ]

80−

81− mxNotify ()

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

84− stash result =<< receiveChanTimeout 10000000 resultRP

85−

86− kill publisher "finished"

87− kill consumer "finished"

88−

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

90−testAgentDualInput result = do

91− (sp, rp) <- newChan

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

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

94− mxSetLocal . (+i) =<< mxGetLocal

95− i' <- mxGetLocal

96− if i' == 15

97− then do mxGetLocal >>= liftMX . sendChan sp

98− mxDeactivate "finished"

99− else mxReady)

100− ]

101−

102− mRef <- monitor s

103−

104− mxNotify (1 :: Int)

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

106− mxNotify (2 :: Int)

107− nsend "sum-agent" (4 :: Int)

108− mxNotify (5 :: Int)

109−

110− stash result =<< receiveChanTimeout 10000000 rp

111− died <- receiveTimeout 10000000 [

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

113− ]

114− died `shouldBe` equalTo (Just True)

115−

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

117−testAgentPrioritisation result = do

118−

119− -- TODO: this isn't really testing how we /prioritise/ one source

120− -- over another at all, but I've not yet figured out the right way

121− -- to do so, since we're at the whim of the scheduler with regards

122− -- the timeliness of nsend versus mxNotify anyway.

123−

124− let name = "prioritising-agent"

125− (sp, rp) <- newChan

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

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

128− mxUpdateLocal (s:)

129− st <- mxGetLocal

130− case length st of

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

132− mxDeactivate "finished"

133− _ -> mxReceive -- go to the mailbox

134− )

135− ]

136−

137− nsend name "second"

138− mxNotify "third"

139− mxNotify "fourth"

140− nsend name "fifth"

141−

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

143− awaitExit s

144−

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

146−testAgentMailboxHandling result = do

147− (sp, rp) <- newChan

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

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

150− ]

151−

152− nsend "mailbox-agent" ()

153−

154− stash result =<< receiveChanTimeout 1000000 rp

155− kill agent "finished"

156−

157−testAgentEventHandling :: TestResult Bool -> Process ()

158−testAgentEventHandling 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]

168− (rc, rs) <- newChan

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

170− (mxSink $ \ev -> do

171− st <- mxGetLocal

172− let act =

173− case ev of

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

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

176− _ -> return ()

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

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

179− st <- mxGetLocal

180− let found =

181− case ev of

182− MxSpawned p ->

183− isJust $ find (\ev' ->

184− case ev' of

185− (MxSpawned p') -> p' == p

186− _ -> False) st

187− MxProcessDied p r ->

188− isJust $ find (\ev' ->

189− case ev' of

190− (MxProcessDied p' r') -> p' == p && r == r'

191− _ -> False) st

192− _ -> False

193− liftMX $ sendChan sp found

194− mxReady)

195− ]

196−

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

198− faff 2000000 rs

199−

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

201−

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

203−

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

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

206− 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 ()) ]

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−

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

219− mxNotify (MxSpawned pid, replyTo)

220− mxNotify (MxProcessDied pid DiedNormal, replyTo)

221−

222− seenAlive <- receiveChanTimeout 10000000 reply

223− seenDead <- receiveChanTimeout 10000000 reply

224−

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

226− kill timer "test-complete"

227− kill agentPid "test-complete"

228− where

229− faff delay port = do

230− res <- receiveChanTimeout delay port

231− unless (isNothing res) $ pause delay

232−

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

234−testMxRegEvents result = do

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

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

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

238− ensure (stash result ()) $ do

239− let label = "testMxRegEvents"

240− let agentLabel = "mxRegEvents-agent"

241− let delay = 1000000

242− (regChan, regSink) <- newChan

243− (unRegChan, unRegSink) <- newChan

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

245− mxSink $ \ev -> do

246− case ev of

247− MxRegistered pid label'

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

249− MxUnRegistered pid label'

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

251− _ -> return ()

252− mxReady

253− ]

254−

255− p1 <- spawnLocal expect

256− p2 <- spawnLocal expect

257−

258− register label p1

259− reg1 <- receiveChanTimeout delay regSink

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

261−

262− unregister label

263− unreg1 <- receiveChanTimeout delay unRegSink

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

265−

266− register label p2

267− reg2 <- receiveChanTimeout delay regSink

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

269−

270− reregister label p1

271− unreg2 <- receiveChanTimeout delay unRegSink

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

273−

274− reg3 <- receiveChanTimeout delay regSink

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

276−

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

278−

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

280−testMxRegMon remoteNode result = do

281− ensure (stash result ()) $ do

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

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

284− let label1 = "aaaaa"

285− let label2 = "bbbbb"

286− let isValid l = l == label1 || l == label2

287− let agentLabel = "mxRegMon-agent"

288− let delay = 1000000

289− (regChan, regSink) <- newChan

290− (unRegChan, unRegSink) <- newChan

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

292− mxSink $ \ev -> do

293− case ev of

294− MxRegistered pid label

295− | isValid label -> liftMX $ sendChan regChan (label, pid)

296− MxUnRegistered pid label

297− | isValid label -> liftMX $ sendChan unRegChan (label, pid)

298− _ -> return ()

299− mxReady

300− ]

301−

302− (sp, rp) <- newChan

303− liftIO $ forkProcess remoteNode $ do

304− getSelfPid >>= sendChan sp

305− expect :: Process ()

306−

307− p1 <- receiveChan rp

308−

309− register label1 p1

310− reg1 <- receiveChanTimeout delay regSink

311− reg1 `shouldBe` equalTo (Just (label1, p1))

312−

313− register label2 p1

314− reg2 <- receiveChanTimeout delay regSink

315− reg2 `shouldBe` equalTo (Just (label2, p1))

316−

317− n1 <- whereis label1

318− n1 `shouldBe` equalTo (Just p1)

319−

320− n2 <- whereis label2

321− n2 `shouldBe` equalTo (Just p1)

322−

323− kill p1 "goodbye"

324−

325− unreg1 <- receiveChanTimeout delay unRegSink

326− unreg2 <- receiveChanTimeout delay unRegSink

327−

328− let evts = [unreg1, unreg2]

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

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

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

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

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

334−

335− kill agent "test-complete"

336−

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

338−ensure = flip finally

339−

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

341− -> Maybe LocalNode

342− -> Process ()

343−testNSend op n = do

344− us <- getSelfPid

345− let delay = 5000000

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

347− let isValid = isValidLabel n label

348−

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

350− register label p1

351− reg1 <- receiveChanTimeout delay sink

352− case reg1 of

353− Just (MxRegistered pd lb)

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

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

356−

357− op label ()

358−

359− sent <- receiveChanTimeout delay sink

360− case sent of

361− Just (MxSentToName lb by _)

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

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

364−

365− where

366− isValidLabel nd l1 l2

367− | l2 == l2 = True

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

369− | otherwise = False

370−

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

372− -> Maybe LocalNode

373− -> Process ()

374−testSend op n = do

375− us <- getSelfPid

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

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

378− -- initiate a send

379− op p1 ()

380−

381− -- verify the management event

382− sent <- receiveChanTimeout 5000000 sink

383− case sent of

384− Just (MxSent pidTo pidFrom _)

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

386− _ -> return False

387−

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

389− -> Maybe LocalNode

390− -> Process ()

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

392−

393− us <- getSelfPid

394− send p1 us

395−

396− cleared <- receiveChanTimeout 2000000 sink

397− case cleared of

398− Just (MxSent pidTo pidFrom _)

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

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

401−

402− chan <- receiveTimeout 5000000 [ match return ]

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

404−

405− -- initiate a send

406− op ch' ()

407−

408− -- verify the management event

409− sent <- receiveChanTimeout 5000000 sink

410− case sent of

411− Just (MxSentToPort sId spId _)

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

413− _ -> return False

414−

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

416−

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

418−testMxSend mNode label test = do

419− us <- getSelfPid

420− (sp, rp) <- newChan

421− (chan, sink) <- newChan

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

423− mxSink $ \ev -> do

424− case ev of

425− m@(MxSentToPort _ cid _)

426− | cid /= sendPortId chan

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

428− m@(MxSent _ fromPid _)

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

430− m@(MxSentToName _ fromPid _)

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

432− m@(MxRegistered _ name)

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

434− _ -> return ()

435− mxReady

436− ]

437−

438− case mNode of

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

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

441−

442− p1 <- receiveChanTimeout 2000000 rp

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

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

445−

446− kill agent "bye"

447− kill (fromJust p1) "bye"

448−

449− case res of

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

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

452−

453−

454− where

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

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

457−

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

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

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

461−

462− replyChannel p' = do

463− (s, r) <- newChan

464− send p' s

465− return r

466−

467−tests :: TestTransport -> IO [Test]

468−tests TestTransport{..} = do

469− node1 <- newLocalNode testTransport initRemoteTable

470− node2 <- newLocalNode testTransport initRemoteTable

471− return [

472− testGroup "MxAgents" [

473− testCase "EventHandling"

474− (delayedAssertion

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

476− node1 True testAgentEventHandling)

477− , testCase "InterAgentBroadcast"

478− (delayedAssertion

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

480− node1 (Just ()) testAgentBroadcast)

481− , testCase "AgentMailboxHandling"

482− (delayedAssertion

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

484− node1 (Just ()) testAgentMailboxHandling)

485− , testCase "AgentDualInputHandling"

486− (delayedAssertion

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

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

489− , testCase "AgentInputPrioritisation"

490− (delayedAssertion

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

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

493− "third", "fourth",

494− "fifth"]) testAgentPrioritisation)

495− ]

496− , testGroup "MxEvents" [

497− testCase "NameRegistrationEvents"

498− (delayedAssertion

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

500− node1 () testMxRegEvents)

501− , testCase "PostDeathNameUnRegistrationEvents"

502− (delayedAssertion

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

504− node1 () (testMxRegMon node2))

505− , testGroup "SendEvents" $ buildTestCases node1 node2

506− ]

507− ]

508− where

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

510− ("NSend", [

511− ("nsend", testNSend nsend)

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

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

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

515− ])

516− , ("Send", [

517− ("send", testSend send)

518− , ("Unsafe.send", testSend Unsafe.send)

519− , ("usend", testSend usend)

520− , ("Unsafe.usend", testSend Unsafe.usend)

521− , ("sendChan", testChan sendChan)

522− , ("Unsafe.sendChan", testChan Unsafe.sendChan)

523− ])

524− , ("Forward", [

525− ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))

526− , ("uforward", testSend (\p m -> uforward (unsafeCreateUnencodedMessage m) p))

527− ])

528− ]

529−

530− build :: LocalNode

531− -> LocalNode

532− -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

533− -> [Test]

534− build n ln specs =

535− [ testGroup (intercalate "-" [groupName, caseSuffix]) [

536− testCase (intercalate "-" [caseName, caseSuffix])

537− (runProcess n (caseImpl caseNode))

538− | (caseName, caseImpl) <- groupCases

539− ]

540− | (groupName, groupCases) <- specs

541− , (caseSuffix, caseNode) <- [("RemotePid", Just ln), ("LocalPid", Nothing)]

542− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hsdeleted−154

@@ -1,154 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# OPTIONS_GHC -Wall #-}

3−

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

5−-- test always claims to succeed, even if it failed.

6−

7−module Control.Distributed.Process.Tests.Receive (tests) where

8−

9−import Network.Transport.Test (TestTransport(..))

10−

11−import Network.Transport (Transport)

12−import Control.Distributed.Process

13−import Control.Distributed.Process.Node

14−

15−import Control.Monad

16−

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

18−import Test.Framework (Test)

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

20−

21−-- Tests:

22−

23−-- 1. 2 matchChans, receive on each one

24−-- 2. matchChan/matchIf, receive on each one

25−-- 3. matchIf/matchChan, receive on each one

26−-- 4. matchIf/matchChan/matchIf, receive on each one

27−

28−recTest1 :: ReceivePort ()

29− -> SendPort String

30− -> ReceivePort String -> ReceivePort String

31− -> Process ()

32−recTest1 wait sync r1 r2 = do

33− forever $ do

34− receiveChan wait

35− r <- receiveWait

36− [ matchChan r1 $ \s -> return ("received1 " ++ s)

37− , matchChan r2 $ \s -> return ("received2 " ++ s)

38− ]

39− sendChan sync r

40−

41−recTest2 :: ReceivePort ()

42− -> SendPort String

43− -> ReceivePort String -> ReceivePort String

44− -> Process ()

45−recTest2 wait sync r1 _ = do

46− forever $ do

47− receiveChan wait

48− r <- receiveWait

49− [ matchChan r1 $ \s -> return ("received1 " ++ s)

50− , matchIf (== "foo") $ \s -> return ("received2 " ++ s)

51− ]

52− sendChan sync r

53−

54−recTest3 :: ReceivePort ()

55− -> SendPort String

56− -> ReceivePort String -> ReceivePort String

57− -> Process ()

58−recTest3 wait sync r1 _ = do

59− forever $ do

60− receiveChan wait

61− r <- receiveWait

62− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)

63− , matchChan r1 $ \s -> return ("received2 " ++ s)

64− ]

65− sendChan sync r

66−

67−recTest4 :: ReceivePort ()

68− -> SendPort String

69− -> ReceivePort String -> ReceivePort String

70− -> Process ()

71−recTest4 wait sync r1 _ = do

72− forever $ do

73− receiveChan wait

74− r <- receiveWait

75− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)

76− , matchChan r1 $ \s -> return ("received2 " ++ s)

77− , matchIf (== "bar") $ \s -> return ("received3 " ++ s)

78− ]

79− sendChan sync r

80−

81−master :: Process ()

82−master = do

83− (waits,waitr) <- newChan

84− (syncs,syncr) <- newChan

85− let go expected = do

86− sendChan waits ()

87− r <- receiveChan syncr

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

89− liftIO $ r @?= expected

90−

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

92− (s1,r1) <- newChan

93− (s2,r2) <- newChan

94− p <- spawnLocal (recTest1 waitr syncs r1 r2)

95−

96− sendChan s1 "a" >> go "received1 a"

97− sendChan s2 "b" >> go "received2 b"

98− sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"

99− go "received2 b"

100−

101− kill p "BANG"

102−

103− liftIO $ putStrLn "\n---- Test 2 ----"

104− (s1,r1) <- newChan

105− (s2,r2) <- newChan

106− p <- spawnLocal (recTest2 waitr syncs r1 r2)

107−

108− sendChan s1 "a" >> go "received1 a"

109− send p "foo" >> go "received2 foo"

110− sendChan s1 "a" >> send p "foo" >> go "received1 a"

111− sendChan s1 "a" >> send p "bar" >> go "received1 a"

112− go "received2 foo"

113−

114− kill p "BANG"

115−

116− liftIO $ putStrLn "\n---- Test 3 ----"

117− (s1,r1) <- newChan

118− (s2,r2) <- newChan

119− p <- spawnLocal (recTest3 waitr syncs r1 r2)

120−

121− sendChan s1 "a" >> go "received2 a"

122− send p "foo" >> go "received1 foo"

123− sendChan s1 "a" >> send p "foo" >> go "received1 foo"

124− sendChan s1 "a" >> send p "bar" >> go "received2 a"

125− go "received2 a"

126−

127− kill p "BANG"

128−

129− liftIO $ putStrLn "\n---- Test 4 ----"

130− (s1,r1) <- newChan

131− (s2,r2) <- newChan

132− p <- spawnLocal (recTest4 waitr syncs r1 r2)

133−

134− sendChan s1 "a" >> go "received2 a"

135− send p "foo" >> go "received1 foo"

136− send p "bar" >> go "received3 bar"

137− sendChan s1 "a" >> send p "foo" >> go "received1 foo"

138− send p "bar" >> go "received2 a"

139− send p "foo" >> go "received1 foo" >> go "received3 bar"

140−

141− kill p "BANG"

142−

143− terminate

144−

145−testReceive :: Transport -> RemoteTable -> Assertion

146−testReceive transport rtable = do

147− node <- newLocalNode transport rtable

148− runProcess node $ master

149−

150−tests :: TestTransport -> IO [Test]

151−tests TestTransport{..} = do

152− let rtable = initRemoteTable

153− return

154− [ testCase "testReceive" (testReceive testTransport rtable) ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hsdeleted−129

@@ -1,129 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3−module Control.Distributed.Process.Tests.Stats (tests) where

4−

5−import Control.Distributed.Process.Tests.Internal.Utils

6−import Network.Transport.Test (TestTransport(..))

7−

8−import Control.Concurrent.MVar

9− ( MVar

10− , newEmptyMVar

11− , putMVar

12− , takeMVar

13− )

14−import Control.Distributed.Process

15−import Control.Distributed.Process.Node

16−import Data.Binary ()

17−import Data.Typeable ()

18−

19−#if ! MIN_VERSION_base(4,6,0)

20−import Prelude hiding (catch)

21−#endif

22−

23−import Test.Framework

24− ( Test

25− , testGroup

26− )

27−import Test.HUnit (Assertion)

28−import Test.Framework.Providers.HUnit (testCase)

29−

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

31−testLocalDeadProcessInfo result = do

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

33− mref <- monitor pid

34− send pid "finish"

35− _ <- receiveWait [

36− matchIf (\(ProcessMonitorNotification ref' pid' r) ->

37− ref' == mref && pid' == pid && r == DiedNormal)

38− (\p -> return p)

39− ]

40− getProcessInfo pid >>= stash result

41−

42−testLocalLiveProcessInfo :: TestResult Bool -> Process ()

43−testLocalLiveProcessInfo result = do

44− self <- getSelfPid

45− node <- getSelfNode

46− register "foobar" self

47−

48− mon <- liftIO $ newEmptyMVar

49− -- TODO: we can't get the mailbox's length

50− -- mapM (send self) ["hello", "there", "mr", "process"]

51− pid <- spawnLocal $ do

52− link self

53− mRef <- monitor self

54− stash mon mRef

55− res <- expect

56− case res of

57− "die" -> return ()

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

59−

60− monRef <- liftIO $ takeMVar mon

61−

62− mpInfo <- getProcessInfo self

63− case mpInfo of

64− Nothing -> stash result False

65− Just p -> verifyPInfo p pid monRef node

66− where verifyPInfo :: ProcessInfo

67− -> ProcessId

68− -> MonitorRef

69− -> NodeId

70− -> Process ()

71− verifyPInfo pInfo pid mref node =

72− stash result $ infoNode pInfo == node &&

73− infoLinks pInfo == [pid] &&

74− infoMonitors pInfo == [(pid, mref)] &&

75−-- infoMessageQueueLength pInfo == Just 4 &&

76− infoRegisteredNames pInfo == ["foobar"]

77−

78−testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion

79−testRemoteLiveProcessInfo TestTransport{..} node1 = do

80− serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)

81− liftIO $ launchRemote serverAddr

82− serverPid <- liftIO $ takeMVar serverAddr

83− withActiveRemote node1 $ \result -> do

84− self <- getSelfPid

85− link serverPid

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

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

88− send serverPid (self, "ping")

89− pong <- expect

90− pInfo <- getProcessInfo serverPid

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

92− where

93− launchRemote :: MVar ProcessId -> IO ()

94− launchRemote locMV = do

95− node2 <- liftIO $ newLocalNode testTransport initRemoteTable

96− _ <- liftIO $ forkProcess node2 $ do

97− self <- getSelfPid

98− liftIO $ putMVar locMV self

99− _ <- receiveWait [

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

101− ]

102− res <- expect

103− case res of

104− "stop" -> return ()

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

106− return ()

107−

108− withActiveRemote :: LocalNode

109− -> ((TestResult Bool -> Process ()) -> Assertion)

110− withActiveRemote n = do

111− a <- delayedAssertion "getProcessInfo remotePid failed" n True

112− return a

113−

114−tests :: TestTransport -> IO [Test]

115−tests testtrans@TestTransport{..} = do

116− node1 <- newLocalNode testTransport initRemoteTable

117− return [

118− testGroup "Process Info" [

119− testCase "testLocalDeadProcessInfo"

120− (delayedAssertion

121− "expected dead process-info to be ProcessInfoNone"

122− node1 (Nothing) testLocalDeadProcessInfo)

123− , testCase "testLocalLiveProcessInfo"

124− (delayedAssertion

125− "expected process-info to be correctly populated"

126− node1 True testLocalLiveProcessInfo)

127− , testCase "testRemoveLiveProcessInfo"

128− (testRemoteLiveProcessInfo testtrans node1)

129− ] ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hsdeleted−431

@@ -1,431 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3−module Control.Distributed.Process.Tests.Tracing (tests) where

4−

5−import Control.Distributed.Process.Tests.Internal.Utils

6−import Network.Transport.Test (TestTransport(..))

7−

8−import Control.Applicative ((<*))

9−import Control.Concurrent (threadDelay)

10−import Control.Concurrent.MVar

11− ( MVar

12− , newEmptyMVar

13− , newMVar

14− , putMVar

15− , takeMVar

16− )

17−import Control.Distributed.Process

18−import Control.Distributed.Process.Node

19−import Control.Distributed.Process.Debug

20−import Control.Distributed.Process.Management

21− ( MxEvent(..)

22− )

23−import qualified Control.Exception as IO (bracket)

24−import Data.List (isPrefixOf, isSuffixOf)

25−

26−#if ! MIN_VERSION_base(4,6,0)

27−import Prelude hiding (catch, log)

28−#else

29−import Prelude hiding ((<*))

30−#endif

31−

32−import Test.Framework

33− ( Test

34− , testGroup

35− )

36−import Test.Framework.Providers.HUnit (testCase)

37−import System.Environment (getEnvironment)

38−-- These are available in System.Environment only since base 4.7

39−import System.SetEnv (setEnv, unsetEnv)

40−

41−

42−testSpawnTracing :: TestResult Bool -> Process ()

43−testSpawnTracing result = do

44− setTraceFlags defaultTraceFlags {

45− traceSpawned = (Just TraceAll)

46− , traceDied = (Just TraceAll)

47− }

48−

49− evSpawned <- liftIO $ newEmptyMVar

50− evDied <- liftIO $ newEmptyMVar

51− tracer <- startTracer $ \ev -> do

52− case ev of

53− (MxSpawned p) -> liftIO $ putMVar evSpawned p

54− (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)

55− _ -> return ()

56−

57− (sp, rp) <- newChan

58− pid <- spawnLocal $ sendChan sp ()

59− () <- receiveChan rp

60−

61− tracedAlive <- liftIO $ takeMVar evSpawned

62− (tracedDead, tracedReason) <- liftIO $ takeMVar evDied

63−

64− mref <- monitor tracer

65− stopTracer -- this is asynchronous, so we need to wait...

66− receiveWait [

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

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

69− ]

70− setTraceFlags defaultTraceFlags

71− stash result (tracedAlive == pid &&

72− tracedDead == pid &&

73− tracedReason == DiedNormal)

74−

75−testTraceRecvExplicitPid :: TestResult Bool -> Process ()

76−testTraceRecvExplicitPid result = do

77− res <- liftIO $ newEmptyMVar

78− pid <- spawnLocal $ do

79− self <- getSelfPid

80− expect >>= (flip sendChan) self

81− withFlags defaultTraceFlags {

82− traceRecv = traceOnly [pid]

83− } $ do

84− withTracer

85− (\ev ->

86− case ev of

87− (MxReceived pid' _) -> stash res (pid == pid')

88− _ -> return ()) $ do

89− (sp, rp) <- newChan

90− send pid sp

91− p <- receiveChan rp

92− res' <- liftIO $ takeMVar res

93− stash result (res' && (p == pid))

94− return ()

95−

96−testTraceRecvNamedPid :: TestResult Bool -> Process ()

97−testTraceRecvNamedPid result = do

98− res <- liftIO $ newEmptyMVar

99− pid <- spawnLocal $ do

100− self <- getSelfPid

101− register "foobar" self

102− expect >>= (flip sendChan) self

103− withFlags defaultTraceFlags {

104− traceRecv = traceOnly ["foobar"]

105− } $ do

106− withTracer

107− (\ev ->

108− case ev of

109− (MxReceived pid' _) -> stash res (pid == pid')

110− _ -> return ()) $ do

111− (sp, rp) <- newChan

112− send pid sp

113− p <- receiveChan rp

114− res' <- liftIO $ takeMVar res

115− stash result (res' && (p == pid))

116− return ()

117−

118−testTraceSending :: TestResult Bool -> Process ()

119−testTraceSending result = do

120− pid <- spawnLocal $ (expect :: Process String) >> return ()

121− self <- getSelfPid

122− res <- liftIO $ newEmptyMVar

123− withFlags defaultTraceFlags { traceSend = traceOn } $ do

124− withTracer

125− (\ev ->

126− case ev of

127− (MxSent to from msg) -> do

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

129− case mS of

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

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

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

133− _ ->

134− return ()) $ do

135− send pid "hello there"

136− res' <- liftIO $ takeMVar res

137− stash result res'

138−

139−testTraceRegistration :: TestResult Bool -> Process ()

140−testTraceRegistration result = do

141− (sp, rp) <- newChan

142− pid <- spawnLocal $ do

143− self <- getSelfPid

144− () <- expect

145− register "foobar" self

146− sendChan sp ()

147− () <- expect

148− return ()

149− res <- liftIO $ newEmptyMVar

150− withFlags defaultTraceFlags { traceRegistered = traceOn } $ do

151− withTracer

152− (\ev ->

153− case ev of

154− MxRegistered p s ->

155− stash res (p == pid && s == "foobar")

156− _ ->

157− return ()) $ do

158− _ <- monitor pid

159− send pid ()

160− () <- receiveChan rp

161− send pid ()

162− receiveWait [

163− match (\(ProcessMonitorNotification _ _ _) -> return ())

164− ]

165− res' <- liftIO $ takeMVar res

166− stash result res'

167−

168−testTraceUnRegistration :: TestResult Bool -> Process ()

169−testTraceUnRegistration result = do

170− pid <- spawnLocal $ do

171− () <- expect

172− unregister "foobar"

173− () <- expect

174− return ()

175− register "foobar" pid

176− res <- liftIO $ newEmptyMVar

177− withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do

178− withTracer

179− (\ev ->

180− case ev of

181− MxUnRegistered p n -> do

182− stash res (p == pid && n == "foobar")

183− send pid ()

184− _ ->

185− return ()) $ do

186− mref <- monitor pid

187− send pid ()

188− receiveWait [

189− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')

190− (\_ -> return ())

191− ]

192− res' <- liftIO $ takeMVar res

193− stash result res'

194−

195−testTraceLayering :: TestResult () -> Process ()

196−testTraceLayering result = do

197− pid <- spawnLocal $ do

198− getSelfPid >>= register "foobar"

199− () <- expect

200− traceMessage ("traceMsg", 123 :: Int)

201− return ()

202− withFlags defaultTraceFlags {

203− traceDied = traceOnly [pid]

204− , traceRecv = traceOnly ["foobar"]

205− } $ doTest pid result

206− return ()

207− where

208− doTest :: ProcessId -> MVar () -> Process ()

209− doTest pid result' = do

210− -- TODO: this is pretty gross, even for a test case

211− died <- liftIO $ newEmptyMVar

212− withTracer

213− (\ev ->

214− case ev of

215− MxProcessDied _ _ -> liftIO $ putMVar died ()

216− _ -> return ())

217− ( do {

218− recv <- liftIO $ newEmptyMVar

219− ; withTracer

220− (\ev' ->

221− case ev' of

222− MxReceived _ _ -> liftIO $ putMVar recv ()

223− _ -> return ())

224− ( do {

225− user <- liftIO $ newEmptyMVar

226− ; withTracer

227− (\ev'' ->

228− case ev'' of

229− MxUser _ -> liftIO $ putMVar user ()

230− _ -> return ())

231− (send pid () >> (liftIO $ takeMVar user))

232− ; liftIO $ takeMVar recv

233− })

234− ; liftIO $ takeMVar died

235− })

236− liftIO $ putMVar result' ()

237−

238−testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()

239−testRemoteTraceRelay TestTransport{..} result =

240− let flags = defaultTraceFlags { traceSpawned = traceOn }

241− in do

242− node2 <- liftIO $ newLocalNode testTransport initRemoteTable

243− mvNid <- liftIO $ newEmptyMVar

244−

245− -- As well as needing node2's NodeId, we want to

246− -- redirect all its logs back here, to avoid generating

247− -- garbage on stderr for the duration of the test run.

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

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

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

251−

252− pid <- splinchLogger node2 mvNid

253− nid <- liftIO $ takeMVar mvNid

254− mref <- monitor pid

255− observedPid <- liftIO $ newEmptyMVar

256− spawnedPid <- liftIO $ newEmptyMVar

257− setTraceFlagsRemote flags nid

258−

259− withFlags defaultTraceFlags { traceSpawned = traceOn } $ do

260− withTracer

261− (\ev ->

262− case ev of

263− MxSpawned p -> stash observedPid p >> send pid ()

264− _ -> return ()) $ do

265− relayPid <- startTraceRelay nid

266− liftIO $ threadDelay 1000000

267− p <- liftIO $ forkProcess node2 $ do

268− expectTimeout 1000000 :: Process (Maybe ())

269− return ()

270− stash spawnedPid p

271−

272− -- Now we wait for (the outer) pid to exit. This won't happen until

273− -- our tracer has seen the trace event for `p' and sent `p' the

274− -- message it's waiting for prior to exiting

275− receiveWait [

276− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')

277− (\_ -> return ())

278− ]

279−

280− relayRef <- monitor relayPid

281− kill relayPid "stop"

282− receiveWait [

283− matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)

284− (\_ -> return ())

285− ]

286− observed <- liftIO $ takeMVar observedPid

287− expected <- liftIO $ takeMVar spawnedPid

288− stash result (observed == expected)

289− -- and just to be polite...

290− liftIO $ closeLocalNode node2

291−

292− where

293− splinchLogger n2 mv = do

294− mLog <- whereis "logger"

295− case mLog of

296− Nothing -> die "no logger registered"

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

298− logRelay <- spawnLocal $ relay log'

299− reregister "logger" logRelay

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

301−

302−

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

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

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

306−withEnv var val =

307− IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)

308− (maybe (unsetEnv var) (setEnv var))

309− . const

310−

311−-- | Tests that one and only one interesting trace message is produced when a

312−-- given action is performed. A message is considered interesting when the given

313−-- function return @True@.

314−testSystemLoggerMsg :: TestTransport

315− -> Process a

316− -> (a -> String -> Bool)

317− -> IO ()

318−testSystemLoggerMsg t action interestingMessage =

319− withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $

320− withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do

321− n <- newLocalNode (testTransport t) initRemoteTable

322−

323− runProcess n $ do

324− self <- getSelfPid

325− reregister "trace.logger" self

326− a <- action

327− let interestingMessage' (_ :: String, msg) = interestingMessage a msg

328− -- Wait for the trace message.

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

330− -- Only one interesting message should arrive.

331− expectedTimeout <- receiveTimeout

332− 100000

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

334− case expectedTimeout of

335− Nothing -> return ()

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

337−

338−

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

340−-- received.

341−testSystemLoggerMxReceive :: TestTransport -> IO ()

342−testSystemLoggerMxReceive t = testSystemLoggerMsg t

343− (getSelfPid >>= flip send ())

344− (\_ msg -> "MxReceived" `isPrefixOf` msg

345− -- discard traces of internal messages

346− && not (":: RegisterReply" `isSuffixOf` msg)

347− )

348−

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

350−-- sent.

351−testSystemLoggerMxSent :: TestTransport -> IO ()

352−testSystemLoggerMxSent t = testSystemLoggerMsg t

353− (getSelfPid >>= flip send ())

354− (const $ isPrefixOf "MxSent")

355−

356−-- | Tests that one and only one trace message is produced when a process dies.

357−testSystemLoggerMxProcessDied :: TestTransport -> IO ()

358−testSystemLoggerMxProcessDied t = testSystemLoggerMsg t

359− (spawnLocal $ return ())

360− (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)

361−

362−-- | Tests that one and only one trace message appears when a process spawns.

363−testSystemLoggerMxSpawned :: TestTransport -> IO ()

364−testSystemLoggerMxSpawned t = testSystemLoggerMsg t

365− (spawnLocal $ return ())

366− (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)

367−

368−-- | Tests that one and only one trace message appears when a process is

369−-- registered.

370−testSystemLoggerMxRegistered :: TestTransport -> IO ()

371−testSystemLoggerMxRegistered t = testSystemLoggerMsg t

372− (getSelfPid >>= register "a" >> getSelfPid)

373− (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")

374−

375−-- | Tests that one and only one trace message appears when a process is

376−-- unregistered.

377−testSystemLoggerMxUnRegistered :: TestTransport -> IO ()

378−testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t

379− (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)

380− (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")

381−

382−tests :: TestTransport -> IO [Test]

383−tests testtrans@TestTransport{..} = do

384− node1 <- newLocalNode testTransport initRemoteTable

385− -- if we execute the test cases in parallel, the

386− -- various tracers will race with one another and

387− -- we'll get garbage results (or worse, deadlocks)

388− lock <- liftIO $ newMVar ()

389− return [

390− testGroup "Tracing" [

391− testCase "Spawn Tracing"

392− (synchronisedAssertion

393− "expected dead process-info to be ProcessInfoNone"

394− node1 True testSpawnTracing lock)

395− , testCase "Recv Tracing (Explicit Pid)"

396− (synchronisedAssertion

397− "expected a recv trace for the supplied pid"

398− node1 True testTraceRecvExplicitPid lock)

399− , testCase "Recv Tracing (Named Pid)"

400− (synchronisedAssertion

401− "expected a recv trace for the process registered as 'foobar'"

402− node1 True testTraceRecvNamedPid lock)

403− , testCase "Trace Send(er)"

404− (synchronisedAssertion

405− "expected a 'send' trace with the requisite fields set"

406− node1 True testTraceSending lock)

407− , testCase "Trace Registration"

408− (synchronisedAssertion

409− "expected a 'registered' trace"

410− node1 True testTraceRegistration lock)

411− , testCase "Trace Unregistration"

412− (synchronisedAssertion

413− "expected an 'unregistered' trace"

414− node1 True testTraceUnRegistration lock)

415− , testCase "Trace Layering"

416− (synchronisedAssertion

417− "expected blah"

418− node1 () testTraceLayering lock)

419− , testCase "Remote Trace Relay"

420− (synchronisedAssertion

421− "expected blah"

422− node1 True (testRemoteTraceRelay testtrans) lock)

423− , testGroup "SystemLoggerTracer"

424− [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans

425− , testCase "MxSent" $ testSystemLoggerMxSent testtrans

426− , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans

427− , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans

428− , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans

429− , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans

430− ]

431− ] ]

distributed-process-tests/src/Network/Transport/Test.hsdeleted−12

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

1−module Network.Transport.Test where

2−

3−import qualified Network.Transport as NT

4−import Data.Typeable (Typeable)

5−

6−-- | Extra operations required of transports for the purposes of testing.

7−data TestTransport = TestTransport

8− { -- | The transport to use for testing.

9− testTransport :: NT.Transport

10− -- | IO action to perform to simulate losing a connection.

11− , testBreakConnection :: NT.EndPointAddress -> NT.EndPointAddress -> IO ()

12− } deriving (Typeable)

distributed-process-tests/tests/runInMemory.hsdeleted−30

@@ -1,30 +0,0 @@

1−-- Run tests using the TCP transport.

2−

3−module Main where

4−

5−import TEST_SUITE_MODULE (tests)

6−

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

8−import Network.Transport.InMemory

9−import Test.Framework (defaultMainWithArgs)

10−

11−import System.Environment (getArgs)

12−

13−main :: IO ()

14−main = do

15− (transport, internals) <- createTransportExposeInternals

16− ts <- tests TestTransport

17− { testTransport = transport

18− , testBreakConnection = \addr1 addr2 -> breakConnection internals addr1 addr2 "user error"

19− }

20− args <- getArgs

21− -- Tests are time sensitive. Running the tests concurrently can slow them

22− -- down enough that threads using threadDelay would wake up later than

23− -- expected, thus changing the order in which messages were expected.

24− -- Therefore we run the tests sequentially by passing "-j 1" to

25− -- test-framework. This does not solve the issue but makes it less likely.

26− --

27− -- The problem was first detected with

28− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'

29− -- in particular.

30− defaultMainWithArgs ts ("-j" : "1" : args)

distributed-process-tests/tests/runTCP.hsdeleted−47

@@ -1,47 +0,0 @@

1−-- Run tests using the TCP transport.

2−--

3−module Main where

4−

5−import TEST_SUITE_MODULE (tests)

6−

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

8−import Network.Socket (sClose)

9−import Network.Transport.TCP

10− ( createTransportExposeInternals

11− , TransportInternals(socketBetween)

12− , defaultTCPParameters

13− , defaultTCPAddr

14− , TCPParameters(..)

15− )

16−import Test.Framework (defaultMainWithArgs)

17−

18−import Control.Concurrent (threadDelay)

19−import Control.Exception (IOException, try)

20−import System.Environment (getArgs)

21−import System.IO

22−

23−main :: IO ()

24−main = do

25− hSetBuffering stdout LineBuffering

26− hSetBuffering stderr LineBuffering

27− Right (transport, internals) <-

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

29− defaultTCPParameters { transportConnectTimeout = Just 3000000 }

30− ts <- tests TestTransport

31− { testTransport = transport

32− , testBreakConnection = \addr1 addr2 -> do

33− esock <- try $ socketBetween internals addr1 addr2

34− either (\e -> const (return ()) (e :: IOException)) sClose esock

35− threadDelay 10000

36− }

37− args <- getArgs

38− -- Tests are time sensitive. Running the tests concurrently can slow them

39− -- down enough that threads using threadDelay would wake up later than

40− -- expected, thus changing the order in which messages were expected.

41− -- Therefore we run the tests sequentially by passing "-j 1" to

42− -- test-framework. This does not solve the issue but makes it less likely.

43− --

44− -- The problem was first detected with

45− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'

46− -- in particular.

47− defaultMainWithArgs ts ("-j" : "1" : args)

distributed-process.cabaldeleted−168

@@ -1,168 +0,0 @@

1−Name: distributed-process

2−Version: 0.7.4

3−Cabal-Version: >=1.8

4−Build-Type: Simple

5−License: BSD3

6−License-File: LICENSE

7−Copyright: Well-Typed LLP, Tweag I/O Limited

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

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

10−Stability: experimental

11−Homepage: http://haskell-distributed.github.com/

12−Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues

13−Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell

14−Description: This is an implementation of Cloud Haskell, as described in

15− /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,

16− and Simon Peyton Jones

17− (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

18− although some of the details are different. The precise message

19− passing semantics are based on /A unified semantics for future Erlang/

20− by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.

21−

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

25−Category: Control

26−extra-source-files: ChangeLog

27−

28−Source-Repository head

29− Type: git

30− Location: https://github.com/haskell-distributed/distributed-process

31− SubDir: distributed-process

32−

33−flag th

34− description: Build with Template Haskell support

35− default: True

36−

37−flag old-locale

38− description: If false then depend on time >= 1.5.

39− .

40− If true then depend on time < 1.5 together with old-locale.

41− default: False

42−

43−Library

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

45− binary >= 0.6.3 && < 0.10,

46− hashable >= 1.2.0.5 && < 1.3,

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

48− stm >= 2.4 && < 2.6,

49− transformers >= 0.2 && < 0.6,

50− mtl >= 2.0 && < 2.4,

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

52− bytestring >= 0.9 && < 0.11,

53− random >= 1.0 && < 1.2,

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

55− rank1dynamic >= 0.1 && < 0.5,

56− syb >= 0.3 && < 0.8,

57− exceptions >= 0.5,

58− containers >= 0.5 && < 0.7,

59− deepseq >= 1.3.0.1 && < 1.6

60− Exposed-modules: Control.Distributed.Process,

61− Control.Distributed.Process.Closure,

62− Control.Distributed.Process.Debug,

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

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

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

66− Control.Distributed.Process.Internal.CQueue,

67− Control.Distributed.Process.Internal.Messaging,

68− Control.Distributed.Process.Internal.Primitives,

69− Control.Distributed.Process.Internal.Spawn,

70− Control.Distributed.Process.Internal.StrictContainerAccessors,

71− Control.Distributed.Process.Internal.StrictList,

72− Control.Distributed.Process.Internal.StrictMVar,

73− Control.Distributed.Process.Internal.Types,

74− Control.Distributed.Process.Internal.WeakTQueue,

75− Control.Distributed.Process.Management,

76− Control.Distributed.Process.Node,

77− Control.Distributed.Process.Serializable,

78− Control.Distributed.Process.UnsafePrimitives

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

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

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

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

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

84− Control.Distributed.Process.Management.Internal.Trace.Types,

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

86− ghc-options: -Wall

87− HS-Source-Dirs: src

88− other-extensions: BangPatterns

89− CPP

90− DeriveDataTypeable

91− DeriveFunctor

92− DeriveGeneric

93− ExistentialQuantification

94− FlexibleInstances

95− GADTs

96− GeneralizedNewtypeDeriving

97− KindSignatures

98− MagicHash

99− PatternGuards

100− RankNTypes

101− RecordWildCards

102− ScopedTypeVariables

103− StandaloneDeriving

104− TypeFamilies

105− TypeSynonymInstances

106− UnboxedTuples

107− UndecidableInstances

108− if flag(old-locale)

109− Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

110− else

111− Build-Depends: time >= 1.5

112− if flag(th)

113− other-extensions: TemplateHaskell

114− Build-Depends: template-haskell >= 2.6

115− Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

116− CPP-Options: -DTemplateHaskellSupport

117−

118−-- Tests are in distributed-process-test package, for convenience.

119−

120−benchmark distributed-process-throughput

121− Type: exitcode-stdio-1.0

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

123− distributed-process,

124− network-transport-tcp >= 0.3 && < 0.7,

125− bytestring >= 0.9 && < 0.11,

126− binary >= 0.6.3 && < 0.10

127− Main-Is: benchmarks/Throughput.hs

128− ghc-options: -Wall

129−

130−benchmark distributed-process-latency

131− Type: exitcode-stdio-1.0

132− Build-Depends: base >= 4.6 && < 5,

133− distributed-process,

134− network-transport-tcp >= 0.3 && < 0.7,

135− bytestring >= 0.9 && < 0.11,

136− binary >= 0.6.3 && < 0.10

137− Main-Is: benchmarks/Latency.hs

138− ghc-options: -Wall

139−

140−benchmark distributed-process-channels

141− Type: exitcode-stdio-1.0

142− Build-Depends: base >= 4.6 && < 5,

143− distributed-process,

144− network-transport-tcp >= 0.3 && < 0.7,

145− bytestring >= 0.9 && < 0.11,

146− binary >= 0.6.3 && < 0.10

147− Main-Is: benchmarks/Channels.hs

148− ghc-options: -Wall

149−

150−benchmark distributed-process-spawns

151− Type: exitcode-stdio-1.0

152− Build-Depends: base >= 4.6 && < 5,

153− distributed-process,

154− network-transport-tcp >= 0.3 && < 0.7,

155− bytestring >= 0.9 && < 0.11,

156− binary >= 0.6.3 && < 0.10

157− Main-Is: benchmarks/Spawns.hs

158− ghc-options: -Wall

159−

160−benchmark distributed-process-ring

161− Type: exitcode-stdio-1.0

162− Build-Depends: base >= 4.6 && < 5,

163− distributed-process,

164− network-transport-tcp >= 0.3 && < 0.7,

165− bytestring >= 0.9 && < 0.11,

166− binary >= 0.6.3 && < 0.10

167− Main-Is: benchmarks/ProcessRing.hs

168− ghc-options: -Wall -threaded -O2 -rtsopts

distributed-process/ChangeLognew file+35

@@ -0,0 +1,35 @@

1+2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

3+* Bugfix in the node controller

4+(one way this bug materialized: when using the SimpleLocalnet backend,

5+slave nodes could not be reused)

6+* Improved documentation in Control.Distributed.Process.Closure

8+2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3

10+* Improve docs

11+* Local versions of spawn

12+

13+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2

14+

15+* Base 4.6 compatibility

16+* Relax constraints on bytestring and containers

17+

18+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1

19+

20+* Relax upper bound on 'time' dependency

21+

22+2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1

23+

24+* Complete redesign of the underlying implementation of static values and

25+closures.

26+

27+* Add support for 'spawnChannel'

28+

29+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

30+

31+* Bugfix: Continue processing messages when a connection breaks.

32+

33+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

34+

35+* Initial release.

LICENSE → distributed-process/LICENSErenamed−1

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

11Copyright Well-Typed LLP, 2011-2012

2−Copyright Tweag I/O Limited, 2015

43All rights reserved.

distributed-process/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

distributed-process/distributed-process.cabalnew file+138

@@ -0,0 +1,138 @@

1+Name: distributed-process

2+Version: 0.2.1.4

3+Cabal-Version: >=1.8

4+Build-Type: Simple

5+License: BSD3

6+License-File: LICENSE

7+Copyright: Well-Typed LLP

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

9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com

10+Stability: experimental

11+Homepage: http://github.com/haskell-distributed/distributed-process

12+Bug-Reports: mailto:edsko@well-typed.com

13+Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell

14+Description: This is an implementation of Cloud Haskell, as described in

15+ /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,

16+ and Simon Peyton Jones

17+ (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

18+ although some of the details are different. The precise message

19+ passing semantics are based on /A unified semantics for future Erlang/

20+ by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.

21+

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

23+ as distributed-process-simplelocalnet.

24+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2

25+Category: Control

26+

27+Source-Repository head

28+ Type: git

29+ Location: https://github.com/haskell-distributed/distributed-process

30+ SubDir: distributed-process

31+

32+Library

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

34+ binary >= 0.5 && < 0.6,

35+ network-transport >= 0.2 && < 0.3,

36+ stm >= 2.3 && < 2.5,

37+ transformers >= 0.2 && < 0.4,

38+ mtl >= 2.0 && < 2.2,

39+ data-accessor >= 0.2 && < 0.3,

40+ bytestring >= 0.9 && < 0.11,

41+ containers >= 0.4 && < 0.6,

42+ old-locale >= 1.0 && < 1.1,

43+ time >= 1.2 && < 1.5,

44+ template-haskell >= 2.6 && < 2.8,

45+ random >= 1.0 && < 1.1,

46+ ghc-prim >= 0.2 && < 0.3

47+ Exposed-modules: Control.Distributed.Process,

48+ Control.Distributed.Process.Serializable,

49+ Control.Distributed.Process.Closure,

50+ Control.Distributed.Process.Node,

51+ Control.Distributed.Process.Internal.Primitives,

52+ Control.Distributed.Process.Internal.CQueue,

53+ Control.Distributed.Process.Internal.Dynamic,

54+ Control.Distributed.Process.Internal.TypeRep,

55+ Control.Distributed.Process.Internal.Types,

56+ Control.Distributed.Process.Internal.Closure.Static,

57+ Control.Distributed.Process.Internal.Closure.MkClosure,

58+ Control.Distributed.Process.Internal.Closure.CP,

59+ Control.Distributed.Process.Internal.Closure.TH,

60+ Control.Distributed.Process.Internal.Closure.Resolution,

61+ Control.Distributed.Process.Internal.Node

62+ Extensions: RankNTypes,

63+ ScopedTypeVariables,

64+ FlexibleInstances,

65+ UndecidableInstances,

66+ ExistentialQuantification,

67+ GADTs,

68+ GeneralizedNewtypeDeriving,

69+ DeriveDataTypeable,

70+ TemplateHaskell,

71+ CPP

72+ ghc-options: -Wall

73+ HS-Source-Dirs: src

74+

75+Test-Suite TestCH

76+ Type: exitcode-stdio-1.0

77+ Main-Is: TestCH.hs

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

79+ binary >= 0.5 && < 0.6,

80+ network-transport >= 0.2 && < 0.3,

81+ network-transport-tcp >= 0.2 && < 0.3,

82+ stm >= 2.3 && < 2.5,

83+ transformers >= 0.2 && < 0.4,

84+ mtl >= 2.0 && < 2.2,

85+ data-accessor >= 0.2 && < 0.3,

86+ bytestring >= 0.9 && < 0.11,

87+ containers >= 0.4 && < 0.6,

88+ old-locale >= 1.0 && < 1.1,

89+ time >= 1.2 && < 1.5,

90+ template-haskell >= 2.6 && < 2.8,

91+ random >= 1.0 && < 1.1,

92+ ghc-prim >= 0.2 && < 0.3,

93+ ansi-terminal >= 0.5 && < 0.6

94+ Extensions: RankNTypes,

95+ ScopedTypeVariables,

96+ FlexibleInstances,

97+ UndecidableInstances,

98+ ExistentialQuantification,

99+ GADTs,

100+ GeneralizedNewtypeDeriving,

101+ DeriveDataTypeable,

102+ TemplateHaskell,

103+ CPP

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

105+ HS-Source-Dirs: tests src

106+

107+Test-Suite TestClosure

108+ Type: exitcode-stdio-1.0

109+ Main-Is: TestClosure.hs

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

111+ binary >= 0.5 && < 0.6,

112+ network-transport >= 0.2 && < 0.3,

113+ network-transport-tcp >= 0.2 && < 0.3,

114+ stm >= 2.3 && < 2.5,

115+ transformers >= 0.2 && < 0.4,

116+ mtl >= 2.0 && < 2.2,

117+ data-accessor >= 0.2 && < 0.3,

118+ bytestring >= 0.9 && < 0.11,

119+ containers >= 0.4 && < 0.6,

120+ old-locale >= 1.0 && < 1.1,

121+ time >= 1.2 && < 1.5,

122+ template-haskell >= 2.6 && < 2.8,

123+ random >= 1.0 && < 1.1,

124+ ghc-prim >= 0.2 && < 0.3,

125+ ansi-terminal >= 0.5 && < 0.6

126+ Other-modules: TestAuxiliary

127+ Extensions: RankNTypes,

128+ ScopedTypeVariables,

129+ FlexibleInstances,

130+ UndecidableInstances,

131+ ExistentialQuantification,

132+ GADTs,

133+ GeneralizedNewtypeDeriving,

134+ DeriveDataTypeable,

135+ TemplateHaskell,

136+ CPP

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

138+ HS-Source-Dirs: tests src

src/Control/Distributed/Process.hs → distributed-process/src/Control/Distributed/Process.hsrenamed+174−236

@@ -1,33 +1,24 @@

1−{-# LANGUAGE CPP #-}

2−{- | [Cloud Haskell]

3−

4−This is an implementation of Cloud Haskell, as described in

5−/Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon

6−Peyton Jones (see

7−<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

8−although some of the details are different. The precise message passing

9−semantics are based on /A unified semantics for future Erlang/ by Hans

10−Svensson, Lars-Åke Fredlund and Clara Benac Earle.

11−

12−For a detailed description of the package and other reference materials,

13−please see the distributed-process wiki page on github:

14−<https://github.com/haskell-distributed/distributed-process/wiki>.

15−

16−-}

17−module Control.Distributed.Process

18− ( -- * Basic types

1+-- | [Cloud Haskell]

2+--

3+-- This is an implementation of Cloud Haskell, as described in

4+-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon

5+-- Peyton Jones

6+-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

7+-- although some of the details are different. The precise message passing

8+-- semantics are based on /A unified semantics for future Erlang/ by Hans

9+-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.

10+module Control.Distributed.Process

11+ ( -- * Basic types

1912 ProcessId

20− , NodeId(..)

13+ , NodeId

2114 , Process

2215 , SendPortId

2316 , processNodeId

2417 , sendPortProcessId

2518 , liftIO -- Reexported for convenience

2619 -- * Basic messaging

27− , send

28− , usend

20+ , send

2921 , expect

30− , expectTimeout

3122 -- * Channels

3223 , ReceivePort

3324 , SendPort

@@ -35,16 +26,8 @@ module Control.Distributed.Process

3526 , newChan

3627 , sendChan

3728 , receiveChan

38− , receiveChanTimeout

3929 , mergePortsBiased

4030 , mergePortsRR

41− -- * Unsafe messaging variants

42− , unsafeSend

43− , unsafeUSend

44− , unsafeSendChan

45− , unsafeNSend

46− , unsafeNSendRemote

47− , unsafeWrapMessage

4831 -- * Advanced messaging

4932 , Match

5033 , receiveWait

@@ -52,44 +35,14 @@ module Control.Distributed.Process

5235 , match

5336 , matchIf

5437 , matchUnknown

55− , matchAny

56− , matchAnyIf

57− , matchChan

58− , matchSTM

59− , Message

60− , matchMessage

61− , matchMessageIf

62− , isEncoded

63− , wrapMessage

64− , unwrapMessage

65− , handleMessage

66− , handleMessageIf

67− , handleMessage_

68− , handleMessageIf_

69− , forward

70− , uforward

71− , delegate

72− , relay

73− , proxy

7438 -- * Process management

7539 , spawn

7640 , call

7741 , terminate

78− , die

79− , kill

80− , exit

81− , catchExit

82− , catchesExit

8342 , ProcessTerminationException(..)

84− , ProcessRegistrationException(..)

8543 , SpawnRef

8644 , getSelfPid

8745 , getSelfNode

88− , ProcessInfo(..)

89− , getProcessInfo

90− , NodeStats(..)

91− , getNodeStats

92− , getLocalNodeStats

9346 -- * Monitoring and linking

9447 , link

9548 , linkNode

@@ -101,85 +54,62 @@ module Control.Distributed.Process

10154 , monitorNode

10255 , monitorPort

10356 , unmonitor

104− , withMonitor

105− , withMonitor_

106− , MonitorRef -- opaque

10757 , ProcessLinkException(..)

10858 , NodeLinkException(..)

10959 , PortLinkException(..)

60+ , MonitorRef -- opaque

11061 , ProcessMonitorNotification(..)

11162 , NodeMonitorNotification(..)

11263 , PortMonitorNotification(..)

11364 , DiedReason(..)

11465 -- * Closures

11566 , Closure

116− , closure

11767 , Static

118− , unStatic

11968 , unClosure

12069 , RemoteTable

12170 -- * Logging

12271 , say

12372 -- * Registry

12473 , register

125− , reregister

12674 , unregister

12775 , whereis

12876 , nsend

129− , registerRemoteAsync

130− , reregisterRemoteAsync

131− , unregisterRemoteAsync

77+ , registerRemote

78+ , unregisterRemote

79+ , whereisRemote

13280 , whereisRemoteAsync

13381 , nsendRemote

13482 , WhereIsReply(..)

135− , RegisterReply(..)

136− -- * Exception handling

137− , catch

138− , Handler(..)

139− , catches

140− , try

141− , mask

142− , mask_

143− , onException

144− , bracket

145− , bracket_

146− , finally

14783 -- * Auxiliary API

84+ , catch

85+ , expectTimeout

14886 , spawnAsync

14987 , spawnSupervised

15088 , spawnLink

15189 , spawnMonitor

15290 , spawnChannel

15391 , DidSpawn(..)

154− -- * Local versions of 'spawn'

92+ -- * Local versions of 'spawn'

15593 , spawnLocal

15694 , spawnChannelLocal

157− , callLocal

158− -- * Reconnecting

159− , reconnect

160− , reconnectPort

16195 ) where

16296

97+

98+#if ! MIN_VERSION_base(4,6,0)

99+import Prelude hiding (catch)

100+#endif

101+

102+import Data.Typeable (Typeable)

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

164−import Control.Applicative

104+import Control.Applicative ((<$>))

165105import Control.Monad.Reader (ask)

166−import Control.Concurrent (killThread)

167−import Control.Concurrent.MVar

168− ( MVar

169− , newEmptyMVar

170− , takeMVar

171− , putMVar

172− )

173−import Control.Distributed.Static

174− ( Closure

175− , closure

176− , Static

177− , RemoteTable

178− )

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

180− ( NodeId(..)

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

107+ ( RemoteTable

108+ , NodeId(..)

181109 , ProcessId(..)

182110 , Process(..)

111+ , Closure(..)

112+ , Static(..)

183113 , MonitorRef(..)

184114 , ProcessMonitorNotification(..)

185115 , NodeMonitorNotification(..)

@@ -187,24 +117,35 @@ import Control.Distributed.Process.Internal.Types

187117 , ProcessLinkException(..)

188118 , NodeLinkException(..)

189119 , PortLinkException(..)

190− , ProcessRegistrationException(..)

191120 , DiedReason(..)

192121 , SpawnRef(..)

193122 , DidSpawn(..)

123+ , Closure(..)

194124 , SendPort(..)

195125 , ReceivePort(..)

126+ , SerializableDict(..)

196127 , SendPortId(..)

197128 , WhereIsReply(..)

198− , RegisterReply(..)

199129 , LocalProcess(processNode)

200− , Message

201− , localProcessWithId

202130 )

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

131+import Control.Distributed.Process.Internal.Closure.CP

132+ ( cpSeq

133+ , cpBind

134+ , cpSend

135+ , cpExpect

136+ , cpLink

137+ , cpUnlink

138+ , cpNewChan

139+ , cpCancelL

140+ , cpSplit

141+ )

142+import Control.Distributed.Process.Internal.Closure.Static

143+ ( sdictUnit

144+ , sdictSendPort

145+ )

204146import Control.Distributed.Process.Internal.Primitives

205147 ( -- Basic messaging

206− send

207− , usend

148+ send

208149 , expect

209150 -- Channels

210151 , newChan

@@ -212,11 +153,6 @@ import Control.Distributed.Process.Internal.Primitives

212153 , receiveChan

213154 , mergePortsBiased

214155 , mergePortsRR

215− , unsafeSend

216− , unsafeUSend

217− , unsafeSendChan

218− , unsafeNSend

219− , unsafeNSendRemote

220156 -- Advanced messaging

221157 , Match

222158 , receiveWait

@@ -224,40 +160,11 @@ import Control.Distributed.Process.Internal.Primitives

224160 , match

225161 , matchIf

226162 , matchUnknown

227− , matchAny

228− , matchAnyIf

229− , matchChan

230− , matchSTM

231− , matchMessage

232− , matchMessageIf

233− , isEncoded

234− , wrapMessage

235− , unsafeWrapMessage

236− , unwrapMessage

237− , handleMessage

238− , handleMessageIf

239− , handleMessage_

240− , handleMessageIf_

241− , forward

242− , uforward

243− , delegate

244− , relay

245− , proxy

246163 -- Process management

247164 , terminate

248165 , ProcessTerminationException(..)

249− , die

250− , exit

251− , catchExit

252− , catchesExit

253− , kill

254166 , getSelfPid

255167 , getSelfNode

256− , ProcessInfo(..)

257− , getProcessInfo

258− , NodeStats(..)

259− , getNodeStats

260− , getLocalNodeStats

261168 -- Monitoring and linking

262169 , link

263170 , linkNode

@@ -269,71 +176,30 @@ import Control.Distributed.Process.Internal.Primitives

269176 , monitorNode

270177 , monitorPort

271178 , unmonitor

272− , withMonitor

273− , withMonitor_

274179 -- Logging

275180 , say

276181 -- Registry

277182 , register

278− , reregister

279183 , unregister

280184 , whereis

281185 , nsend

282− , registerRemoteAsync

283− , reregisterRemoteAsync

284− , unregisterRemoteAsync

186+ , registerRemote

187+ , unregisterRemote

188+ , whereisRemote

285189 , whereisRemoteAsync

286190 , nsendRemote

287191 -- Closures

288− , unStatic

289192 , unClosure

290− -- Exception handling

291− , catch

292− , Handler(..)

293− , catches

294− , try

295− , mask

296− , mask_

297− , onException

298− , bracket

299− , bracket_

300− , finally

301193 -- Auxiliary API

194+ , catch

302195 , expectTimeout

303− , receiveChanTimeout

304196 , spawnAsync

305− -- Reconnecting

306− , reconnect

307− , reconnectPort

308197 )

198+import Control.Distributed.Process.Serializable (Serializable)

309199import Control.Distributed.Process.Node (forkProcess)

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

311− ( processThread

312− , withValidLocalState

313− )

314−import Control.Distributed.Process.Internal.Spawn

315− ( -- Spawning Processes/Channels

316− spawn

317− , spawnLink

318− , spawnMonitor

319− , spawnChannel

320− , spawnSupervised

321− , call

322− )

323−import qualified Control.Monad.Catch as Catch

324−

325−#if MIN_VERSION_base(4,6,0)

326−import Prelude

327−#else

328−import Prelude hiding (catch)

329−#endif

330−import qualified Control.Exception as Exception (onException)

331−import Data.Accessor ((^.))

332−import Data.Foldable (forM_)

333−

334200

335201-- INTERNAL NOTES

336−--

202+--

337203-- 1. 'send' never fails. If you want to know that the remote process received

338204-- your message, you will need to send an explicit acknowledgement. If you

339205-- want to know when the remote process failed, you will need to monitor

@@ -342,11 +208,7 @@ import Data.Foldable (forM_)

342208-- 2. 'send' may block (when the system TCP buffers are full, while we are

343209-- trying to establish a connection to the remote endpoint, etc.) but its

344210-- return does not imply that the remote process received the message (much

345−-- less processed it). When 'send' targets a local process, it is dispatched

346−-- via the node controller however, in which cases it will /not/ block. This

347−-- isn't part of the semantics, so it should be ok. The ordering is maintained

348−-- because the ctrlChannel still has FIFO semantics with regards interactions

349−-- between two disparate forkIO threads.

211+-- less processed it)

350212--

351213-- 3. Message delivery is reliable and ordered. That means that if process A

352214-- sends messages m1, m2, m3 to process B, B will either arrive all three

@@ -375,17 +237,17 @@ import Data.Foldable (forM_)

375237-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf

376238--

377239-- The precise semantics for message passing is based on

378−--

240+--

379241-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund

380242-- and Clara Benac Earle (not freely available online, unfortunately)

381243--

382244-- Some pointers to related documentation about Erlang, for comparison and

383−-- inspiration:

245+-- inspiration:

384246--

385247-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",

386−-- Hans Svensson and Lars-Ake Fredlund

248+-- Hans Svensson and Lars-Ake Fredlund

387249-- http://man.lupaworld.com/content/develop/p37-svensson.pdf

388−-- [4] The Erlang manual, sections "Message Sending" and "Send"

250+-- [4] The Erlang manual, sections "Message Sending" and "Send"

389251-- http://www.erlang.org/doc/reference_manual/processes.html#id82409

390252-- http://www.erlang.org/doc/reference_manual/expressions.html#send

391253-- [5] Questions "Is the order of message reception guaranteed?" and

@@ -395,6 +257,112 @@ import Data.Foldable (forM_)

395257-- [6] "Delivery of Messages", post on erlang-questions

396258-- http://erlang.org/pipermail/erlang-questions/2012-February/064767.html

397259

260+--------------------------------------------------------------------------------

261+-- Primitives are defined in a separate module; here we only define derived --

262+-- constructs --

263+--------------------------------------------------------------------------------

264+

265+-- | Spawn a process

266+--

267+-- For more information about 'Closure', see

268+-- "Control.Distributed.Process.Closure".

269+--

270+-- See also 'call'.

271+spawn :: NodeId -> Closure (Process ()) -> Process ProcessId

272+spawn nid proc = do

273+ us <- getSelfPid

274+ -- Since we throw an exception when the remote node dies, we could use

275+ -- linkNode instead. However, we don't have a way of "scoped" linking so if

276+ -- we call linkNode here, and unlinkNode after, then we might remove a link

277+ -- that was already set up

278+ mRef <- monitorNode nid

279+ sRef <- spawnAsync nid $ cpLink us

280+ `cpSeq` cpExpect sdictUnit

281+ `cpSeq` cpUnlink us

282+ `cpSeq` proc

283+ mPid <- receiveWait

284+ [ matchIf (\(DidSpawn ref _) -> ref == sRef)

285+ (\(DidSpawn _ pid) -> return $ Just pid)

286+ , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)

287+ (\_ -> return Nothing)

288+ ]

289+ unmonitor mRef

290+ case mPid of

291+ Nothing -> fail "spawn: remote node failed"

292+ Just pid -> send pid () >> return pid

293+

294+-- | Spawn a process and link to it

295+--

296+-- Note that this is just the sequential composition of 'spawn' and 'link'.

297+-- (The "Unified" semantics that underlies Cloud Haskell does not even support

298+-- a synchronous link operation)

299+spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId

300+spawnLink nid proc = do

301+ pid <- spawn nid proc

302+ link pid

303+ return pid

304+

305+-- | Like 'spawnLink', but monitor the spawned process

306+spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)

307+spawnMonitor nid proc = do

308+ pid <- spawn nid proc

309+ ref <- monitor pid

310+ return (pid, ref)

311+

312+-- | Run a process remotely and wait for it to reply

313+--

314+-- We monitor the remote process: if it dies before it can send a reply, we die

315+-- too.

316+--

317+-- For more information about 'Static', 'SerializableDict', and 'Closure', see

318+-- "Control.Distributed.Process.Closure".

319+--

320+-- See also 'spawn'.

321+call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

322+call dict nid proc = do

323+ us <- getSelfPid

324+ (_, mRef) <- spawnMonitor nid (proc `cpBind` cpSend dict us)

325+ -- We are guaranteed to receive the reply before the monitor notification

326+ -- (if a reply is sent at all)

327+ -- NOTE: This might not be true if we switch to unreliable delivery.

328+ mResult <- receiveWait

329+ [ match (return . Right)

330+ , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

331+ (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

332+ ]

333+ case mResult of

334+ Right a -> unmonitor mRef >> return a

335+ Left err -> fail $ "call: remote process died: " ++ show err

336+

337+-- | Spawn a child process, have the child link to the parent and the parent

338+-- monitor the child

339+spawnSupervised :: NodeId

340+ -> Closure (Process ())

341+ -> Process (ProcessId, MonitorRef)

342+spawnSupervised nid proc = do

343+ us <- getSelfPid

344+ them <- spawn nid (cpLink us `cpSeq` proc)

345+ ref <- monitor them

346+ return (them, ref)

347+

348+-- | Spawn a new process, supplying it with a new 'ReceivePort' and return

349+-- the corresponding 'SendPort'.

350+spawnChannel :: forall a. Typeable a => Static (SerializableDict a)

351+ -> NodeId

352+ -> Closure (ReceivePort a -> Process ())

353+ -> Process (SendPort a)

354+spawnChannel dict nid proc = do

355+ us <- getSelfPid

356+ spawn nid (go us)

357+ expect

358+ where

359+ go :: ProcessId -> Closure (Process ())

360+ go pid = cpNewChan dict

361+ `cpBind`

362+ (cpSend (sdictSendPort dict) pid `cpSplit` proc)

363+ `cpBind`

364+ cpCancelL

365+

398366--------------------------------------------------------------------------------

399367-- Local versions of spawn --

400368--------------------------------------------------------------------------------

@@ -402,46 +370,16 @@ import Data.Foldable (forM_)

402370-- | Spawn a process on the local node

403371spawnLocal :: Process () -> Process ProcessId

404372spawnLocal proc = do

405− node <- processNode <$> ask

373+ node <- processNode <$> ask

406374 liftIO $ forkProcess node proc

407375

408376-- | Create a new typed channel, spawn a process on the local node, passing it

409377-- the receive port, and return the send port

410378spawnChannelLocal :: Serializable a

411− => (ReceivePort a -> Process ())

379+ => (ReceivePort a -> Process ())

412380 -> Process (SendPort a)

413−spawnChannelLocal proc = do

414− node <- processNode <$> ask

415− liftIO $ do

416− mvar <- newEmptyMVar

417− _ <- forkProcess node $ do

418− -- It is important that we allocate the new channel in the new process,

419− -- because otherwise it will be associated with the wrong process ID

420− (sport, rport) <- newChan

421− liftIO $ putMVar mvar sport

422− proc rport

423− takeMVar mvar

424−

425−-- | Local version of 'call'. Running a process in this way isolates it from

426−-- messages sent to the caller process, and also allows silently dropping late

427−-- or duplicate messages sent to the isolated process after it exits.

428−-- Silently dropping messages may not always be the best approach.

429−callLocal :: Process a -> Process a

430−callLocal proc = Catch.mask $ \release -> do

431− mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

432− child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

433− lproc <- ask

434− liftIO $ do

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

381+spawnChannelLocal proc = do

382+ node <- processNode <$> ask

383+ (sport, rport) <- newChan

384+ _ <- liftIO $ forkProcess node (proc rport)

385+ return sport

distributed-process/src/Control/Distributed/Process/Closure.hsnew file+322

@@ -0,0 +1,322 @@

1+-- | Static values and Closures

2+--

3+-- [Static values]

4+--

5+-- /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)

6+-- proposes a new type construct called 'static' that characterizes values that

7+-- are known statically. There is no support for 'static' in ghc yet, however,

8+-- so we emulate it using Template Haskell. Given a top-level definition

9+--

10+-- > f :: forall a1 .. an. T

11+-- > f = ...

12+--

13+-- you can use a Template Haskell splice to create a static version of 'f':

14+--

15+-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T

16+--

17+-- Every module that you write that contains calls to 'mkStatic' needs to

18+-- have a call to 'remotable':

19+--

20+-- > remotable [ 'f, 'g, ... ]

21+--

22+-- where you must pass every function (or other value) that you pass as an

23+-- argument to 'mkStatic'. The call to 'remotable' will create a definition

24+--

25+-- > __remoteTable :: RemoteTable -> RemoteTable

26+--

27+-- which can be used to construct the 'RemoteTable' used to initialize

28+-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,

29+-- and compose all created functions when initializing Cloud Haskell:

30+--

31+-- > let rtable :: RemoteTable

32+-- > rtable = M1.__remoteTable

33+-- > . M2.__remoteTable

34+-- > . ...

35+-- > . Mn.__remoteTable

36+-- > $ initRemoteTable

37+--

38+-- [Dealing with type class qualifiers]

39+--

40+-- Although 'mkStatic' supports polymorphic types, it does not support

41+-- qualified types. For instance, you cannot call 'mkStatic' on

42+--

43+-- > decode :: Serializable a => ByteString -> a

44+--

45+-- Instead, you will need to reify the type class dictionary. Cloud Haskell

46+-- comes with a reified version of 'Serializable':

47+--

48+-- > data SerializableDict a where

49+-- > SerializableDict :: Serializable a => SerializableDict a

50+--

51+-- Using the reified dictionary you can define

52+--

53+-- > decodeDict :: SerializableDict a -> ByteString -> a

54+-- > decodeDict SerializableDict = decode

55+--

56+-- where 'decodeDict' is a normal (unqualified) polymorphic value and hence

57+-- can be passed as an argument to remotable:

58+--

59+-- > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)

60+--

61+-- [Composing static values]

62+--

63+-- The version of 'static' provided by this implementation of Cloud Haskell is

64+-- strictly more expressive than the one proposed in the paper, and additionally

65+-- supports

66+--

67+-- > staticApply :: Static (a -> b) -> Static a -> Static b

68+--

69+-- This is extremely useful. For example, Cloud Haskell comes with

70+-- 'staticDecode' defined as

71+--

72+-- > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)

73+-- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict

74+--

75+-- 'staticDecode' is used when defining closures (see below), and makes

76+-- essential use of 'staticApply'.

77+--

78+-- Support for 'staticApply' also makes it possible to define a rich set of

79+-- combinators on 'static' values, a number of which are provided in this

80+-- module.

81+--

82+-- [Static serialization dictionaries]

83+--

84+-- Many Cloud Haskell primitives (like 'staticDecode', above) require static

85+-- serialization dictionaries. In principle these dictionaries require nothing

86+-- special; for instance, given some serializable type 'T' you can define

87+--

88+-- > sdictT :: SerializableDict T

89+-- > sdictT = SerializableDict

90+--

91+-- and then have

92+--

93+-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)

94+--

95+-- However, since these dictionaries are so frequently required Cloud Haskell

96+-- provides special support for them. When you call 'remotable' on a

97+-- /monomorphic/ function @f :: T1 -> T2@

98+--

99+-- > remotable ['f]

100+--

101+-- then a serialization dictionary is automatically created for you, which you

102+-- can access with

103+--

104+-- > $(functionSDict 'f) :: Static (SerializableDict T1)

105+--

106+-- In addition, if @f :: T1 -> Process T2@, then a second dictionary is created

107+--

108+-- > $(functionTDict 'f) :: Static (SerializableDict T2)

109+--

110+-- [Closures]

111+--

112+-- Suppose you have a process

113+--

114+-- > isPrime :: Integer -> Process Bool

115+--

116+-- Then

117+--

118+-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)

119+--

120+-- which you can then 'call', for example, to have a remote node check if

121+-- a number is prime.

122+--

123+-- In general, if you have a /monomorphic/ function

124+--

125+-- > f :: T1 -> T2

126+--

127+-- then

128+--

129+-- > $(mkClosure 'f) :: T1 -> Closure T2

130+--

131+-- provided that 'T1' is serializable (*).

132+--

133+-- [Creating closures manually]

134+--

135+-- You don't /need/ to use 'mkClosure', however. Closures are defined exactly

136+-- as described in /Towards Haskell in the Cloud/:

137+--

138+-- > data Closure a = Closure (Static (ByteString -> a)) ByteString

139+--

140+-- The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit):

141+--

142+-- > let decoder :: Static (ByteString -> Process Bool)

143+-- > decoder = $(mkStatic 'isPrime)

144+-- > `staticCompose`

145+-- > staticDecode $(functionSDict 'isPrime)

146+-- > in Closure decoder (encode n)

147+--

148+-- where 'staticCompose' is composition of static functions. Note that

149+-- 'mkClosure' makes use of the static serialization dictionary

150+-- ('functionSDict') created by 'remotable'.

151+--

152+-- [Combinators on Closures]

153+--

154+-- Support for 'staticApply' (described above) also means that we can define

155+-- combinators on Closures, and we provide a number of them in this module,

156+-- the most important of which is 'cpBind'. Have a look at the implementation

157+-- of 'Control.Distributed.Process.call' for an example use.

158+--

159+-- [Example]

160+--

161+-- Here is a small self-contained example that uses closures and serialization

162+-- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet

163+-- Cloud Haskell backend.

164+--

165+-- > {-# LANGUAGE TemplateHaskell #-}

166+-- > import System.Environment (getArgs)

167+-- > import Control.Distributed.Process

168+-- > import Control.Distributed.Process.Closure

169+-- > import Control.Distributed.Process.Backend.SimpleLocalnet

170+-- > import Control.Distributed.Process.Node (initRemoteTable)

171+-- >

172+-- > isPrime :: Integer -> Process Bool

173+-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]

174+-- > where

175+-- > sieve :: [Integer] -> [Integer]

176+-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]

177+-- >

178+-- > remotable ['isPrime]

179+-- >

180+-- > master :: [NodeId] -> Process ()

181+-- > master [] = liftIO $ putStrLn "no slaves"

182+-- > master (slave:_) = do

183+-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))

184+-- > liftIO $ print isPrime79

185+-- >

186+-- > main :: IO ()

187+-- > main = do

188+-- > args <- getArgs

189+-- > case args of

190+-- > ["master", host, port] -> do

191+-- > backend <- initializeBackend host port rtable

192+-- > startMaster backend master

193+-- > ["slave", host, port] -> do

194+-- > backend <- initializeBackend host port rtable

195+-- > startSlave backend

196+-- > where

197+-- > rtable :: RemoteTable

198+-- > rtable = __remoteTable initRemoteTable

199+--

200+-- [Notes]

201+--

202+-- (*) If 'T1' is not serializable you will get a type error in the generated

203+-- code. Unfortunately, the Template Haskell infrastructure cannot check

204+-- a priori if 'T1' is serializable or not due to a bug in the Template

205+-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)

206+--

207+-- (**) Even though 'staticDecode' is passed an explicit serialization

208+-- dictionary, we still need the 'Typeable' constraint because

209+-- 'Static' is not the /true/ static. If it was, we could 'unstatic'

210+-- the dictionary and pattern match on it to bring the 'Typeable'

211+-- instance into scope, but unless proper 'static' support is added to

212+-- ghc we need both the type class argument and the explicit dictionary.

213+module Control.Distributed.Process.Closure

214+ ( -- * Creating static values

215+ remotable

216+ , mkStatic

217+ -- * Template-Haskell support for creating closures

218+ , mkClosure

219+ , functionSDict

220+ , functionTDict

221+ -- * Primitive operations on static values

222+ , staticApply

223+ , staticDuplicate

224+ -- * Static functionals

225+ , staticConst

226+ , staticFlip

227+ , staticFst

228+ , staticSnd

229+ , staticCompose

230+ , staticFirst

231+ , staticSecond

232+ , staticSplit

233+ -- * Static constants

234+ , staticUnit

235+ -- * Creating closures

236+ , staticDecode

237+ , staticClosure

238+ , toClosure

239+ -- * Serialization dictionaries (and their static versions)

240+ , SerializableDict(..)

241+ , sdictUnit

242+ , sdictProcessId

243+ , sdictSendPort

244+ -- * Definition of CP and the generalized arrow combinators

245+ , CP

246+ , cpIntro

247+ , cpElim

248+ , cpId

249+ , cpComp

250+ , cpFirst

251+ , cpSecond

252+ , cpSplit

253+ , cpCancelL

254+ , cpCancelR

255+ -- * Closure versions of CH primitives

256+ , cpLink

257+ , cpUnlink

258+ , cpSend

259+ , cpExpect

260+ , cpNewChan

261+ -- * @Closure (Process a)@ as a not-quite-monad

262+ , cpReturn

263+ , cpBind

264+ , cpSeq

265+ ) where

266+

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

268+ ( SerializableDict(..)

269+ , staticApply

270+ , staticDuplicate

271+ )

272+import Control.Distributed.Process.Internal.Closure.TH

273+ ( remotable

274+ , mkStatic

275+ , functionSDict

276+ , functionTDict

277+ )

278+import Control.Distributed.Process.Internal.Closure.Static

279+ ( -- Static functionals

280+ staticConst

281+ , staticFlip

282+ , staticFst

283+ , staticSnd

284+ , staticCompose

285+ , staticFirst

286+ , staticSecond

287+ , staticSplit

288+ -- Static constants

289+ , staticUnit

290+ -- Creating closures

291+ , staticDecode

292+ , staticClosure

293+ , toClosure

294+ -- Serialization dictionaries (and their static versions)

295+ , sdictUnit

296+ , sdictProcessId

297+ , sdictSendPort

298+ )

299+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)

300+import Control.Distributed.Process.Internal.Closure.CP

301+ ( -- Definition of CP and the generalized arrow combinators

302+ CP

303+ , cpIntro

304+ , cpElim

305+ , cpId

306+ , cpComp

307+ , cpFirst

308+ , cpSecond

309+ , cpSplit

310+ , cpCancelL

311+ , cpCancelR

312+ -- Closure versions of CH primitives

313+ , cpLink

314+ , cpUnlink

315+ , cpSend

316+ , cpExpect

317+ , cpNewChan

318+ -- @Closure (Process a)@ as a not-quite-monad

319+ , cpReturn

320+ , cpBind

321+ , cpSeq

322+ )

distributed-process/src/Control/Distributed/Process/Internal/CQueue.hsnew file+105

@@ -0,0 +1,105 @@

1+-- | Concurrent queue for single reader, single writer

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

3+ ( CQueue

4+ , BlockSpec(..)

5+ , newCQueue

6+ , enqueue

7+ , dequeue

8+ ) where

10+import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)

11+import Control.Concurrent.STM

12+ ( atomically

13+ , TChan

14+ , newTChan

15+ , writeTChan

16+ , readTChan

17+ , tryReadTChan

18+ )

19+import Control.Applicative ((<$>), (<*>))

20+import Control.Exception (mask, onException)

21+import System.Timeout (timeout)

22+

23+-- We use a TCHan rather than a Chan so that we have a non-blocking read

24+data CQueue a = CQueue (MVar [a]) -- Arrived

25+ (TChan a) -- Incoming

26+

27+newCQueue :: IO (CQueue a)

28+newCQueue = CQueue <$> newMVar [] <*> atomically newTChan

29+

30+enqueue :: CQueue a -> a -> IO ()

31+enqueue (CQueue _arrived incoming) a = atomically $ writeTChan incoming a

32+

33+data BlockSpec =

34+ NonBlocking

35+ | Blocking

36+ | Timeout Int

37+

38+-- | Dequeue an element

39+--

40+-- The timeout (if any) is applied only to waiting for incoming messages, not

41+-- to checking messages that have already arrived

42+dequeue :: forall a b.

43+ CQueue a -- ^ Queue

44+ -> BlockSpec -- ^ Blocking behaviour

45+ -> [a -> Maybe b] -- ^ List of matches

46+ -> IO (Maybe b) -- ^ 'Nothing' only on timeout

47+dequeue (CQueue arrived incoming) blockSpec matches = go

48+ where

49+ go :: IO (Maybe b)

50+ go = mask $ \restore -> do

51+ arr <- takeMVar arrived

52+ -- We first check the arrived messages. If we get interrupted during this

53+ -- search, we just put the MVar back (we haven't read from the Chan yet)

54+ (arr', mb) <- onException (restore (checkArrived [] arr))

55+ (putMVar arrived arr)

56+ case (mb, blockSpec) of

57+ (Just b, _) -> do

58+ putMVar arrived arr'

59+ return (Just b)

60+ (Nothing, NonBlocking) ->

61+ checkNonBlocking arr'

62+ (Nothing, Blocking) ->

63+ Just <$> checkBlocking arr'

64+ (Nothing, Timeout n) ->

65+ timeout n $ checkBlocking arr'

66+

67+ -- We reverse the accumulator on return only if we find a match

68+ checkArrived :: [a] -> [a] -> IO ([a], Maybe b)

69+ checkArrived acc [] = return (acc, Nothing)

70+ checkArrived acc (x:xs) =

71+ case check x of

72+ Just y -> return (reverse acc ++ xs, Just y)

73+ Nothing -> checkArrived (x:acc) xs

74+

75+ -- If we call checkBlocking there may or may not be a timeout

76+ checkBlocking :: [a] -> IO b

77+ checkBlocking acc = do

78+ -- readTChan is a blocking call, and hence is interruptable. If it is

79+ -- interrupted, we put the value of the accumulator in 'arrived'

80+ -- (as opposed to the original value), so that no messages get lost

81+ -- (hence the low-level structure using mask rather than modifyMVar)

82+ x <- onException (atomically $ readTChan incoming)

83+ (putMVar arrived $ reverse acc)

84+ case check x of

85+ Nothing -> checkBlocking (x:acc)

86+ Just y -> putMVar arrived (reverse acc) >> return y

87+

88+ -- checkNonBlocking is only called if there is no timeout

89+ checkNonBlocking :: [a] -> IO (Maybe b)

90+ checkNonBlocking acc = do

91+ -- tryReadTChan is *not* interruptible

92+ mx <- atomically $ tryReadTChan incoming

93+ case mx of

94+ Nothing -> putMVar arrived (reverse acc) >> return Nothing

95+ Just x -> case check x of

96+ Nothing -> checkNonBlocking (x:acc)

97+ Just y -> putMVar arrived (reverse acc) >> return (Just y)

98+

99+ check :: a -> Maybe b

100+ check = checkMatches matches

101+

102+ checkMatches :: [a -> Maybe b] -> a -> Maybe b

103+ checkMatches [] _ = Nothing

104+ checkMatches (m:ms) a = case m a of Nothing -> checkMatches ms a

105+ Just b -> Just b

distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hsnew file+330

@@ -0,0 +1,330 @@

1+-- | Combinator for process closures

2+{-# LANGUAGE MagicHash #-}

3+module Control.Distributed.Process.Internal.Closure.CP

4+ ( -- * Definition of CP and the generalized arrow combinators

5+ CP

6+ , cpIntro

7+ , cpElim

8+ , cpId

9+ , cpComp

10+ , cpFirst

11+ , cpSecond

12+ , cpSplit

13+ , cpCancelL

14+ , cpCancelR

15+ -- * Closure versions of CH primitives

16+ , cpLink

17+ , cpUnlink

18+ , cpSend

19+ , cpExpect

20+ , cpNewChan

21+ -- * @Closure (Process a)@ as a not-quite-monad

22+ , cpReturn

23+ , cpBind

24+ , cpSeq

25+ -- * Runtime support

26+ , __remoteTable

27+ ) where

28+

29+import Data.Binary (encode)

30+import Data.ByteString.Lazy (ByteString)

31+import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)

32+import Control.Applicative ((<$>))

33+import Control.Monad ((>=>))

34+import Control.Monad.Reader (ask)

35+import Control.Distributed.Process.Serializable (Serializable)

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

37+ ( Closure(Closure)

38+ , SerializableDict(SerializableDict)

39+ , Static(Static)

40+ , Process

41+ , staticApply

42+ , staticDuplicate

43+ , staticTypeOf

44+ , typeOfStaticLabel

45+ , ProcessId

46+ , LocalNode(remoteTable)

47+ , LocalProcess(processNode)

48+ , SendPort

49+ , ReceivePort

50+ )

51+import Control.Distributed.Process.Internal.Primitives

52+ ( link

53+ , unlink

54+ , send

55+ , expect

56+ , newChan

57+ )

58+import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

59+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

60+import Control.Distributed.Process.Internal.Closure.Static

61+ ( staticCompose

62+ , staticDecode

63+ , staticClosure

64+ , staticSplit

65+ , staticConst

66+ , staticUnit

67+ , staticFlip

68+ , staticFst

69+ , staticSnd

70+ , sdictProcessId

71+ )

72+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)

73+import Control.Distributed.Process.Internal.Dynamic

74+ ( Dynamic(Dynamic)

75+ , unsafeCoerce#

76+ , dynTypeRep

77+ , dynKleisli

78+ )

79+import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)

80+

81+--------------------------------------------------------------------------------

82+-- Setup: A number of functions that we will pass to 'remotable' --

83+--------------------------------------------------------------------------------

84+

85+---- Type specializations of monadic operations on Processes -------------------

86+

87+returnProcess :: a -> Process a

88+returnProcess = return

89+

90+bindProcess :: Process a -> (a -> Process b) -> Process b

91+bindProcess = (>>=)

92+

93+kleisliProcess :: (a -> Process b) -> (b -> Process c) -> a -> Process c

94+kleisliProcess = (>=>)

95+

96+parJoinProcess :: Process (a -> Process b) -> a -> Process b

97+parJoinProcess proc a = proc >>= ($ a)

98+

99+---- Variations on standard or CH functions with an explicit dictionary arg ----

100+

101+sendDict :: SerializableDict a -> ProcessId -> a -> Process ()

102+sendDict SerializableDict = send

103+

104+expectDict :: SerializableDict a -> Process a

105+expectDict SerializableDict = expect

106+

107+newChanDict :: SerializableDict a -> Process (SendPort a, ReceivePort a)

108+newChanDict SerializableDict = newChan

109+

110+---- Serialization dictionaries ------------------------------------------------

111+

112+-- | Specialized serialization dictionary required in 'cpBind'

113+sdictComp :: SerializableDict (ByteString, ByteString)

114+sdictComp = SerializableDict

115+

116+---- Some specialised processes necessary to implement the combinators ---------

117+

118+-- | Resolve a closure

119+unClosure :: Static a -> ByteString -> Process Dynamic

120+unClosure (Static label) env = do

121+ rtable <- remoteTable . processNode <$> ask

122+ case resolveClosure rtable label env of

123+ Nothing -> fail "Derived.unClosure: resolveClosure failed"

124+ Just dyn -> return dyn

125+

126+-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the

127+-- type of the first static argument (the value of that argument is not used)

128+unDynamic :: Static a -> Process Dynamic -> Process a

129+unDynamic (Static label) pdyn = do

130+ Dynamic typ val <- pdyn

131+ if typ `compareTypeRep` typeOfStaticLabel label

132+ then return (unsafeCoerce# val)

133+ else fail $ "unDynamic: cannot match "

134+ ++ show typ

135+ ++ " against expected type "

136+ ++ show (typeOfStaticLabel label)

137+

138+-- | Dynamic kleisli composition

139+--

140+-- The first argument stops remotable from trying to generate a SerializableDict

141+-- for (Process Dynamic, Process Dynamic)

142+kleisliCompDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic

143+kleisliCompDyn () (pf, pg) = do

144+ f <- pf -- a -> Process b

145+ g <- pg -- b -> Process c

146+ case dynKleisli tyConProcess kleisliProcess f g of

147+ Just dyn -> return dyn

148+ Nothing -> fail $ "kleisliCompDyn: could not compose "

149+ ++ show (dynTypeRep f)

150+ ++ " with "

151+ ++ show (dynTypeRep g)

152+ where

153+ tyConProcess :: TyCon

154+ tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))

155+

156+cpFirstAux :: (a -> Process b) -> (a, c) -> Process (b, c)

157+cpFirstAux f (a, c) = f a >>= \b -> return (b, c)

158+

159+cpSecondAux :: (a -> Process b) -> (c, a) -> Process (c, b)

160+cpSecondAux f (c, a) = f a >>= \b -> return (c, b)

161+

162+---- Finally, the call to remotable --------------------------------------------

163+

164+remotable [ -- Monadic operations

165+ 'returnProcess

166+ , 'bindProcess

167+ , 'parJoinProcess

168+ -- CH primitives

169+ , 'link

170+ , 'unlink

171+ -- Explicit dictionaries

172+ , 'sendDict

173+ , 'expectDict

174+ , 'newChanDict

175+ -- Serialization dictionaries

176+ , 'sdictComp

177+ -- Specialized processes

178+ , 'unClosure

179+ , 'unDynamic

180+ , 'kleisliCompDyn

181+ , 'cpFirstAux

182+ , 'cpSecondAux

183+ ]

184+

185+--------------------------------------------------------------------------------

186+-- Some derived static functions --

187+--------------------------------------------------------------------------------

188+

189+staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)

190+staticUndynamic =

191+ $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))

192+

193+staticKleisliCompDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)

194+staticKleisliCompDyn = $(mkStatic 'kleisliCompDyn) `staticApply` staticUnit

195+

196+--------------------------------------------------------------------------------

197+-- Definition of CP and the generalized arrow combinators --

198+--------------------------------------------------------------------------------

199+

200+-- | 'CP a b' represents the closure of a process parameterized by 'a' and

201+-- returning 'b'. 'CP a b' forms a (restricted) generalized arrow

202+-- (<http://www.cs.berkeley.edu/~megacz/garrows/>)

203+type CP a b = Closure (a -> Process b)

204+

205+-- | 'CP' introduction form

206+cpIntro :: forall a b. (Typeable a, Typeable b)

207+ => Closure (Process b) -> Closure (a -> Process b)

208+cpIntro (Closure static env) = Closure decoder env

209+ where

210+ decoder :: Static (ByteString -> a -> Process b)

211+ decoder = staticConst `staticCompose` static

212+

213+-- | 'CP' elimination form

214+cpElim :: forall a. Typeable a => CP () a -> Closure (Process a)

215+cpElim (Closure static env) = Closure decoder env

216+ where

217+ decoder :: Static (ByteString -> Process a)

218+ decoder = staticFlip static `staticApply` staticUnit

219+

220+-- | Identity ('Closure' version of 'return')

221+cpId :: Typeable a => CP a a

222+cpId = staticClosure $(mkStatic 'returnProcess)

223+

224+-- | Left-to-right composition ('Closure' version of '>=>')

225+cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)

226+ => CP a b -> CP b c -> CP a c

227+cpComp (Closure fstatic fenv) (Closure gstatic genv) =

228+ Closure decoder (encode (fenv, genv))

229+ where

230+ decoder :: Static (ByteString -> a -> Process c)

231+ decoder = $(mkStatic 'parJoinProcess)

232+ `staticCompose`

233+ staticUndynamic

234+ `staticCompose`

235+ staticKleisliCompDyn

236+ `staticCompose`

237+ (staticUnclosure fstatic `staticSplit` staticUnclosure gstatic)

238+ `staticCompose`

239+ staticDecode $(mkStatic 'sdictComp)

240+

241+-- | First

242+cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)

243+ => CP a b -> CP (a, c) (b, c)

244+cpFirst (Closure static env) = Closure decoder env

245+ where

246+ decoder :: Static (ByteString -> (a, c) -> Process (b, c))

247+ decoder = $(mkStatic 'cpFirstAux) `staticCompose` static

248+

249+-- | Second

250+cpSecond :: forall a b c. (Typeable a, Typeable b, Typeable c)

251+ => CP a b -> CP (c, a) (c, b)

252+cpSecond (Closure static env) = Closure decoder env

253+ where

254+ decoder :: Static (ByteString -> (c, a) -> Process (c, b))

255+ decoder = $(mkStatic 'cpSecondAux) `staticCompose` static

256+

257+-- | Split (Like 'Control.Arrow.***')

258+cpSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)

259+ => CP a c -> CP b d -> CP (a, b) (c, d)

260+cpSplit f g = cpFirst f `cpComp` cpSecond g

261+

262+-- | Left cancellation

263+cpCancelL :: Typeable a => CP ((), a) a

264+-- Closure (((), a) -> Process a)

265+cpCancelL = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticSnd)

266+

267+-- | Right cancellation

268+cpCancelR :: Typeable a => CP (a, ()) a

269+cpCancelR = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticFst)

270+

271+--------------------------------------------------------------------------------

272+-- Closure versions of CH primitives --

273+--------------------------------------------------------------------------------

274+

275+-- | Closure version of 'link'

276+cpLink :: ProcessId -> Closure (Process ())

277+cpLink = $(mkClosure 'link)

278+

279+-- | Closure version of 'unlink'

280+cpUnlink :: ProcessId -> Closure (Process ())

281+cpUnlink = $(mkClosure 'unlink)

282+

283+-- | Closure version of 'send'

284+cpSend :: forall a. Typeable a

285+ => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())

286+cpSend dict pid = Closure decoder (encode pid)

287+ where

288+ decoder :: Static (ByteString -> a -> Process ())

289+ decoder = ($(mkStatic 'sendDict) `staticApply` dict)

290+ `staticCompose`

291+ staticDecode sdictProcessId

292+

293+-- | Closure version of 'expect'

294+cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

295+cpExpect dict = staticClosure ($(mkStatic 'expectDict) `staticApply` dict)

296+

297+-- | Closure version of 'newChan'

298+cpNewChan :: Typeable a

299+ => Static (SerializableDict a)

300+ -> Closure (Process (SendPort a, ReceivePort a))

301+cpNewChan dict = staticClosure ($(mkStatic 'newChanDict) `staticApply` dict)

302+

303+--------------------------------------------------------------------------------

304+-- (Closure . Process) as a not-quite-monad --

305+--------------------------------------------------------------------------------

306+

307+-- | Not-quite-monadic 'return'

308+cpReturn :: forall a. Serializable a

309+ => Static (SerializableDict a) -> a -> Closure (Process a)

310+cpReturn dict x = Closure decoder (encode x)

311+ where

312+ decoder :: Static (ByteString -> Process a)

313+ decoder = $(mkStatic 'returnProcess)

314+ `staticCompose`

315+ staticDecode dict

316+

317+

318+staticUnclosure :: Typeable a

319+ => Static a -> Static (ByteString -> Process Dynamic)

320+staticUnclosure s =

321+ $(mkStatic 'unClosure) `staticApply` staticDuplicate s

322+

323+-- | Not-quite-monadic bind ('>>=')

324+cpBind :: forall a b. (Typeable a, Typeable b)

325+ => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)

326+cpBind x f = cpElim (cpIntro x `cpComp` f)

327+

328+-- | Monadic sequencing ('>>')

329+cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())

330+cpSeq p q = p `cpBind` cpIntro q

distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hsnew file+25

@@ -0,0 +1,25 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+module Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure) where

4+import Data.Binary (encode)

5+import Language.Haskell.TH (Q, Exp, Name)

6+import Control.Distributed.Process.Internal.Types (Closure(Closure))

7+import Control.Distributed.Process.Internal.Closure.TH

8+ ( mkStatic

9+ , functionSDict

10+ )

11+import Control.Distributed.Process.Internal.Closure.Static

12+ ( staticCompose

13+ , staticDecode

14+ )

15+

16+-- | Create a closure

17+--

18+-- If @f : T1 -> T2@ is a /monomorphic/ function

19+-- then @$(mkClosure 'f) :: T1 -> Closure T2@.

20+-- Be sure to pass 'f' to 'remotable'.

21+mkClosure :: Name -> Q Exp

22+mkClosure n =

23+ [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))

24+ . encode

25+ |]

distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# LANGUAGE MagicHash #-}

2+module Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure) where

4+import Data.Accessor ((^.))

5+import Data.ByteString.Lazy (ByteString)

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

7+ ( RemoteTable

8+ , remoteTableLabel

9+ , Static(Static)

10+ , StaticLabel(..)

11+ )

12+import Control.Distributed.Process.Internal.Dynamic

13+ ( Dynamic(Dynamic)

14+ , toDyn

15+ , dynApply

16+ , unsafeCoerce#

17+ )

18+import Control.Distributed.Process.Internal.TypeRep () -- Binary instances

19+

20+resolveStatic :: RemoteTable -> StaticLabel -> Maybe Dynamic

21+resolveStatic rtable (StaticLabel string typ) = do

22+ Dynamic _ val <- rtable ^. remoteTableLabel string

23+ return (Dynamic typ val)

24+resolveStatic rtable (StaticApply static1 static2) = do

25+ f <- resolveStatic rtable static1

26+ x <- resolveStatic rtable static2

27+ f `dynApply` x

28+resolveStatic _rtable (StaticDuplicate static typ) =

29+ return $ Dynamic typ (unsafeCoerce# (Static static))

30+

31+resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic

32+resolveClosure rtable static env = do

33+ decoder <- resolveStatic rtable static

34+ decoder `dynApply` toDyn env

distributed-process/src/Control/Distributed/Process/Internal/Closure/Static.hsnew file+190

@@ -0,0 +1,190 @@

1+-- | Combinators on static values

2+{-# LANGUAGE MagicHash #-}

3+module Control.Distributed.Process.Internal.Closure.Static

4+ ( -- * Static functionals

5+ staticConst

6+ , staticFlip

7+ , staticFst

8+ , staticSnd

9+ , staticCompose

10+ , staticFirst

11+ , staticSecond

12+ , staticSplit

13+ -- * Static constants

14+ , staticUnit

15+ -- * Creating closures

16+ , staticDecode

17+ , staticClosure

18+ , toClosure

19+ -- * Serialization dictionaries (and their static versions)

20+ , sdictUnit

21+ , sdictProcessId

22+ , sdictSendPort

23+ -- * Runtime support

24+ , __remoteTable

25+ ) where

26+

27+import Data.Binary (encode, decode)

28+import Data.ByteString.Lazy (ByteString, empty)

29+import Data.Typeable (Typeable)

30+import Control.Distributed.Process.Serializable (Serializable)

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

32+ ( Closure(Closure)

33+ , SerializableDict(SerializableDict)

34+ , Static

35+ , staticApply

36+ , ProcessId

37+ , SendPort

38+ )

39+import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

40+import qualified Control.Arrow as Arrow (first, second, (***))

41+

42+--------------------------------------------------------------------------------

43+-- Setup: A number of functions that we will pass to 'remotable' --

44+--------------------------------------------------------------------------------

45+

46+---- Functionals ---------------------------------------------------------------

47+

48+compose :: (b -> c) -> (a -> b) -> a -> c

49+compose = (.)

50+

51+first :: (a -> b) -> (a, c) -> (b, c)

52+first = Arrow.first

53+

54+second :: (a -> b) -> (c, a) -> (c, b)

55+second = Arrow.second

56+

57+split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')

58+split = (Arrow.***)

59+

60+---- Constants -----------------------------------------------------------------

61+

62+unit :: ()

63+unit = ()

64+

65+---- Variations on standard or CH functions with an explicit dictionary arg ----

66+

67+decodeDict :: SerializableDict a -> ByteString -> a

68+decodeDict SerializableDict = decode

69+

70+---- Serialization dictionaries ------------------------------------------------

71+

72+sdictUnit_ :: SerializableDict ()

73+sdictUnit_ = SerializableDict

74+

75+sdictProcessId_ :: SerializableDict ProcessId

76+sdictProcessId_ = SerializableDict

77+

78+sdictSendPort_ :: SerializableDict a -> SerializableDict (SendPort a)

79+sdictSendPort_ SerializableDict = SerializableDict

80+

81+---- Finally, the call to remotable --------------------------------------------

82+

83+remotable [ -- Functionals (predefined)

84+ 'const

85+ , 'flip

86+ , 'fst

87+ , 'snd

88+ -- Functionals (defined above)

89+ , 'compose

90+ , 'first

91+ , 'second

92+ , 'split

93+ -- Constants

94+ , 'unit

95+ -- Explicit dictionaries

96+ , 'decodeDict

97+ -- Serialization dictionaries

98+ , 'sdictUnit_

99+ , 'sdictProcessId_

100+ , 'sdictSendPort_

101+ ]

102+

103+--------------------------------------------------------------------------------

104+-- Static versions of the functionals --

105+-- (We give these explicit names because they are useful outside this module) --

106+--------------------------------------------------------------------------------

107+

108+-- | Static version of 'const'

109+staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)

110+staticConst = $(mkStatic 'const)

111+

112+-- | Static version of 'flip'

113+staticFlip :: (Typeable a, Typeable b, Typeable c)

114+ => Static (a -> b -> c) -> Static (b -> a -> c)

115+staticFlip f = $(mkStatic 'flip) `staticApply` f

116+

117+-- | Static version of 'fst'

118+staticFst :: (Typeable a, Typeable b)

119+ => Static ((a, b) -> a)

120+staticFst = $(mkStatic 'fst)

121+

122+-- | Static version of 'snd'

123+staticSnd :: (Typeable a, Typeable b)

124+ => Static ((a, b) -> b)

125+staticSnd = $(mkStatic 'snd)

126+

127+-- | Static version of ('Prelude..')

128+staticCompose :: (Typeable a, Typeable b, Typeable c)

129+ => Static (b -> c) -> Static (a -> b) -> Static (a -> c)

130+staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x

131+

132+-- | Static version of 'Control.Arrow.first'

133+staticFirst :: (Typeable a, Typeable b, Typeable c)

134+ => Static ((a -> b) -> (a, c) -> (b, c))

135+staticFirst = $(mkStatic 'first)

136+

137+-- | Static version of 'Control.Arrow.second'

138+staticSecond :: (Typeable a, Typeable b, Typeable c)

139+ => Static ((a -> b) -> (c, a) -> (c, b))

140+staticSecond = $(mkStatic 'second)

141+

142+-- | Static version of ('Control.Arrow.***')

143+staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)

144+ => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))

145+staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g

146+

147+--------------------------------------------------------------------------------

148+-- Constants --

149+--------------------------------------------------------------------------------

150+

151+-- | Static version of '()'

152+staticUnit :: Static ()

153+staticUnit = $(mkStatic 'unit)

154+

155+--------------------------------------------------------------------------------

156+-- Dictionaries --

157+--------------------------------------------------------------------------------

158+

159+-- | Serialization dictionary for '()'

160+sdictUnit :: Static (SerializableDict ())

161+sdictUnit = $(mkStatic 'sdictUnit_)

162+

163+-- | Serialization dictionary for 'ProcessId'

164+sdictProcessId :: Static (SerializableDict ProcessId)

165+sdictProcessId = $(mkStatic 'sdictProcessId_)

166+

167+-- | Serialization dictionary for 'SendPort'

168+sdictSendPort :: Typeable a

169+ => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))

170+sdictSendPort = staticApply $(mkStatic 'sdictSendPort_)

171+

172+--------------------------------------------------------------------------------

173+-- Creating closures --

174+--------------------------------------------------------------------------------

175+

176+-- | Static decoder, given a static serialization dictionary.

177+--

178+-- See module documentation of "Control.Distributed.Process.Closure" for an

179+-- example.

180+staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)

181+staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict

182+

183+-- | Convert a static value into a closure.

184+staticClosure :: forall a. Typeable a => Static a -> Closure a

185+staticClosure static = Closure (staticConst `staticApply` static) empty

186+

187+-- | Convert a serializable value into a closure.

188+toClosure :: forall a. Serializable a

189+ => Static (SerializableDict a) -> a -> Closure a

190+toClosure dict x = Closure (staticDecode dict) (encode x)

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hsnew file+229

@@ -0,0 +1,229 @@

1+-- | Template Haskell support

2+--

3+-- (In a separate file for convenience)

4+{-# LANGUAGE MagicHash #-}

5+module Control.Distributed.Process.Internal.Closure.TH

6+ ( -- * User-level API

7+ remotable

8+ , mkStatic

9+ , functionSDict

10+ , functionTDict

11+ ) where

12+

13+import Prelude hiding (lookup)

14+import Data.Accessor ((^=))

15+import Data.Typeable (typeOf)

16+import Control.Applicative ((<$>))

17+import Language.Haskell.TH

18+ ( -- Q monad and operations

19+ Q

20+ , reify

21+ -- Names

22+ , Name

23+ , mkName

24+ , nameBase

25+ -- Algebraic data types

26+ , Dec

27+ , Exp

28+ , Type(AppT, ForallT, VarT, ArrowT)

29+ , Info(VarI)

30+ , TyVarBndr(PlainTV, KindedTV)

31+ , Pred(ClassP)

32+ -- Lifted constructors

33+ -- .. Literals

34+ , stringL

35+ -- .. Patterns

36+ , normalB

37+ , clause

38+ -- .. Expressions

39+ , varE

40+ , litE

41+ -- .. Top-level declarations

42+ , funD

43+ , sigD

44+ )

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

46+ ( RemoteTable

47+ , Static(Static)

48+ , StaticLabel(StaticLabel)

49+ , remoteTableLabel

50+ , SerializableDict(SerializableDict)

51+ , Process

52+ )

53+import Control.Distributed.Process.Internal.Dynamic

54+ ( Dynamic(..)

55+ , unsafeCoerce#

56+ , toDyn

57+ )

58+

59+--------------------------------------------------------------------------------

60+-- User-level API --

61+--------------------------------------------------------------------------------

62+

63+-- | Create the closure, decoder, and metadata definitions for the given list

64+-- of functions

65+remotable :: [Name] -> Q [Dec]

66+remotable ns = do

67+ (closures, inserts) <- unzip <$> mapM generateDefs ns

68+ rtable <- createMetaData (concat inserts)

69+ return $ concat closures ++ rtable

70+

71+-- | Construct a static value.

72+--

73+-- If @f : forall a1 .. an. T@

74+-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.

75+-- Be sure to pass 'f' to 'remotable'.

76+mkStatic :: Name -> Q Exp

77+mkStatic = varE . staticName

78+

79+-- | If @f : T1 -> T2@ is a monomorphic function

80+-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.

81+--

82+-- Be sure to pass 'f' to 'remotable'.

83+functionSDict :: Name -> Q Exp

84+functionSDict = varE . sdictName

85+

86+-- | If @f : T1 -> Process T2@ is a monomorphic function

87+-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.

88+--

89+-- Be sure to pass 'f' to 'remotable'.

90+functionTDict :: Name -> Q Exp

91+functionTDict = varE . tdictName

92+

93+--------------------------------------------------------------------------------

94+-- Internal (Template Haskell) --

95+--------------------------------------------------------------------------------

96+

97+-- | Generate the code to add the metadata to the CH runtime

98+createMetaData :: [Q Exp] -> Q [Dec]

99+createMetaData is =

100+ [d| __remoteTable :: RemoteTable -> RemoteTable ;

101+ __remoteTable = $(compose is)

102+ |]

103+

104+generateDefs :: Name -> Q ([Dec], [Q Exp])

105+generateDefs n = do

106+ proc <- [t| Process |]

107+ mType <- getType n

108+ case mType of

109+ Just (origName, typ) -> do

110+ let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)

111+ _ -> ([], typ)

112+

113+ -- The main "static" entry

114+ (static, register) <- makeStatic origName typVars typ'

115+

116+ -- If n :: T1 -> T2, static serializable dictionary for T1

117+ -- TODO: we should check if arg is an instance of Serializable, but we cannot

118+ -- http://hackage.haskell.org/trac/ghc/ticket/7066

119+ (sdict, registerSDict) <- case (typVars, typ') of

120+ ([], ArrowT `AppT` arg `AppT` _res) ->

121+ makeDict (sdictName origName) arg

122+ _ ->

123+ return ([], [])

124+

125+ -- If n :: T1 -> Process T2, static serializable dictionary for T2

126+ -- TODO: check if T2 is serializable (same as above)

127+ (tdict, registerTDict) <- case (typVars, typ') of

128+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->

129+ makeDict (tdictName origName) res

130+ _ ->

131+ return ([], [])

132+

133+ return ( concat [static, sdict, tdict]

134+ , concat [register, registerSDict, registerTDict]

135+ )

136+ _ ->

137+ fail $ "remotable: " ++ show n ++ " not found"

138+ where

139+ makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])

140+ makeStatic origName typVars typ = do

141+ static <- generateStatic origName typVars typ

142+ let dyn = case typVars of

143+ [] -> [| toDyn $(varE origName) |]

144+ _ -> [| Dynamic (error "Polymorphic value")

145+ (unsafeCoerce# $(varE origName))

146+ |]

147+ return ( static

148+ , [ [| registerStatic $(stringE (show origName)) $dyn |] ]

149+ )

150+

151+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])

152+ makeDict dictName typ = do

153+ sdict <- generateDict dictName typ

154+ let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]

155+ return ( sdict

156+ , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]

157+ )

158+

159+

160+registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable

161+registerStatic label dyn = remoteTableLabel label ^= Just dyn

162+

163+-- | Generate a static value

164+generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]

165+generateStatic n xs typ = do

166+ staticTyp <- [t| Static |]

167+ sequence

168+ [ sigD (staticName n) $

169+ return (ForallT xs

170+ (map typeable xs)

171+ (staticTyp `AppT` typ)

172+ )

173+ , sfnD (staticName n)

174+ [| Static $ StaticLabel

175+ $(stringE (show n))

176+ (typeOf (undefined :: $(return typ)))

177+ |]

178+ ]

179+ where

180+ typeable :: TyVarBndr -> Pred

181+ typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]

182+ typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]

183+

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

185+generateDict :: Name -> Type -> Q [Dec]

186+generateDict n typ = do

187+ sequence

188+ [ sigD n $ [t| Static (SerializableDict $(return typ)) |]

189+ , sfnD n

190+ [| Static $ StaticLabel

191+ $(stringE (show n))

192+ (typeOf (undefined :: SerializableDict $(return typ)))

193+ |]

194+ ]

195+

196+staticName :: Name -> Name

197+staticName n = mkName $ nameBase n ++ "__static"

198+

199+sdictName :: Name -> Name

200+sdictName n = mkName $ nameBase n ++ "__sdict"

201+

202+tdictName :: Name -> Name

203+tdictName n = mkName $ nameBase n ++ "__tdict"

204+

205+--------------------------------------------------------------------------------

206+-- Generic Template Haskell auxiliary functions --

207+--------------------------------------------------------------------------------

208+

209+-- | Compose a set of expressions

210+compose :: [Q Exp] -> Q Exp

211+compose [] = [| id |]

212+compose [e] = e

213+compose (e:es) = [| $e . $(compose es) |]

214+

215+-- | Literal string as an expression

216+stringE :: String -> Q Exp

217+stringE = litE . stringL

218+

219+-- | Look up the "original name" (module:name) and type of a top-level function

220+getType :: Name -> Q (Maybe (Name, Type))

221+getType name = do

222+ info <- reify name

223+ case info of

224+ VarI origName typ _ _ -> return $ Just (origName, typ)

225+ _ -> return Nothing

226+

227+-- | Variation on 'funD' which takes a single expression to define the function

228+sfnD :: Name -> Q Exp -> Q Dec

229+sfnD n e = funD n [clause [] (normalB e) []]

distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hsnew file+112

@@ -0,0 +1,112 @@

1+-- | Reimplementation of Dynamic that supports dynBind

2+--

3+-- We don't have access to the internal representation of Dynamic, otherwise

4+-- we would not have to redefine it completely. Note that we use this only

5+-- internally, so the incompatibility with "our" Dynamic from the standard

6+-- Dynamic is not important.

7+{-# LANGUAGE MagicHash #-}

8+module Control.Distributed.Process.Internal.Dynamic

9+ ( Dynamic(..)

10+ , toDyn

11+ , fromDyn

12+ , fromDynamic

13+ , dynTypeRep

14+ , dynApply

15+ , dynApp

16+ , dynBind

17+ , dynBind'

18+ , dynKleisli

19+ , GHC.unsafeCoerce#

20+ ) where

21+

22+import Data.Typeable

23+ ( Typeable

24+ , TypeRep

25+ , typeOf

26+ , funResultTy

27+ , TyCon

28+ , splitTyConApp

29+ , mkFunTy

30+ )

31+import Data.Typeable.Internal (funTc)

32+import qualified GHC.Prim as GHC (Any, unsafeCoerce#)

33+import Data.Maybe (fromMaybe)

34+

35+data Dynamic = Dynamic TypeRep GHC.Any

36+ deriving Typeable

37+

38+toDyn :: Typeable a => a -> Dynamic

39+toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)

40+

41+fromDyn :: Typeable a => Dynamic -> a -> a

42+fromDyn (Dynamic rep val) a =

43+ if rep == typeOf a

44+ then GHC.unsafeCoerce# val

45+ else a

46+

47+fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a

48+fromDynamic (Dynamic rep val) =

49+ if rep == typeOf (undefined :: a)

50+ then Just (GHC.unsafeCoerce# val)

51+ else Nothing

52+

53+dynTypeRep :: Dynamic -> TypeRep

54+dynTypeRep (Dynamic t _) = t

55+

56+instance Show Dynamic where

57+ show = show . dynTypeRep

58+

59+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic

60+dynApply (Dynamic t1 f) (Dynamic t2 x) =

61+ case funResultTy t1 t2 of

62+ Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))

63+ Nothing -> Nothing

64+

65+dynApp :: Dynamic -> Dynamic -> Dynamic

66+dynApp f x = fromMaybe (error typeError) (dynApply f x)

67+ where

68+ typeError = "Type error in dynamic application.\n"

69+ ++ "Can't apply function " ++ show f

70+ ++ " to argument " ++ show x

71+

72+dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic

73+dynBind m bind (Dynamic t1 x) (Dynamic t2 f) =

74+ case splitTyConApp t1 of

75+ (m', [a]) | m' == m ->

76+ case funResultTy t2 a of

77+ Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))

78+ _ -> Nothing

79+ _ -> Nothing

80+

81+dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic

82+dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)

83+ where

84+ typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f

85+

86+

87+

88+

89+-- | Dynamically typed Kleisli composition

90+dynKleisli :: TyCon

91+ -> (forall a b c. (a -> m b) -> (b -> m c) -> a -> m c)

92+ -> Dynamic

93+ -> Dynamic

94+ -> Maybe Dynamic

95+dynKleisli m comp (Dynamic tf f) (Dynamic tg g) =

96+ case splitTyConApp tf of

97+ (arr1, [a, mb]) | arr1 == funTc ->

98+ case splitTyConApp tg of

99+ (arr2, [b, mc]) | arr2 == funTc ->

100+ case splitTyConApp mb of

101+ (m', [b']) | m' == m && b' == b ->

102+ case splitTyConApp mc of

103+ (m'', [_c]) | m'' == m ->

104+ Just (Dynamic (mkFunTy a mc) (GHC.unsafeCoerce# comp f g))

105+ _ ->

106+ Nothing

107+ _ ->

108+ Nothing

109+ _ ->

110+ Nothing

111+ _ ->

112+ Nothing

distributed-process/src/Control/Distributed/Process/Internal/Node.hsnew file+91

@@ -0,0 +1,91 @@

1+module Control.Distributed.Process.Internal.Node

2+ ( -- * Message sending

3+ sendPayload

4+ , sendBinary

5+ , sendMessage

6+ ) where

8+import Data.Accessor ((^.), (^=))

9+import Data.Binary (Binary, encode)

10+import qualified Data.ByteString.Lazy as BSL (toChunks)

11+import qualified Data.ByteString as BSS (ByteString)

12+import Control.Concurrent.MVar (withMVar, modifyMVar_)

13+import Control.Concurrent.Chan (writeChan)

14+import Control.Monad (unless)

15+import qualified Network.Transport as NT

16+ ( Connection

17+ , send

18+ , defaultConnectHints

19+ , connect

20+ , Reliability(ReliableOrdered)

21+ )

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

23+ ( LocalNode(localState, localEndPoint, localCtrlChan)

24+ , Identifier

25+ , localConnectionBetween

26+ , nodeAddress

27+ , nodeOf

28+ , messageToPayload

29+ , createMessage

30+ , NCMsg(..)

31+ , ProcessSignal(Died)

32+ , DiedReason(DiedDisconnect)

33+ )

34+import Control.Distributed.Process.Serializable (Serializable)

35+

36+--------------------------------------------------------------------------------

37+-- Message sending --

38+--------------------------------------------------------------------------------

39+

40+sendPayload :: LocalNode -> Identifier -> Identifier -> [BSS.ByteString] -> IO ()

41+sendPayload node from to payload = do

42+ mConn <- connBetween node from to

43+ didSend <- case mConn of

44+ Just conn -> do

45+ didSend <- NT.send conn payload

46+ case didSend of

47+ Left _ -> return False

48+ Right _ -> return True

49+ Nothing -> return False

50+ unless didSend $

51+ writeChan (localCtrlChan node) NCMsg

52+ { ctrlMsgSender = to

53+ , ctrlMsgSignal = Died to DiedDisconnect

54+ }

55+

56+sendBinary :: Binary a => LocalNode -> Identifier -> Identifier -> a -> IO ()

57+sendBinary node from to = sendPayload node from to . BSL.toChunks . encode

58+

59+sendMessage :: Serializable a => LocalNode -> Identifier -> Identifier -> a -> IO ()

60+sendMessage node from to = sendPayload node from to . messageToPayload . createMessage

61+

62+setupConnBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)

63+setupConnBetween node from to = do

64+ mConn <- NT.connect endPoint

65+ (nodeAddress . nodeOf $ to)

66+ NT.ReliableOrdered

67+ NT.defaultConnectHints

68+ case mConn of

69+ Right conn -> do

70+ didSend <- NT.send conn (BSL.toChunks . encode $ to)

71+ case didSend of

72+ Left _ ->

73+ return Nothing

74+ Right () -> do

75+ modifyMVar_ nodeState $ return .

76+ (localConnectionBetween from to ^= Just conn)

77+ return $ Just conn

78+ Left _ ->

79+ return Nothing

80+ where

81+ endPoint = localEndPoint node

82+ nodeState = localState node

83+

84+connBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)

85+connBetween node from to = do

86+ mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)

87+ case mConn of

88+ Just conn -> return $ Just conn

89+ Nothing -> setupConnBetween node from to

90+ where

91+ nodeState = localState node

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hsnew file+524

@@ -0,0 +1,524 @@

1+-- | Cloud Haskell primitives

2+--

3+-- We define these in a separate module so that we don't have to rely on

4+-- the closure combinators

5+module Control.Distributed.Process.Internal.Primitives

6+ ( -- * Basic messaging

7+ send

8+ , expect

9+ -- * Channels

10+ , newChan

11+ , sendChan

12+ , receiveChan

13+ , mergePortsBiased

14+ , mergePortsRR

15+ -- * Advanced messaging

16+ , Match

17+ , receiveWait

18+ , receiveTimeout

19+ , match

20+ , matchIf

21+ , matchUnknown

22+ -- * Process management

23+ , terminate

24+ , ProcessTerminationException(..)

25+ , getSelfPid

26+ , getSelfNode

27+ -- * Monitoring and linking

28+ , link

29+ , unlink

30+ , monitor

31+ , unmonitor

32+ -- * Logging

33+ , say

34+ -- * Registry

35+ , register

36+ , unregister

37+ , whereis

38+ , nsend

39+ , registerRemote

40+ , unregisterRemote

41+ , whereisRemote

42+ , whereisRemoteAsync

43+ , nsendRemote

44+ -- * Closures

45+ , unClosure

46+ -- * Auxiliary API

47+ , catch

48+ , expectTimeout

49+ , spawnAsync

50+ , linkNode

51+ , linkPort

52+ , unlinkNode

53+ , unlinkPort

54+ , monitorNode

55+ , monitorPort

56+ ) where

57+

58+#if ! MIN_VERSION_base(4,6,0)

59+import Prelude hiding (catch)

60+#endif

61+

62+import Data.Binary (decode)

63+import Data.Typeable (Typeable, typeOf)

64+import Data.Time.Clock (getCurrentTime)

65+import Data.Time.Format (formatTime)

66+import System.Locale (defaultTimeLocale)

67+import Control.Monad.Reader (ask)

68+import Control.Monad.IO.Class (MonadIO, liftIO)

69+import Control.Applicative ((<$>))

70+import Control.Exception (Exception, throw)

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

72+import Control.Concurrent.MVar (modifyMVar)

73+import Control.Concurrent.Chan (writeChan)

74+import Control.Concurrent.STM

75+ ( STM

76+ , atomically

77+ , orElse

78+ , newTChan

79+ , readTChan

80+ , newTVar

81+ , readTVar

82+ , writeTVar

83+ )

84+import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..))

85+import Control.Distributed.Process.Serializable (Serializable, fingerprint)

86+import Data.Accessor ((^.), (^:), (^=))

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

88+ ( NodeId(..)

89+ , ProcessId(..)

90+ , LocalNode(..)

91+ , LocalProcess(..)

92+ , Process(..)

93+ , Closure(..)

94+ , Message(..)

95+ , MonitorRef(..)

96+ , SpawnRef(..)

97+ , NCMsg(..)

98+ , ProcessSignal(..)

99+ , monitorCounter

100+ , spawnCounter

101+ , Closure(..)

102+ , SendPort(..)

103+ , ReceivePort(..)

104+ , channelCounter

105+ , typedChannelWithId

106+ , TypedChannel(..)

107+ , SendPortId(..)

108+ , Identifier(..)

109+ , DidUnmonitor(..)

110+ , DidUnlinkProcess(..)

111+ , DidUnlinkNode(..)

112+ , DidUnlinkPort(..)

113+ , WhereIsReply(..)

114+ , createMessage

115+ , Static(..)

116+ , runLocalProcess

117+ )

118+import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)

119+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

120+import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)

121+

122+--------------------------------------------------------------------------------

123+-- Basic messaging --

124+--------------------------------------------------------------------------------

125+

126+-- | Send a message

127+send :: Serializable a => ProcessId -> a -> Process ()

128+-- This requires a lookup on every send. If we want to avoid that we need to

129+-- modify serializable to allow for stateful (IO) deserialization

130+send them msg = do

131+ proc <- ask

132+ liftIO $ sendMessage (processNode proc)

133+ (ProcessIdentifier (processId proc))

134+ (ProcessIdentifier them)

135+ msg

136+

137+-- | Wait for a message of a specific type

138+expect :: forall a. Serializable a => Process a

139+expect = receiveWait [match return]

140+

141+--------------------------------------------------------------------------------

142+-- Channels --

143+--------------------------------------------------------------------------------

144+

145+-- | Create a new typed channel

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

147+newChan = do

148+ proc <- ask

149+ liftIO . modifyMVar (processState proc) $ \st -> do

150+ chan <- liftIO . atomically $ newTChan

151+ let lcid = st ^. channelCounter

152+ cid = SendPortId { sendPortProcessId = processId proc

153+ , sendPortLocalId = lcid

154+ }

155+ sport = SendPort cid

156+ rport = ReceivePortSingle chan

157+ tch = TypedChannel chan

158+ return ( (channelCounter ^: (+ 1))

159+ . (typedChannelWithId lcid ^= Just tch)

160+ $ st

161+ , (sport, rport)

162+ )

163+

164+-- | Send a message on a typed channel

165+sendChan :: Serializable a => SendPort a -> a -> Process ()

166+sendChan (SendPort cid) msg = do

167+ proc <- ask

168+ liftIO $ sendBinary (processNode proc)

169+ (ProcessIdentifier (processId proc))

170+ (SendPortIdentifier cid)

171+ msg

172+

173+-- | Wait for a message on a typed channel

174+receiveChan :: Serializable a => ReceivePort a -> Process a

175+receiveChan = liftIO . atomically . receiveSTM

176+ where

177+ receiveSTM :: ReceivePort a -> STM a

178+ receiveSTM (ReceivePortSingle c) =

179+ readTChan c

180+ receiveSTM (ReceivePortBiased ps) =

181+ foldr1 orElse (map receiveSTM ps)

182+ receiveSTM (ReceivePortRR psVar) = do

183+ ps <- readTVar psVar

184+ a <- foldr1 orElse (map receiveSTM ps)

185+ writeTVar psVar (rotate ps)

186+ return a

187+

188+ rotate :: [a] -> [a]

189+ rotate [] = []

190+ rotate (x:xs) = xs ++ [x]

191+

192+-- | Merge a list of typed channels.

193+--

194+-- The result port is left-biased: if there are messages available on more

195+-- than one port, the first available message is returned.

196+mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)

197+mergePortsBiased = return . ReceivePortBiased

198+

199+-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than

200+-- left-biased)

201+mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)

202+mergePortsRR ps = liftIO . atomically $ ReceivePortRR <$> newTVar ps

203+

204+--------------------------------------------------------------------------------

205+-- Advanced messaging --

206+--------------------------------------------------------------------------------

207+

208+-- | Opaque type used in 'receiveWait' and 'receiveTimeout'

209+newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }

210+

211+-- | Test the matches in order against each message in the queue

212+receiveWait :: [Match b] -> Process b

213+receiveWait ms = do

214+ queue <- processQueue <$> ask

215+ Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)

216+ proc

217+

218+-- | Like 'receiveWait' but with a timeout.

219+--

220+-- If the timeout is zero do a non-blocking check for matching messages. A

221+-- non-zero timeout is applied only when waiting for incoming messages (that is,

222+-- /after/ we have checked the messages that are already in the mailbox).

223+receiveTimeout :: Int -> [Match b] -> Process (Maybe b)

224+receiveTimeout t ms = do

225+ queue <- processQueue <$> ask

226+ let blockSpec = if t == 0 then NonBlocking else Timeout t

227+ mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)

228+ case mProc of

229+ Nothing -> return Nothing

230+ Just proc -> Just <$> proc

231+

232+-- | Match against any message of the right type

233+match :: forall a b. Serializable a => (a -> Process b) -> Match b

234+match = matchIf (const True)

235+

236+-- | Match against any message of the right type that satisfies a predicate

237+matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b

238+matchIf c p = Match $ \msg ->

239+ let decoded :: a

240+ decoded = decode . messageEncoding $ msg in

241+ if messageFingerprint msg == fingerprint (undefined :: a) && c decoded

242+ then Just $ p decoded

243+ else Nothing

244+

245+-- | Remove any message from the queue

246+matchUnknown :: Process b -> Match b

247+matchUnknown = Match . const . Just

248+

249+--------------------------------------------------------------------------------

250+-- Process management --

251+--------------------------------------------------------------------------------

252+

253+-- | Thrown by 'terminate'

254+data ProcessTerminationException = ProcessTerminationException

255+ deriving (Show, Typeable)

256+

257+instance Exception ProcessTerminationException

258+

259+-- | Terminate (throws a ProcessTerminationException)

260+terminate :: Process a

261+terminate = liftIO $ throw ProcessTerminationException

262+

263+-- | Our own process ID

264+getSelfPid :: Process ProcessId

265+getSelfPid = processId <$> ask

266+

267+-- | Get the node ID of our local node

268+getSelfNode :: Process NodeId

269+getSelfNode = localNodeId . processNode <$> ask

270+

271+--------------------------------------------------------------------------------

272+-- Monitoring and linking --

273+--------------------------------------------------------------------------------

274+

275+-- | Link to a remote process (asynchronous)

276+--

277+-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').

278+-- Linking makes no distinction between normal and abnormal termination of

279+-- the remote process.

280+link :: ProcessId -> Process ()

281+link = sendCtrlMsg Nothing . Link . ProcessIdentifier

282+

283+-- | Monitor another process (asynchronous)

284+monitor :: ProcessId -> Process MonitorRef

285+monitor = monitor' . ProcessIdentifier

286+

287+-- | Remove a link (synchronous)

288+unlink :: ProcessId -> Process ()

289+unlink pid = do

290+ unlinkAsync pid

291+ receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)

292+ (\_ -> return ())

293+ ]

294+

295+-- | Remove a node link (synchronous)

296+unlinkNode :: NodeId -> Process ()

297+unlinkNode nid = do

298+ unlinkNodeAsync nid

299+ receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)

300+ (\_ -> return ())

301+ ]

302+

303+-- | Remove a channel (send port) link (synchronous)

304+unlinkPort :: SendPort a -> Process ()

305+unlinkPort sport = do

306+ unlinkPortAsync sport

307+ receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)

308+ (\_ -> return ())

309+ ]

310+

311+-- | Remove a monitor (synchronous)

312+unmonitor :: MonitorRef -> Process ()

313+unmonitor ref = do

314+ unmonitorAsync ref

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

316+ (\_ -> return ())

317+ ]

318+

319+--------------------------------------------------------------------------------

320+-- Auxiliary API --

321+--------------------------------------------------------------------------------

322+

323+-- | Catch exceptions within a process

324+catch :: Exception e => Process a -> (e -> Process a) -> Process a

325+catch p h = do

326+ lproc <- ask

327+ liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

328+

329+-- | Like 'expect' but with a timeout

330+expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)

331+expectTimeout timeout = receiveTimeout timeout [match return]

332+

333+-- | Asynchronous version of 'spawn'

334+--

335+-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')

336+spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef

337+spawnAsync nid proc = do

338+ spawnRef <- getSpawnRef

339+ sendCtrlMsg (Just nid) $ Spawn proc spawnRef

340+ return spawnRef

341+

342+-- | Monitor a node

343+monitorNode :: NodeId -> Process MonitorRef

344+monitorNode =

345+ monitor' . NodeIdentifier

346+

347+-- | Monitor a typed channel

348+monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef

349+monitorPort (SendPort cid) =

350+ monitor' (SendPortIdentifier cid)

351+

352+-- | Remove a monitor (asynchronous)

353+unmonitorAsync :: MonitorRef -> Process ()

354+unmonitorAsync =

355+ sendCtrlMsg Nothing . Unmonitor

356+

357+-- | Link to a node

358+linkNode :: NodeId -> Process ()

359+linkNode = link' . NodeIdentifier

360+

361+-- | Link to a channel (send port)

362+linkPort :: SendPort a -> Process ()

363+linkPort (SendPort cid) =

364+ link' (SendPortIdentifier cid)

365+

366+-- | Remove a process link (asynchronous)

367+unlinkAsync :: ProcessId -> Process ()

368+unlinkAsync =

369+ sendCtrlMsg Nothing . Unlink . ProcessIdentifier

370+

371+-- | Remove a node link (asynchronous)

372+unlinkNodeAsync :: NodeId -> Process ()

373+unlinkNodeAsync =

374+ sendCtrlMsg Nothing . Unlink . NodeIdentifier

375+

376+-- | Remove a channel (send port) link (asynchronous)

377+unlinkPortAsync :: SendPort a -> Process ()

378+unlinkPortAsync (SendPort cid) =

379+ sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid

380+

381+--------------------------------------------------------------------------------

382+-- Logging --

383+--------------------------------------------------------------------------------

384+

385+-- | Log a string

386+--

387+-- @say message@ sends a message (time, pid of the current process, message)

388+-- to the process registered as 'logger'. By default, this process simply

389+-- sends the string to 'stderr'. Individual Cloud Haskell backends might

390+-- replace this with a different logger process, however.

391+say :: String -> Process ()

392+say string = do

393+ now <- liftIO getCurrentTime

394+ us <- getSelfPid

395+ nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

396+

397+--------------------------------------------------------------------------------

398+-- Registry --

399+--------------------------------------------------------------------------------

400+

401+-- | Register a process with the local registry (asynchronous).

402+--

403+-- The process to be registered does not have to be local itself.

404+register :: String -> ProcessId -> Process ()

405+register label pid =

406+ sendCtrlMsg Nothing (Register label (Just pid))

407+

408+-- | Register a process with a remote registry (asynchronous).

409+--

410+-- The process to be registered does not have to live on the same remote node.

411+registerRemote :: NodeId -> String -> ProcessId -> Process ()

412+registerRemote nid label pid =

413+ sendCtrlMsg (Just nid) (Register label (Just pid))

414+

415+-- | Remove a process from the local registry (asynchronous).

416+unregister :: String -> Process ()

417+unregister label =

418+ sendCtrlMsg Nothing (Register label Nothing)

419+

420+-- | Remove a process from a remote registry (asynchronous).

421+unregisterRemote :: NodeId -> String -> Process ()

422+unregisterRemote nid label =

423+ sendCtrlMsg (Just nid) (Register label Nothing)

424+

425+-- | Query the local process registry (synchronous).

426+whereis :: String -> Process (Maybe ProcessId)

427+whereis label = do

428+ sendCtrlMsg Nothing (WhereIs label)

429+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')

430+ (\(WhereIsReply _ mPid) -> return mPid)

431+ ]

432+

433+-- | Query a remote process registry (synchronous)

434+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)

435+whereisRemote nid label = do

436+ whereisRemoteAsync nid label

437+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')

438+ (\(WhereIsReply _ mPid) -> return mPid)

439+ ]

440+

441+-- | Query a remote process registry (asynchronous)

442+--

443+-- Reply will come in the form of a 'WhereIsReply' message

444+whereisRemoteAsync :: NodeId -> String -> Process ()

445+whereisRemoteAsync nid label =

446+ sendCtrlMsg (Just nid) (WhereIs label)

447+

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

449+nsend :: Serializable a => String -> a -> Process ()

450+nsend label msg =

451+ sendCtrlMsg Nothing (NamedSend label (createMessage msg))

452+

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

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

455+nsendRemote nid label msg =

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

457+

458+--------------------------------------------------------------------------------

459+-- Closures --

460+--------------------------------------------------------------------------------

461+

462+-- | Deserialize a closure

463+unClosure :: forall a. Typeable a => Closure a -> Process a

464+unClosure (Closure (Static label) env) = do

465+ rtable <- remoteTable . processNode <$> ask

466+ case resolveClosure rtable label env of

467+ Nothing -> throw . userError $ "Unregistered closure " ++ show label

468+ Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

469+ where

470+ typeError dyn = userError $ "lookupStatic type error: "

471+ ++ "cannot match " ++ show (dynTypeRep dyn)

472+ ++ " against " ++ show (typeOf (undefined :: a))

473+

474+--------------------------------------------------------------------------------

475+-- Auxiliary functions --

476+--------------------------------------------------------------------------------

477+

478+getMonitorRefFor :: Identifier -> Process MonitorRef

479+getMonitorRefFor ident = do

480+ proc <- ask

481+ liftIO $ modifyMVar (processState proc) $ \st -> do

482+ let counter = st ^. monitorCounter

483+ return ( monitorCounter ^: (+ 1) $ st

484+ , MonitorRef ident counter

485+ )

486+

487+getSpawnRef :: Process SpawnRef

488+getSpawnRef = do

489+ proc <- ask

490+ liftIO $ modifyMVar (processState proc) $ \st -> do

491+ let counter = st ^. spawnCounter

492+ return ( spawnCounter ^: (+ 1) $ st

493+ , SpawnRef counter

494+ )

495+

496+-- | Monitor a process/node/channel

497+monitor' :: Identifier -> Process MonitorRef

498+monitor' ident = do

499+ monitorRef <- getMonitorRefFor ident

500+ sendCtrlMsg Nothing $ Monitor monitorRef

501+ return monitorRef

502+

503+-- | Link to a process/node/channel

504+link' :: Identifier -> Process ()

505+link' = sendCtrlMsg Nothing . Link

506+

507+-- Send a control message

508+sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node

509+ -> ProcessSignal -- ^ Message to send

510+ -> Process ()

511+sendCtrlMsg mNid signal = do

512+ proc <- ask

513+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)

514+ , ctrlMsgSignal = signal

515+ }

516+ case mNid of

517+ Nothing -> do

518+ ctrlChan <- localCtrlChan . processNode <$> ask

519+ liftIO $ writeChan ctrlChan msg

520+ Just nid ->

521+ liftIO $ sendBinary (processNode proc)

522+ (ProcessIdentifier (processId proc))

523+ (NodeIdentifier nid)

524+ msg

distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hsnew file+33

@@ -0,0 +1,33 @@

1+-- | 'Binary' instances for 'TypeRep', and 'TypeRep' equality (bug workaround)

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where

5+import Control.Applicative ((<$>), (<*>))

6+import Data.Binary (Binary(get, put))

7+import Data.Typeable.Internal (TypeRep(..), TyCon(..))

8+import GHC.Fingerprint.Type (Fingerprint(..))

10+instance Binary Fingerprint where

11+ put (Fingerprint hi lo) = put hi >> put lo

12+ get = Fingerprint <$> get <*> get

13+

14+instance Binary TypeRep where

15+ put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts

16+ get = TypeRep <$> get <*> get <*> get

17+

18+instance Binary TyCon where

19+ put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name

20+ get = TyCon <$> get <*> get <*> get <*> get

21+

22+-- | Compare two type representations

23+--

24+-- For base >= 4.6 this compares fingerprints, but older versions of base

25+-- have a bug in the fingerprint construction

26+-- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)

27+compareTypeRep :: TypeRep -> TypeRep -> Bool

28+#if ! MIN_VERSION_base(4,6,0)

29+compareTypeRep (TypeRep _ con ts) (TypeRep _ con' ts')

30+ = con == con' && all (uncurry compareTypeRep) (zip ts ts')

31+#else

32+compareTypeRep = (==)

33+#endif

distributed-process/src/Control/Distributed/Process/Internal/Types.hsnew file+602

@@ -0,0 +1,602 @@

1+-- | Types used throughout the Cloud Haskell framework

2+--

3+-- We collect all types used internally in a single module because

4+-- many of these data types are mutually recursive and cannot be split across

5+-- modules.

6+{-# LANGUAGE MagicHash #-}

7+module Control.Distributed.Process.Internal.Types

8+ ( -- * Node and process identifiers

9+ NodeId(..)

10+ , LocalProcessId(..)

11+ , ProcessId(..)

12+ , Identifier(..)

13+ , nodeOf

14+ -- * Local nodes and processes

15+ , LocalNode(..)

16+ , LocalNodeState(..)

17+ , LocalProcess(..)

18+ , LocalProcessState(..)

19+ , Process(..)

20+ , runLocalProcess

21+ -- * Typed channels

22+ , LocalSendPortId

23+ , SendPortId(..)

24+ , TypedChannel(..)

25+ , SendPort(..)

26+ , ReceivePort(..)

27+ -- * Closures

28+ , StaticLabel(..)

29+ , Static(..)

30+ , staticApply

31+ , staticDuplicate

32+ , staticTypeOf

33+ , typeOfStaticLabel

34+ , Closure(..)

35+ , RemoteTable(..)

36+ , SerializableDict(..)

37+ -- * Messages

38+ , Message(..)

39+ , createMessage

40+ , messageToPayload

41+ , payloadToMessage

42+ -- * Node controller user-visible data types

43+ , MonitorRef(..)

44+ , ProcessMonitorNotification(..)

45+ , NodeMonitorNotification(..)

46+ , PortMonitorNotification(..)

47+ , ProcessLinkException(..)

48+ , NodeLinkException(..)

49+ , PortLinkException(..)

50+ , DiedReason(..)

51+ , DidUnmonitor(..)

52+ , DidUnlinkProcess(..)

53+ , DidUnlinkNode(..)

54+ , DidUnlinkPort(..)

55+ , SpawnRef(..)

56+ , DidSpawn(..)

57+ , WhereIsReply(..)

58+ -- * Node controller internal data types

59+ , NCMsg(..)

60+ , ProcessSignal(..)

61+ -- * Accessors

62+ , localProcesses

63+ , localPidCounter

64+ , localPidUnique

65+ , localConnections

66+ , localProcessWithId

67+ , localConnectionBetween

68+ , monitorCounter

69+ , spawnCounter

70+ , channelCounter

71+ , typedChannels

72+ , typedChannelWithId

73+ , remoteTableLabels

74+ , remoteTableLabel

75+ ) where

76+

77+import Data.Map (Map)

78+import Data.Int (Int32)

79+import Data.Maybe (fromJust)

80+import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)

81+import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

82+import qualified Data.ByteString as BSS (ByteString, concat)

83+import qualified Data.ByteString.Lazy as BSL

84+ ( ByteString

85+ , toChunks

86+ , splitAt

87+ , fromChunks

88+ )

89+import Data.Accessor (Accessor, accessor)

90+import qualified Data.Accessor.Container as DAC (mapMaybe)

91+import Control.Category ((>>>))

92+import Control.Exception (Exception)

93+import Control.Concurrent (ThreadId)

94+import Control.Concurrent.MVar (MVar)

95+import Control.Concurrent.Chan (Chan)

96+import Control.Concurrent.STM (TChan, TVar)

97+import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

98+import Control.Applicative (Applicative, (<$>), (<*>))

99+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

100+import Control.Monad.IO.Class (MonadIO)

101+import Control.Distributed.Process.Serializable

102+ ( Fingerprint

103+ , Serializable

104+ , fingerprint

105+ , encodeFingerprint

106+ , sizeOfFingerprint

107+ , decodeFingerprint

108+ , showFingerprint

109+ )

110+import Control.Distributed.Process.Internal.CQueue (CQueue)

111+import Control.Distributed.Process.Internal.Dynamic (Dynamic)

112+import Control.Distributed.Process.Internal.TypeRep () -- Binary instances

113+

114+--------------------------------------------------------------------------------

115+-- Node and process identifiers --

116+--------------------------------------------------------------------------------

117+

118+-- | Node identifier

119+newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }

120+ deriving (Eq, Ord, Binary)

121+

122+instance Show NodeId where

123+ show (NodeId addr) = "nid://" ++ show addr

124+

125+-- | A local process ID consists of a seed which distinguishes processes from

126+-- different instances of the same local node and a counter

127+data LocalProcessId = LocalProcessId

128+ { lpidUnique :: Int32

129+ , lpidCounter :: Int32

130+ }

131+ deriving (Eq, Ord, Typeable, Show)

132+

133+-- | Process identifier

134+data ProcessId = ProcessId

135+ { -- | The ID of the node the process is running on

136+ processNodeId :: NodeId

137+ -- | Node-local identifier for the process

138+ , processLocalId :: LocalProcessId

139+ }

140+ deriving (Eq, Ord, Typeable)

141+

142+instance Show ProcessId where

143+ show (ProcessId (NodeId addr) (LocalProcessId _ lid))

144+ = "pid://" ++ show addr ++ ":" ++ show lid

145+

146+-- | Union of all kinds of identifiers

147+data Identifier =

148+ NodeIdentifier NodeId

149+ | ProcessIdentifier ProcessId

150+ | SendPortIdentifier SendPortId

151+ deriving (Eq, Ord)

152+

153+instance Show Identifier where

154+ show (NodeIdentifier nid) = show nid

155+ show (ProcessIdentifier pid) = show pid

156+ show (SendPortIdentifier cid) = show cid

157+

158+nodeOf :: Identifier -> NodeId

159+nodeOf (NodeIdentifier nid) = nid

160+nodeOf (ProcessIdentifier pid) = processNodeId pid

161+nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)

162+

163+--------------------------------------------------------------------------------

164+-- Local nodes and processes --

165+--------------------------------------------------------------------------------

166+

167+-- | Local nodes

168+data LocalNode = LocalNode

169+ { -- | 'NodeId' of the node

170+ localNodeId :: NodeId

171+ -- | The network endpoint associated with this node

172+ , localEndPoint :: NT.EndPoint

173+ -- | Local node state

174+ , localState :: MVar LocalNodeState

175+ -- | Channel for the node controller

176+ , localCtrlChan :: Chan NCMsg

177+ -- | Runtime lookup table for supporting closures

178+ -- TODO: this should be part of the CH state, not the local endpoint state

179+ , remoteTable :: RemoteTable

180+ }

181+

182+-- | Local node state

183+data LocalNodeState = LocalNodeState

184+ { _localProcesses :: Map LocalProcessId LocalProcess

185+ , _localPidCounter :: Int32

186+ , _localPidUnique :: Int32

187+ , _localConnections :: Map (Identifier, Identifier) NT.Connection

188+ }

189+

190+-- | Processes running on our local node

191+data LocalProcess = LocalProcess

192+ { processQueue :: CQueue Message

193+ , processId :: ProcessId

194+ , processState :: MVar LocalProcessState

195+ , processThread :: ThreadId

196+ , processNode :: LocalNode

197+ }

198+

199+-- | Deconstructor for 'Process' (not exported to the public API)

200+runLocalProcess :: LocalProcess -> Process a -> IO a

201+runLocalProcess lproc proc = runReaderT (unProcess proc) lproc

202+

203+-- | Local process state

204+data LocalProcessState = LocalProcessState

205+ { _monitorCounter :: Int32

206+ , _spawnCounter :: Int32

207+ , _channelCounter :: Int32

208+ , _typedChannels :: Map LocalSendPortId TypedChannel

209+ }

210+

211+-- | The Cloud Haskell 'Process' type

212+newtype Process a = Process {

213+ unProcess :: ReaderT LocalProcess IO a

214+ }

215+ deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)

216+

217+--------------------------------------------------------------------------------

218+-- Typed channels --

219+--------------------------------------------------------------------------------

220+

221+type LocalSendPortId = Int32

222+

223+-- | A send port is identified by a SendPortId.

224+--

225+-- You cannot send directly to a SendPortId; instead, use 'newChan'

226+-- to create a SendPort.

227+data SendPortId = SendPortId {

228+ -- | The ID of the process that will receive messages sent on this port

229+ sendPortProcessId :: ProcessId

230+ -- | Process-local ID of the channel

231+ , sendPortLocalId :: LocalSendPortId

232+ }

233+ deriving (Eq, Ord)

234+

235+instance Show SendPortId where

236+ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)

237+ = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid

238+

239+data TypedChannel = forall a. Serializable a => TypedChannel (TChan a)

240+

241+-- | The send send of a typed channel (serializable)

242+newtype SendPort a = SendPort {

243+ -- | The (unique) ID of this send port

244+ sendPortId :: SendPortId

245+ }

246+ deriving (Typeable, Binary, Show, Eq, Ord)

247+

248+-- | The receive end of a typed channel (not serializable)

249+data ReceivePort a =

250+ -- | A single receive port

251+ ReceivePortSingle (TChan a)

252+ -- | A left-biased combination of receive ports

253+ | ReceivePortBiased [ReceivePort a]

254+ -- | A round-robin combination of receive ports

255+ | ReceivePortRR (TVar [ReceivePort a])

256+ deriving Typeable

257+

258+--------------------------------------------------------------------------------

259+-- Closures --

260+--------------------------------------------------------------------------------

261+

262+data StaticLabel =

263+ StaticLabel String TypeRep

264+ | StaticApply StaticLabel StaticLabel

265+ | StaticDuplicate StaticLabel TypeRep

266+ deriving (Typeable, Show)

267+

268+-- | A static value is top-level bound or the application of two static values

269+newtype Static a = Static StaticLabel

270+ deriving (Typeable, Show)

271+

272+-- | Apply two static values

273+staticApply :: Static (a -> b) -> Static a -> Static b

274+staticApply (Static f) (Static x) = Static (StaticApply f x)

275+

276+-- | Co-monadic 'duplicate' for static values

277+staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)

278+staticDuplicate (Static x) =

279+ Static (StaticDuplicate x (typeOf (undefined :: Static a)))

280+

281+staticTypeOf :: forall a. Typeable a => a -> Static a

282+staticTypeOf _ = Static (StaticLabel "undefined" (typeOf (undefined :: a)))

283+

284+typeOfStaticLabel :: StaticLabel -> TypeRep

285+typeOfStaticLabel (StaticLabel _ typ)

286+ = typ

287+typeOfStaticLabel (StaticApply f x)

288+ = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)

289+typeOfStaticLabel (StaticDuplicate _ typ)

290+ = typ

291+

292+-- | A closure is a static value and an encoded environment

293+data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString

294+ deriving (Typeable, Show)

295+

296+-- | Runtime dictionary for 'unstatic' lookups

297+data RemoteTable = RemoteTable {

298+ _remoteTableLabels :: Map String Dynamic

299+ }

300+

301+-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

302+data SerializableDict a where

303+ SerializableDict :: Serializable a => SerializableDict a

304+ deriving (Typeable)

305+

306+--------------------------------------------------------------------------------

307+-- Messages --

308+--------------------------------------------------------------------------------

309+

310+-- | Messages consist of their typeRep fingerprint and their encoding

311+data Message = Message

312+ { messageFingerprint :: Fingerprint

313+ , messageEncoding :: BSL.ByteString

314+ }

315+

316+instance Show Message where

317+ show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []

318+

319+-- | Turn any serialiable term into a message

320+createMessage :: Serializable a => a -> Message

321+createMessage a = Message (fingerprint a) (encode a)

322+

323+-- | Serialize a message

324+messageToPayload :: Message -> [BSS.ByteString]

325+messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc

326+

327+-- | Deserialize a message

328+payloadToMessage :: [BSS.ByteString] -> Message

329+payloadToMessage payload = Message fp msg

330+ where

331+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)

332+ $ BSL.fromChunks payload

333+ fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp

334+

335+--------------------------------------------------------------------------------

336+-- Node controller user-visible data types --

337+--------------------------------------------------------------------------------

338+

339+-- | MonitorRef is opaque for regular Cloud Haskell processes

340+data MonitorRef = MonitorRef

341+ { -- | ID of the entity to be monitored

342+ monitorRefIdent :: Identifier

343+ -- | Unique to distinguish multiple monitor requests by the same process

344+ , monitorRefCounter :: Int32

345+ }

346+ deriving (Eq, Ord, Show)

347+

348+-- | Message sent by process monitors

349+data ProcessMonitorNotification =

350+ ProcessMonitorNotification MonitorRef ProcessId DiedReason

351+ deriving (Typeable, Show)

352+

353+-- | Message sent by node monitors

354+data NodeMonitorNotification =

355+ NodeMonitorNotification MonitorRef NodeId DiedReason

356+ deriving (Typeable, Show)

357+

358+-- | Message sent by channel (port) monitors

359+data PortMonitorNotification =

360+ PortMonitorNotification MonitorRef SendPortId DiedReason

361+ deriving (Typeable, Show)

362+

363+-- | Exceptions thrown when a linked process dies

364+data ProcessLinkException =

365+ ProcessLinkException ProcessId DiedReason

366+ deriving (Typeable, Show)

367+

368+-- | Exception thrown when a linked node dies

369+data NodeLinkException =

370+ NodeLinkException NodeId DiedReason

371+ deriving (Typeable, Show)

372+

373+-- | Exception thrown when a linked channel (port) dies

374+data PortLinkException =

375+ PortLinkException SendPortId DiedReason

376+ deriving (Typeable, Show)

377+

378+instance Exception ProcessLinkException

379+instance Exception NodeLinkException

380+instance Exception PortLinkException

381+

382+-- | Why did a process die?

383+data DiedReason =

384+ -- | Normal termination

385+ DiedNormal

386+ -- | The process exited with an exception

387+ -- (provided as 'String' because 'Exception' does not implement 'Binary')

388+ | DiedException String

389+ -- | We got disconnected from the process node

390+ | DiedDisconnect

391+ -- | The process node died

392+ | DiedNodeDown

393+ -- | Invalid (process/node/channel) identifier

394+ | DiedUnknownId

395+ deriving (Show, Eq)

396+

397+-- | (Asynchronous) reply from unmonitor

398+newtype DidUnmonitor = DidUnmonitor MonitorRef

399+ deriving (Typeable, Binary)

400+

401+-- | (Asynchronous) reply from unlink

402+newtype DidUnlinkProcess = DidUnlinkProcess ProcessId

403+ deriving (Typeable, Binary)

404+

405+-- | (Asynchronous) reply from unlinkNode

406+newtype DidUnlinkNode = DidUnlinkNode NodeId

407+ deriving (Typeable, Binary)

408+

409+-- | (Asynchronous) reply from unlinkPort

410+newtype DidUnlinkPort = DidUnlinkPort SendPortId

411+ deriving (Typeable, Binary)

412+

413+-- | 'SpawnRef' are used to return pids of spawned processes

414+newtype SpawnRef = SpawnRef Int32

415+ deriving (Show, Binary, Typeable, Eq)

416+

417+-- | (Asynchronius) reply from 'spawn'

418+data DidSpawn = DidSpawn SpawnRef ProcessId

419+ deriving (Show, Typeable)

420+

421+-- | (Asynchronous) reply from 'whereis'

422+data WhereIsReply = WhereIsReply String (Maybe ProcessId)

423+ deriving (Show, Typeable)

424+

425+--------------------------------------------------------------------------------

426+-- Node controller internal data types --

427+--------------------------------------------------------------------------------

428+

429+-- | Messages to the node controller

430+data NCMsg = NCMsg

431+ { ctrlMsgSender :: Identifier

432+ , ctrlMsgSignal :: ProcessSignal

433+ }

434+ deriving Show

435+

436+-- | Signals to the node controller (see 'NCMsg')

437+data ProcessSignal =

438+ Link Identifier

439+ | Unlink Identifier

440+ | Monitor MonitorRef

441+ | Unmonitor MonitorRef

442+ | Died Identifier DiedReason

443+ | Spawn (Closure (Process ())) SpawnRef

444+ | WhereIs String

445+ | Register String (Maybe ProcessId) -- Nothing to unregister

446+ | NamedSend String Message

447+ deriving Show

448+

449+--------------------------------------------------------------------------------

450+-- Binary instances --

451+--------------------------------------------------------------------------------

452+

453+instance Binary LocalProcessId where

454+ put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)

455+ get = LocalProcessId <$> get <*> get

456+

457+instance Binary ProcessId where

458+ put pid = put (processNodeId pid) >> put (processLocalId pid)

459+ get = ProcessId <$> get <*> get

460+

461+instance Binary ProcessMonitorNotification where

462+ put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason

463+ get = ProcessMonitorNotification <$> get <*> get <*> get

464+

465+instance Binary NodeMonitorNotification where

466+ put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason

467+ get = NodeMonitorNotification <$> get <*> get <*> get

468+

469+instance Binary PortMonitorNotification where

470+ put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason

471+ get = PortMonitorNotification <$> get <*> get <*> get

472+

473+instance Binary NCMsg where

474+ put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)

475+ get = NCMsg <$> get <*> get

476+

477+instance Binary MonitorRef where

478+ put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)

479+ get = MonitorRef <$> get <*> get

480+

481+instance Binary ProcessSignal where

482+ put (Link pid) = putWord8 0 >> put pid

483+ put (Unlink pid) = putWord8 1 >> put pid

484+ put (Monitor ref) = putWord8 2 >> put ref

485+ put (Unmonitor ref) = putWord8 3 >> put ref

486+ put (Died who reason) = putWord8 4 >> put who >> put reason

487+ put (Spawn proc ref) = putWord8 5 >> put proc >> put ref

488+ put (WhereIs label) = putWord8 6 >> put label

489+ put (Register label pid) = putWord8 7 >> put label >> put pid

490+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

491+ get = do

492+ header <- getWord8

493+ case header of

494+ 0 -> Link <$> get

495+ 1 -> Unlink <$> get

496+ 2 -> Monitor <$> get

497+ 3 -> Unmonitor <$> get

498+ 4 -> Died <$> get <*> get

499+ 5 -> Spawn <$> get <*> get

500+ 6 -> WhereIs <$> get

501+ 7 -> Register <$> get <*> get

502+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

503+ _ -> fail "ProcessSignal.get: invalid"

504+

505+instance Binary DiedReason where

506+ put DiedNormal = putWord8 0

507+ put (DiedException e) = putWord8 1 >> put e

508+ put DiedDisconnect = putWord8 2

509+ put DiedNodeDown = putWord8 3

510+ put DiedUnknownId = putWord8 4

511+ get = do

512+ header <- getWord8

513+ case header of

514+ 0 -> return DiedNormal

515+ 1 -> DiedException <$> get

516+ 2 -> return DiedDisconnect

517+ 3 -> return DiedNodeDown

518+ 4 -> return DiedUnknownId

519+ _ -> fail "DiedReason.get: invalid"

520+

521+instance Binary (Closure a) where

522+ put (Closure (Static label) env) = put label >> put env

523+ get = Closure <$> (Static <$> get) <*> get

524+

525+instance Binary DidSpawn where

526+ put (DidSpawn ref pid) = put ref >> put pid

527+ get = DidSpawn <$> get <*> get

528+

529+instance Binary SendPortId where

530+ put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)

531+ get = SendPortId <$> get <*> get

532+

533+instance Binary Identifier where

534+ put (ProcessIdentifier pid) = putWord8 0 >> put pid

535+ put (NodeIdentifier nid) = putWord8 1 >> put nid

536+ put (SendPortIdentifier cid) = putWord8 2 >> put cid

537+ get = do

538+ header <- getWord8

539+ case header of

540+ 0 -> ProcessIdentifier <$> get

541+ 1 -> NodeIdentifier <$> get

542+ 2 -> SendPortIdentifier <$> get

543+ _ -> fail "Identifier.get: invalid"

544+

545+instance Binary StaticLabel where

546+ put (StaticLabel string typ) = putWord8 0 >> put string >> put typ

547+ put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2

548+ put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ

549+ get = do

550+ header <- getWord8

551+ case header of

552+ 0 -> StaticLabel <$> get <*> get

553+ 1 -> StaticApply <$> get <*> get

554+ 2 -> StaticDuplicate <$> get <*> get

555+ _ -> fail "StaticLabel.get: invalid"

556+

557+instance Binary WhereIsReply where

558+ put (WhereIsReply label mPid) = put label >> put mPid

559+ get = WhereIsReply <$> get <*> get

560+

561+--------------------------------------------------------------------------------

562+-- Accessors --

563+--------------------------------------------------------------------------------

564+

565+localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)

566+localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })

567+

568+localPidCounter :: Accessor LocalNodeState Int32

569+localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })

570+

571+localPidUnique :: Accessor LocalNodeState Int32

572+localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })

573+

574+localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) NT.Connection)

575+localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })

576+

577+localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)

578+localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid

579+

580+localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe NT.Connection)

581+localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)

582+

583+monitorCounter :: Accessor LocalProcessState Int32

584+monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })

585+

586+spawnCounter :: Accessor LocalProcessState Int32

587+spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })

588+

589+channelCounter :: Accessor LocalProcessState LocalSendPortId

590+channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })

591+

592+typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)

593+typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })

594+

595+typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)

596+typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid

597+

598+remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)

599+remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })

600+

601+remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)

602+remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label

distributed-process/src/Control/Distributed/Process/Node.hsnew file+722

@@ -0,0 +1,722 @@

1+-- | Local nodes

2+module Control.Distributed.Process.Node

3+ ( LocalNode

4+ , newLocalNode

5+ , closeLocalNode

6+ , forkProcess

7+ , runProcess

8+ , initRemoteTable

9+ , localNodeId

10+ ) where

11+

12+

13+#if ! MIN_VERSION_base(4,6,0)

14+import Prelude hiding (catch)

15+#endif

16+

17+import System.IO (fixIO, hPutStrLn, stderr)

18+import qualified Data.ByteString.Lazy as BSL (fromChunks)

19+import Data.Binary (decode)

20+import Data.Map (Map)

21+import qualified Data.Map as Map

22+ ( empty

23+ , lookup

24+ , insert

25+ , delete

26+ , toList

27+ , partitionWithKey

28+ , filterWithKey

29+ )

30+import qualified Data.List as List (delete, (\\))

31+import Data.Set (Set)

32+import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)

33+import Data.Foldable (forM_)

34+import Data.Maybe (isJust, fromMaybe)

35+import Data.Typeable (Typeable)

36+import Control.Category ((>>>))

37+import Control.Applicative ((<$>))

38+import Control.Monad (void, when, forever)

39+import Control.Monad.IO.Class (MonadIO, liftIO)

40+import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)

41+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)

42+import Control.Exception (throwIO, SomeException, Exception, throwTo)

43+import qualified Control.Exception as Exception (catch)

44+import Control.Concurrent (forkIO)

45+import Control.Concurrent.MVar

46+ ( newMVar

47+ , withMVar

48+ , modifyMVar

49+ , modifyMVar_

50+ , newEmptyMVar

51+ , putMVar

52+ , takeMVar

53+ )

54+import Control.Concurrent.Chan (newChan, writeChan, readChan)

55+import Control.Concurrent.STM (atomically, writeTChan)

56+import Control.Distributed.Process.Internal.CQueue (enqueue, newCQueue)

57+import qualified Network.Transport as NT

58+ ( Transport

59+ , EndPoint

60+ , newEndPoint

61+ , receive

62+ , Event(..)

63+ , EventErrorCode(..)

64+ , TransportError(..)

65+ , address

66+ , closeEndPoint

67+ , ConnectionId

68+ )

69+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

70+import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)

71+import System.Random (randomIO)

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

73+ ( RemoteTable

74+ , NodeId(..)

75+ , LocalProcessId(..)

76+ , ProcessId(..)

77+ , LocalNode(..)

78+ , LocalNodeState(..)

79+ , LocalProcess(..)

80+ , LocalProcessState(..)

81+ , Process(..)

82+ , DiedReason(..)

83+ , NCMsg(..)

84+ , ProcessSignal(..)

85+ , localPidCounter

86+ , localPidUnique

87+ , localProcessWithId

88+ , MonitorRef(..)

89+ , ProcessMonitorNotification(..)

90+ , NodeMonitorNotification(..)

91+ , PortMonitorNotification(..)

92+ , ProcessLinkException(..)

93+ , NodeLinkException(..)

94+ , PortLinkException(..)

95+ , DidUnmonitor(..)

96+ , DidUnlinkProcess(..)

97+ , DidUnlinkNode(..)

98+ , DidUnlinkPort(..)

99+ , SpawnRef

100+ , DidSpawn(..)

101+ , Closure(..)

102+ , Static(..)

103+ , Message

104+ , TypedChannel(..)

105+ , Identifier(..)

106+ , nodeOf

107+ , SendPortId(..)

108+ , typedChannelWithId

109+ , WhereIsReply(..)

110+ , messageToPayload

111+ , RemoteTable(..)

112+ , payloadToMessage

113+ , createMessage

114+ , runLocalProcess

115+ )

116+import Control.Distributed.Process.Serializable (Serializable)

117+import Control.Distributed.Process.Internal.Dynamic (fromDynamic)

118+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

119+import Control.Distributed.Process.Internal.Node

120+ ( sendBinary

121+ , sendMessage

122+ , sendPayload

123+ )

124+import Control.Distributed.Process.Internal.Primitives (expect, register)

125+import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)

126+import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)

127+

128+--------------------------------------------------------------------------------

129+-- Initialization --

130+--------------------------------------------------------------------------------

131+

132+initRemoteTable :: RemoteTable

133+initRemoteTable = Static.__remoteTable

134+ . CP.__remoteTable

135+ $ RemoteTable Map.empty

136+

137+-- | Initialize a new local node.

138+--

139+-- Note that proper Cloud Haskell initialization and configuration is still

140+-- to do.

141+newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode

142+newLocalNode transport rtable = do

143+ mEndPoint <- NT.newEndPoint transport

144+ case mEndPoint of

145+ Left ex -> throwIO ex

146+ Right endPoint -> do

147+ localNode <- createBareLocalNode endPoint rtable

148+ startServiceProcesses localNode

149+ return localNode

150+

151+-- | Create a new local node (without any service processes running)

152+createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode

153+createBareLocalNode endPoint rtable = do

154+ unq <- randomIO

155+ state <- newMVar LocalNodeState

156+ { _localProcesses = Map.empty

157+ , _localPidCounter = 0

158+ , _localPidUnique = unq

159+ , _localConnections = Map.empty

160+ }

161+ ctrlChan <- newChan

162+ let node = LocalNode { localNodeId = NodeId $ NT.address endPoint

163+ , localEndPoint = endPoint

164+ , localState = state

165+ , localCtrlChan = ctrlChan

166+ , remoteTable = rtable

167+ }

168+ void . forkIO $ runNodeController node

169+ void . forkIO $ handleIncomingMessages node

170+ return node

171+

172+-- | Start and register the service processes on a node

173+-- (for now, this is only the logger)

174+startServiceProcesses :: LocalNode -> IO ()

175+startServiceProcesses node = do

176+ logger <- forkProcess node . forever $ do

177+ (time, pid, string) <- expect :: Process (String, ProcessId, String)

178+ liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

179+ runProcess node $ register "logger" logger

180+

181+-- | Force-close a local node

182+--

183+-- TODO: for now we just close the associated endpoint

184+closeLocalNode :: LocalNode -> IO ()

185+closeLocalNode node =

186+ NT.closeEndPoint (localEndPoint node)

187+

188+-- | Run a process on a local node and wait for it to finish

189+runProcess :: LocalNode -> Process () -> IO ()

190+runProcess node proc = do

191+ done <- newEmptyMVar

192+ void $ forkProcess node (proc >> liftIO (putMVar done ()))

193+ takeMVar done

194+

195+-- | Spawn a new process on a local node

196+forkProcess :: LocalNode -> Process () -> IO ProcessId

197+forkProcess node proc = modifyMVar (localState node) $ \st -> do

198+ let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter

199+ , lpidUnique = st ^. localPidUnique

200+ }

201+ let pid = ProcessId { processNodeId = localNodeId node

202+ , processLocalId = lpid

203+ }

204+ pst <- newMVar LocalProcessState { _monitorCounter = 0

205+ , _spawnCounter = 0

206+ , _channelCounter = 0

207+ , _typedChannels = Map.empty

208+ }

209+ queue <- newCQueue

210+ (_, lproc) <- fixIO $ \ ~(tid, _) -> do

211+ let lproc = LocalProcess { processQueue = queue

212+ , processId = pid

213+ , processState = pst

214+ , processThread = tid

215+ , processNode = node

216+ }

217+ tid' <- forkIO $ do

218+ reason <- Exception.catch

219+ (runLocalProcess lproc proc >> return DiedNormal)

220+ (return . DiedException . (show :: SomeException -> String))

221+ -- [Unified: Table 4, rules termination and exiting]

222+ modifyMVar_ (localState node) $

223+ return . (localProcessWithId lpid ^= Nothing)

224+ writeChan (localCtrlChan node) NCMsg

225+ { ctrlMsgSender = ProcessIdentifier pid

226+ , ctrlMsgSignal = Died (ProcessIdentifier pid) reason

227+ }

228+ return (tid', lproc)

229+

230+ if lpidCounter lpid == maxBound

231+ then do

232+ newUnique <- randomIO

233+ return ( (localProcessWithId lpid ^= Just lproc)

234+ . (localPidCounter ^= 0)

235+ . (localPidUnique ^= newUnique)

236+ $ st

237+ , pid

238+ )

239+ else

240+ return ( (localProcessWithId lpid ^= Just lproc)

241+ . (localPidCounter ^: (+ 1))

242+ $ st

243+ , pid

244+ )

245+

246+handleIncomingMessages :: LocalNode -> IO ()

247+handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

248+ where

249+ go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know

250+ -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes

251+ -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels

252+ -> Set NT.ConnectionId -- ^ Connections to our controller

253+ -> IO ()

254+ go uninitConns procs chans ctrls = do

255+ event <- NT.receive endpoint

256+ case event of

257+ NT.ConnectionOpened cid _rel _theirAddr ->

258+ -- TODO: Check if _rel is ReliableOrdered, and if not, treat as

259+ -- (**) below.

260+ go (cid : uninitConns) procs chans ctrls

261+ NT.Received cid payload ->

262+ case ( Map.lookup cid procs

263+ , Map.lookup cid chans

264+ , cid `Set.member` ctrls

265+ , cid `elem` uninitConns

266+ ) of

267+ (Just proc, _, _, _) -> do

268+ let msg = payloadToMessage payload

269+ enqueue (processQueue proc) msg

270+ go uninitConns procs chans ctrls

271+ (_, Just (TypedChannel chan), _, _) -> do

272+ atomically $ writeTChan chan . decode . BSL.fromChunks $ payload

273+ go uninitConns procs chans ctrls

274+ (_, _, True, _) -> do

275+ let ctrlMsg = decode . BSL.fromChunks $ payload

276+ writeChan ctrlChan ctrlMsg

277+ go uninitConns procs chans ctrls

278+ (_, _, _, True) ->

279+ case decode (BSL.fromChunks payload) of

280+ ProcessIdentifier pid -> do

281+ let lpid = processLocalId pid

282+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)

283+ case mProc of

284+ Just proc ->

285+ go (List.delete cid uninitConns)

286+ (Map.insert cid proc procs)

287+ chans

288+ ctrls

289+ Nothing ->

290+ -- Request for an unknown process.

291+ --

292+ -- TODO: We should treat this as a fatal error on the

293+ -- part of the remote node. That is, we should report the

294+ -- remote node as having died, and we should close

295+ -- incoming connections (this requires a Transport layer

296+ -- extension). (**)

297+ go (List.delete cid uninitConns) procs chans ctrls

298+ SendPortIdentifier chId -> do

299+ let lcid = sendPortLocalId chId

300+ lpid = processLocalId (sendPortProcessId chId)

301+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)

302+ case mProc of

303+ Just proc -> do

304+ mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

305+ case mChannel of

306+ Just channel ->

307+ go (List.delete cid uninitConns)

308+ procs

309+ (Map.insert cid channel chans)

310+ ctrls

311+ Nothing ->

312+ -- Unknown typed channel

313+ -- TODO (**) above

314+ go (List.delete cid uninitConns) procs chans ctrls

315+ Nothing ->

316+ -- Unknown process

317+ -- TODO (**) above

318+ go (List.delete cid uninitConns) procs chans ctrls

319+ NodeIdentifier _ ->

320+ go (List.delete cid uninitConns)

321+ procs

322+ chans

323+ (Set.insert cid ctrls)

324+ _ ->

325+ -- Unexpected message

326+ -- TODO (**) above

327+ go uninitConns procs chans ctrls

328+ NT.ConnectionClosed cid ->

329+ go (List.delete cid uninitConns)

330+ (Map.delete cid procs)

331+ (Map.delete cid chans)

332+ (Set.delete cid ctrls)

333+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost (Just theirAddr) cids) _) -> do

334+ -- [Unified table 9, rule node_disconnect]

335+ let nid = NodeIdentifier $ NodeId theirAddr

336+ writeChan ctrlChan NCMsg

337+ { ctrlMsgSender = nid

338+ , ctrlMsgSignal = Died nid DiedDisconnect

339+ }

340+ go (uninitConns List.\\ cids)

341+ (Map.filterWithKey (\k _ -> k `notElem` cids) procs)

342+ (Map.filterWithKey (\k _ -> k `notElem` cids) chans)

343+ (ctrls Set.\\ Set.fromList cids)

344+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->

345+ -- TODO: We should treat an asymetrical connection loss (incoming

346+ -- connection broken, but outgoing connection still potentially ok)

347+ -- as a fatal error on the part of the remote node (like (**), above)

348+ fail "handleIncomingMessages: TODO"

349+ NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->

350+ fail $ "Cloud Haskell fatal error: end point failed: " ++ str

351+ NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->

352+ fail $ "Cloud Haskell fatal error: transport failed: " ++ str

353+ NT.EndPointClosed ->

354+ return ()

355+ NT.ReceivedMulticast _ _ ->

356+ -- If we received a multicast message, something went horribly wrong

357+ -- and we just give up

358+ fail "Cloud Haskell fatal error: received unexpected multicast"

359+

360+ state = localState node

361+ endpoint = localEndPoint node

362+ ctrlChan = localCtrlChan node

363+

364+--------------------------------------------------------------------------------

365+-- Top-level access to the node controller --

366+--------------------------------------------------------------------------------

367+

368+runNodeController :: LocalNode -> IO ()

369+runNodeController =

370+ runReaderT (evalStateT (unNC nodeController) initNCState)

371+

372+--------------------------------------------------------------------------------

373+-- Internal data types --

374+--------------------------------------------------------------------------------

375+

376+data NCState = NCState

377+ { -- Mapping from remote processes to linked local processes

378+ _links :: Map Identifier (Set ProcessId)

379+ -- Mapping from remote processes to monitoring local processes

380+ , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))

381+ -- Process registry

382+ , _registry :: Map String ProcessId

383+ }

384+

385+newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

386+ deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)

387+

388+initNCState :: NCState

389+initNCState = NCState { _links = Map.empty

390+ , _monitors = Map.empty

391+ , _registry = Map.empty

392+ }

393+

394+--------------------------------------------------------------------------------

395+-- Core functionality --

396+--------------------------------------------------------------------------------

397+

398+-- [Unified: Table 7]

399+nodeController :: NC ()

400+nodeController = do

401+ node <- ask

402+ forever $ do

403+ msg <- liftIO $ readChan (localCtrlChan node)

404+

405+ -- [Unified: Table 7, rule nc_forward]

406+ case destNid (ctrlMsgSignal msg) of

407+ Just nid' | nid' /= localNodeId node ->

408+ liftIO $ sendBinary node

409+ (ctrlMsgSender msg)

410+ (NodeIdentifier nid')

411+ msg

412+ _ ->

413+ return ()

414+

415+ case msg of

416+ NCMsg (ProcessIdentifier from) (Link them) ->

417+ ncEffectMonitor from them Nothing

418+ NCMsg (ProcessIdentifier from) (Monitor ref) ->

419+ ncEffectMonitor from (monitorRefIdent ref) (Just ref)

420+ NCMsg (ProcessIdentifier from) (Unlink them) ->

421+ ncEffectUnlink from them

422+ NCMsg (ProcessIdentifier from) (Unmonitor ref) ->

423+ ncEffectUnmonitor from ref

424+ NCMsg _from (Died ident reason) ->

425+ ncEffectDied ident reason

426+ NCMsg (ProcessIdentifier from) (Spawn proc ref) ->

427+ ncEffectSpawn from proc ref

428+ NCMsg _from (Register label pid) ->

429+ ncEffectRegister label pid

430+ NCMsg (ProcessIdentifier from) (WhereIs label) ->

431+ ncEffectWhereIs from label

432+ NCMsg from (NamedSend label msg') ->

433+ ncEffectNamedSend from label msg'

434+ unexpected ->

435+ error $ "nodeController: unexpected message " ++ show unexpected

436+

437+-- [Unified: Table 10]

438+ncEffectMonitor :: ProcessId -- ^ Who's watching?

439+ -> Identifier -- ^ Who's being watched?

440+ -> Maybe MonitorRef -- ^ 'Nothing' to link

441+ -> NC ()

442+ncEffectMonitor from them mRef = do

443+ node <- ask

444+ shouldLink <-

445+ if not (isLocal node them)

446+ then return True

447+ else isValidLocalIdentifier them

448+ case (shouldLink, isLocal node (ProcessIdentifier from)) of

449+ (True, _) -> -- [Unified: first rule]

450+ case mRef of

451+ Just ref -> modify $ monitorsFor them ^: Set.insert (from, ref)

452+ Nothing -> modify $ linksFor them ^: Set.insert from

453+ (False, True) -> -- [Unified: second rule]

454+ notifyDied from them DiedUnknownId mRef

455+ (False, False) -> -- [Unified: third rule]

456+ -- TODO: this is the right sender according to the Unified semantics,

457+ -- but perhaps having 'them' as the sender would make more sense

458+ -- (see also: notifyDied)

459+ liftIO $ sendBinary node

460+ (NodeIdentifier $ localNodeId node)

461+ (NodeIdentifier $ processNodeId from)

462+ NCMsg

463+ { ctrlMsgSender = NodeIdentifier (localNodeId node)

464+ , ctrlMsgSignal = Died them DiedUnknownId

465+ }

466+

467+-- [Unified: Table 11]

468+ncEffectUnlink :: ProcessId -> Identifier -> NC ()

469+ncEffectUnlink from them = do

470+ node <- ask

471+ when (isLocal node (ProcessIdentifier from)) $

472+ case them of

473+ ProcessIdentifier pid ->

474+ postAsMessage from $ DidUnlinkProcess pid

475+ NodeIdentifier nid ->

476+ postAsMessage from $ DidUnlinkNode nid

477+ SendPortIdentifier cid ->

478+ postAsMessage from $ DidUnlinkPort cid

479+ modify $ linksFor them ^: Set.delete from

480+

481+-- [Unified: Table 11]

482+ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

483+ncEffectUnmonitor from ref = do

484+ node <- ask

485+ when (isLocal node (ProcessIdentifier from)) $

486+ postAsMessage from $ DidUnmonitor ref

487+ modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)

488+

489+-- [Unified: Table 12]

490+ncEffectDied :: Identifier -> DiedReason -> NC ()

491+ncEffectDied ident reason = do

492+ node <- ask

493+ (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))

494+ (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))

495+

496+ let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

497+

498+ forM_ (Map.toList affectedLinks) $ \(them, uss) ->

499+ forM_ uss $ \us ->

500+ when (localOnly <= isLocal node (ProcessIdentifier us)) $

501+ notifyDied us them reason Nothing

502+

503+ forM_ (Map.toList affectedMons) $ \(them, refs) ->

504+ forM_ refs $ \(us, ref) ->

505+ when (localOnly <= isLocal node (ProcessIdentifier us)) $

506+ notifyDied us them reason (Just ref)

507+

508+ modify $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)

509+

510+-- [Unified: Table 13]

511+ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()

512+ncEffectSpawn pid cProc ref = do

513+ mProc <- unClosure cProc

514+ -- If the closure does not exist, we spawn a process that throws an exception

515+ -- This allows the remote node to find out what's happening

516+ let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc

517+ node <- ask

518+ pid' <- liftIO $ forkProcess node proc

519+ liftIO $ sendMessage node

520+ (NodeIdentifier (localNodeId node))

521+ (ProcessIdentifier pid)

522+ (DidSpawn ref pid')

523+

524+-- Unified semantics does not explicitly describe how to implement 'register',

525+-- but mentions it's "very similar to nsend" (Table 14)

526+ncEffectRegister :: String -> Maybe ProcessId -> NC ()

527+ncEffectRegister label mPid =

528+ modify $ registryFor label ^= mPid

529+ -- An acknowledgement is not necessary. If we want a synchronous register,

530+ -- it suffices to send a whereis requiry immediately after the register

531+ -- (that may not suffice if we do decide for unreliable messaging instead)

532+

533+-- Unified semantics does not explicitly describe 'whereis'

534+ncEffectWhereIs :: ProcessId -> String -> NC ()

535+ncEffectWhereIs from label = do

536+ node <- ask

537+ mPid <- gets (^. registryFor label)

538+ liftIO $ sendMessage node

539+ (NodeIdentifier (localNodeId node))

540+ (ProcessIdentifier from)

541+ (WhereIsReply label mPid)

542+

543+-- [Unified: Table 14]

544+ncEffectNamedSend :: Identifier -> String -> Message -> NC ()

545+ncEffectNamedSend from label msg = do

546+ mPid <- gets (^. registryFor label)

547+ -- If mPid is Nothing, we just ignore the named send (as per Table 14)

548+ node <- ask

549+ forM_ mPid $ \pid ->

550+ liftIO $ sendPayload node

551+ from

552+ (ProcessIdentifier pid)

553+ (messageToPayload msg)

554+

555+--------------------------------------------------------------------------------

556+-- Auxiliary --

557+--------------------------------------------------------------------------------

558+

559+notifyDied :: ProcessId -- ^ Who to notify?

560+ -> Identifier -- ^ Who died?

561+ -> DiedReason -- ^ How did they die?

562+ -> Maybe MonitorRef -- ^ 'Nothing' for linking

563+ -> NC ()

564+notifyDied dest src reason mRef = do

565+ node <- ask

566+ case (isLocal node (ProcessIdentifier dest), mRef, src) of

567+ (True, Just ref, ProcessIdentifier pid) ->

568+ postAsMessage dest $ ProcessMonitorNotification ref pid reason

569+ (True, Just ref, NodeIdentifier nid) ->

570+ postAsMessage dest $ NodeMonitorNotification ref nid reason

571+ (True, Just ref, SendPortIdentifier cid) ->

572+ postAsMessage dest $ PortMonitorNotification ref cid reason

573+ (True, Nothing, ProcessIdentifier pid) ->

574+ throwException dest $ ProcessLinkException pid reason

575+ (True, Nothing, NodeIdentifier pid) ->

576+ throwException dest $ NodeLinkException pid reason

577+ (True, Nothing, SendPortIdentifier pid) ->

578+ throwException dest $ PortLinkException pid reason

579+ (False, _, _) ->

580+ -- TODO: why the change in sender? How does that affect 'reconnect' semantics?

581+ -- (see [Unified: Table 10]

582+ liftIO $ sendBinary node

583+ (NodeIdentifier $ localNodeId node)

584+ (NodeIdentifier $ processNodeId dest)

585+ NCMsg

586+ { ctrlMsgSender = NodeIdentifier (localNodeId node)

587+ , ctrlMsgSignal = Died src reason

588+ }

589+

590+-- | [Unified: Table 8]

591+destNid :: ProcessSignal -> Maybe NodeId

592+destNid (Link ident) = Just $ nodeOf ident

593+destNid (Unlink ident) = Just $ nodeOf ident

594+destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

595+destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

596+destNid (Spawn _ _) = Nothing

597+destNid (Register _ _) = Nothing

598+destNid (WhereIs _) = Nothing

599+destNid (NamedSend _ _) = Nothing

600+-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

601+-- then when a local process dies the monitoring/linking machinery will take

602+-- care of notifying remote nodes

603+destNid (Died _ _) = Nothing

604+

605+-- | Check if a process is local to our own node

606+isLocal :: LocalNode -> Identifier -> Bool

607+isLocal nid ident = nodeOf ident == localNodeId nid

608+

609+-- | Lookup a local closure

610+unClosure :: Typeable a => Closure a -> NC (Maybe a)

611+unClosure (Closure (Static label) env) = do

612+ rtable <- remoteTable <$> ask

613+ return (resolveClosure rtable label env >>= fromDynamic)

614+

615+-- | Check if an identifier refers to a valid local object

616+isValidLocalIdentifier :: Identifier -> NC Bool

617+isValidLocalIdentifier ident = do

618+ node <- ask

619+ liftIO . withMVar (localState node) $ \nSt ->

620+ case ident of

621+ NodeIdentifier nid ->

622+ return $ nid == localNodeId node

623+ ProcessIdentifier pid -> do

624+ let mProc = nSt ^. localProcessWithId (processLocalId pid)

625+ return $ isJust mProc

626+ SendPortIdentifier cid -> do

627+ let pid = sendPortProcessId cid

628+ mProc = nSt ^. localProcessWithId (processLocalId pid)

629+ case mProc of

630+ Nothing -> return False

631+ Just proc -> withMVar (processState proc) $ \pSt -> do

632+ let mCh = pSt ^. typedChannelWithId (sendPortLocalId cid)

633+ return $ isJust mCh

634+

635+--------------------------------------------------------------------------------

636+-- Messages to local processes --

637+--------------------------------------------------------------------------------

638+

639+postAsMessage :: Serializable a => ProcessId -> a -> NC ()

640+postAsMessage pid = postMessage pid . createMessage

641+

642+postMessage :: ProcessId -> Message -> NC ()

643+postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg

644+

645+throwException :: Exception e => ProcessId -> e -> NC ()

646+throwException pid e = withLocalProc pid $ \p ->

647+ throwTo (processThread p) e

648+

649+withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()

650+withLocalProc pid p = do

651+ node <- ask

652+ liftIO $ do

653+ -- By [Unified: table 6, rule missing_process] messages to dead processes

654+ -- can silently be dropped

655+ let lpid = processLocalId pid

656+ mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)

657+ forM_ mProc p

658+

659+--------------------------------------------------------------------------------

660+-- Accessors --

661+--------------------------------------------------------------------------------

662+

663+links :: Accessor NCState (Map Identifier (Set ProcessId))

664+links = accessor _links (\ls st -> st { _links = ls })

665+

666+monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

667+monitors = accessor _monitors (\ms st -> st { _monitors = ms })

668+

669+registry :: Accessor NCState (Map String ProcessId)

670+registry = accessor _registry (\ry st -> st { _registry = ry })

671+

672+linksFor :: Identifier -> Accessor NCState (Set ProcessId)

673+linksFor ident = links >>> DAC.mapDefault Set.empty ident

674+

675+monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

676+monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

677+

678+registryFor :: String -> Accessor NCState (Maybe ProcessId)

679+registryFor ident = registry >>> DAC.mapMaybe ident

680+

681+-- | @splitNotif ident@ splits a notifications map into those

682+-- notifications that should trigger when 'ident' fails and those links that

683+-- should not.

684+--

685+-- There is a hierarchy between identifiers: failure of a node implies failure

686+-- of all processes on that node, and failure of a process implies failure of

687+-- all typed channels to that process. In other words, if 'ident' refers to a

688+-- node, then the /should trigger/ set will include

689+--

690+-- * the notifications for the node specifically

691+-- * the notifications for processes on that node, and

692+-- * the notifications for typed channels to processes on that node.

693+--

694+-- Similarly, if 'ident' refers to a process, the /should trigger/ set will

695+-- include

696+--

697+-- * the notifications for that process specifically and

698+-- * the notifications for typed channels to that process.

699+splitNotif :: Identifier

700+ -> Map Identifier a

701+ -> (Map Identifier a, Map Identifier a)

702+splitNotif ident = Map.partitionWithKey (const . impliesDeathOf ident)

703+

704+-- | Does the death of one entity (node, project, channel) imply the death

705+-- of another?

706+impliesDeathOf :: Identifier -- ^ Who died

707+ -> Identifier -- ^ Who's being watched

708+ -> Bool -- ^ Does this death implies the death of the watchee?

709+NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =

710+ nid' == nid

711+NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =

712+ processNodeId pid == nid

713+NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =

714+ processNodeId (sendPortProcessId cid) == nid

715+ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =

716+ pid' == pid

717+ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =

718+ sendPortProcessId cid == pid

719+SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =

720+ cid' == cid

721+_ `impliesDeathOf` _ =

722+ False

src/Control/Distributed/Process/Serializable.hs → distributed-process/src/Control/Distributed/Process/Serializable.hsrenamed+16−32

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

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE GADTs #-}

6−module Control.Distributed.Process.Serializable

1+module Control.Distributed.Process.Serializable

72 ( Serializable

83 , encodeFingerprint

94 , decodeFingerprint

@@ -11,33 +6,22 @@ module Control.Distributed.Process.Serializable

116 , sizeOfFingerprint

127 , Fingerprint

138 , showFingerprint

14− , SerializableDict(SerializableDict)

15− , TypeableDict(TypeableDict)

169 ) where

1710

1811import Data.Binary (Binary)

19−

20−import Data.Typeable (Typeable, typeRepFingerprint, typeOf)

21−

12+import Data.Typeable (Typeable(..))

13+import Data.Typeable.Internal (TypeRep(TypeRep))

2214import Numeric (showHex)

2315import Control.Exception (throw)

2416import GHC.Fingerprint.Type (Fingerprint(..))

2517import Data.ByteString (ByteString)

2618import qualified Data.ByteString as BS

27−import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr )

19+import qualified Data.ByteString.Internal as BSI ( unsafeCreate

20+ , inlinePerformIO

21+ , toForeignPtr

22+ )

2823import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

2924import Foreign.ForeignPtr (withForeignPtr)

30−import System.IO.Unsafe (unsafePerformIO)

31−

32−-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

33−data SerializableDict a where

34− SerializableDict :: Serializable a => SerializableDict a

35− deriving (Typeable)

36−

37−-- | Reification of 'Typeable'.

38−data TypeableDict a where

39− TypeableDict :: Typeable a => TypeableDict a

40− deriving (Typeable)

4125

4226-- | Objects that can be sent across the network

4327class (Binary a, Typeable a) => Serializable a

@@ -45,29 +29,29 @@ instance (Binary a, Typeable a) => Serializable a

4529

4630-- | Encode type representation as a bytestring

4731encodeFingerprint :: Fingerprint -> ByteString

48−encodeFingerprint fp =

32+encodeFingerprint fp =

4933 -- Since all CH nodes will run precisely the same binary, we don't have to

5034 -- worry about cross-arch issues here (like endianness)

51− BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp

35+ BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp

5236

53−-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure

37+-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure

5438decodeFingerprint :: ByteString -> Fingerprint

5539decodeFingerprint bs

56− | BS.length bs /= sizeOfFingerprint =

40+ | BS.length bs /= sizeOfFingerprint =

5741 throw $ userError "decodeFingerprint: Invalid length"

58− | otherwise = unsafePerformIO $ do

42+ | otherwise = BSI.inlinePerformIO $ do

5943 let (fp, offset, _) = BSI.toForeignPtr bs

60− withForeignPtr fp $ \p -> peekByteOff p offset

44+ withForeignPtr fp $ \p -> peekByteOff p offset

6145

6246-- | Size of a fingerprint

6347sizeOfFingerprint :: Int

6448sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

6549

66−-- | The fingerprint of the typeRep of the argument

50+-- | The fingerprint of the typeRep of the argument

6751fingerprint :: Typeable a => a -> Fingerprint

68−fingerprint = typeRepFingerprint . typeOf

52+fingerprint a = let TypeRep fp _ _ = typeOf a in fp

6953

7054-- | Show fingerprint (for debugging purposes)

7155showFingerprint :: Fingerprint -> ShowS

72−showFingerprint (Fingerprint hi lo) =

56+showFingerprint (Fingerprint hi lo) =

7357 showString "(" . showHex hi . showString "," . showHex lo . showString ")"

distributed-process/tests/TestAuxiliary.hsnew file+75

@@ -0,0 +1,75 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+module TestAuxiliary ( -- Running tests

3+ runTest

4+ , runTests

5+ -- Writing tests

6+ , forkTry

7+ , trySome

8+ , randomThreadDelay

9+ ) where

10+

11+

12+#if ! MIN_VERSION_base(4,6,0)

13+import Prelude hiding (catch)

14+#endif

15+

16+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)

17+import Control.Monad (liftM2, unless)

18+import Control.Exception (SomeException, try, catch)

19+import System.Timeout (timeout)

20+import System.IO (stdout, hFlush)

21+import System.Console.ANSI ( SGR(SetColor, Reset)

22+ , Color(Red, Green)

23+ , ConsoleLayer(Foreground)

24+ , ColorIntensity(Vivid)

25+ , setSGR

26+ )

27+import System.Random (randomIO)

28+

29+-- | Like fork, but throw exceptions in the child thread to the parent

30+forkTry :: IO () -> IO ThreadId

31+forkTry p = do

32+ tid <- myThreadId

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

34+

35+-- | Like try, but specialized to SomeException

36+trySome :: IO a -> IO (Either SomeException a)

37+trySome = try

38+

39+-- | Run the given test, catching timeouts and exceptions

40+runTest :: String -> IO () -> IO Bool

41+runTest description test = do

42+ putStr $ "Running " ++ show description ++ ": "

43+ hFlush stdout

44+ done <- try . timeout 60000000 $ test -- 60 seconds

45+ case done of

46+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"

47+ Right Nothing -> failed "(timeout)"

48+ Right (Just ()) -> ok

49+ where

50+ failed :: String -> IO Bool

51+ failed err = do

52+ setSGR [SetColor Foreground Vivid Red]

53+ putStr "failed "

54+ setSGR [Reset]

55+ putStrLn err

56+ return False

57+

58+ ok :: IO Bool

59+ ok = do

60+ setSGR [SetColor Foreground Vivid Green]

61+ putStrLn "ok"

62+ setSGR [Reset]

63+ return True

64+

65+-- | Run a bunch of tests and throw an exception if any fails

66+runTests :: [(String, IO ())] -> IO ()

67+runTests tests = do

68+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests

69+ unless success $ fail "Some tests failed"

70+

71+-- | Random thread delay between 0 and the specified max

72+randomThreadDelay :: Int -> IO ()

73+randomThreadDelay maxDelay = do

74+ delay <- randomIO :: IO Int

75+ threadDelay (delay `mod` maxDelay)

distributed-process/tests/TestCH.hsnew file+622

@@ -0,0 +1,622 @@

1+module Main where

3+#if ! MIN_VERSION_base(4,6,0)

4+import Prelude hiding (catch)

5+#endif

7+import Data.Binary (Binary(..))

8+import Data.Typeable (Typeable)

9+import Data.Foldable (forM_)

10+import Control.Concurrent (forkIO, threadDelay)

11+import Control.Concurrent.MVar

12+ ( MVar

13+ , newEmptyMVar

14+ , putMVar

15+ , takeMVar

16+ , readMVar

17+ )

18+import Control.Monad (replicateM_, replicateM)

19+import Control.Exception (throwIO)

20+import Control.Applicative ((<$>), (<*>))

21+import qualified Network.Transport as NT (Transport, closeEndPoint)

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

23+import Control.Distributed.Process

24+import Control.Distributed.Process.Internal.Types (LocalNode(localEndPoint))

25+import Control.Distributed.Process.Node

26+import Control.Distributed.Process.Serializable (Serializable)

27+import TestAuxiliary

28+

29+newtype Ping = Ping ProcessId

30+ deriving (Typeable, Binary, Show)

31+

32+newtype Pong = Pong ProcessId

33+ deriving (Typeable, Binary, Show)

34+

35+-- | The ping server from the paper

36+ping :: Process ()

37+ping = do

38+ Pong partner <- expect

39+ self <- getSelfPid

40+ send partner (Ping self)

41+ ping

42+

43+-- | Basic ping test

44+testPing :: NT.Transport -> IO ()

45+testPing transport = do

46+ serverAddr <- newEmptyMVar

47+ clientDone <- newEmptyMVar

48+

49+ -- Server

50+ forkIO $ do

51+ localNode <- newLocalNode transport initRemoteTable

52+ addr <- forkProcess localNode ping

53+ putMVar serverAddr addr

54+

55+ -- Client

56+ forkIO $ do

57+ localNode <- newLocalNode transport initRemoteTable

58+ pingServer <- readMVar serverAddr

59+

60+ let numPings = 10000

61+

62+ runProcess localNode $ do

63+ pid <- getSelfPid

64+ replicateM_ numPings $ do

65+ send pingServer (Pong pid)

66+ Ping _ <- expect

67+ return ()

68+

69+ putMVar clientDone ()

70+

71+ takeMVar clientDone

72+

73+-- | Monitor or link to a remote node

74+monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link

75+ -> ProcessId -- Process to monitor/link to

76+ -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up

77+ -> Process (Maybe MonitorRef)

78+monitorOrLink mOrL pid mSignal = do

79+ result <- if mOrL then Just <$> monitor pid

80+ else link pid >> return Nothing

81+ -- Monitor is asynchronous, which usually does not matter but if we want a

82+ -- *specific* signal then it does. Therefore we wait an arbitrary delay and

83+ -- hope that this means the monitor has been set up

84+ forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()

85+ return result

86+

87+monitorTestProcess :: ProcessId -- Process to monitor/link to

88+ -> Bool -- 'True' for monitor, 'False' for link

89+ -> Bool -- Should we unmonitor?

90+ -> DiedReason -- Expected cause of death

91+ -> Maybe (MVar ()) -- Signal for 'monitor set up'

92+ -> MVar () -- Signal for successful termination

93+ -> Process ()

94+monitorTestProcess theirAddr mOrL un reason monitorSetup done =

95+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup

96+ case (un, mRef) of

97+ (True, Nothing) -> do

98+ unlink theirAddr

99+ liftIO $ putMVar done ()

100+ (True, Just ref) -> do

101+ unmonitor ref

102+ liftIO $ putMVar done ()

103+ (False, ref) -> do

104+ ProcessMonitorNotification ref' pid reason' <- expect

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

106+ liftIO $ putMVar done ()

107+ )

108+ (\(ProcessLinkException pid reason') -> do

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

110+ liftIO $ putMVar done ()

111+ )

112+

113+

114+-- | Monitor a process on an unreachable node

115+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()

116+testMonitorUnreachable transport mOrL un = do

117+ deadProcess <- newEmptyMVar

118+ done <- newEmptyMVar

119+

120+ forkIO $ do

121+ localNode <- newLocalNode transport initRemoteTable

122+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000

123+ closeLocalNode localNode

124+ putMVar deadProcess addr

125+

126+ forkIO $ do

127+ localNode <- newLocalNode transport initRemoteTable

128+ theirAddr <- readMVar deadProcess

129+ runProcess localNode $

130+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done

131+

132+ takeMVar done

133+

134+-- | Monitor a process which terminates normally

135+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()

136+testMonitorNormalTermination transport mOrL un = do

137+ monitorSetup <- newEmptyMVar

138+ monitoredProcess <- newEmptyMVar

139+ done <- newEmptyMVar

140+

141+ forkIO $ do

142+ localNode <- newLocalNode transport initRemoteTable

143+ addr <- forkProcess localNode $

144+ liftIO $ readMVar monitorSetup

145+ putMVar monitoredProcess addr

146+

147+ forkIO $ do

148+ localNode <- newLocalNode transport initRemoteTable

149+ theirAddr <- readMVar monitoredProcess

150+ runProcess localNode $

151+ monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done

152+

153+ takeMVar done

154+

155+-- | Monitor a process which terminates abnormally

156+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()

157+testMonitorAbnormalTermination transport mOrL un = do

158+ monitorSetup <- newEmptyMVar

159+ monitoredProcess <- newEmptyMVar

160+ done <- newEmptyMVar

161+

162+ let err = userError "Abnormal termination"

163+

164+ forkIO $ do

165+ localNode <- newLocalNode transport initRemoteTable

166+ addr <- forkProcess localNode . liftIO $ do

167+ readMVar monitorSetup

168+ throwIO err

169+ putMVar monitoredProcess addr

170+

171+ forkIO $ do

172+ localNode <- newLocalNode transport initRemoteTable

173+ theirAddr <- readMVar monitoredProcess

174+ runProcess localNode $

175+ monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done

176+

177+ takeMVar done

178+

179+-- | Monitor a local process that is already dead

180+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()

181+testMonitorLocalDeadProcess transport mOrL un = do

182+ processDead <- newEmptyMVar

183+ processAddr <- newEmptyMVar

184+ localNode <- newLocalNode transport initRemoteTable

185+ done <- newEmptyMVar

186+

187+ forkIO $ do

188+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()

189+ putMVar processAddr addr

190+

191+ forkIO $ do

192+ theirAddr <- readMVar processAddr

193+ readMVar processDead

194+ runProcess localNode $ do

195+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

196+

197+ takeMVar done

198+

199+-- | Monitor a remote process that is already dead

200+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()

201+testMonitorRemoteDeadProcess transport mOrL un = do

202+ processDead <- newEmptyMVar

203+ processAddr <- newEmptyMVar

204+ done <- newEmptyMVar

205+

206+ forkIO $ do

207+ localNode <- newLocalNode transport initRemoteTable

208+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()

209+ putMVar processAddr addr

210+

211+ forkIO $ do

212+ localNode <- newLocalNode transport initRemoteTable

213+ theirAddr <- readMVar processAddr

214+ readMVar processDead

215+ runProcess localNode $ do

216+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

217+

218+ takeMVar done

219+

220+-- | Monitor a process that becomes disconnected

221+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()

222+testMonitorDisconnect transport mOrL un = do

223+ processAddr <- newEmptyMVar

224+ monitorSetup <- newEmptyMVar

225+ done <- newEmptyMVar

226+

227+ forkIO $ do

228+ localNode <- newLocalNode transport initRemoteTable

229+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000

230+ putMVar processAddr addr

231+ readMVar monitorSetup

232+ NT.closeEndPoint (localEndPoint localNode)

233+

234+ forkIO $ do

235+ localNode <- newLocalNode transport initRemoteTable

236+ theirAddr <- readMVar processAddr

237+ runProcess localNode $ do

238+ monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done

239+

240+ takeMVar done

241+

242+data Add = Add ProcessId Double Double deriving (Typeable)

243+data Divide = Divide ProcessId Double Double deriving (Typeable)

244+data DivByZero = DivByZero deriving (Typeable)

245+

246+instance Binary Add where

247+ put (Add pid x y) = put pid >> put x >> put y

248+ get = Add <$> get <*> get <*> get

249+

250+instance Binary Divide where

251+ put (Divide pid x y) = put pid >> put x >> put y

252+ get = Divide <$> get <*> get <*> get

253+

254+instance Binary DivByZero where

255+ put DivByZero = return ()

256+ get = return DivByZero

257+

258+math :: Process ()

259+math = do

260+ receiveWait

261+ [ match (\(Add pid x y) -> send pid (x + y))

262+ , matchIf (\(Divide _ _ y) -> y /= 0)

263+ (\(Divide pid x y) -> send pid (x / y))

264+ , match (\(Divide pid _ _) -> send pid DivByZero)

265+ ]

266+ math

267+

268+-- | Test the math server (i.e., receiveWait)

269+testMath :: NT.Transport -> IO ()

270+testMath transport = do

271+ serverAddr <- newEmptyMVar

272+ clientDone <- newEmptyMVar

273+

274+ -- Server

275+ forkIO $ do

276+ localNode <- newLocalNode transport initRemoteTable

277+ addr <- forkProcess localNode math

278+ putMVar serverAddr addr

279+

280+ -- Client

281+ forkIO $ do

282+ localNode <- newLocalNode transport initRemoteTable

283+ mathServer <- readMVar serverAddr

284+

285+ runProcess localNode $ do

286+ pid <- getSelfPid

287+ send mathServer (Add pid 1 2)

288+ 3 <- expect :: Process Double

289+ send mathServer (Divide pid 8 2)

290+ 4 <- expect :: Process Double

291+ send mathServer (Divide pid 8 0)

292+ DivByZero <- expect

293+ liftIO $ putMVar clientDone ()

294+

295+ takeMVar clientDone

296+

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

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

299+-- the same remote node (we're checking that the remote node did not die)

300+testSendToTerminated :: NT.Transport -> IO ()

301+testSendToTerminated transport = do

302+ serverAddr1 <- newEmptyMVar

303+ serverAddr2 <- newEmptyMVar

304+ clientDone <- newEmptyMVar

305+

306+ forkIO $ do

307+ terminated <- newEmptyMVar

308+ localNode <- newLocalNode transport initRemoteTable

309+ addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()

310+ addr2 <- forkProcess localNode $ ping

311+ readMVar terminated

312+ putMVar serverAddr1 addr1

313+ putMVar serverAddr2 addr2

314+

315+ forkIO $ do

316+ localNode <- newLocalNode transport initRemoteTable

317+ server1 <- readMVar serverAddr1

318+ server2 <- readMVar serverAddr2

319+ runProcess localNode $ do

320+ pid <- getSelfPid

321+ send server1 "Hi"

322+ send server2 (Pong pid)

323+ Ping pid' <- expect

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

325+ liftIO $ putMVar clientDone ()

326+

327+ takeMVar clientDone

328+

329+-- | Test (non-zero) timeout

330+testTimeout :: NT.Transport -> IO ()

331+testTimeout transport = do

332+ localNode <- newLocalNode transport initRemoteTable

333+ runProcess localNode $ do

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

335+ return ()

336+

337+-- | Test zero timeout

338+testTimeout0 :: NT.Transport -> IO ()

339+testTimeout0 transport = do

340+ serverAddr <- newEmptyMVar

341+ clientDone <- newEmptyMVar

342+ messagesSent <- newEmptyMVar

343+

344+ forkIO $ do

345+ localNode <- newLocalNode transport initRemoteTable

346+ addr <- forkProcess localNode $ do

347+ liftIO $ readMVar messagesSent >> threadDelay 1000000

348+ -- Variation on the venerable ping server which uses a zero timeout

349+ -- Since we wait for all messages to be sent before doing this receive,

350+ -- we should nevertheless find the right message immediately

351+ Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]

352+ self <- getSelfPid

353+ send partner (Ping self)

354+ putMVar serverAddr addr

355+

356+ forkIO $ do

357+ localNode <- newLocalNode transport initRemoteTable

358+ server <- readMVar serverAddr

359+ runProcess localNode $ do

360+ pid <- getSelfPid

361+ -- Send a bunch of messages. A large number of messages that the server

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

363+ replicateM_ 10000 $ send server "Irrelevant message"

364+ send server (Pong pid)

365+ liftIO $ putMVar messagesSent ()

366+ Ping _ <- expect

367+ liftIO $ putMVar clientDone ()

368+

369+ takeMVar clientDone

370+

371+-- | Test typed channels

372+testTypedChannels :: NT.Transport -> IO ()

373+testTypedChannels transport = do

374+ serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))

375+ clientDone <- newEmptyMVar

376+

377+ forkIO $ do

378+ localNode <- newLocalNode transport initRemoteTable

379+ forkProcess localNode $ do

380+ (serverSendPort, rport) <- newChan

381+ liftIO $ putMVar serverChannel serverSendPort

382+ (clientSendPort, i) <- receiveChan rport

383+ sendChan clientSendPort (even i)

384+ return ()

385+

386+ forkIO $ do

387+ localNode <- newLocalNode transport initRemoteTable

388+ serverSendPort <- readMVar serverChannel

389+ runProcess localNode $ do

390+ (clientSendPort, rport) <- newChan

391+ sendChan serverSendPort (clientSendPort, 5)

392+ False <- receiveChan rport

393+ liftIO $ putMVar clientDone ()

394+

395+ takeMVar clientDone

396+

397+-- | Test merging receive ports

398+testMergeChannels :: NT.Transport -> IO ()

399+testMergeChannels transport = do

400+ localNode <- newLocalNode transport initRemoteTable

401+ testFlat localNode True "aaabbbccc"

402+ testFlat localNode False "abcabcabc"

403+ testNested localNode True True "aaabbbcccdddeeefffggghhhiii"

404+ testNested localNode True False "adgadgadgbehbehbehcficficfi"

405+ testNested localNode False True "abcabcabcdefdefdefghighighi"

406+ testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"

407+ testBlocked localNode True

408+ testBlocked localNode False

409+ where

410+ -- Single layer of merging

411+ testFlat :: LocalNode -> Bool -> String -> IO ()

412+ testFlat localNode biased expected =

413+ runProcess localNode $ do

414+ rs <- mapM charChannel "abc"

415+ m <- mergePorts biased rs

416+ xs <- replicateM 9 $ receiveChan m

417+ True <- return $ xs == expected

418+ return ()

419+

420+ -- Two layers of merging

421+ testNested :: LocalNode -> Bool -> Bool -> String -> IO ()

422+ testNested localNode biasedInner biasedOuter expected =

423+ runProcess localNode $ do

424+ rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]

425+ ms <- mapM (mergePorts biasedInner) rss

426+ m <- mergePorts biasedOuter ms

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

428+ True <- return $ xs == expected

429+ return ()

430+

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

432+ testBlocked :: LocalNode -> Bool -> IO ()

433+ testBlocked localNode biased = do

434+ vs <- replicateM 3 newEmptyMVar

435+

436+ forkProcess localNode $ do

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

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

439+ [ -- a, b, c

440+ (sa, 'a')

441+ , (sb, 'b')

442+ , (sc, 'c')

443+ -- a, c, b

444+ , (sa, 'a')

445+ , (sc, 'c')

446+ , (sb, 'b')

447+ -- b, a, c

448+ , (sb, 'b')

449+ , (sa, 'a')

450+ , (sc, 'c')

451+ -- b, c, a

452+ , (sb, 'b')

453+ , (sc, 'c')

454+ , (sa, 'a')

455+ -- c, a, b

456+ , (sc, 'c')

457+ , (sa, 'a')

458+ , (sb, 'b')

459+ -- c, b, a

460+ , (sc, 'c')

461+ , (sb, 'b')

462+ , (sa, 'a')

463+ ]

464+

465+ runProcess localNode $ do

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

467+ liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

468+ m <- mergePorts biased rs

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

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

471+ return ()

472+

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

474+ mergePorts True = mergePortsBiased

475+ mergePorts False = mergePortsRR

476+

477+ charChannel :: Char -> Process (ReceivePort Char)

478+ charChannel c = do

479+ (sport, rport) <- newChan

480+ replicateM_ 3 $ sendChan sport c

481+ liftIO $ threadDelay 10000 -- Make sure messages have been sent

482+ return rport

483+

484+testTerminate :: NT.Transport -> IO ()

485+testTerminate transport = do

486+ localNode <- newLocalNode transport initRemoteTable

487+

488+ pid <- forkProcess localNode $ do

489+ liftIO $ threadDelay 100000

490+ terminate

491+

492+ runProcess localNode $ do

493+ ref <- monitor pid

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

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

496+ return ()

497+

498+testMonitorNode :: NT.Transport -> IO ()

499+testMonitorNode transport = do

500+ [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

501+

502+ closeLocalNode node1

503+

504+ runProcess node2 $ do

505+ ref <- monitorNode (localNodeId node1)

506+ NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

508+ return ()

509+

510+testMonitorChannel :: NT.Transport -> IO ()

511+testMonitorChannel transport = do

512+ [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

513+ gotNotification <- newEmptyMVar

514+

515+ pid <- forkProcess node1 $ do

516+ sport <- expect :: Process (SendPort ())

517+ ref <- monitorPort sport

518+ PortMonitorNotification ref' port' DiedNormal <- expect

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

520+ liftIO $ putMVar gotNotification ()

521+

522+ runProcess node2 $ do

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

524+ send pid sport

525+ liftIO $ threadDelay 100000

526+

527+ takeMVar gotNotification

528+

529+testRegistry :: NT.Transport -> IO ()

530+testRegistry transport = do

531+ node <- newLocalNode transport initRemoteTable

532+

533+ pingServer <- forkProcess node ping

534+

535+ runProcess node $ do

536+ register "ping" pingServer

537+ Just pid <- whereis "ping"

538+ True <- return $ pingServer == pid

539+ us <- getSelfPid

540+ nsend "ping" (Pong us)

541+ Ping pid' <- expect

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

543+ return ()

544+

545+testRemoteRegistry :: NT.Transport -> IO ()

546+testRemoteRegistry transport = do

547+ node1 <- newLocalNode transport initRemoteTable

548+ node2 <- newLocalNode transport initRemoteTable

549+

550+ pingServer <- forkProcess node1 ping

551+

552+ runProcess node2 $ do

553+ let nid1 = localNodeId node1

554+ registerRemote nid1 "ping" pingServer

555+ Just pid <- whereisRemote nid1 "ping"

556+ True <- return $ pingServer == pid

557+ us <- getSelfPid

558+ nsendRemote nid1 "ping" (Pong us)

559+ Ping pid' <- expect

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

561+ return ()

562+

563+testSpawnLocal :: NT.Transport -> IO ()

564+testSpawnLocal transport = do

565+ node <- newLocalNode transport initRemoteTable

566+

567+ runProcess node $ do

568+ us <- getSelfPid

569+

570+ pid <- spawnLocal $ do

571+ sport <- expect

572+ sendChan sport (1234 :: Int)

573+

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

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

576+ send us ()

577+

578+ send pid sport

579+ expect

580+

581+main :: IO ()

582+main = do

583+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

584+ runTests

585+ [ ("Ping", testPing transport)

586+ , ("Math", testMath transport)

587+ , ("Timeout", testTimeout transport)

588+ , ("Timeout0", testTimeout0 transport)

589+ , ("SendToTerminated", testSendToTerminated transport)

590+ , ("TypedChannnels", testTypedChannels transport)

591+ , ("MergeChannels", testMergeChannels transport)

592+ , ("Terminate", testTerminate transport)

593+ , ("Registry", testRegistry transport)

594+ , ("RemoteRegistry", testRemoteRegistry transport)

595+ , ("SpawnLocal", testSpawnLocal transport)

596+ -- Monitoring processes

597+ --

598+ -- The "missing" combinations in the list below don't make much sense, as

599+ -- we cannot guarantee that the monitor reply or link exception will not

600+ -- happen before the unmonitor or unlink

601+ , ("MonitorUnreachable", testMonitorUnreachable transport True False)

602+ , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)

603+ , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)

604+ , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)

605+ , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)

606+ , ("MonitorDisconnect", testMonitorDisconnect transport True False)

607+ , ("LinkUnreachable", testMonitorUnreachable transport False False)

608+ , ("LinkNormalTermination", testMonitorNormalTermination transport False False)

609+ , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)

610+ , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)

611+ , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)

612+ , ("LinkDisconnect", testMonitorDisconnect transport False False)

613+ , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)

614+ , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)

615+ , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)

616+ , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)

617+ , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)

618+ , ("UnlinkDisconnect", testMonitorDisconnect transport False True)

619+ -- Monitoring nodes and channels

620+ , ("MonitorNode", testMonitorNode transport)

621+ , ("MonitorChannel", testMonitorChannel transport)

622+ ]

distributed-process/tests/TestClosure.hsnew file+332

@@ -0,0 +1,332 @@

1+module Main where

3+import Data.ByteString.Lazy (empty)

4+import Data.Typeable (Typeable, typeOf)

5+import Control.Monad (join, replicateM, forever)

6+import Control.Exception (IOException, throw)

7+import Control.Concurrent (forkIO, threadDelay)

8+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, takeMVar, putMVar)

9+import Control.Applicative ((<$>))

10+import Network.Transport (Transport)

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

12+import Control.Distributed.Process

13+import Control.Distributed.Process.Closure

14+import Control.Distributed.Process.Node

15+import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))

16+import TestAuxiliary

17+

18+sdictInt :: SerializableDict Int

19+sdictInt = SerializableDict

20+

21+factorial :: Int -> Process Int

22+factorial 0 = return 1

23+factorial n = (n *) <$> factorial (n - 1)

24+

25+addInt :: Int -> Int -> Int

26+addInt x y = x + y

27+

28+putInt :: Int -> MVar Int -> IO ()

29+putInt = flip putMVar

30+

31+sendPid :: ProcessId -> Process ()

32+sendPid toPid = do

33+ fromPid <- getSelfPid

34+ send toPid fromPid

35+

36+wait :: Int -> Process ()

37+wait = liftIO . threadDelay

38+

39+isPrime :: Integer -> Process Bool

40+isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]

41+ where

42+ sieve :: [Integer] -> [Integer]

43+ sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]

44+

45+-- | First argument indicates empty closure environment

46+typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()

47+typedPingServer () rport = forever $ do

48+ sport <- receiveChan rport

49+ sendChan sport ()

50+

51+remotable [ 'factorial

52+ , 'addInt

53+ , 'putInt

54+ , 'sendPid

55+ , 'sdictInt

56+ , 'wait

57+ , 'typedPingServer

58+ , 'isPrime

59+ ]

60+

61+factorialClosure :: Int -> Closure (Process Int)

62+factorialClosure = $(mkClosure 'factorial)

63+

64+addIntClosure :: Int -> Closure (Int -> Int)

65+addIntClosure = $(mkClosure 'addInt)

66+

67+putIntClosure :: Int -> Closure (MVar Int -> IO ())

68+putIntClosure = $(mkClosure 'putInt)

69+

70+sendPidClosure :: ProcessId -> Closure (Process ())

71+sendPidClosure = $(mkClosure 'sendPid)

72+

73+sendFac :: Int -> ProcessId -> Closure (Process ())

74+sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid

75+

76+factorialOf :: Closure (Int -> Process Int)

77+factorialOf = staticClosure $(mkStatic 'factorial)

78+

79+factorial' :: Int -> Closure (Process Int)

80+factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf

81+

82+waitClosure :: Int -> Closure (Process ())

83+waitClosure = $(mkClosure 'wait)

84+

85+testUnclosure :: Transport -> RemoteTable -> IO ()

86+testUnclosure transport rtable = do

87+ node <- newLocalNode transport rtable

88+ runProcess node $ do

89+ 120 <- join . unClosure $ factorialClosure 5

90+ return ()

91+

92+testBind :: Transport -> RemoteTable -> IO ()

93+testBind transport rtable = do

94+ node <- newLocalNode transport rtable

95+ runProcess node $ do

96+ us <- getSelfPid

97+ join . unClosure $ sendFac 6 us

98+ (720 :: Int) <- expect

99+ return ()

100+

101+testSendPureClosure :: Transport -> RemoteTable -> IO ()

102+testSendPureClosure transport rtable = do

103+ serverAddr <- newEmptyMVar

104+ serverDone <- newEmptyMVar

105+

106+ forkIO $ do

107+ node <- newLocalNode transport rtable

108+ addr <- forkProcess node $ do

109+ cl <- expect

110+ fn <- unClosure cl :: Process (Int -> Int)

111+ 13 <- return $ fn 6

112+ liftIO $ putMVar serverDone ()

113+ putMVar serverAddr addr

114+

115+ forkIO $ do

116+ node <- newLocalNode transport rtable

117+ theirAddr <- readMVar serverAddr

118+ runProcess node $ send theirAddr (addIntClosure 7)

119+

120+ takeMVar serverDone

121+

122+testSendIOClosure :: Transport -> RemoteTable -> IO ()

123+testSendIOClosure transport rtable = do

124+ serverAddr <- newEmptyMVar

125+ serverDone <- newEmptyMVar

126+

127+ forkIO $ do

128+ node <- newLocalNode transport rtable

129+ addr <- forkProcess node $ do

130+ cl <- expect

131+ io <- unClosure cl :: Process (MVar Int -> IO ())

132+ liftIO $ do

133+ someMVar <- newEmptyMVar

134+ io someMVar

135+ 5 <- readMVar someMVar

136+ putMVar serverDone ()

137+ putMVar serverAddr addr

138+

139+ forkIO $ do

140+ node <- newLocalNode transport rtable

141+ theirAddr <- readMVar serverAddr

142+ runProcess node $ send theirAddr (putIntClosure 5)

143+

144+ takeMVar serverDone

145+

146+testSendProcClosure :: Transport -> RemoteTable -> IO ()

147+testSendProcClosure transport rtable = do

148+ serverAddr <- newEmptyMVar

149+ clientDone <- newEmptyMVar

150+

151+ forkIO $ do

152+ node <- newLocalNode transport rtable

153+ addr <- forkProcess node $ do

154+ cl <- expect

155+ pr <- unClosure cl :: Process (Int -> Process ())

156+ pr 5

157+ putMVar serverAddr addr

158+

159+ forkIO $ do

160+ node <- newLocalNode transport rtable

161+ theirAddr <- readMVar serverAddr

162+ runProcess node $ do

163+ pid <- getSelfPid

164+ send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

165+ 5 <- expect :: Process Int

166+ liftIO $ putMVar clientDone ()

167+

168+ takeMVar clientDone

169+

170+testSpawn :: Transport -> RemoteTable -> IO ()

171+testSpawn transport rtable = do

172+ serverNodeAddr <- newEmptyMVar

173+ clientDone <- newEmptyMVar

174+

175+ forkIO $ do

176+ node <- newLocalNode transport rtable

177+ putMVar serverNodeAddr (localNodeId node)

178+

179+ forkIO $ do

180+ node <- newLocalNode transport rtable

181+ nid <- readMVar serverNodeAddr

182+ runProcess node $ do

183+ pid <- getSelfPid

184+ pid' <- spawn nid (sendPidClosure pid)

185+ pid'' <- expect

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

187+ liftIO $ putMVar clientDone ()

188+

189+ takeMVar clientDone

190+

191+testCall :: Transport -> RemoteTable -> IO ()

192+testCall transport rtable = do

193+ serverNodeAddr <- newEmptyMVar

194+ clientDone <- newEmptyMVar

195+

196+ forkIO $ do

197+ node <- newLocalNode transport rtable

198+ putMVar serverNodeAddr (localNodeId node)

199+

200+ forkIO $ do

201+ node <- newLocalNode transport rtable

202+ nid <- readMVar serverNodeAddr

203+ runProcess node $ do

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

205+ liftIO $ putMVar clientDone ()

206+

207+ takeMVar clientDone

208+

209+testCallBind :: Transport -> RemoteTable -> IO ()

210+testCallBind transport rtable = do

211+ serverNodeAddr <- newEmptyMVar

212+ clientDone <- newEmptyMVar

213+

214+ forkIO $ do

215+ node <- newLocalNode transport rtable

216+ putMVar serverNodeAddr (localNodeId node)

217+

218+ forkIO $ do

219+ node <- newLocalNode transport rtable

220+ nid <- readMVar serverNodeAddr

221+ runProcess node $ do

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

223+ liftIO $ putMVar clientDone ()

224+

225+ takeMVar clientDone

226+

227+testSeq :: Transport -> RemoteTable -> IO ()

228+testSeq transport rtable = do

229+ node <- newLocalNode transport rtable

230+ runProcess node $ do

231+ us <- getSelfPid

232+ join . unClosure $ sendFac 5 us `cpSeq` sendFac 6 us

233+ 120 :: Int <- expect

234+ 720 :: Int <- expect

235+ return ()

236+

237+-- Test 'spawnSupervised'

238+--

239+-- Set up a supervisor, spawn a child, then have a third process monitor the

240+-- child. The supervisor then throws an exception, the child dies because it

241+-- was linked to the supervisor, and the third process notices that the child

242+-- dies.

243+testSpawnSupervised :: Transport -> RemoteTable -> IO ()

244+testSpawnSupervised transport rtable = do

245+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

246+ [superPid, childPid] <- replicateM 2 $ newEmptyMVar

247+ thirdProcessDone <- newEmptyMVar

248+

249+ forkProcess node1 $ do

250+ us <- getSelfPid

251+ liftIO $ putMVar superPid us

252+ (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)

253+ liftIO $ do

254+ putMVar childPid child

255+ threadDelay 500000 -- Give the child a chance to link to us

256+ throw supervisorDeath

257+

258+ forkProcess node2 $ do

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

260+ ref <- monitor child

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

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

263+ && pid' == child

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

265+ liftIO $ putMVar thirdProcessDone ()

266+

267+ takeMVar thirdProcessDone

268+ where

269+ supervisorDeath :: IOException

270+ supervisorDeath = userError "Supervisor died"

271+

272+testSpawnInvalid :: Transport -> RemoteTable -> IO ()

273+testSpawnInvalid transport rtable = do

274+ node <- newLocalNode transport rtable

275+ runProcess node $ do

276+ (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (StaticLabel "ThisDoesNotExist" (typeOf ()))) empty)

277+ ProcessMonitorNotification ref' pid' _reason <- expect

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

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

280+ return ()

281+

282+testClosureExpect :: Transport -> RemoteTable -> IO ()

283+testClosureExpect transport rtable = do

284+ node <- newLocalNode transport rtable

285+ runProcess node $ do

286+ nodeId <- getSelfNode

287+ us <- getSelfPid

288+ them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `cpBind` cpSend $(mkStatic 'sdictInt) us

289+ send them (1234 :: Int)

290+ (1234 :: Int) <- expect

291+ return ()

292+

293+testSpawnChannel :: Transport -> RemoteTable -> IO ()

294+testSpawnChannel transport rtable = do

295+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

296+

297+ runProcess node1 $ do

298+ pingServer <- spawnChannel

299+ (sdictSendPort sdictUnit)

300+ (localNodeId node2)

301+ ($(mkClosure 'typedPingServer) ())

302+ (sendReply, receiveReply) <- newChan

303+ sendChan pingServer sendReply

304+ receiveChan receiveReply

305+

306+testTDict :: Transport -> RemoteTable -> IO ()

307+testTDict transport rtable = do

308+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

309+ runProcess node1 $ do

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

311+ return ()

312+

313+main :: IO ()

314+main = do

315+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

316+ let rtable = __remoteTable initRemoteTable

317+ runTests

318+ [ ("Unclosure", testUnclosure transport rtable)

319+ , ("Bind", testBind transport rtable)

320+ , ("SendPureClosure", testSendPureClosure transport rtable)

321+ , ("SendIOClosure", testSendIOClosure transport rtable)

322+ , ("SendProcClosure", testSendProcClosure transport rtable)

323+ , ("Spawn", testSpawn transport rtable)

324+ , ("Call", testCall transport rtable)

325+ , ("CallBind", testCallBind transport rtable)

326+ , ("Seq", testSeq transport rtable)

327+ , ("SpawnSupervised", testSpawnSupervised transport rtable)

328+ , ("SpawnInvalid", testSpawnInvalid transport rtable)

329+ , ("ClosureExpect", testClosureExpect transport rtable)

330+ , ("SpawnChannel", testSpawnChannel transport rtable)

331+ , ("TDict", testTDict transport rtable)

332+ ]

doc/InternalsTransportMulticast.txtnew file+181

@@ -0,0 +1,181 @@

1+Adding Support for Multicast to the Transport API

2+=================================================

4+This document describes various design options for adding support for multicast

5+to the Transport API.

7+Creating a new multicast group

8+------------------------------

10+We can either have this as part of the transport

11+

12+ data Transport = Transport {

13+ ...

14+ , newMulticastGroup :: IO (Either Error MulticastGroup)

15+ }

16+

17+ data MulticastGroup = MulticastGroup {

18+ ...

19+ , multicastAddress :: MulticastAddress

20+ , deleteMulticastGroup :: IO ()

21+ }

22+

23+or as part of an endpoint:

24+

25+ data Transport = Transport {

26+ newEndPoint :: IO (Either Error EndPoint)

27+ }

28+

29+ data EndPoint = EndPoint {

30+ ...

31+ , newMulticastGroup :: IO (Either Error MulticastGroup)

32+ }

33+

34+It should probably be part of the `Transport`, as there is no real connection

35+between an endpoint and the creation of the multigroup (however, see section

36+"Sending messages to a multicast group").

37+

38+Subscribing to a multicast group

39+--------------------------------

40+

41+This should be part of an endpoint; subscribing basically means that the

42+endpoint wants to receive events when multicast messages are sent.

43+

44+We could reify a subscription:

45+

46+ data EndPoint = EndPoint {

47+ ...

48+ , multicastSubscribe :: MulticastAddress -> IO MulticastSubscription

49+ }

50+

51+ data MulticastSubscription = MulticastSubscription {

52+ ...

53+ , multicastSubscriptionClose :: IO ()

54+ }

55+

56+but this suggests that one might have multiple subscriptions to the same group

57+which can be distinguished, which is misleading. Probably better to have:

58+

59+ data EndPoint = EndPoint {

60+ multicastSubscribe :: MulticastAddress -> IO ()

61+ , multicastUnsubscribe :: MulticastAddress -> IO ()

62+ }

63+

64+Sending messages to a multicast group

65+-------------------------------------

66+

67+An important feature of the Transport API is that we are clear about which

68+operations are *lightweight* and which are not. For instance, creating new

69+endpoints is not lightweight, but opening new connections to endpoints is (as

70+light-weight as possible).

71+

72+Clearly the creation of a new multicast group is a heavyweight operation. It is

73+less evident however if we can support multiple lightweight "connections" to the

74+same multicast group, and if so, whether it is useful.

75+

76+If we decide that multiple lightweight connections to the multigroup is useful,

77+one option might be

78+

79+ data EndPoint = EndPoint {

80+ ...

81+ , connect :: Address -> Reliability -> IO (Either Error Connection)

82+ , multicastConnect :: MulticastAddress -> IO (Either Error Connection)

83+ }

84+

85+ data Connection = Connection {

86+ connectionId :: ConnectionId

87+ , send :: [ByteString] -> IO ()

88+ , close :: IO ()

89+ , maxMsgSize :: Maybe Int

90+ }

91+

92+ data Event =

93+ Receive ConnectionId [ByteString]

94+ | ConnectionClosed ConnectionId

95+ | ConnectionOpened ConnectionId ConnectionType Reliability Address

96+

97+The advantage of this approach is it's consistency with the rest of the

98+interface. The problem is that with multicast we cannot reliably send any

99+control messages, so we cannot make sure that the subscribers of the multicast

100+group will receive ConnectionOpened events when an endpoint creates a new

101+connection. Since we don't support these "connectionless connections" anywhere

102+else in the API this seems inconsistent with the rest of the design (this

103+implies that an "unreliable" Transport over UDP still needs to have reliable

104+control messages). (On the other hand, if we were going to support reliable

105+multicast protocols, then that would fit this design).

106+

107+If we don't want to support multiple lightweight connections to a multicast

108+group then a better design would be

109+

110+ data EndPoint = EndPoint {

111+ , connect :: Address -> Reliability -> IO (Either Error Connection)

112+ , multicastSend :: MulticastAddress -> [ByteString] -> IO ()

113+ }

114+

115+ data Event =

116+ ...

117+ | MulticastReceive Address [ByteString]

118+

119+or alternatively

120+

121+ data EndPoint = EndPoint {

122+ ...

123+ , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup)

124+ }

125+

126+ data MulticastGroup = MulticastGroup {

127+ , ...

128+ , send :: [ByteString] -> IO ()

129+ }

130+

131+If we do this however we need to make sure that newGroup is part an `EndPoint`,

132+not the `Transport`, otherwise `send` will not know the source of the message.

133+The version with `resolveMulticastGroup` has the additional benefit that in

134+"real" implementations we will probably need to allocate some resources before

135+we can send to the multicast group, and need to deallocate these resources at

136+some point too.

137+

138+The current solution

139+--------------------

140+

141+The above considerations lead to the following tentative proposal:

142+

143+ data Transport = Transport {

144+ newEndPoint :: IO (Either Error EndPoint)

145+ }

146+

147+ data EndPoint = EndPoint {

148+ receive :: IO Event

149+ , address :: Address

150+ , connect :: Address -> Reliability -> IO (Either Error Connection)

151+ , newMulticastGroup :: IO (Either Error MulticastGroup)

152+ , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup)

153+ }

154+

155+ data Connection = Connection {

156+ send :: [ByteString] -> IO ()

157+ , close :: IO ()

158+ }

159+

160+ data Event =

161+ Receive ConnectionId [ByteString]

162+ | ConnectionClosed ConnectionId

163+ | ConnectionOpened ConnectionId Reliability Address

164+ | MulticastReceive MulticastAddress [ByteString]

165+

166+ data MulticastGroup = MulticastGroup {

167+ multicastAddress :: MulticastAddress

168+ , deleteMulticastGroup :: IO ()

169+ , maxMsgSize :: Maybe Int

170+ , multicastSend :: [ByteString] -> IO ()

171+ , multicastSubscribe :: IO ()

172+ , multicastUnsubscribe :: IO ()

173+ , multicastClose :: IO ()

174+ }

175+

176+where `multicastClose` indicates to the runtime that this endpoint no longer

177+wishes to send to this multicast group, and we can therefore deallocate the

178+resources we needed to send to the group (these resources can be allocated on

179+`resolveMulticastGroup` or on the first `multicastSend`; the advantage of the

180+latter is that is somebody resolves a group only to subscribe to it, not to

181+send to it, we don't allocate any unneeded resources).

doc/InternalsTransportTCP.txtnew file+81

@@ -0,0 +1,81 @@

1+The TCP Transport

2+=================

4+Overview

5+--------

7+When a TCP transport is created a new server is started which listens on a

8+given port number on the local host. In order to support multiple connections

9+the transport maintains a set of channels, one per connection, represented as a

10+pair of a `MVar [ByteString]` and a list of pairs `(ThreadId, Socket)` of

11+threads that are listening on this channel. A source end then corresponds to a

12+hostname (the hostname used by clients to identity the local host), port

13+number, and channel ID; a receive end simply corresponds to a channel ID.

14+

15+When `mkTransport` creates a new transport it spawns a thread that listens for

16+incoming connections, running `procConnections` (see below). The set of

17+channels (connections) associated with the transport is initialized to be

18+empty.

19+

20+`newConnectionWith` creates a new channel and add its to the transport channel

21+map (with an empty list of associated threads).

22+

23+To serialize the source end we encode the triple of the local host name, port

24+number, and channel ID, and to deserialize we just decode the same triple

25+(deserialize does not need any other properties of the TCP transport).

26+

27+To connect to the source end we create a new socket, connect to the server at

28+the IP address specified in the TCPConfig, and send the channel number over the

29+connection. Then to `closeSourceEnd` we simply close the socket, and to send a

30+bunch of byte strings we output them on the socket.

31+

32+To receive from the target end we just read from the channel associated with

33+the target end. To `closeTargetEnd` we find kill all threads associated with

34+the channel and close their sockets.

35+

36+When somebody connects to server (running `procConnections`), he first sends a

37+channel ID. `procConnections` then spawns a new thread running

38+`procMessages` which listens for bytestrings on the socket and output them on

39+the specified channel. The ID of this new thread (and the socket it uses) are

40+added to the channel map of the transport.

41+

42+`closeTransport` kills the server thread and all threads that were listening on

43+the channels associated with the transport, and closes all associated sockets.

44+

45+Improving Latency

46+-----------------

47+

48+A series of benchmarks has shown that

49+

50+* The use of `-threaded` triples the latency.

51+

52+* Prepending a header to messages has a negligible effect on latency, even when

53+ sending very small packets. However, the way that we turn the length from an

54+ `Int32` to a `ByteString` _does_ have a significant impact; in particular,

55+ using `Data.Serialize` is very slow (and using Blaze.ByteString not much

56+ better). This is fast:

57+

58+ foreign import ccall unsafe "htonl" htonl :: CInt -> CInt

59+

60+ encodeLength :: Int32 -> IO ByteString

61+ encodeLength i32 =

62+ BSI.create 4 $ \p ->

63+ pokeByteOff p 0 (htonl (fromIntegral i32))

64+

65+* We do not need to use `blaze-builder` or related;

66+ `Network.Socket.Bytestring.sendMany` uses vectored I/O. On the client side

67+ doing a single `recv` to try and read the message header and message, rather

68+ one to read the header and one to read the payload improves latency, but only

69+ by a tiny amount.

70+

71+* Indirection through an `MVar` or a `Chan` does not have an observable effect

72+ on latency.

73+

74+* When two nodes _A_ and _B_ communicate, latency is worse when they

75+ communicate over two pairs of sockets (used unidirectionally) rather than one

76+ pair (used bidirectionally) by about 20%. This is not improved by using

77+ `TCP_NODELAY`, and might be because [acknowledgements cannot piggyback with

78+ payload][1] this way. It might thus be worthwhile to try and reuse TCP

79+ connections (or use UDP).

80+

81+[1]: http://lists.freebsd.org/pipermail/freebsd-hackers/2009-March/028006.html "2 uni-directional TCP connection good?"

doc/NetworkTCP.pngnew file

Binary file not shown.

doc/NetworkTCP.svgnew file+657

@@ -0,0 +1,657 @@

1+<?xml version="1.0" encoding="UTF-8" standalone="no"?>

2+

4+<svg

5+ xmlns:dc="http://purl.org/dc/elements/1.1/"

6+ xmlns:cc="http://creativecommons.org/ns#"

7+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"

8+ xmlns:svg="http://www.w3.org/2000/svg"

9+ xmlns="http://www.w3.org/2000/svg"

10+ xmlns:xlink="http://www.w3.org/1999/xlink"

11+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"

12+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"

13+ width="1024px"

14+ height="768px"

15+ id="svg4129"

16+ version="1.1"

17+ inkscape:version="0.48.2 r9819"

18+ sodipodi:docname="NetworkTCP.svg"

19+ inkscape:export-filename="/tmp/distributed-process/doc/NetworkTCP.png"

20+ inkscape:export-xdpi="90.040001"

21+ inkscape:export-ydpi="90.040001">

22+ <defs

23+ id="defs4131">

24+ <linearGradient

25+ id="linearGradient4726">

26+ <stop

27+ style="stop-color:#800000;stop-opacity:1;"

28+ offset="0"

29+ id="stop4728" />

30+ <stop

31+ style="stop-color:#ffffff;stop-opacity:1;"

32+ offset="1"

33+ id="stop4730" />

34+ </linearGradient>

35+ <linearGradient

36+ id="linearGradient4647">

37+ <stop

38+ style="stop-color:#008080;stop-opacity:1;"

39+ offset="0"

40+ id="stop4649" />

41+ <stop

42+ style="stop-color:#ffffff;stop-opacity:1;"

43+ offset="1"

44+ id="stop4651" />

45+ </linearGradient>

46+ <linearGradient

47+ inkscape:collect="always"

48+ xlink:href="#linearGradient4647-0"

49+ id="linearGradient4655-9"

50+ x1="-666.70703"

51+ y1="18.113195"

52+ x2="952.4931"

53+ y2="345.05661"

54+ gradientUnits="userSpaceOnUse"

55+ gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />

56+ <linearGradient

57+ id="linearGradient4647-0">

58+ <stop

59+ style="stop-color:#008080;stop-opacity:1;"

60+ offset="0"

61+ id="stop4649-1" />

62+ <stop

63+ style="stop-color:#ffffff;stop-opacity:1;"

64+ offset="1"

65+ id="stop4651-0" />

66+ </linearGradient>

67+ <linearGradient

68+ inkscape:collect="always"

69+ xlink:href="#linearGradient4647-9"

70+ id="linearGradient4655-8"

71+ x1="-666.70703"

72+ y1="18.113195"

73+ x2="952.4931"

74+ y2="345.05661"

75+ gradientUnits="userSpaceOnUse"

76+ gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />

77+ <linearGradient

78+ id="linearGradient4647-9">

79+ <stop

80+ style="stop-color:#008080;stop-opacity:1;"

81+ offset="0"

82+ id="stop4649-4" />

83+ <stop

84+ style="stop-color:#ffffff;stop-opacity:1;"

85+ offset="1"

86+ id="stop4651-7" />

87+ </linearGradient>

88+ <linearGradient

89+ inkscape:collect="always"

90+ xlink:href="#linearGradient4726-0"

91+ id="linearGradient4732-1"

92+ x1="484.52829"

93+ y1="88.754707"

94+ x2="18.113218"

95+ y2="336.90564"

96+ gradientUnits="userSpaceOnUse" />

97+ <linearGradient

98+ inkscape:collect="always"

99+ id="linearGradient4726-0">

100+ <stop

101+ style="stop-color:#800000;stop-opacity:1;"

102+ offset="0"

103+ id="stop4728-2" />

104+ <stop

105+ style="stop-color:#800000;stop-opacity:0;"

106+ offset="1"

107+ id="stop4730-5" />

108+ </linearGradient>

109+ <linearGradient

110+ gradientTransform="translate(539.26415,1.83019)"

111+ y2="336.90564"

112+ x2="18.113218"

113+ y1="88.754707"

114+ x1="484.52829"

115+ gradientUnits="userSpaceOnUse"

116+ id="linearGradient4755"

117+ xlink:href="#linearGradient4726-0"

118+ inkscape:collect="always" />

119+ <linearGradient

120+ inkscape:collect="always"

121+ xlink:href="#linearGradient4726-6"

122+ id="linearGradient4732-4"

123+ x1="484.52829"

124+ y1="88.754707"

125+ x2="18.113218"

126+ y2="336.90564"

127+ gradientUnits="userSpaceOnUse" />

128+ <linearGradient

129+ id="linearGradient4726-6">

130+ <stop

131+ style="stop-color:#800000;stop-opacity:1;"

132+ offset="0"

133+ id="stop4728-4" />

134+ <stop

135+ style="stop-color:#ffffff;stop-opacity:1;"

136+ offset="1"

137+ id="stop4730-53" />

138+ </linearGradient>

139+ <linearGradient

140+ inkscape:collect="always"

141+ xlink:href="#linearGradient4726-4"

142+ id="linearGradient4732-6"

143+ x1="484.52829"

144+ y1="88.754707"

145+ x2="18.113218"

146+ y2="336.90564"

147+ gradientUnits="userSpaceOnUse" />

148+ <linearGradient

149+ id="linearGradient4726-4">

150+ <stop

151+ style="stop-color:#800000;stop-opacity:1;"

152+ offset="0"

153+ id="stop4728-40" />

154+ <stop

155+ style="stop-color:#ffffff;stop-opacity:1;"

156+ offset="1"

157+ id="stop4730-7" />

158+ </linearGradient>

159+ <linearGradient

160+ inkscape:collect="always"

161+ xlink:href="#linearGradient4726-3"

162+ id="linearGradient4732-2"

163+ x1="484.52829"

164+ y1="88.754707"

165+ x2="18.113218"

166+ y2="336.90564"

167+ gradientUnits="userSpaceOnUse" />

168+ <linearGradient

169+ id="linearGradient4726-3">

170+ <stop

171+ style="stop-color:#800000;stop-opacity:1;"

172+ offset="0"

173+ id="stop4728-8" />

174+ <stop

175+ style="stop-color:#ffffff;stop-opacity:1;"

176+ offset="1"

177+ id="stop4730-1" />

178+ </linearGradient>

179+ </defs>

180+ <sodipodi:namedview

181+ id="base"

182+ pagecolor="#ffffff"

183+ bordercolor="#666666"

184+ borderopacity="1.0"

185+ inkscape:pageopacity="0.0"

186+ inkscape:pageshadow="2"

187+ inkscape:zoom="0.70710678"

188+ inkscape:cx="510.54885"

189+ inkscape:cy="435.44033"

190+ inkscape:current-layer="layer1"

191+ inkscape:document-units="px"

192+ showgrid="false"

193+ showguides="true"

194+ inkscape:guide-bbox="true"

195+ inkscape:window-width="1393"

196+ inkscape:window-height="789"

197+ inkscape:window-x="47"

198+ inkscape:window-y="3"

199+ inkscape:window-maximized="0">

200+ <sodipodi:guide

201+ orientation="1,0"

202+ position="984,175"

203+ id="guide4870" />

204+ </sodipodi:namedview>

205+ <metadata

206+ id="metadata4134">

207+ <rdf:RDF>

208+ <cc:Work

209+ rdf:about="">

210+ <dc:format>image/svg+xml</dc:format>

211+ <dc:type

212+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />

213+ <dc:title />

214+ </cc:Work>

215+ </rdf:RDF>

216+ </metadata>

217+ <g

218+ id="layer1"

219+ inkscape:label="Layer 1"

220+ inkscape:groupmode="layer">

221+ <rect

222+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24376427999999994;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

223+ id="rect4137-5"

224+ width="412.79617"

225+ height="287.24374"

226+ x="571.56415"

227+ y="34.192436" />

228+ <rect

229+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24167538000000000;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

230+ id="rect4137"

231+ width="412.79617"

232+ height="286.27966"

233+ x="33.567425"

234+ y="34.473083" />

235+ <rect

236+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.89734482999999998;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

237+ id="rect4137-6"

238+ width="950.33942"

239+ height="290.35135"

240+ x="32.696255"

241+ y="448.07922" />

242+ <rect

243+ style="fill:#999999;stroke:none;stroke-width:1.97458196000000008;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

244+ id="rect4657-9"

245+ width="582.76776"

246+ height="145.3952"

247+ x="109.61612"

248+ y="-307.5813"

249+ transform="matrix(0,1,-1,0,0,0)" />

250+ <rect

251+ style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1;opacity:1"

252+ id="rect4657"

253+ width="582.76776"

254+ height="149.16254"

255+ x="256.99347"

256+ y="124.76707" />

257+ <text

258+ xml:space="preserve"

259+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"

260+ x="36.887089"

261+ y="73.584908"

262+ id="text4659"

263+ sodipodi:linespacing="125%"><tspan

264+ sodipodi:role="line"

265+ id="tspan4661"

266+ x="36.887089"

267+ y="73.584908"

268+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan

269+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"

270+ id="tspan4038">1</tspan>:<tspan

271+ style="font-weight:normal;-inkscape-font-specification:Courier New;fill:#800000"

272+ id="tspan4036">1080</tspan></tspan></text>

273+ <text

274+ xml:space="preserve"

275+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"

276+ x="574.88385"

277+ y="73.30426"

278+ id="text4659-2"

279+ sodipodi:linespacing="125%"><tspan

280+ sodipodi:role="line"

281+ id="tspan4661-9"

282+ x="574.88385"

283+ y="73.30426"

284+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan

285+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"

286+ id="tspan4042">1</tspan>:<tspan

287+ style="fill:#800000"

288+ id="tspan4044">1081</tspan></tspan></text>

289+ <rect

290+ style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

291+ id="rect4657-7"

292+ width="582.76776"

293+ height="149.16254"

294+ x="229.61612"

295+ y="535.4187" />

296+ <text

297+ xml:space="preserve"

298+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"

299+ x="321.0159"

300+ y="488.19104"

301+ id="text4659-9"

302+ sodipodi:linespacing="125%"><tspan

303+ sodipodi:role="line"

304+ id="tspan4661-90"

305+ x="321.0159"

306+ y="488.19104"

307+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan

308+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"

309+ id="tspan4046">2</tspan>:<tspan

310+ style="fill:#800000"

311+ id="tspan4048">1080</tspan></tspan></text>

312+ <rect

313+ style="fill:#ffa23a;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1"

314+ id="rect4724"

315+ width="366.79245"

316+ height="200.15094"

317+ x="54.339622"

318+ y="95.094337" />

319+ <text

320+ xml:space="preserve"

321+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"

322+ x="62.264153"

323+ y="117.35849"

324+ id="text4734"

325+ sodipodi:linespacing="125%"><tspan

326+ sodipodi:role="line"

327+ id="tspan4736"

328+ x="62.264153"

329+ y="117.35849"

330+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1080:0</tspan></text>

331+ <rect

332+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

333+ id="rect4724-0"

334+ width="366.79245"

335+ height="200.15094"

336+ x="597.60376"

337+ y="98.92453" />

338+ <text

339+ xml:space="preserve"

340+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"

341+ x="605.52832"

342+ y="121.18868"

343+ id="text4734-8"

344+ sodipodi:linespacing="125%"><tspan

345+ sodipodi:role="line"

346+ id="tspan4736-8"

347+ x="605.52832"

348+ y="121.18868"

349+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1081:0</tspan></text>

350+ <rect

351+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

352+ id="rect4724-6"

353+ width="366.79245"

354+ height="200.15094"

355+ x="53.60376"

356+ y="511.92453" />

357+ <text

358+ xml:space="preserve"

359+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier New;-inkscape-font-specification:Courier New"

360+ x="63.52832"

361+ y="534.18872"

362+ id="text4734-0"

363+ sodipodi:linespacing="125%"><tspan

364+ sodipodi:role="line"

365+ id="tspan4736-9"

366+ x="63.52832"

367+ y="534.18872">198.51.100.2:1080:0</tspan></text>

368+ <rect

369+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"

370+ id="rect4724-06"

371+ width="366.79245"

372+ height="200.15094"

373+ x="596.60376"

374+ y="510.92456" />

375+ <text

376+ xml:space="preserve"

377+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"

378+ x="604.52832"

379+ y="533.18872"

380+ id="text4734-02"

381+ sodipodi:linespacing="125%"><tspan

382+ sodipodi:role="line"

383+ id="tspan4736-4"

384+ x="604.52832"

385+ y="533.18872"

386+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.2:1080:1</tspan></text>

387+ <path

388+ sodipodi:type="arc"

389+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

390+ id="path5106"

391+ sodipodi:cx="215.5"

392+ sodipodi:cy="197.5"

393+ sodipodi:rx="14.5"

394+ sodipodi:ry="14.5"

395+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"

396+ transform="translate(22.235847,-2.3301926)" />

397+ <path

398+ sodipodi:type="arc"

399+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

400+ id="path5106-0"

401+ sodipodi:cx="215.5"

402+ sodipodi:cy="197.5"

403+ sodipodi:rx="14.5"

404+ sodipodi:ry="14.5"

405+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"

406+ transform="translate(565.49998,1.5)" />

407+ <path

408+ sodipodi:type="arc"

409+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

410+ id="path5106-7"

411+ sodipodi:cx="215.5"

412+ sodipodi:cy="197.5"

413+ sodipodi:rx="14.5"

414+ sodipodi:ry="14.5"

415+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"

416+ transform="translate(564.49998,413.50003)" />

417+ <path

418+ sodipodi:type="arc"

419+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

420+ id="path5106-06"

421+ sodipodi:cx="215.5"

422+ sodipodi:cy="197.5"

423+ sodipodi:rx="14.5"

424+ sodipodi:ry="14.5"

425+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"

426+ transform="translate(21.499985,414.5)" />

427+ <path

428+ sodipodi:type="star"

429+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

430+ id="path5217"

431+ sodipodi:sides="3"

432+ sodipodi:cx="-58"

433+ sodipodi:cy="224"

434+ sodipodi:r1="15.033296"

435+ sodipodi:r2="7.5166483"

436+ sodipodi:arg1="-1.5707963"

437+ sodipodi:arg2="-0.52359878"

438+ inkscape:flatsided="true"

439+ inkscape:rounded="0"

440+ inkscape:randomized="0"

441+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

442+ inkscape:transform-center-y="-3.7583241"

443+ transform="translate(250,279.48335)" />

444+ <path

445+ sodipodi:type="star"

446+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

447+ id="path5217-1"

448+ sodipodi:sides="3"

449+ sodipodi:cx="-58"

450+ sodipodi:cy="224"

451+ sodipodi:r1="15.033296"

452+ sodipodi:r2="7.5166483"

453+ sodipodi:arg1="-1.5707963"

454+ sodipodi:arg2="-0.52359878"

455+ inkscape:flatsided="true"

456+ inkscape:rounded="0"

457+ inkscape:randomized="0"

458+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

459+ inkscape:transform-center-y="-3.7583241"

460+ transform="translate(336,278.75832)" />

461+ <path

462+ sodipodi:type="star"

463+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

464+ id="path5217-0"

465+ sodipodi:sides="3"

466+ sodipodi:cx="-58"

467+ sodipodi:cy="224"

468+ sodipodi:r1="15.033296"

469+ sodipodi:r2="7.5166483"

470+ sodipodi:arg1="-1.5707963"

471+ sodipodi:arg2="-0.52359878"

472+ inkscape:flatsided="true"

473+ inkscape:rounded="0"

474+ inkscape:randomized="0"

475+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

476+ inkscape:transform-center-y="-3.7583241"

477+ transform="translate(292,278.75832)" />

478+ <path

479+ sodipodi:type="star"

480+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

481+ id="path5217-7"

482+ sodipodi:sides="3"

483+ sodipodi:cx="-58"

484+ sodipodi:cy="224"

485+ sodipodi:r1="15.033296"

486+ sodipodi:r2="7.5166483"

487+ sodipodi:arg1="-1.5707963"

488+ sodipodi:arg2="-0.52359878"

489+ inkscape:flatsided="true"

490+ inkscape:rounded="0"

491+ inkscape:randomized="0"

492+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

493+ transform="matrix(0,1,-1,0,654,214.75832)"

494+ inkscape:transform-center-x="-3.7583239" />

495+ <path

496+ sodipodi:type="star"

497+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

498+ id="path5217-4"

499+ sodipodi:sides="3"

500+ sodipodi:cx="-58"

501+ sodipodi:cy="224"

502+ sodipodi:r1="15.033296"

503+ sodipodi:r2="7.5166483"

504+ sodipodi:arg1="-1.5707963"

505+ sodipodi:arg2="-0.52359878"

506+ inkscape:flatsided="true"

507+ inkscape:rounded="0"

508+ inkscape:randomized="0"

509+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

510+ transform="matrix(0,1,-1,0,653,299.75832)"

511+ inkscape:transform-center-x="-3.7583239" />

512+ <path

513+ sodipodi:type="star"

514+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

515+ id="path5217-49"

516+ sodipodi:sides="3"

517+ sodipodi:cx="-58"

518+ sodipodi:cy="224"

519+ sodipodi:r1="15.033296"

520+ sodipodi:r2="7.5166483"

521+ sodipodi:arg1="-1.5707963"

522+ sodipodi:arg2="-0.52359878"

523+ inkscape:flatsided="true"

524+ inkscape:rounded="0"

525+ inkscape:randomized="0"

526+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

527+ transform="matrix(0,-1,1,0,365,140.75832)"

528+ inkscape:transform-center-x="3.7583235" />

529+ <path

530+ sodipodi:type="star"

531+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

532+ id="path5217-70"

533+ sodipodi:sides="3"

534+ sodipodi:cx="-58"

535+ sodipodi:cy="224"

536+ sodipodi:r1="15.033296"

537+ sodipodi:r2="7.5166483"

538+ sodipodi:arg1="-1.5707963"

539+ sodipodi:arg2="-0.52359878"

540+ inkscape:flatsided="true"

541+ inkscape:rounded="0"

542+ inkscape:randomized="0"

543+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"

544+ transform="matrix(0,1,-1,0,653,665.75832)"

545+ inkscape:transform-center-x="-3.7583239" />

546+ <path

547+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

548+ id="path5272"

549+ d="m 193.68926,500.34844 c -0.0623,-0.011 -3.1352,-0.097 -2.77128,-1.41324 0.2615,-0.94576 1.83318,-1.37784 1.76404,-2.35665 -0.0476,-0.67399 -2.3566,0.0555 -1.96552,-0.49551 3.61436,-5.09213 7.40016,-2.72086 3.75441,-4.53186 -1.02814,0.14511 -2.14021,0.86727 -3.08442,0.43531 -0.51327,-0.2348 0.48469,-1.05111 0.89792,-1.43558 1.1048,-1.02792 2.49187,-1.72109 3.59807,-2.74751 0.46707,-0.43338 1.70248,-1.66102 1.07001,-1.58392 -5.6701,0.69128 -9.05745,4.75136 -4.37921,0.0443 -0.70285,-0.0451 -1.58092,0.33122 -2.10855,-0.13529 -0.36515,-0.32287 0.13779,-0.98089 0.34974,-1.41981 0.746,-1.54482 2.04183,-2.71312 3.1089,-4.00945 0.4506,-0.54741 1.18336,-0.99124 1.28844,-1.69243 0.0528,-0.35257 -0.64405,-0.30591 -0.96608,-0.45886 -0.29448,-0.23467 -0.54733,-0.53426 -0.88345,-0.704 -4.59528,-2.32065 4.03029,4.51864 2.22179,-3.3353 -0.30962,-1.34461 -4.25255,2.34931 -4.01941,0.98936 0.49925,-2.91216 11.67979,-5.28818 -0.97921,-1.80297 2.24958,4.51807 3.74218,-3.55163 2.31947,-3.58424 -1.2249,-0.0281 -2.37028,0.65039 -3.58472,0.8125 -0.52552,0.0702 -1.82785,0.34942 -1.58584,-0.1223 0.5628,-1.09696 1.92657,-1.54028 2.85501,-2.35149 0.70996,-0.62032 1.37164,-1.29381 2.05746,-1.94071 -0.89522,0.15512 -1.79044,0.31024 -2.68566,0.46535 0.40052,-0.43099 1.78504,-1.21739 1.20156,-1.29297 -1.00554,-0.13025 -3.61463,1.73864 -2.84352,1.08028 2.61678,-2.23416 7.40375,-3.51247 2.7139,-2.27363 -0.68863,-0.56914 -4.0411,1.72327 -3.46573,0.69506 6.10702,-10.91337 6.03578,15.71084 15.20135,-9.25342 1.34953,-3.67571 -7.11657,3.28455 -10.78034,4.66617 -0.56483,0.21299 -1.20609,0.0542 -1.80913,0.0813 0.76568,-2.82657 9.84801,-2.83331 8.08522,-5.59671 -1.3756,-2.15643 -4.67918,2.20115 -7.19335,2.67169 -0.59179,0.11076 0.56857,-1.08069 0.98997,-1.51069 0.9071,-0.92561 3.07293,-1.22924 2.96045,-2.52034 -0.0925,-1.06133 -2.0796,0.46382 -3.1194,0.69573 -1.9254,-1.61777 -0.23831,-2.25512 1.24604,-3.92389 0.51908,-0.58358 2.26263,-1.8224 1.48163,-1.81517 -4.72816,0.0437 -15.68126,8.0904 3.31529,-3.96387 -2.08474,0.72265 -4.12918,1.57418 -6.25422,2.16795 -6.19352,1.73056 1.93855,-2.61924 2.43539,-3.11862 0.23788,-0.23911 -1.011,-0.39289 -0.78275,-0.64119 1.19525,-1.30024 3.85496,-1.42731 4.26366,-3.14549 0.29345,-1.23365 -2.47514,0.55288 -3.71271,0.82932 -0.47093,1.29702 -2.86607,-0.7275 -2.30369,-1.43649 1.13698,-1.43339 6.00313,-3.6915 4.17835,-3.55914 -3.87338,0.28095 -7.04111,4.03354 -10.92463,4.04848 -2.19049,0.008 3.44176,-2.71129 5.19354,-4.02643 2.07031,-1.55429 4.18104,-3.054 6.27156,-4.581 -2.38158,0.72626 -4.66588,1.94492 -7.14472,2.17878 -0.53269,0.0503 0.25632,-1.04063 0.43321,-1.5456 0.96518,-2.7553 0.80112,-1.64828 3.58926,-4.46916 0.67747,-0.68544 2.91667,-2.22292 1.95765,-2.12762 -2.73974,0.27225 -5.202,1.80566 -7.80301,2.70849 -8.68307,1.74603 11.86244,-6.07092 8.35137,-7.01022 -1.96335,-0.52524 -6.69769,3.57812 -5.84576,1.73289 1.22888,-2.6617 5.30375,-2.7549 7.30622,-4.89614 0.68666,-0.73425 -2.00109,0.19549 -3.00164,0.29323 0.87732,-0.86011 1.75464,-1.72023 2.63196,-2.58035 -9.58228,3.08729 -5.78397,4.19264 -6.58589,0.97012 -0.0902,-0.3624 -0.0624,-0.93313 -0.42075,-1.03836 -0.91483,-0.26865 -3.5847,0.69399 -2.8594,0.0751 8.61485,-7.35105 17.70344,-8.79375 5.26595,-5.85043 1.60054,-3.41758 1.28401,-1.02057 -0.60908,-2.58794 -0.3464,-0.2868 -0.289,-0.89839 -0.62771,-1.19424 -0.43227,-0.37759 -1.86567,-0.23189 -1.56403,-0.7202 2.34987,-3.80416 8.10292,-4.17851 0.0503,-2.68926 -1.15677,-3.65997 -0.0599,1.01346 5.25047,-5.42269 0.33771,-0.40931 -1.12483,-0.33282 -1.37625,-0.80012 -0.22134,-0.4114 0.2271,-0.9209 0.19939,-1.38724 -0.20588,-3.46551 -0.71496,1.54991 -0.16416,-2.39216 -5.64005,3.38956 6.40177,-4.28155 4.35608,-4.32495 -1.7082,-0.0362 -3.23754,1.16492 -4.92891,1.40681 -0.55643,0.0796 -2.04039,-0.0979 -1.61937,-0.47032 2.59221,-2.29286 6.19284,-3.30617 8.64724,-5.74599 0.70785,-0.70364 -1.99446,0.0827 -2.99169,0.12404 -0.76412,-0.0589 -2.58888,0.52999 -2.29238,-0.17673 0.62545,-1.49077 4.87787,-2.0553 3.688,-3.14973 -1.3995,-1.28723 -3.63271,1.17661 -5.51093,1.47304 -0.6753,0.10658 -1.96892,0.39814 -2.03141,-0.28266 2.03577,-2.47367 2.13582,-1.3059 1.42131,-3.21609 0.58154,-2.04915 3.24163,-2.36974 4.11535,-4.097 -0.79817,-0.13876 -2.2949,0.11553 -1.46683,-1.35383 0.38381,-0.68104 2.31695,-1.56406 1.55829,-1.75265 -1.35197,-0.33608 -2.68049,0.76035 -4.02074,1.14053 10.77595,-7.1105 3.36075,-1.66253 -0.19448,-1.41063 -0.80754,0.0572 1.50647,-0.94746 1.70133,-1.73322 0.0991,-0.39958 -0.87355,-0.0758 -1.18632,-0.34348 -0.22941,-0.19634 -0.44034,-0.65146 -0.2367,-0.87442 1.11915,-1.22532 2.58807,-2.07788 3.88211,-3.11681 0.46226,-0.59368 2.13907,-1.7945 1.38677,-1.78102 -14.87693,0.26652 -1.27125,4.70958 -2.16014,-1.06114 -0.19906,-1.29234 -2.99053,1.78966 -3.84104,0.79648 -2.43359,-2.8418 7.84171,-2.59072 -0.18106,-2.32196 1.26696,-1.11062 2.53393,-2.22125 3.80089,-3.33188 -0.37381,-0.36169 -1.34521,-0.61552 -1.12142,-1.08506 0.6859,-1.4391 2.50279,-2.08411 3.29206,-3.46921 0.30719,-0.53911 0.33063,-1.66965 -0.26531,-1.84246 -1.52437,-0.44204 -4.51329,1.95947 -4.74554,0.38939 -0.28847,-1.95008 2.79003,-2.78566 4.18504,-4.17849 -2.84688,0.77924 -5.61536,1.94441 -8.54064,2.33772 -0.86059,0.11571 -2.88311,-0.10077 -2.4594,-0.85871 1.22634,-2.19374 3.76055,-3.33687 5.69902,-4.93647 2.28197,-1.88304 5.17285,-3.1505 6.95922,-5.5089 0.48483,-0.64009 -1.53136,-0.56213 -2.33353,-0.59804 -1.34734,-0.0603 -2.6893,0.20862 -4.03395,0.31293 0.68463,-0.93535 1.93126,-1.65341 2.0539,-2.80605 0.14342,-1.34792 -3.60803,-0.10431 -3.67727,-1.17576 -0.0618,-0.95616 1.17488,-1.51652 1.82059,-2.22442 3.91139,-4.28816 5.04581,-3.35568 -6.18155,0.79961 3.2876,-2.35602 5.31447,-2.73015 6.79781,-5.80474 0.18346,-0.38028 0.74816,-1.16656 0.32973,-1.223 -1.22167,-0.16479 -2.80483,1.70893 -3.61503,0.77985 -0.71461,-0.81948 1.69757,-1.45353 2.17622,-2.42979 0.17131,-0.3494 -0.3057,-0.71572 -0.45855,-1.07358 0.20589,-0.53947 1.0395,-1.22409 0.61769,-1.61843 -0.59794,-0.559 -1.71607,0.25692 -2.45368,-0.098 -0.35235,-0.16954 -0.12335,-0.77263 -0.16402,-1.16153 -0.35068,-3.35404 1.76007,-2.61899 -2.06169,-3.55371 0.97288,-0.96358 6.7044,-6.50628 7.49127,-7.802 0.42498,-0.6998 1.09682,-2.25813 0.2981,-2.43805 -2.14748,-0.48373 -4.40681,1.64541 -6.52208,1.03607 -0.89757,-0.25856 0.33999,-1.8897 0.85608,-2.66825 0.97958,-1.47772 2.36172,-2.64483 3.54258,-3.96725 0.0597,-0.68098 0.49091,-1.4346 0.17912,-2.04295 -1.44492,-2.81925 -3.89682,2.01552 0.0472,-3.44476 0.58877,-0.81511 2.85288,-2.38727 1.84737,-2.38469 -5.49626,0.0141 -12.52399,6.39939 -2.52177,-1.41194 0.1794,-0.46573 0.24889,-0.99051 0.53821,-1.39719 4.68594,-6.58674 -0.51929,4.47458 -3.32287,-0.5112 -0.864,-1.53652 3.5875,-1.65903 4.094,-3.34747 0.30845,-1.02819 -2.13504,0.50427 -3.19953,0.36577 -0.41883,-0.0545 -0.59573,-0.59889 -0.8936,-0.89833 0.92251,-0.92192 1.84502,-1.84384 2.76752,-2.76576 -1.55796,0.31564 -5.53053,2.28596 -4.67389,0.94692 1.58563,-2.47854 5.13653,-2.97992 7.27047,-5.00568 0.39453,-0.37453 -1.07912,-0.19012 -1.5841,-0.39242 -2.59907,-1.04122 1.45702,-1.10305 -3.99527,-0.0413 0.23249,-0.50921 2.4381,-3.75255 2.14815,-3.95163 -0.6386,-0.43846 -1.56195,0.16288 -2.3238,0.0227 -0.41951,-0.0772 -0.73377,-0.43517 -1.10066,-0.65276 -1.05703,0.094 -2.11405,0.18798 -3.17108,0.28197 14.56659,-10.91162 6.60855,-1.66215 5.19861,-5.97316 -0.7148,-2.18559 1.24321,-1.65251 -0.51252,-3.60095 -0.48504,-0.53828 -1.8482,-0.40764 -1.85561,-1.13218 -0.0121,-1.18458 1.20852,-2.03788 1.81278,-3.05682 -9.27694,-0.46414 -0.43422,1.04567 -1.03621,-3.77995 -0.14103,-1.13058 -2.45562,0.40168 -3.41099,-0.2191 -0.53557,-0.348 -0.27624,-1.42029 0.13193,-1.91155 1.52211,-1.83192 3.75639,-2.96142 5.37142,-4.71197 0.69547,-0.75384 0.97981,-1.80216 1.46971,-2.70325 -0.96071,-0.0793 -1.91817,-0.23172 -2.88212,-0.23794 -8.55832,-0.0551 2.30363,2.43158 5.84613,-5.75478 1.04199,-2.40794 -6.05494,4.67811 -7.47329,2.47082 -1.97994,-3.08124 13.63059,-6.08404 2.2912,-3.51859 -0.25021,-0.2252 -0.8741,-0.36244 -0.75064,-0.67561 0.33861,-0.85888 1.28474,-1.33325 1.8349,-2.07463 0.3234,-0.4358 1.30072,-1.54508 0.76935,-1.4348 -2.61741,0.54321 -4.9249,2.12483 -7.50279,2.83224 -0.26475,0.0727 -0.6308,-0.3697 -0.53436,-0.62673 0.22699,-0.60501 0.87117,-0.95461 1.30676,-1.43191 8.33195,-4.95149 5.03236,-1.13737 6.11797,-4.3184 0.10381,-0.30416 0.66881,-0.79561 0.36265,-0.89337 -0.70346,-0.22461 -2.72427,0.82235 -2.19373,0.30871 3.86981,-3.74657 7.01351,-2.20799 4.21301,-3.35731 6.47296,-4.28612 -2.20647,1.73687 -2.12215,-0.0258 0.0771,-1.61222 3.0843,-1.12915 4.34522,-2.13676 0.70337,-0.56207 -1.70011,0.66929 -2.59767,0.74027 -0.317,0.0251 0.78281,-0.5597 2.49822,-1.51137 0.46567,-0.53737 0.66407,-0.83263 1.36374,-1.22722 0.98725,-0.55676 2.06782,-0.93963 3.04281,-1.51759 0.0706,-0.0419 -0.0426,-0.23655 -0.12151,-0.21413 -5.29503,1.50384 -4.40257,3.36258 -5.22385,1.37394 3.06387,-1.38383 6.12774,-2.76767 9.1916,-4.1515 -1.02417,0.2612 -2.73589,1.78554 -3.07252,0.78362 -0.34305,-1.02104 2.16911,-0.75459 2.7855,-1.63792 0.3836,-0.54973 -1.31058,0.6231 -1.95917,0.45373 -0.38527,-0.1006 0.60234,-0.53362 0.95654,-0.71554 1.47371,-0.75691 3.00581,-1.3943 4.50871,-2.09145 -0.63184,0.1759 -1.24071,0.5651 -1.89552,0.52772 -0.3639,-0.0208 0.62135,-0.38155 0.92504,-0.58312 3.01431,-2.00081 5.71058,-4.58179 9.02869,-6.02384 1.54675,-0.67223 -4.64784,3.89499 -4.52219,5.19822 0.0355,0.36779 0.73819,0.0341 1.10729,0.0512 4.32563,-0.80488 7.35768,-4.13082 11.1,-6.17039 0.43499,-0.23707 -1.10983,0.83769 -0.82002,1.23946 0.2765,0.38331 0.88036,-0.35243 1.29073,-0.58691 0.67659,-0.38659 1.30782,-0.84766 1.96173,-1.27149 -5.61569,3.81123 5.847,-4.12908 4.57733,-2.85552 -1.45264,1.4571 -6.72903,3.75042 -4.68856,4.01464 2.53042,0.32765 4.77089,-2.05254 6.66849,-3.75827 1.18442,-1.06466 -3.01765,1.13692 -4.60412,1.27648 -0.49565,0.11429 -1.88012,0.66559 -1.48695,0.34287 0.77429,-0.63555 1.7993,-0.88123 2.69333,-1.33308 0.97151,-0.49102 1.95644,-0.95806 2.9031,-1.49543 2.92382,-1.0436 -0.19707,-0.51294 -0.0215,-0.62582 1.25048,-0.80387 2.65543,-1.33729 3.98314,-2.00593 0,0 4.7807,-1.95243 4.7807,-1.95243 l 0,0 c -1.85659,1.05808 -3.72243,2.42084 -5.65484,3.34966 -9.08762,4.36805 -8.0472,3.12416 2.63095,-0.35854 0.20723,-0.0676 -0.32075,0.29522 -0.48112,0.44283 -2.06995,0.87954 -4.1399,1.75908 -6.20986,2.63862 0.9538,-0.27297 3.69622,-1.35491 2.86139,-0.81891 -2.24338,1.44037 -4.80919,2.30726 -7.15434,3.57521 -0.84863,0.45883 -2.71756,2.51318 -2.41323,1.5977 0.55196,-1.66044 2.99692,-2.07528 3.70559,-3.71809 2.47079,-5.12674 -0.15677,0.50283 -12.08956,8.85874 -0.3399,0.23801 0.52938,-0.68968 0.57986,-1.10155 0.0246,-0.20093 -0.29494,-0.28758 -0.38754,-0.4676 -0.11097,-0.21572 -0.0206,-0.54638 -0.21125,-0.69644 -0.23265,-0.18316 -0.58274,-0.10535 -0.8741,-0.15803 -1.08077,0.53197 -2.16154,1.06394 -3.2423,1.59591 0.61123,-0.74052 2.73074,-2.56403 1.8337,-2.22155 -2.15024,0.82093 -3.72623,2.75117 -5.80559,3.73796 -0.98272,0.46636 -3.62463,1.55286 -3.21762,0.54411 0.0771,-0.19114 4.26615,-1.34033 5.19748,-1.60123 -0.002,0.84843 0.0797,0.35024 -1.54628,1.13776 -2.43685,1.18026 -4.9713,2.16361 -7.35391,3.44985 -0.17851,0.0964 0.36821,0.22917 0.57035,0.21223 0.76295,-0.0639 2.88998,-0.87285 2.25259,-0.44871 -1.73923,1.15733 -3.76736,1.80676 -5.65104,2.71013 10.64971,-3.49618 2.1377,-0.93772 0.0559,0.71953 -0.87207,0.69424 4.11786,-1.63073 3.18387,-1.02234 -2.76085,1.79836 -4.83888,1.37533 -6.50296,3.57948 0.91407,-0.27289 1.78835,-0.80636 2.74221,-0.81867 0.91196,-0.0118 -3.46726,1.47612 -1.8579,1.29003 0.88484,-0.10231 1.72074,-1.001 2.56995,-0.7322 1.4859,0.47035 -9.20657,3.22381 1.57572,0.11558 -2.36017,1.26735 -4.72034,2.53469 -7.08052,3.80204 0.11469,0.19623 0.51051,0.43392 0.34406,0.58869 -1.0316,0.95918 -4.91768,2.38029 -3.50929,2.35433 2.37641,-0.0438 4.3475,-2.14947 6.70962,-2.41333 0.99204,-0.11081 -4.76651,2.1144 -1.8757,2.33444 -2.47051,2.27022 -1.40706,0.62544 -0.30171,1.4434 0.23656,0.17505 0.58096,0.61391 0.35865,0.80673 -10.38418,9.00668 -4.16531,0.51016 -6.4293,6.51935 2.63048,-0.9705 5.18095,-2.19421 7.89145,-2.91149 0.52827,-0.1398 2.01774,0.0636 1.58915,0.40263 -3.37773,2.67161 -8.32186,3.49544 -10.88911,6.95316 -1.61096,2.16972 5.0682,-1.89717 7.67205,-2.62025 1.25504,-0.34852 2.5621,-0.62886 3.86383,-0.5832 0.65675,0.023 1.20643,0.52147 1.80965,0.7822 -3.46414,2.44363 -7.191,4.55195 -10.39243,7.33089 -0.58409,0.50701 -1.35877,1.98436 -0.62675,2.2341 1.58563,0.54094 3.29876,-0.62716 4.96942,-0.75257 1.2209,-0.0917 4.12945,-1.03159 3.67154,0.10389 -2.69944,6.69376 -9.76124,4.11086 -2.82461,5.80978 6.90857,0.95619 0.9429,-0.72532 -1.57226,5.00935 -0.34511,0.78688 2.32093,-0.12806 2.47595,0.71707 0.20152,1.09859 -1.35608,1.79559 -1.82949,2.80722 -0.6057,1.2943 -0.13837,2.97783 -1.37315,4.06119 6.75468,-0.97119 2.63252,-1.01551 -0.36648,2.73408 -0.22941,0.28683 0.44063,0.77321 0.80719,0.75004 1.40095,-0.0885 4.53648,-2.38467 4.07603,-1.05858 -1.26042,3.62998 -8.23101,3.63354 -3.0188,3.37711 -1.05416,3.23385 -0.10913,-0.73895 4.56561,-0.24918 0.70549,0.0739 -0.68816,1.25315 -1.15449,1.78768 -0.64077,0.73448 -4.96366,4.6973 -5.48665,5.53109 -0.22878,0.36475 0.0942,0.85596 0.14131,1.28395 6.80006,0.91876 -1.15929,-0.83571 1.30873,1.95101 0.51573,0.58233 2.76862,-0.57122 2.33248,0.0729 -1.14053,1.68436 -4.05337,1.81352 -4.87103,3.67613 -0.54479,1.24101 4.28517,-2.52858 4.06555,0.0598 -0.63833,0.76458 -1.43148,1.42297 -1.915,2.29376 -0.0769,0.1384 -0.3511,2.69941 -0.12976,2.8934 0.56558,0.4957 2.22633,-0.20159 2.18825,0.54951 -0.064,1.2629 -1.57761,1.97665 -2.36641,2.96498 -0.019,0.66037 -0.0381,1.32074 -0.0571,1.98111 0.94651,0.22022 2.00211,0.1676 2.83952,0.66067 1.70887,1.0062 0.93959,2.64925 0.89198,4.10584 -0.0661,2.02294 0.18274,3.87611 1.1481,5.67875 -1.06661,1.09941 -2.13322,2.19882 -3.19983,3.29823 0.2676,0.37359 1.04509,0.73029 0.80279,1.12077 -0.8266,1.33216 -3.21601,1.62884 -3.46899,3.17607 -0.16227,0.99251 2.62242,-1.24441 3.00082,-0.31263 1.09046,2.68514 -8.21468,3.66408 1.80952,1.70153 -1.63218,1.29533 -4.86877,1.80245 -4.89653,3.88598 -0.0224,1.67689 3.19324,-1.46022 4.86198,-1.29358 0.65024,0.0649 -1.66078,1.77119 -1.014,1.67783 7.46951,-1.07821 11.3939,-6.41009 0.77149,1.84447 -0.88572,0.68828 -1.57915,1.5935 -2.36873,2.39026 1.30757,-0.26932 2.64879,-1.20722 3.92271,-0.80795 0.63932,0.20037 -0.58657,1.23688 -1.06824,1.70258 -1.32676,1.28278 -3.70274,1.74138 -4.29988,3.48758 -0.15335,0.44846 6.75296,-0.67501 6.46415,-0.24736 -1.58594,2.34843 -4.48718,3.46216 -6.73077,5.19323 1.3217,-0.0924 2.67555,-0.58142 3.96508,-0.27724 0.51852,0.1223 1.02338,0.92317 0.77805,1.39606 -0.77215,1.48839 -2.31758,2.42555 -3.41729,3.69131 -0.96138,1.10654 -2.78709,1.9559 -2.76247,3.42152 0.0163,0.96872 1.93043,0.30116 2.83102,0.65839 0.65744,0.26079 1.18121,0.77827 1.77181,1.16741 -2.81262,4.75928 -2.80872,3.10652 4.67589,1.64938 -1.26041,3.25333 -6.0635,3.67638 -8.34922,6.31233 -0.54709,0.63092 1.63108,0.59247 2.45866,0.48082 6.96578,-0.93979 6.8916,-4.14914 6.40783,-0.21327 -1.18995,1.02522 -2.55904,1.87345 -3.56986,3.07565 -0.54677,0.6503 0.29383,1.66499 0.74286,1.93962 0.0538,0.0329 2.28883,0.36373 1.51653,1.38907 -0.74758,0.99254 -1.85029,1.65906 -2.77544,2.48858 -2.01492,4.0117 0.0735,-1.05844 4.36134,-0.0885 1.08359,0.24512 -1.77515,1.36522 -2.48925,2.21628 -0.52276,0.62303 0.058,4.29809 2.41131,0.37226 -1.92105,1.23721 -3.8421,2.47441 -5.76316,3.71162 0.3956,0.10122 0.79231,0.40919 1.18678,0.30368 2.2344,-0.59765 5.44044,-4.40981 6.52306,-2.36587 3.53427,6.67249 -6.90959,1.38524 -6.55868,5.44393 0.0324,0.37432 0.7442,0.19661 1.04558,0.42095 0.25204,0.18763 0.3661,0.51079 0.54915,0.76618 0.0712,0.37017 -0.10001,0.90141 0.21364,1.11051 0.53553,0.35702 2.28266,-0.21938 1.90691,0.30318 -1.19701,1.66473 -3.90255,1.96694 -4.84762,3.78655 -0.45816,0.88212 2.94486,-1.17713 2.97633,-0.18363 0.0919,2.90267 -10.32021,4.68553 2.55412,1.32332 -13.88816,10.05064 -4.21703,1.92319 -0.25957,2.91804 1.17513,0.29542 -1.99914,1.5097 -2.55359,2.58711 -0.16659,0.32374 0.84505,0.2375 0.91628,0.59456 0.15946,0.79941 -1.27266,1.48463 -0.45859,2.40209 -0.70281,0.75107 -2.11627,1.22464 -2.10843,2.25323 0.027,3.53852 5.53042,-3.86509 0.87871,2.07078 -0.73188,0.93392 -3.50631,2.521 -2.33181,2.68947 4.62982,0.66407 18.02038,-9.23088 -2.55995,4.0518 0.41314,0.23165 0.79809,0.52297 1.23941,0.69496 0.55373,0.2158 1.74031,-0.13462 1.72268,0.45941 -0.03,1.01163 -1.4099,1.50852 -1.80872,2.4387 -0.19008,0.44335 0.29109,0.9798 0.14581,1.43979 -0.89241,2.82552 -2.35877,1.39391 0.18581,2.80361 1.15576,-0.0399 2.31084,-0.1194 3.4673,-0.11973 0.91829,-2.6e-4 2.02747,-0.44581 2.75234,0.11795 1.24736,0.97013 -3.54168,3.86915 -2.35717,3.83563 5.02162,-0.14213 14.14556,-7.29822 -0.0472,2.40961 2.98489,1.23449 0.18921,-0.41624 -0.68824,2.82616 -0.60033,2.21837 4.83753,-1.87475 0.42281,2.20368 -5.8186,5.37536 -11.65517,6.41542 5.10315,0.15479 -0.74735,0.80324 -1.36046,1.75663 -2.24204,2.40972 -2.59356,1.92134 -5.97818,2.8581 -8.12378,5.26942 -0.94007,1.05648 3.87672,-2.20293 4.1629,-0.81801 0.32872,1.59077 -5.29356,3.22403 -3.66927,3.20683 9.34954,-0.099 9.14109,-6.9726 8.95016,-1.77383 -0.66494,0.80063 -1.18496,1.74821 -1.99481,2.40188 -2.30911,1.8638 -6.64809,2.20309 -7.2977,5.09856 -0.49714,2.2159 4.34211,-1.35479 6.56359,-1.82642 1.09779,-0.23306 4.03951,-1.16883 3.35516,-0.27937 -5.32352,6.9192 -9.26326,2.75287 -6.07651,5.70641 1.67414,2.04701 0.30461,0.84469 5.41887,-0.72561 0.11184,0.1144 -6.91012,5.41422 -6.9318,5.49711 -0.24616,0.94113 1.90254,-0.44718 2.87321,-0.5114 0.52816,-0.0349 1.04869,0.14483 1.57303,0.21724 -1.52161,1.1575 -3.3167,2.0243 -4.56482,3.47251 -0.44671,0.51832 2.2492,0.46712 1.74568,1.2988 -0.6216,1.02671 -3.07583,1.37328 -2.61071,2.47971 1.65123,3.92793 4.90473,-3.87333 2.6877,0.77006 -6.66072,5.56962 0.36798,-0.83336 4.28539,-0.27792 1.1079,0.15709 -5.53866,3.34557 -5.46553,4.78461 0.037,0.72743 2.02338,-0.83333 2.15168,0.38075 4.12173,0.99404 -0.0563,-0.29498 -6.22292,4.83789 -0.56224,0.46799 1.47621,-0.0627 2.178,-0.26914 1.64502,-0.48384 3.21416,-1.19582 4.82264,-1.78991 1.49947,-0.55383 4.24314,-3.23134 4.50121,-1.65384 0.27342,1.67132 -2.893,1.76151 -4.3395,2.64227 -1.95306,2.20485 -4.62765,2.88503 -7.18354,4.55102 -0.27259,0.17768 0.66562,-0.2445 0.96818,-0.12476 0.19028,0.0753 0.12726,0.38899 0.19089,0.58349 1.80537,-0.61886 3.61073,-1.23772 5.4161,-1.85658 -0.84041,0.72567 -1.82938,1.30856 -2.52124,2.17702 -0.1752,0.21991 0.033,0.56791 0.12198,0.83464 0.96367,2.88967 4.76481,-1.02093 4.14926,2.23243 -2.60527,1.74858 -5.40667,3.23551 -7.81581,5.24574 -0.25305,0.21115 0.40301,0.70659 0.73015,0.66667 1.61028,-0.1965 3.11405,-0.91185 4.68222,-1.32713 5.53619,-1.46608 4.75726,-1.80858 1.75589,1.30793 -0.67715,0.70314 -1.3174,1.4409 -1.97611,2.16135 0.34892,0.13924 1.05014,0.0421 1.04674,0.41771 -0.003,0.31093 -2.48306,3.33637 -2.38036,3.44466 1.97496,2.08253 2.7307,-1.87751 3.63602,0.61954 0.13879,0.38282 -0.0124,0.81431 -0.0186,1.22147 -0.72121,0.73268 -1.83167,1.22502 -2.16363,2.19804 -0.14402,0.42214 0.92361,0.15463 1.26175,0.44549 0.23821,0.2049 0.0682,0.67886 0.29638,0.89481 1.89225,1.79045 3.97497,-3.22614 -2.61618,3.25198 -0.37523,0.3688 -0.44084,0.95545 -0.66126,1.43318 -0.74546,2.83605 -0.90252,1.57357 3.71736,0.86489 0.008,0.42841 -6.88909,5.34977 -7.0881,6.42457 -0.14836,0.80124 1.73679,-0.14013 2.42695,0.2931 0.35611,0.22354 0.032,0.84032 0.048,1.26048 0,0 0.60987,-0.29215 0.60987,-0.29215 z"

550+ inkscape:connector-curvature="0" />

551+ <path

552+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

553+ id="path5274"

554+ d="m 235.10087,494.853 c -1.72477,0.26384 -3.45101,1.06486 -5.1743,0.79153 -0.6595,-0.1046 -1.35563,-1.23186 -0.95104,-1.76306 1.85598,-2.43682 6.54502,-3.01774 6.90875,-6.05919 0.24847,-2.0776 -4.22104,1.06972 -6.25171,0.56521 -0.73743,-0.18322 -0.89283,-1.60823 -0.45989,-2.23268 1.45131,-2.09329 3.73816,-3.46105 5.60724,-5.19158 -1.30165,-0.0397 -3.61704,1.15104 -3.90497,-0.11899 -0.346,-1.52615 2.44277,-2.11658 3.07345,-3.54874 0.21772,-0.49443 -0.40056,-1.19952 -0.92452,-1.33116 -2.9824,-0.74933 -3.35447,1.04728 -6.00663,-0.1243 -0.44177,-0.19515 -0.59317,-0.76231 -0.88975,-1.14347 -1.62467,-2.19337 7.01252,-3.6846 6.03097,-6.4629 -0.35181,-0.99579 -2.82628,0.69214 -3.15292,-0.31219 -0.38064,-1.1704 1.77768,-1.8691 2.05342,-3.06855 0.13841,-0.60205 -0.6583,-1.04553 -0.98745,-1.56829 0.30475,-0.89097 0.60949,-1.78193 0.91424,-2.67289 -7.53264,-2.23618 2.38396,1.59728 1.54227,-5.15805 -0.19963,-1.60228 -4.7333,1.91176 -4.83467,0.30028 -0.13257,-2.10718 3.96145,-2.35795 4.5782,-4.3772 0.30919,-1.0123 -2.1105,-0.1648 -3.16575,-0.24721 1.05904,-1.13455 2.11809,-2.26911 3.17714,-3.40366 -0.0107,-0.005 -2.87769,-1.00308 -2.64038,-1.81722 0.28175,-0.96659 2.02632,-1.34668 1.90262,-2.34586 -0.0907,-0.7326 -2.66456,0.44301 -2.21022,-0.13879 4.30542,-5.51324 7.1961,-2.12072 4.55559,-4.73091 -10.33839,2.77071 -4.13255,1.83896 0.36955,-2.9086 0.29783,-0.31407 -0.57517,-0.86256 -1.00599,-0.821 -1.92044,0.18526 -4.33153,2.91099 -5.60131,1.45839 4.33291,-3.89435 5.22082,-2.41149 2.30678,-4.64367 -0.95622,-0.209 -2.72732,0.34155 -2.86867,-0.62699 -0.18982,-1.30072 1.45602,-2.19689 2.31084,-3.19549 1.82796,-2.13542 4.60067,-3.91377 5.39003,-6.85628 0.1612,-0.60094 0.29581,-1.49754 -0.21396,-1.85426 -0.8024,-0.56149 -1.9457,-0.22517 -2.91855,-0.33776 13.2084,-10.64887 -4.15898,2.78139 1.32237,-6.03641 0.64361,-1.03536 2.37686,-1.74659 2.16556,-2.94724 -3.43454,-0.58468 -2.63967,0.45586 -3.04384,-2.48312 -1.56436,2.8e-4 -3.65465,1.17085 -4.69308,8.6e-4 -0.85123,-0.95908 0.86545,-2.44305 1.58105,-3.50717 1.18764,-1.76606 2.96115,-3.10066 4.08003,-4.91106 5.48924,-8.88184 -2.19873,1.44113 -2.88812,-4.43772 -0.21626,-1.84413 2.23606,-2.96484 3.35409,-4.44726 -0.43526,2.04932 -5.52153,-1.4114 -4.49527,-2.86108 1.54224,-2.17853 4.97434,-2.83829 6.00046,-5.30235 0.48638,-1.16795 -3.85006,1.27155 -3.79552,0.008 0.29225,-6.77243 6.68102,-1.96905 2.60362,-4.63478 -1.03744,0.0157 -3.37206,1.05159 -3.11233,0.0471 0.4629,-1.79031 2.90142,-2.33554 4.07379,-3.76559 0.6145,-0.74957 0.86383,-1.74051 1.18878,-2.65368 0.33006,-0.92755 1.7161,-2.57839 0.77018,-2.8514 -7.79155,-2.2488 -8.87812,5.07596 -6.27386,-2.9532 -0.19249,-5.38304 7.51347,-6.23842 8.35735,-10.67915 0.32218,-1.6954 -4.83804,1.06359 -5.13804,-0.63588 -0.37881,-2.14591 3.18898,-3.10151 4.13147,-5.06624 0.37314,-0.77786 -0.50218,-1.68058 -0.48124,-2.54306 0.0239,-0.98457 0.40879,-1.92683 0.61318,-2.89025 -13.08296,-3e-5 0.34211,1.32306 -2.48426,-3.42912 -0.72627,-1.22112 -2.99658,0.75682 -4.26095,0.10876 -0.63537,-0.32567 0.43448,-1.404 0.35062,-2.11303 -0.59735,-5.05055 -8.30722,4.38127 5.7127,-6.54936 -0.0182,-1.2e-4 -4.80445,0.71053 -5.00217,-1.19016 -0.0931,-0.89458 1.35621,-1.63297 1.05882,-2.48178 -0.26951,-0.7692 -2.36655,-0.1317 -2.25749,-0.93942 0.21104,-1.56284 1.93828,-2.48832 2.89013,-3.74569 0.93981,-1.24147 1.8564,-2.50034 2.7846,-3.75051 -2.76858,-2.34245 -1.68916,-0.49431 -0.42062,-4.50395 0.27132,-0.8576 0.13894,-1.83132 0.51325,-2.64924 0.0839,-0.18345 4.09283,-3.81873 1.03007,-4.56276 -1.17187,-0.28469 -2.40782,0.1402 -3.61173,0.2103 0.44344,-0.69241 1.62548,-1.3098 1.33032,-2.07723 -0.27912,-0.72573 -1.74502,0.12468 -2.29333,-0.42664 -2.14536,-2.1571 2.94322,-3.721 4.63358,-7.16098 0.43562,-0.88652 -0.5755,-1.88984 -0.86326,-2.83476 1.38204,-1.92046 2.76407,-3.84091 4.1461,-5.76136 -1.12321,-2.72543 -5.51508,-1.70553 -6.87835,-3.97595 -0.64832,-1.07972 0.6824,-2.56943 0.29228,-3.76689 -0.32662,-1.00257 -2.37342,-1.18153 -2.24537,-2.22816 0.2216,-1.8113 4.5249,-3.42652 3.07232,-4.53103 -2.03388,-1.54653 -5.05737,0.73258 -7.58605,1.09887 3.45501,-4.83392 2.38586,-3.59475 6.51263,-8.25392 1.30105,-1.46891 3.68816,-2.41085 3.96198,-4.3539 0.1544,-1.09559 -3.26799,0.49128 -3.26173,-0.61512 0.0295,-5.20775 9.08516,-4.03102 -1.61053,-3.94352 1.95939,-1.79801 4.27984,-3.26861 5.87816,-5.39403 0.5383,-0.71582 1.049,-2.4148 0.1935,-2.67992 -2.17746,-0.6748 -4.83656,1.77094 -6.80983,0.62951 -1.14404,-0.66177 0.90074,-2.53951 1.7331,-3.56613 5.14504,-6.34577 8.38621,-4.56052 2.51601,-6.13981 -0.85199,-0.32077 -2.4474,-0.0584 -2.55599,-0.96231 -0.15992,-1.33111 1.81714,-2.15158 2.02274,-3.47641 0.10406,-0.6705 -0.95976,-0.99901 -1.23172,-1.62066 -0.25041,-0.57238 0.0184,-1.30737 -0.28754,-1.8521 -0.28092,-0.5002 -1.61971,-0.55889 -1.35127,-1.06589 0.82116,-1.55092 2.55255,-2.40897 3.82883,-3.61345 0.68857,-0.86315 3.1386,-2.32855 2.06571,-2.58945 -10.65886,-2.59195 -5.5639,9.83091 1.19302,-3.59935 0.81945,-1.62876 -6.02054,2.91187 -5.33113,1.22396 2.10963,-5.16508 13.61278,-6.44046 1.79364,-4.30704 0.21403,-0.73136 0.91552,-1.4828 0.64208,-2.1941 -0.26442,-0.68781 -1.27472,-0.73968 -1.91207,-1.10953 1.76068,-1.5448 5.50805,-2.30302 5.28205,-4.63441 -0.18401,-1.89836 -4.58115,2.58145 -5.63515,0.99188 -2.44934,-3.69394 14.48858,-5.96488 -2.32442,-2.54757 -1.7179,-1.85348 6.47741,-4.03448 5.12419,-6.41256 -0.5953,-1.04614 -2.55849,0.49122 -3.60971,-0.095 -0.53027,-0.29573 -0.24018,-1.38425 0.19132,-1.81139 2.01047,-1.99013 4.52431,-3.3972 6.78646,-5.0958 0,0 0.68933,-0.35123 0.68933,-0.35123 l 0,0 c -1.6505,1.38695 -3.301,2.7739 -4.9515,4.16084 1.18084,-0.0304 3.93897,-1.20381 3.54252,-0.0911 -0.76705,2.15293 -7.26975,3.74376 -5.1306,4.54845 4.99319,1.8783 18.98607,-10.22151 2.1677,2.69716 4.46028,0.74689 2.96356,-0.31341 -0.0889,3.77723 -0.63494,0.85088 -2.69281,2.50424 -1.65372,2.72204 2.33328,0.48909 4.58505,-1.63653 6.96887,-1.60791 0.61976,0.007 1.18756,1.25976 0.75189,1.70062 -2.49496,2.5247 -5.74404,4.17153 -8.61606,6.2573 12.12981,-2.41278 3.30013,-1.95214 3.56234,1.57757 0.054,0.72705 2.55848,-0.20768 2.15087,0.39678 -1.23294,1.82837 -6.14542,2.11983 -5.18729,4.10604 2.15892,4.47548 10.45489,-6.74524 4.2017,0.92413 2.15257,3.5125 1.16422,0.95894 -5.41535,6.17669 1.26621,2.35461 6.76352,-4.43669 7.77661,-1.96259 8.28333,20.22899 -28.85471,-8.50838 3.09217,3.12802 1.84928,0.67359 -2.68677,2.87671 -4.03016,4.31506 -0.92921,1.24117 -1.85842,2.48233 -2.78763,3.7235 0.58132,0.56011 1.79929,0.87498 1.74397,1.68034 -0.0987,1.43783 -1.97261,2.33537 -2.11827,3.76921 -0.0857,0.8441 1.28221,1.22332 1.52863,2.03519 1.49261,4.91758 -5.97031,3.63582 7.4952,1.34569 -0.55001,0.45931 -10.77994,8.64592 -11.73418,10.56561 -0.32217,0.64811 2.10161,0.84706 1.64937,1.41214 -2.09388,2.61633 -7.66175,2.96102 -7.82786,6.30795 -0.16991,3.4234 8.56273,-4.46712 10.27927,-0.27127 -1.76159,1.81971 -3.52318,3.63942 -5.28477,5.45913 0.76622,0.59813 2.4346,0.8319 2.29867,1.79438 -0.27968,1.9803 -3.80714,3.11034 -3.26317,5.0349 0.46282,1.63743 4.21131,-0.43752 4.99021,1.07532 3.93398,7.64091 -10.83273,3.14159 3.44758,5.72402 -0.9151,1.68254 -1.83021,3.36508 -2.74532,5.04762 -0.11662,1.15096 0.18214,2.42561 -0.34986,3.45288 -0.92725,1.79049 -2.95622,2.85717 -3.85317,4.66303 -1.3412,2.70028 4.81416,2.32838 5.47911,2.30305 -0.3941,0.74413 -1.64975,1.53203 -1.18229,2.23241 0.55364,0.82952 3.61797,-0.31799 2.96056,0.43196 -2.55013,2.90915 -6.77897,3.98142 -9.35743,6.86548 -0.53751,0.60121 1.34054,0.89766 1.99237,1.3725 3.00597,2.18979 0.67181,0.85532 4.1958,2.58013 0.97743,0.27897 3.12712,-0.1607 2.93229,0.83692 -0.37108,1.90014 -2.58726,2.88188 -3.93077,4.27586 -1.41178,1.46482 -5.0521,2.39525 -4.3329,4.29829 0.66993,1.77268 4.05322,-1.99686 5.61067,-0.91724 2.00902,1.39265 -6.05121,4.28837 -4.30844,5.93449 8.79644,-0.97427 2.46458,-1.29009 1.54772,2.85609 -0.55951,2.53017 5.57675,-0.6921 4.65189,1.63694 -4.43479,11.16791 -5.60958,0.57178 -4.52068,6.97527 -1.01107,1.36804 -2.96739,2.40428 -3.03319,4.10412 -0.0404,1.04402 1.88097,0.91014 2.82145,1.36521 0.80303,0.59941 2.46039,0.79749 2.40909,1.79825 -0.0133,0.25895 -5.43921,8.7383 -5.29443,9.14273 0.52067,1.4545 3.02467,0.63085 4.53701,0.94627 -0.64141,1.38413 -0.99081,2.94575 -1.92422,4.15238 -1.68564,2.17903 -8.12235,4.34484 -5.82411,5.86392 2.99789,1.98153 6.81296,-3.05371 10.40013,-2.83928 1.37703,0.0823 -2.60327,1.93867 -2.48051,3.31268 0.0835,0.9342 1.86713,0.1807 2.80069,0.27105 -2.14561,1.60336 -4.29121,3.20672 -6.43682,4.81008 3.30783,4.57067 -4.3191,-6.77248 -4.22041,5.45487 0.0138,1.70811 3.38667,-0.86784 5.08198,-0.6587 2.45197,0.30248 2.15812,5.02735 1.95842,6.42304 -3.19404,2.52625 -8.52248,3.64671 -9.58211,7.57875 -0.68106,2.52726 6.18106,-3.00764 7.79494,-0.94699 1.4073,1.79689 -3.96866,2.95153 -4.48356,5.17508 -0.24512,1.05851 2.84501,0.24565 2.9786,1.32394 0.65218,5.26442 -11.20032,5.62551 5.28419,2.39953 -0.67702,1.06264 -1.40702,2.09332 -2.03106,3.18792 -0.45821,0.80372 -1.7507,1.74672 -1.21035,2.49769 0.61904,0.86033 2.63525,-0.68635 3.17151,0.22788 0.50566,0.86208 -1.0545,1.6999 -1.52286,2.58281 -2.38314,4.49245 0.66315,0.65249 -5.01938,6.11325 2.51835,3.02589 0.23004,-0.58326 -2.18819,4.90305 -0.24233,0.54978 0.86402,0.916 0.99629,1.50207 0.16072,0.71214 -0.80005,1.82496 -0.16437,2.18397 1.16036,0.65534 2.71959,-0.39573 3.99784,-0.0189 0.60248,0.17759 0.73877,1.01601 1.10815,1.52402 -1.36074,1.34979 -3.20063,2.34749 -4.08221,4.04936 -0.27139,0.52391 1.05543,0.7318 1.64139,0.66261 1.97114,-0.23275 3.95028,-2.36609 5.75307,-1.53572 1.23577,0.5692 -2.05672,1.79651 -2.93984,2.8315 -0.48863,0.57266 -0.71854,1.32576 -1.13976,1.94967 -0.51361,0.76074 -1.1066,1.46475 -1.6599,2.19713 0.33873,0.23814 1.19514,0.34101 1.01619,0.71442 -0.51118,1.06668 -1.77446,1.57558 -2.54408,2.4738 -3.23585,3.77652 -0.50318,0.34945 -0.55933,2.92637 -0.0502,2.30217 -3.339,4.40022 -4.37743,5.39298 18.27135,-5.79195 7.34887,-3.82125 5.07084,1.06134 -0.30011,0.64325 1.3829,0.55521 1.80963,1.12243 0.39639,0.52689 0.0574,1.41202 0.47866,1.91923 2.55384,3.07493 4.72612,-2.11248 -1.30905,5.03921 0.59055,0.43479 1.11486,0.97814 1.77163,1.30437 0.77872,0.38681 2.79133,-0.004 2.4803,0.80765 -0.73427,1.91687 -3.09181,2.72119 -4.42871,4.27883 -3.95484,4.60782 -1.14208,11.46892 8.83243,0.8083 -2.78274,1.95014 -5.79944,3.60312 -8.34822,5.85044 -0.32391,0.28561 -0.30561,2.75922 0.50582,2.9271 1.34444,0.27816 4.07556,-1.66363 4.10843,-0.29112 0.0607,2.53601 -5.62402,2.95619 -4.29713,6.28092 2.63484,-0.56434 7.72239,-4.38145 7.90451,-1.69301 0.22273,3.28781 -5.39696,3.87479 -7.59009,6.33435 -0.4392,0.49256 -1.07168,4.84516 -0.91018,5.62296 0.13638,0.65682 1.15889,1.0274 1.08607,1.69426 -0.11092,1.01582 -1.03951,1.7596 -1.55927,2.6394 0,0 1.72998,-0.88147 1.72998,-0.88147 z"

555+ inkscape:connector-curvature="0" />

556+ <path

557+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

558+ id="path5276"

559+ d="m 271.40967,500.0231 c 0.84361,-1.11502 2.99222,-2.02518 2.53083,-3.34505 -0.4382,-1.25354 -3.99371,0.67052 -3.92942,-0.65585 0.10731,-2.21366 3.58902,-3.01826 4.21063,-5.14555 0.29949,-1.02491 -2.43266,-1.56527 -1.96867,-2.52695 1.35708,-2.81273 4.53987,-4.32256 6.46127,-6.78454 1.08733,-1.39324 1.65843,-3.12142 2.48765,-4.68213 -7.46636,-0.79001 -5.08221,1.28307 -4.90812,-4.06826 0.0316,-0.97271 -0.27942,-1.93215 -0.28908,-2.90532 -0.01,-0.98605 1.13592,-2.55748 0.23099,-2.94925 -1.80824,-0.78284 -6.00039,2.46658 -5.89015,0.49924 0.15148,-2.70327 4.10594,-3.5304 6.15891,-5.2956 0.0863,-0.32458 1.27486,-3.51563 0.28596,-4.10661 -1.01075,-0.60403 -5.10035,0.971 -2.93296,-2.24553 0.98758,-1.46562 4.18347,-2.1455 3.66196,-3.8341 -0.47465,-1.53684 -3.21662,0.0457 -4.82493,0.0686 2.53225,-3.24957 8.12982,-9.92119 3.34362,-13.96697 -0.84971,-0.71826 -2.89316,-0.3958 -2.97925,-1.50507 -0.13245,-1.70646 1.67665,-2.98445 2.51498,-4.47667 -0.58297,-0.66933 -1.16594,-1.33865 -1.74891,-2.00798 0.6124,-1.11344 2.66426,-2.37557 1.8372,-3.34034 -0.96917,-1.13053 -3.04522,0.75237 -4.45833,0.28279 -0.57763,-0.19194 -0.54641,-1.34538 -0.16369,-1.81869 1.64069,-2.02908 4.24365,-3.14716 5.84497,-5.20745 0.62197,-0.80025 0.35302,-1.99609 0.52954,-2.99413 1.18656,-1.71414 5.51829,-4.42825 3.55968,-5.14242 -3.68312,-1.34296 -7.74476,3.18213 -11.54765,2.2298 -1.60687,-0.4024 0.40917,-3.40618 1.31691,-4.79181 2.25208,-3.43772 11.80529,-7.67655 4.00813,-10.58092 -2.01538,-0.75071 -4.26368,-0.56779 -6.39552,-0.85169 18.31556,-19.35763 6.94798,-2.12539 4.25278,-10.10937 -0.45617,-1.35131 1.87569,-2.93051 1.10826,-4.13267 -0.81412,-1.27531 -3.9706,0.39684 -4.41614,-1.04908 3.1689,-5.21567 3.70236,-3.03245 1.23334,-6.62861 -8.18188,-0.007 -4.8163,1.36305 -2.0755,-4.06271 0.36854,-0.72956 0.7691,-1.82926 0.22758,-2.4415 -0.65309,-0.73837 -3.47767,0.21889 -2.89987,-0.57977 6.09343,-8.42267 10.79235,-3.56777 5.91985,-7.57855 -12.25386,-1.1019 4.27779,1.54129 1.65438,-6.69263 -0.80029,-2.51183 -5.25694,0.40437 -7.88541,0.60655 4.24469,-3.40941 9.75453,-5.67149 12.73406,-10.22823 0.98096,-1.50023 -4.44943,0.36646 -5.23091,-1.24669 -0.79604,-1.6432 1.46396,-3.34544 2.19595,-5.01817 -0.44562,-1.0569 -0.89124,-2.11379 -1.33686,-3.17069 1.21842,-1.89661 4.4227,-3.57023 3.65526,-5.68983 -0.096,-0.26526 -11.48,-0.72332 -11.66559,-0.80844 -0.84802,-0.38896 -1.35245,-1.93441 -0.79604,-2.68331 2.10967,-2.83952 5.32265,-4.66087 7.98397,-6.99131 2.34226,-3.02177 -2.3457,-2.92502 -2.13068,-5.33277 0.0676,-0.75729 1.50987,-1.53029 0.96915,-2.06479 -2.53936,-2.51012 -10.63271,6.31581 2.37228,-4.61883 -6.19474,1.66146 -9.1703,5.00092 -7.46109,-0.21769 0.33443,-1.02109 0.72495,-2.03797 1.27773,-2.95934 0.83764,-1.39618 2.56915,-2.35267 2.86929,-3.95293 0.18473,-0.98495 -4.34465,-3.06502 -4.46788,-3.13006 -0.99349,-2.65488 2.28337,-4.28846 2.23274,-6.61519 -0.008,-0.38838 -3.79592,-3.07607 -3.34144,-3.91339 1.29663,-2.38888 5.23411,-3.12425 5.73612,-5.79557 0.28158,-1.49837 -3.02289,-0.39958 -4.53434,-0.59936 -0.73879,-0.56327 -2.69562,-0.89392 -2.21638,-1.6898 1.57771,-2.62017 4.86309,-3.77022 6.8856,-6.06454 0.60727,-0.68889 1.19228,-1.81559 0.7877,-2.64001 -0.39219,-0.79916 -1.88839,-0.25903 -2.51884,-0.88752 -3.52309,-3.51214 5.42905,-1.06978 -3.64123,-2.45646 -1.28883,-1.47023 4.42724,-4.22495 3.00729,-5.92455 -0.87349,-1.04551 -4.62824,0.79539 -4.06292,-0.44416 1.2864,-2.82067 5.3809,-3.45971 7.0382,-6.07971 0.48077,-0.76003 -2.25924,-0.53635 -2.2845,-1.43532 -0.0391,-1.39345 1.42887,-2.394 2.14331,-3.591 0.57897,-1.13977 2.39829,-2.3253 1.7369,-3.4193 -0.70437,-1.16508 -2.77891,0.0285 -4.06202,-0.42667 -4.36529,-1.54853 1.70005,-4.13301 2.00734,-5.56729 0.1857,-0.86677 -1.69451,-0.52131 -2.54176,-0.78196 1.09797,-1.11213 2.19594,-2.22425 3.29391,-3.33638 -7.62803,0.34657 -0.62323,0.76416 0.31659,-3.27246 0.22707,-0.97527 -1.99998,0.10431 -2.99997,0.15647 1.88627,-1.35807 4.42344,-2.10539 5.65881,-4.0742 0.6094,-0.9712 -2.25983,0.52665 -3.40556,0.48318 -0.49695,-0.0188 -0.89097,-0.44207 -1.33646,-0.6631 -5.22674,-0.89819 -1.26314,0.31771 4.36293,-5.17642 0.40557,-0.39606 0.69638,-1.64645 0.13163,-1.69553 -1.86658,-0.16222 -5.82482,3.07279 -5.48453,1.23034 0.86459,-4.68123 15.40434,-8.00968 -0.85374,-3.14014 -0.53032,-0.34481 -1.68223,-0.40848 -1.59097,-1.03442 0.19075,-1.30836 3.0586,-2.26352 2.22094,-3.2865 -0.93884,-1.14654 -2.98163,1.04666 -4.40173,0.62324 -0.64237,-0.19154 0.3747,-1.67926 -0.21416,-1.99954 -5.42716,-2.95183 -2.51001,2.85865 -4.39836,-2.21361 -1.0113,-2.24228 -4.57355,0.1204 -5.66196,-1.50056 -0.59485,-0.88591 1.78009,-2.58036 0.84181,-3.08859 -1.49807,-0.81144 -3.4198,1.31804 -5.04636,0.81115 -0.75563,-0.23548 0.0205,-1.5828 0.0307,-2.37421 -0.78514,-0.23306 -1.57029,-0.46613 -2.35544,-0.6992 -18.82244,6.26303 -1.07068,2.06578 -7.70098,1.1906 -1.1255,-0.14856 -3.19802,1.33749 -3.39866,0.22011 -0.0112,-0.0625 5.46172,-7.20216 5.52409,-7.28374 0,0 -1.31152,0.82398 -1.31152,0.82398 l 0,0 c 0.10548,0.55469 -0.0164,1.20797 0.31643,1.66406 1.996,2.73517 7.61323,-1.59563 8.31169,-1.60148 0.86632,-0.007 -0.60768,1.62267 -0.91151,2.43401 1.32261,-0.19648 2.64522,-0.39296 3.96783,-0.58944 0.98298,4.11711 -0.6215,0.21591 4.5331,1.56511 3.1779,0.83181 -0.81124,5.16423 -0.63379,5.49385 1.18549,2.20203 6.22576,-1.97788 7.49509,0.33556 0.0419,3.06555 -0.51194,2.13147 1.3249,4.21502 0.41138,0.46665 0.67506,1.34969 1.2971,1.34182 1.97297,-0.025 4.46542,-2.93396 5.74383,-1.43099 1.16055,1.36441 -4.40317,2.5692 -3.47341,4.10022 0.93565,1.54072 3.52951,-0.73456 5.29427,-1.10184 0.24843,0.52021 0.45786,1.06092 0.74531,1.56063 0.28443,0.49446 1.19772,0.89213 0.96528,1.41305 -0.6129,1.37359 -2.07256,2.18119 -3.071,3.30614 -0.81192,0.9148 -3.20997,1.93322 -2.35835,2.81118 1.02778,1.05958 2.91649,-1.02103 4.36594,-0.74149 0.51104,0.0986 -0.10293,1.03582 -0.15439,1.55373 -0.90402,0.90742 -2.11634,1.58835 -2.71205,2.72228 -0.18254,0.34745 0.46747,0.83858 0.85858,0.80575 1.71116,-0.14364 3.53033,-2.2076 4.98576,-1.29633 1.08463,0.6791 -1.95527,1.68725 -2.70466,2.72456 -0.3822,0.52905 -0.40546,1.24075 -0.6082,1.86113 -0.73879,0.89107 -1.47759,1.78213 -2.21639,2.6732 -2.6156,4.34603 -1.72804,1.25734 2.28963,2.6141 0.6603,0.22298 1.61939,0.89052 1.4007,1.55225 -0.52966,1.60271 -3.05305,2.23698 -3.20843,3.91777 -0.0904,0.97838 1.83173,0.71158 2.7476,1.06737 -0.14246,0.9235 -0.28492,1.84701 -0.42738,2.77052 -17.69737,16.4527 -0.29839,-1.93789 0.46659,4.845 0.29603,2.62482 -4.02236,3.45288 -5.75948,5.44278 -2.96193,3.39292 -2.80901,4.63463 0.58667,6.56553 -0.71195,3.37109 -1.32723,2.23656 2.17358,3.20427 -0.25398,1.70167 -3.37311,2.17554 -3.38566,3.89601 -0.009,1.22027 7.05377,-0.32166 6.38009,1.54413 -0.87889,2.4341 -3.60347,3.71541 -5.4052,5.57312 1.47272,0.21953 3.73062,-0.66216 4.41814,0.6586 1.2021,2.30926 -4.75905,5.20232 -5.26915,8.38805 -0.29809,1.8617 8.33922,2.21527 5.25308,5.58725 -2.34657,2.11623 -4.82208,4.0977 -7.03972,6.34868 -1.35667,1.37707 -4.99171,3.11027 -3.65263,4.50445 1.62643,1.69336 4.64369,-1.4155 6.96405,-1.05677 0.72132,0.11151 -0.0472,1.51283 0.26216,2.17392 1.59106,3.40017 3.61933,-1.30155 -1.31458,4.69517 1.74643,5.18425 -1.91013,-4.03341 4.14083,1.28591 0.65697,0.57753 -0.7704,1.59325 -1.34315,2.25439 -1.20653,1.39272 -3.31939,2.13238 -3.95537,3.86181 -0.27479,0.74726 1.97176,0.24327 2.16143,1.01653 0.26163,1.06662 -0.77015,2.05703 -1.15523,3.08554 0.46488,0.70316 1.66986,1.31273 1.39465,2.10948 -0.70049,2.02806 -5.77724,4.09808 -3.89369,5.12569 2.954,1.6116 6.67212,-2.6877 9.92708,-1.83407 1.38407,0.36298 -0.26721,3.00285 -1.1364,4.13947 -7.69167,10.05825 -11.30113,4.9757 -5.50453,10.47003 12.1809,2.58454 0.68305,-1.60595 1.50332,7.04834 0.15075,1.59053 3.7325,0.0369 4.58818,1.38612 0.74593,1.17615 -1.03929,2.62565 -1.16411,4.01279 -0.0314,0.34944 0.93404,4.71611 1.05781,5.28963 -1.3802,1.51721 -4.84437,2.62508 -4.14062,4.55164 0.63712,1.74412 3.69816,-1.18051 5.51394,-0.79214 0.65481,0.14005 0.6238,1.53115 0.149,2.00335 -2.81355,2.79816 -8.04318,3.53205 -9.44682,7.2436 -0.82141,2.17201 11.13635,-5.11164 6.76838,1.64927 0.091,0.92514 -0.0854,1.91766 0.27296,2.77541 0.35755,0.85586 1.9948,1.23647 1.78003,2.13881 -0.48142,2.02267 -3.23036,3.09296 -3.51545,5.15249 -0.15382,1.11121 1.86813,1.33099 2.48861,2.26557 2.10332,3.16805 0.92404,4.31695 0.06,7.89324 -10.57418,17.09201 -0.63343,-3.00266 3.38288,6.60571 0.99622,2.38331 -2.8287,4.32307 -4.24305,6.48461 -0.25211,1.50129 -1.38497,3.11742 -0.75634,4.50387 0.56327,1.24229 2.56202,1.0317 3.64324,1.86327 0.79588,0.6121 1.24,1.57949 1.86,2.36924 -8.39878,9.58005 -3.85858,2.27949 2.00132,3.93387 0.86536,0.24431 -0.51486,1.78055 -1.10053,2.46285 -1.42711,1.6626 -4.03733,2.4121 -4.83549,4.45265 -0.34986,0.89445 1.79295,0.68927 2.68943,1.03391 -1.31854,1.63819 -2.63708,3.27639 -3.95562,4.91458 0.66656,0.72544 1.92921,1.19368 1.99967,2.17633 0.0985,1.37395 -1.25826,2.48092 -1.56948,3.82278 -0.31391,1.35345 0.11788,4.84884 0.11683,6.22575 -8e-4,1.05328 -0.46388,2.14171 -0.17615,3.15493 0.24138,0.85002 1.10612,1.3783 1.65918,2.06746 7.82248,2.82758 -3.54352,-2.1669 -3.75729,6.27252 -0.0553,2.18496 4.23975,-1.72368 6.40311,-1.4122 0.77116,0.11103 -0.28142,1.56687 -0.68022,2.23618 -0.55535,0.93205 -4.91731,6.04302 -5.54138,6.78439 1.57917,-0.0855 3.18481,-0.55678 4.73749,-0.2564 0.79773,0.15433 2.07487,0.7473 1.89058,1.53864 -0.42269,1.81501 -2.92768,2.68693 -3.29992,4.51295 -0.18906,0.92743 1.54302,1.20422 1.96139,2.05324 1.93613,3.92917 -1.20747,5.21438 -3.71401,8.46144 0.47992,0.89368 0.58071,2.14155 1.43974,2.68104 1.34606,0.84534 4.13572,-0.37781 4.63211,1.13218 0.93525,2.84501 -5.60155,6.20062 -3.45815,8.29218 1.10289,1.07621 3.61454,-0.86631 4.61266,0.30772 0.75374,0.88657 -1.21106,1.98741 -1.81659,2.98112 0,0 -9.14493,4.65958 -9.14493,4.65958 z"

560+ inkscape:connector-curvature="0" />

561+ <path

562+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

563+ id="path5278"

564+ d="m 581.73672,201.15421 c -5.84049,0.0226 -12.46977,3.74174 -18.23522,1.43917 -0.92495,-0.3694 -1.5343,-1.27727 -2.36778,-1.82253 -0.87794,-0.57434 -1.83477,-1.01794 -2.75215,-1.52691 -7.8597,-0.6834 -0.70651,-0.5885 -11.70003,2.01168 -1.54963,0.36652 -3.24586,1.07687 -4.74618,0.54324 -1.59834,-0.5685 0.85485,-5.45684 0.64497,-5.42188 -3.26191,0.54332 -5.93446,2.91946 -8.90169,4.37918 -1.07703,0.12394 -2.49605,1.16872 -3.23111,0.37181 -0.67458,-0.73134 1.68867,-2.13419 0.97042,-2.82271 -0.88828,-0.85153 -2.51436,-0.15881 -3.68494,0.22051 -3.53501,1.14552 -6.56729,4.25069 -10.28286,4.30575 -1.41951,0.021 0.58867,-2.77764 0.88301,-4.16646 -2.91053,0.68366 -5.82106,1.36733 -8.73159,2.05099 -8.55726,-7.49791 7.12666,4.81414 -14.40115,1.39085 -1.87303,-0.29784 3.21179,-4.26845 1.70996,-5.42666 -1.91086,-1.47365 -4.74198,0.90779 -7.13129,1.24574 -10.05799,1.42263 -1.29042,-0.848 -12.92141,2.92188 5.75912,-7.83975 5.57265,-5.71046 -3.55664,-2.09752 -2.02766,0.80245 -4.06024,1.61861 -6.16523,2.18815 -1.4706,0.39791 -3.76794,2.02901 -4.51623,0.70196 -7.88504,-13.98369 9.26915,0.86687 0.0352,-6.49718 -3.10338,1.17026 -6.20676,2.34052 -9.31014,3.51078 -0.57567,-0.69237 -0.83006,-2.15625 -1.72699,-2.0771 -3.09746,0.27333 -5.72754,2.79919 -8.82997,3.00868 -0.91247,0.0616 -0.59156,-2.08023 -1.47605,-2.31278 -1.66146,-0.43682 -4.08937,1.95174 -5.12124,0.57823 -0.99973,-1.33072 1.45413,-2.99444 2.18119,-4.49166 -5.27131,3.01667 -10.21343,6.70024 -15.81393,9.05001 -0.70494,0.29576 0.0899,-1.64484 -0.3563,-2.26558 -0.50641,-0.70446 -1.36894,-1.2616 -2.23327,-1.33677 -1.86367,-0.16207 -3.74223,1.04035 -5.57342,0.65787 -1.06648,-0.22276 -1.54432,-1.53723 -2.31648,-2.30585 -2.11262,0.0407 -4.22524,0.0813 -6.33786,0.12201 -12.42253,2.1242 -6.53573,2.91676 -15.18382,-0.38034 -1.73617,-0.66191 -3.38695,-1.91563 -5.24481,-1.8878 -3.53288,0.0529 -6.89889,2.69571 -10.38526,2.12195 -1.37022,-0.2255 -0.74241,-2.67624 -1.11361,-4.01436 -1.88368,-0.006 -3.76736,-0.012 -5.65104,-0.018 -24.28983,7.62107 -2.5727,3.42937 -7.44036,-1.19304 -1.17426,-1.1151 -3.36042,0.76142 -4.85605,0.14059 -0.9471,-0.39314 -0.37753,-2.78281 -1.40202,-2.73831 -17.07323,0.74169 -4.68269,5.70713 -13.15884,1.68512 -13.47711,1.23798 -0.53507,0.38388 -11.61335,0.31509 -1.85578,-0.0115 -3.70698,0.21371 -5.56273,0.2289 -1.65286,0.0135 -3.33144,-0.4439 -4.95669,-0.14277 -2.69057,0.49853 -5.20719,1.68414 -7.81614,2.50939 -2.13831,0.67638 -4.28365,1.33032 -6.42547,1.99548 -0.9837,-2.83624 -11.06653,5.91354 -9.75378,2.79645 1.53204,-3.63777 6.99404,-4.59873 8.4956,-8.24918 0.86063,-2.09228 -4.2097,1.67823 -6.21979,2.71644 -3.72203,1.92244 -6.92828,5.00691 -10.95697,6.15539 -1.36693,0.38967 1.46202,-2.43801 2.19303,-3.65701 -1.17023,0.0909 -2.53198,0.92049 -3.51069,0.27257 -0.68695,-0.45477 0.96331,-2.14961 0.20152,-2.46328 -4.37993,-1.80347 -8.71503,6.31425 -13.28098,5.05394 -9.4835,-2.61768 17.38499,-9.14192 -0.38289,-4.16034 -0.53601,-0.28526 -1.00462,-0.92342 -1.60803,-0.85578 -1.6592,0.18598 -3.16377,1.06881 -4.75661,1.56922 -1.28969,0.40517 -2.59751,0.75066 -3.88989,1.14719 -1.27067,0.38987 -2.49478,0.95467 -3.7988,1.21188 -0.57067,0.11256 -1.73101,0.46238 -1.74093,-0.1192 -0.0174,-1.01834 1.13036,-1.69456 1.69554,-2.54183 1.13752,-1.49935 -4.63996,2.07583 -4.03582,0.84154 0.66217,-1.35285 4.65116,-3.58371 3.19622,-3.19408 -2.64341,0.70788 -4.51559,3.1669 -7.03997,4.22341 -0.68424,0.28637 0.85778,-1.21035 1.28667,-1.81553 -1.25078,0.65196 -2.50155,1.30391 -3.75232,1.95586 9.21621,-7.98762 6.18858,-4.83213 -0.87423,-0.87619 -0.72387,0.40544 -1.54218,0.6125 -2.31326,0.91875 0,0 2.61292,-1.89841 2.61292,-1.89841 l 0,0 c 1.14285,-0.57635 2.16869,-1.50316 3.42856,-1.72905 0.47365,-0.0849 -0.48687,0.83017 -0.73031,1.24525 0.72034,-0.25777 1.44068,-0.51554 2.16102,-0.77331 -0.0129,0.26612 0.11092,0.57784 -0.0386,0.79836 -0.61275,0.9037 -3.19334,2.83016 -2.16774,2.45563 2.58273,-0.94316 4.57145,-3.1023 7.07165,-4.24644 0.52365,-0.23963 -1.37048,1.87365 -0.20579,1.9951 0.74974,0.0782 1.47219,-0.32486 2.20828,-0.48729 1.12167,-0.37799 2.86257,-2.20567 3.36502,-1.13396 0.5616,1.19787 -1.995,1.89173 -2.42282,3.14363 -0.14298,0.41839 0.66423,0.8732 1.09039,0.75536 2.14236,-0.59239 4.04954,-1.83414 6.08018,-2.73811 7.30472,-3.2518 6.963,-5.26487 6.23711,-0.62098 2.93608,2.63023 -0.0453,0.63795 6.49918,-0.28738 0.87818,-0.12417 1.74981,0.3045 2.63356,0.3793 1.00939,0.0854 2.02969,0.20481 3.03732,0.10065 1.47374,-0.15233 3.07086,-1.5959 4.35975,-0.86523 0.8671,0.49155 -0.53804,1.91949 -0.80707,2.87923 1.97363,-0.76926 3.95449,-1.52021 5.92088,-2.30778 1.9543,-0.78272 3.79068,-1.92385 5.84067,-2.40289 0.58192,-0.13598 1.89487,0.0929 1.67184,0.64736 -0.76788,1.90882 -4.79687,2.97497 -3.86747,4.81058 1.48135,2.92575 7.32339,-5.50614 9.48936,-2.59649 1.42331,-0.13101 2.86231,-0.14485 4.26993,-0.39303 2.16768,-0.38218 4.23629,-1.34177 6.43214,-1.49385 1.38899,-0.0962 2.73015,0.97425 4.10649,0.76394 3.11854,-0.47655 5.9479,-3.356 9.04853,-2.77417 1.44152,0.2705 -2.0691,4.5208 -0.61155,4.35735 4.97883,-0.55833 9.23228,-3.89449 13.84842,-5.84174 2.70996,5.53973 -0.455,1.31529 7.32522,2.53772 1.08502,0.17048 1.78761,1.32193 2.81267,1.71639 3.87458,1.49101 7.92222,0.0734 11.83057,1.37936 2.68235,-0.56484 5.31262,-1.88683 8.04704,-1.69452 1.35852,0.0955 2.16027,1.65891 3.24041,2.48837 2.61456,-0.0998 5.22912,-0.19951 7.84368,-0.29927 4.64473,-0.95021 8.88553,-3.87351 13.62142,-4.09202 1.60186,-0.0739 2.33226,2.20143 3.49839,3.30214 2.94984,-0.29944 5.89968,-0.59888 8.84953,-0.89833 1.33758,0.50801 2.58403,1.44687 4.01276,1.52403 2.28088,0.12319 5.73312,-2.96689 6.78773,-0.94072 1.14605,2.20185 -6.4441,5.77702 -4.01202,6.27356 3.87161,0.79045 6.92622,-4.10745 10.7999,-4.88771 0.91737,-0.18479 -1.29282,2.74099 -0.35803,2.78445 2.40459,0.11179 4.52016,-1.65725 6.78024,-2.48588 1.31945,0.0101 2.75475,-0.51033 3.95836,0.0304 0.78176,0.35121 0.32942,2.27564 1.18643,2.28098 2.67859,0.0167 5.04481,-2.12584 7.72159,-2.22554 0.94208,-0.0351 1.26601,1.48553 2.13182,1.8585 3.60961,1.55491 6.53653,0.002 10.21237,-0.83478 20.52329,-6.74084 1.89226,-2.51045 4.15948,3.45256 0.73899,1.94361 4.01445,-1.09539 5.98399,-1.76219 2.23019,-0.75505 4.26124,-2.7115 6.60629,-2.50033 1.06227,0.0957 -1.16158,1.92736 -1.13013,2.99346 0.0199,0.67426 0.84334,1.05302 1.26501,1.57952 4.12862,-2.00822 7.89397,-5.07526 12.38586,-6.02468 1.10106,-0.23272 -0.91579,3.05361 0.16356,3.37219 2.3053,0.68043 4.7056,-1.09801 7.10578,-1.22658 1.70439,-0.0913 3.40092,0.83038 5.0883,0.57341 3.51787,-0.53576 6.7499,-3.43107 10.27034,-2.91244 1.4619,0.21537 0.033,2.95518 0.0495,4.43277 0.30181,1.19077 -0.20039,3.03734 0.90543,3.57231 1.66477,0.80539 3.68366,-0.33775 5.52901,-0.45944 5.57141,-0.36741 4.65262,0.33142 10.53807,-2.04259 2.8186,-1.13693 5.21399,-3.79318 8.25207,-3.87782 1.47239,-0.041 -1.59556,2.4764 -2.39334,3.7146 0.73439,-0.24086 6.01373,-2.85719 7.87461,-1.29776 0.0775,0.0649 0.89268,4.62211 1.49732,4.43526 14.78199,-4.56792 12.68988,-12.15571 13.93555,-3.63588 2.66352,6.81078 -1.20811,-0.39314 10.26637,-0.38966 1.05436,3.1e-4 -0.57443,2.7161 0.39151,3.13875 2.9451,1.28864 13.55718,-4.08658 14.2252,-4.14987 0.94238,-0.0893 -0.4954,1.82723 -0.7431,2.74084 0,0 -1.4256,1.03576 -1.4256,1.03576 z"

565+ inkscape:connector-curvature="0" />

566+ <path

567+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

568+ id="path5280"

569+ d="m 437.91913,154.10856 c 1.23619,-0.0682 2.47239,-0.13636 3.70859,-0.20454 1.58967,0.0869 3.17891,0.33934 4.76902,0.2608 2.60001,-0.1284 5.26923,-1.63681 7.75984,-0.87957 1.37606,0.41837 0.54192,3.9983 1.97124,3.83817 35.88963,-4.02092 2.82269,-7.22874 20.51937,-5.03347 3.69136,2.35282 7.48018,-1.04865 11.12799,-0.36496 0.89607,0.16795 0.44139,2.40963 1.35248,2.3772 3.04143,-0.10825 5.79477,-1.86385 8.71066,-2.73538 3.21228,-0.96013 6.53974,-3.95409 9.67225,-2.75912 1.88961,0.72083 -0.98785,3.92236 -1.48177,5.88355 7.4778,-2.6997 15.0486,-0.18493 22.64137,-0.87945 2.98582,-0.27312 5.86817,-1.42005 8.86462,-1.52519 0.64451,-0.0226 7.36205,1.74657 8.38695,2.01041 22.66233,-6.2164 -5.59406,-0.006 1.79508,4.88026 3.01566,1.99414 6.60785,-3.07778 10.1398,-3.84989 1.21885,-0.26645 2.41213,0.66777 3.64842,0.83569 1.51909,0.20634 3.07181,0.49347 4.59038,0.28337 2.64393,-0.36579 5.17049,-1.32765 7.75573,-1.99148 4.22728,5.71577 -1.93151,-1.13286 8.0372,1.02932 0.90762,0.19686 0.25793,1.83945 0.38689,2.75918 3.89585,-1.98477 7.40915,-5.05301 11.68754,-5.95432 1.46572,-0.30877 -2.98474,2.70083 -2.15115,3.94534 0.81315,1.21397 2.88525,-0.46374 4.32788,-0.69561 -0.19386,1.02948 -1.62892,3.11096 -0.58158,3.08846 3.16055,-0.0679 5.77676,-2.79974 8.90328,-3.26728 1.17277,-0.17538 2.07855,1.64352 3.24848,1.4501 3.6131,-0.59735 6.7766,-2.87648 10.3455,-3.69758 2.04298,-0.47003 7.74632,0.36486 9.92961,0.62392 1.54872,0.10745 3.32447,-0.49201 4.64618,0.32236 0.83502,0.51449 -0.41383,2.96447 0.56398,2.88785 3.16131,-0.24772 5.68039,-3.03528 8.79677,-3.62136 0.63863,-0.1201 -0.0278,2.00105 0.60497,1.85324 13.56341,-3.16818 3.77193,-4.72057 10.23057,-3.37752 1.24491,-0.0989 2.70181,-0.99864 3.73472,-0.29674 0.77133,0.52414 -0.93495,2.48789 -0.0552,2.79714 1.80758,0.63537 3.81902,-0.40231 5.6897,-0.81658 2.85096,-0.63135 5.54036,-2.05462 8.44881,-2.31443 1.41531,-0.12642 2.67478,1.09344 4.09215,1.19417 2.08296,0.14804 4.16519,-0.30621 6.24779,-0.45931 3.35928,-1.08463 6.71857,-2.16926 10.07785,-3.25389 0.55553,0.85196 0.64963,2.54065 1.6666,2.55589 2.67042,-0.80363 5.34085,-1.60725 8.01128,-2.41088 0.47122,0.60211 0.67697,1.60175 1.41368,1.80633 1.24445,0.34558 4.10822,-1.60936 3.85951,-0.34198 -0.48472,2.4701 -3.27807,3.82095 -4.91711,5.73142 5.70103,-1.33877 10.12612,-5.88484 15.70457,-7.45129 0.58355,-0.16386 -0.0962,1.23344 0.0671,1.81715 0.12902,0.46112 0.31209,1.10095 0.77906,1.20689 3.35426,0.76105 3.63331,-2.23898 2.23264,1.86594 4.56137,3.27917 -3.43228,-1.96059 10.56193,-4.51534 1.97581,-0.3607 -3.49921,2.45408 -4.17344,4.34599 -0.32903,0.92328 1.91845,-0.40858 2.86324,-0.66949 3.86803,-1.06818 2.71345,-2.07285 4.06916,-0.29377 0.65874,-0.0329 2.02115,-0.75681 1.97621,-0.0988 -0.0787,1.1527 -3.30667,2.8058 -2.15487,2.7149 2.30435,-0.18187 4.05842,-2.25648 6.23422,-3.03687 0.64315,-0.23067 1.38324,0.22087 2.04874,0.0661 5.51896,-1.28379 3.78688,-3.25824 5.50883,-0.19721 -1.46583,1.71812 -4.57212,2.90268 -4.39748,5.15437 0.0156,0.20143 8.67506,-2.31725 8.69122,-1.51312 0.0418,2.08276 -5.97008,4.93862 -3.88739,4.89336 7.80888,-0.16971 16.70616,-11.4037 6.31714,0.11757 0.90308,0.0651 1.80616,0.1302 2.70924,0.1953 0.27814,0.42273 0.34662,1.1336 0.83442,1.26817 0.95893,0.26455 2.42441,-1.04441 2.97636,-0.21683 0.53135,0.79669 -2.30924,1.98837 -1.47786,2.46364 3.33256,1.90507 5.5039,-3.90126 3.07872,1.08059 4.23139,0.93002 -3.61451,3.89543 -2.08482,4.59396 2.0287,0.9264 4.18748,-2.97245 6.29916,-2.25506 1.45192,0.49325 -4.18448,2.13801 -3.19514,3.30956 1.96861,2.33118 11.74376,-7.47434 0.389,2.57794 -0.0375,0.53551 -0.64336,1.68584 -0.11242,1.60654 9.29633,-1.38852 9.7283,-6.25852 2.73533,1.82238 -0.71864,0.83044 -2.31993,2.03153 -1.61359,2.87246 4.45015,-0.20547 3.30627,-1.34009 4.63554,1.36899 6.1752,-0.54264 -0.212,2.16231 3.94226,3.83059 0.70833,0.28445 2.2706,-0.38153 2.25791,0.38168 -0.0534,3.21284 -8.33635,4.79542 2.76754,1.28484 0.83075,1.91899 -2.55661,2.61469 -2.23156,4.1519 0.16395,0.77534 1.75121,-0.54192 2.37683,-0.0555 0.43233,0.33616 -0.62952,1.09756 -0.39821,1.59396 0.32296,0.69309 3.34908,0.74132 3.53405,0.75722 -6.37567,7.34986 -1.26749,0.14391 -0.0687,2.59487 0.35848,0.73292 -0.86775,1.38193 -1.30163,2.07289 0,0 2.83108,-1.71491 2.83108,-1.71491 l 0,0 c -1.62573,0.55271 -3.171,1.46474 -4.87719,1.65811 -1.86292,0.21113 3.92214,-13.77688 3.30994,-4.54751 -0.43697,-0.22138 -0.82145,-0.64501 -1.31093,-0.66414 -1.08331,-0.0423 -2.45436,1.25905 -3.21571,0.48724 -0.62898,-0.63763 1.2009,-1.38762 1.49202,-2.23463 0.1294,-0.37651 0.0634,-1.08308 -0.32938,-1.14805 -1.07257,-0.17743 -2.83327,1.58094 -3.21263,0.56213 -0.4318,-1.15963 1.56848,-1.91432 2.35272,-2.87148 -2.08529,0.77586 -4.04044,2.122 -6.25586,2.3276 -1.2483,0.11584 1.87343,-2.85833 0.13022,-3.36272 -1.25443,-0.36296 -2.64297,0.7181 -3.9005,0.36606 -1.98283,-0.5551 0.33136,-8.6675 2.44939,-5.67082 -0.11377,-0.59785 0.0423,-1.32107 -0.34132,-1.79354 -0.44536,-0.54858 -1.18502,-0.96523 -1.89156,-0.95682 -1.75728,0.0209 -4.10153,2.43729 -5.16845,1.04082 -0.97742,-1.27933 2.58059,-2.13226 3.19884,-3.6188 0.35667,-0.85759 -3.97088,-0.70327 -0.94285,-2.62205 -0.30912,-0.2909 -1.07662,-0.47532 -0.92737,-0.87269 0.41542,-1.10604 3.15171,-1.92448 2.27577,-2.71734 -1.06356,-0.9627 -2.76722,1.17347 -4.18937,0.98523 -0.50454,-0.0668 0.67442,-1.53777 0.16587,-1.5178 -2.00217,0.0786 -4.22172,3.02759 -5.75464,1.73723 -1.28523,-1.08186 2.27523,-2.47231 3.41284,-3.70846 1.69334,-3.79201 1.02434,-0.89294 -2.96887,-1.10444 -0.43164,-0.0229 -0.70644,-0.64888 -0.71619,-1.08101 -0.0159,-0.70575 1.25738,-1.66328 0.64632,-2.01675 -3.18866,-1.84449 -5.78111,4.03437 -1.35578,-2.85334 -2.21776,-1.64947 -1.21018,-1.37236 -4.79348,-1.13862 -1.39043,0.0907 -2.84666,0.9726 -4.15193,0.48495 -0.65871,-0.2461 0.41497,-1.72217 -0.17671,-2.10214 -1.42729,-0.91658 -3.70494,0.93947 -5.03484,-0.73883 -0.60299,-0.21393 -1.16997,-0.67416 -1.80895,-0.64178 -1.28889,0.0653 -2.74506,1.72143 -3.75975,0.924 -0.80647,-0.63381 2.20098,-1.84945 1.56159,-2.65151 -0.65242,-0.81839 -2.00917,1.00735 -3.03556,0.80256 -0.45187,-0.0902 0.14067,-0.91075 0.21101,-1.36613 -1.21839,0.43181 -2.43678,0.86363 -3.65517,1.29544 -0.25354,-0.22264 -0.62939,-0.35707 -0.76062,-0.66793 -0.17042,-0.40368 0.34819,-1.20015 -0.0754,-1.31238 -1.8936,-0.50174 -8.19894,3.49373 -8.31461,3.19586 -0.81569,-2.10049 4.56795,-2.57491 4.73782,-4.82182 0.12012,-1.58882 -2.99734,1.0822 -4.49601,1.6233 -2.08036,0.93553 -4.14334,1.9107 -6.24108,2.80658 -1.80069,0.76903 -4.53985,3.91984 -5.45174,2.18712 -0.97455,-1.85178 3.0537,-2.94119 4.10168,-4.75242 0.26628,-0.46021 0.0615,-1.507 -0.46996,-1.52428 -1.58559,-0.0515 -2.99345,1.11425 -4.56062,1.36077 -0.79363,0.12484 -1.59692,-0.17771 -2.39537,-0.26657 -4.2548,2.37378 -7.90174,6.81699 -12.7644,7.12133 -2.94666,0.18442 3.87288,-4.45736 5.80931,-6.68603 -0.48591,-0.59114 -0.69261,-1.78416 -1.45775,-1.77341 -2.51475,0.0353 -4.81733,1.51195 -7.30276,1.89646 -5.06126,0.783 -4.67311,0.33438 -8.50322,-1.66221 -3.47983,1.1729 -6.95966,2.3458 -10.43949,3.5187 -0.30549,-1.1707 0.29338,-3.52556 -0.91645,-3.51209 -3.62555,0.0404 -6.62575,3.65582 -10.25148,3.63642 -1.23853,-0.007 1.66672,-3.89226 0.44498,-3.68891 -4.09903,0.68224 -7.13798,4.59273 -11.19787,5.47861 -1.12856,0.24626 0.7464,-2.18633 1.1196,-3.2795 -2.70903,1.27901 -5.1708,4.32182 -8.12711,3.83702 -1.90269,-0.31201 3.59746,-2.66683 3.5158,-4.59321 -0.0525,-1.23781 -2.45976,0.30037 -3.69255,0.4234 -1.46662,0.14638 -2.9419,0.20626 -4.40496,0.38477 -10.62024,1.29579 -0.63827,0.54815 -11.1481,1.16065 -2.80818,0.75238 -5.61635,1.50477 -8.42453,2.25716 0.42608,-1.63775 2.96629,-5.03264 1.27824,-4.91325 -4.77994,0.33808 -8.7824,3.8364 -13.1736,5.7546 0.15542,-1.38489 1.85968,-4.17566 0.46625,-4.15467 -13.75571,0.20727 -7.80115,8.29755 -11.47942,2.48146 -2.33385,0.88589 -4.51172,2.47751 -7.00154,2.65765 -0.71542,0.0518 0.18093,-1.61481 -0.32031,-2.12791 -1.69982,-1.74004 -6.36894,-4.9e-4 -7.57099,-0.11103 -0.99157,-0.0912 -1.76798,-0.91671 -2.65197,-1.37507 -2.09073,0.3287 -4.18146,0.65741 -6.27219,0.98612 -4.18788,-0.43557 -4.06426,-0.009 -7.55836,-1.74909 -0.90521,-0.4509 -1.58091,-1.59702 -2.59199,-1.5767 -2.46011,0.0494 -4.7061,1.70603 -7.1658,1.77273 -0.85835,0.0233 -1.38548,-1.01473 -2.07822,-1.52209 -1.71767,0.15619 -3.43533,0.31238 -5.153,0.46857 -12.16079,-1.35046 6.81819,0.27799 -13.25426,1.47955 -1.76161,0.10546 -3.40987,-1.20637 -5.17287,-1.12741 -3.27207,0.14656 -6.39822,1.50844 -9.66129,1.79185 -5.95391,0.51713 -6.23671,-0.2208 -11.03836,-2.32483 -2.57098,0.27277 -5.14197,0.54555 -7.71295,0.81832 -0.91766,-0.76156 -1.56555,-2.3947 -2.75298,-2.28469 -3.40416,0.31538 -6.37271,2.50981 -9.66387,3.43505 -1.89983,0.5341 -3.88985,0.6772 -5.84762,0.9257 -1.86103,0.23622 -4.98041,2.29736 -5.60307,0.52776 -0.83546,-2.3744 2.2799,-4.48833 3.41985,-6.7325 -6.30568,3.02597 -12.28992,6.842 -18.91706,9.07792 -2.01786,0.6808 -5.02029,1.10316 -6.3653,-0.54796 -1.28614,-1.57885 3.01586,-5.66819 1.01096,-6.02496 -4.18293,-0.74434 -7.97301,2.98121 -12.08383,4.05456 -18.47256,4.82328 8.73927,-5.16607 -13.65645,3.68169 0,0 8.30503,-6.03396 8.30503,-6.03396 z"

570+ inkscape:connector-curvature="0" />

571+ <path

572+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

573+ id="path5282"

574+ d="m 439.33369,237.08082 c -5.47439,-2.96028 -3.28562,5.72694 -1.53636,5.2325 3.44066,-0.97252 6.23707,-3.74491 9.72747,-4.52016 0.75774,-0.16831 0.0633,2.07164 0.83265,2.17464 2.67303,0.35787 13.46994,-4.64024 14.14779,-4.92121 2.04586,-0.54266 4.02194,-1.56426 6.13758,-1.62798 8.26835,-0.24902 -5.3663,4.92975 0.63623,6.00394 3.33252,0.59637 6.26374,-2.88469 9.6326,-3.21942 1.2112,-0.12034 2.05563,1.30397 3.08344,1.95596 4.62785,-1.95699 9.2557,-3.91398 13.88356,-5.87097 1.74763,0.52552 7.10975,2.28627 8.91991,2.20657 4.91708,-0.21649 9.55324,-2.7245 14.4705,-2.93685 0.96534,-0.0417 2.29151,0.18143 2.6989,1.05758 0.48206,1.03674 -0.42687,2.24646 -0.6403,3.36969 0.42808,-0.18104 13.87161,-6.49543 16.43017,-5.66676 1.26258,0.40892 -0.86067,3.47065 0.37133,3.96409 2.45886,0.98481 5.28458,-0.37938 7.92014,-0.64321 15.4825,-1.54984 2.47234,-0.73607 17.32767,-1.44683 20.16342,-0.68595 -0.61738,-1.19219 12.25354,1.71416 1.88649,0.42598 3.86273,0.35948 5.79515,0.2814 2.08666,-0.0843 4.32689,-1.6528 6.21799,-0.76679 1.05283,0.49326 -0.32071,2.30308 -0.48106,3.45461 1.74185,-0.3169 3.4837,-0.6338 5.22556,-0.9507 6.48171,0.58028 11.31801,-5.02464 17.37162,-5.86508 1.21646,-0.16889 0.92241,2.46374 1.96105,3.11914 1.64086,1.0354 3.65432,1.44253 5.58426,1.64206 12.40919,-0.10851 6.3507,-0.44262 18.18031,0.91002 5.2457,-0.519 10.31623,3.10438 15.5601,2.66514 4.34908,-0.36429 8.39276,-3.24534 12.74907,-2.98106 1.44232,0.0875 0.87592,2.90366 1.94781,3.87268 5.51735,4.98789 4.48486,-2.50811 3.9798,6.33873 5.76444,2.19985 12.43819,-6.60952 18.41769,-4.55109 1.44645,0.49794 -1.68101,4.66965 -0.15351,4.58671 4.81321,-0.26138 8.63125,-5.36947 13.45116,-5.30882 1.86087,0.0234 -0.76563,3.64243 -1.14845,5.46364 2.80475,-0.55712 5.6095,-1.11423 8.41425,-1.67135 4.05645,-1.59233 7.85344,-4.17428 12.16934,-4.777 1.04286,-0.14563 0.82904,1.93593 1.24356,2.90389 1.42922,0.0469 2.87497,0.36245 4.28766,0.14068 2.12504,-0.33359 4.1136,-1.26683 6.20077,-1.78717 8.61601,-2.14799 -0.68024,1.02577 9.22492,-2.7096 0.72398,-0.0381 1.46437,-0.27231 2.17195,-0.11441 0.35929,0.0802 0.5247,0.51649 0.78706,0.77473 2.09582,-1.26276 4.09681,-2.69827 6.28745,-3.78827 0.18826,-0.0937 0.30755,0.28684 0.46132,0.43026 0.20897,0.0476 0.43874,0.24546 0.62691,0.14284 1.47903,-0.80655 2.81173,-1.85645 4.21759,-2.78467 10.09216,-6.69652 -1.79879,0.91257 -0.29335,1.23767 1.96082,0.42344 3.21705,-2.44369 5.02727,-3.30811 1.21936,-0.58227 -3.94065,3.52558 -2.67863,3.04268 1.34115,-0.51318 2.40022,-1.57706 3.60033,-2.36559 3.58809,-1.94003 -0.10481,0.10832 -3.22044,1.2596 -1.18007,0.43606 2.73229,-0.76526 2.43591,-1.6751 -0.28452,-0.87342 -1.83157,-0.28546 -2.74741,-0.21451 24.89401,-13.44905 10.98443,-4.78107 6.10519,-4.80799 -0.5874,-0.003 0.47601,-1.09001 0.84739,-1.54512 0.68406,-0.83828 1.57306,-1.49001 2.29035,-2.30005 0.57577,-0.65021 1.0537,-1.38089 1.58056,-2.07134 0.79967,-0.87436 1.59935,-1.74871 2.39902,-2.62307 0.20201,-0.60032 1.14138,-1.46243 0.60604,-1.80097 -0.9444,-0.59722 -2.26102,0.30833 -3.35154,0.0648 -0.4229,-0.0944 -1.12945,-0.68431 -0.83167,-0.9991 2.87301,-3.03713 7.29695,-4.22652 10.35349,-7.07887 0.23764,-0.22177 -0.41926,-0.49684 -0.62888,-0.74526 -1.4682,-0.57082 -1.26023,-0.042 -1.06626,-1.32997 0,0 3.02138,-1.27939 3.02138,-1.27939 l 0,0 c -7.61861,4.36787 -7.57924,3.76889 1.37583,1.16192 -2.79852,1.96211 -7.60545,5.05804 -9.695,7.79492 -0.10971,0.14368 -1.22351,2.57933 -0.59404,3.03807 0.67307,0.49052 1.63956,0.29393 2.45934,0.4409 -10.69683,7.76533 -6.46048,2.28777 -3.95825,4.66925 0.28022,0.26669 0.34086,0.73833 0.2949,1.12243 -0.0613,0.51213 -1.11159,1.36151 -0.59991,1.42631 3.44049,0.43571 7.18169,-3.194 1.54058,1.27161 0.51455,0.0832 1.85256,-0.17022 1.54366,0.24963 -0.42993,0.58435 -5.88925,3.82593 -6.64539,4.28618 -2.25283,1.37126 -4.25988,3.13349 -6.56145,4.42126 -0.57965,0.32433 0.91585,-0.96229 1.37377,-1.44343 -0.97832,0.61888 -1.77788,1.82089 -2.93498,1.85665 -0.84725,0.0262 1.25052,-1.15506 1.77523,-1.8208 0.14614,-0.18543 0.39428,-0.8091 0.19623,-0.68058 -2.95533,1.9178 -5.47115,4.52716 -8.60483,6.13714 -1.41463,0.7268 7.50902,-5.73994 3.22744,-3.51403 -1.94695,1.35889 -3.46817,4.16386 -5.84085,4.07668 -2.00788,-0.0738 5.80425,-2.70226 4.39051,-4.12997 -1.44757,-1.46188 -3.44965,2.24521 -5.22143,3.29084 -1.58833,0.93737 -3.17327,1.89624 -4.85411,2.65534 -3.03629,1.37125 -2.45211,1.51547 -3.62353,-0.19057 -1.2459,0.29401 -2.4918,0.58801 -3.7377,0.88202 -0.94895,-0.0594 -1.91563,-0.37033 -2.84684,-0.17826 -0.90464,0.18658 -13.69919,4.55903 -14.20983,4.39414 -1.42497,-0.46012 2.23239,-3.95305 0.80923,-4.41875 -2.71665,-0.88896 -5.56686,1.30075 -8.35029,1.95112 -18.56769,0.0793 13.70185,-0.82956 -20.27406,5.77609 -1.24209,0.24149 -1.79361,-1.8371 -2.90263,-2.44636 -1.29963,-0.71396 -2.72775,-1.30777 -4.20303,-1.45723 -7.88112,-0.79842 -5.93835,3.28036 -6.95179,-3.55661 -4.15903,1.41034 -8.31806,2.82068 -12.47709,4.23101 0.13929,-1.64904 2.02947,-4.5709 0.41789,-4.94714 -3.68032,-0.8592 -7.29587,2.22135 -11.06755,2.46089 -19.20033,1.21941 3.42849,-1.74287 -8.44928,-6.51391 -3.19359,-1.2828 -6.88148,0.1533 -10.32222,0.22994 -4.01012,0.4663 -8.02025,0.93261 -12.03037,1.39891 -1.70721,-1.01184 -3.14481,-2.86055 -5.12161,-3.03552 -3.42478,-0.30314 -6.76114,2.07637 -10.17655,1.68141 -1.21543,-0.14056 -0.76145,-3.11341 -1.98472,-3.08777 -3.40485,0.0714 -6.28097,2.89341 -9.65823,3.33189 -0.82541,0.10716 -1.10923,-1.24127 -1.66384,-1.86191 -1.46833,0.1182 -2.93216,0.38115 -4.405,0.3546 -1.20724,-0.0218 -2.40792,-0.75508 -3.5878,-0.49866 -3.40511,0.74001 -6.46807,4.14784 -9.87684,3.42487 -1.76071,-0.37343 2.8545,-4.90599 1.09548,-5.28732 -6.30413,-1.36664 -12.36869,6.47925 -19.07787,3.24381 -2.81278,-1.15043 -8.0235,-3.73838 -11.21616,-2.99339 -5.30446,1.23778 -9.81702,5.25422 -15.21947,5.94913 -1.30931,0.16841 0.63002,-3.1138 -0.3995,-3.94008 -0.96711,-0.77619 -8.78805,0.52726 -9.49794,0.62362 -2.43958,0.81492 -4.75139,2.60053 -7.31876,2.44474 -3.96541,-0.24062 4.43728,-6.06793 -2.4985,-4.79696 -4.07548,0.74683 -7.54039,3.65131 -11.60589,4.45071 -3.28335,0.64561 -6.23377,-5.00667 -9.93337,-1.45023 -2.69658,0.53612 -5.34039,1.61546 -8.08974,1.60836 -1.29308,-0.003 -2.27044,-1.2921 -3.5163,-1.63834 -1.44221,-0.40081 -2.95661,-0.56492 -4.45344,-0.57657 -7.07426,-0.0551 -4.52877,1.11419 -12.43282,2.68962 -1.29287,0.25769 -2.63653,0.0199 -3.9548,0.0298 -0.74509,-0.3974 -1.39082,-1.19305 -2.23527,-1.19222 -8.48298,0.008 -5.99334,5.38203 -16.7296,6.92971 -1.63516,0.23571 1.50781,-2.94003 2.26172,-4.41004 -1.14109,0.0362 -2.31128,-0.14996 -3.42328,0.10862 -1.6719,0.38879 -3.21432,1.20574 -4.82148,1.80861 0,0 6.59652,-4.79266 6.59652,-4.79266 z"

575+ inkscape:connector-curvature="0" />

576+ <path

577+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"

578+ id="path5288"

579+ d="m 427.09099,608.80296 c -0.54536,0.88302 -2.59373,3.0492 -1.6361,2.64907 3.94655,-2.30416 7.89309,-4.60832 11.83964,-6.91247 -0.48068,0.95507 -2.45697,2.52886 -1.44204,2.86521 1.68661,0.55895 3.34268,-1.22337 5.06375,-1.66497 1.38771,-0.35607 2.85207,-1.08817 4.237,-0.72145 0.74384,0.19697 0.64163,1.39882 0.96244,2.09823 1.37197,0.0822 2.78072,0.57276 4.11592,0.24671 3.459,-0.84467 6.54045,-2.94826 10.02108,-3.69889 2.35754,-0.50843 6.11513,1.00569 8.24077,1.90515 1.08276,0.45817 2.01316,1.647 3.18215,1.5214 3.04137,-0.32679 5.82554,-1.86816 8.73831,-2.80223 0.0213,1.01023 -0.88531,2.68436 0.064,3.03068 1.6579,0.60487 3.51554,-0.518 5.17469,-1.11943 3.10954,-1.12717 5.90095,-3.06895 9.06232,-4.04132 1.11082,-0.34167 3.56487,-0.97615 3.48173,0.18305 -0.17139,2.38956 -5.60845,4.31354 -3.92661,6.01963 1.90254,1.92996 5.2515,-1.34136 7.87725,-2.01204 5.57129,2.09339 10.88855,-4.38851 16.19806,-2.9901 1.5161,0.39931 -1.91863,4.4988 -0.36246,4.68943 3.61195,0.44246 6.80584,-2.64975 10.35214,-3.4657 4.75582,-1.09424 4.54067,-0.5378 7.56802,1.586 2.7685,-1.48955 4.99284,1.99196 7.53405,1.61787 3.37273,-0.49649 6.43938,-2.27591 9.75173,-3.08218 2.40251,-0.5848 4.93371,-0.50568 7.33922,-1.078 3.43034,-0.81613 6.59584,-3.15152 10.12112,-3.07612 1.16193,0.0249 0.71886,2.21042 1.07829,3.31564 1.42789,0.26396 2.89169,0.37849 4.28369,0.79187 4.40179,1.3072 2.47933,2.85169 8.61077,1.10238 2.82423,-0.80575 18.5379,-8.0104 22.90225,-7.58044 1.38563,0.1365 1.07795,2.56757 1.61692,3.85135 6.71637,11.01182 -3.68387,-3.37038 21.00188,-5.1411 2.86377,-0.20542 -5.40592,5.18669 -3.94363,7.65753 1.31649,2.22446 5.10447,-0.84577 7.6179,-1.44914 2.83592,-0.68079 5.59821,-1.63981 8.41404,-2.39945 2.34076,-0.63148 4.70255,-1.18227 7.05383,-1.7734 1.89507,-0.27942 3.83635,-1.33931 5.68522,-0.83825 0.91429,0.24778 0.67699,1.76946 1.01548,2.65418 2.87065,-0.87358 5.62729,-2.92999 8.61194,-2.62073 1.19443,0.12376 -0.64239,3.23232 0.51114,3.56602 2.02002,0.58437 15.38587,-3.38686 16.41366,-3.66716 -0.15304,1.37971 -1.82071,3.86876 -0.45913,4.13912 2.88522,0.57288 5.56173,-1.98169 8.44725,-2.55301 1.49987,-0.29697 3.07716,0.21428 4.58688,-0.0277 2.14755,-0.34421 4.12553,-1.5628 6.29505,-1.71648 0.71473,-0.0506 1.11339,1.25168 1.8214,1.14155 2.30654,-0.35876 4.37463,-1.63033 6.56195,-2.4455 -0.44888,1.15735 -2.31073,2.69008 -1.34663,3.47204 1.24004,1.00577 3.13873,-0.68571 4.73492,-0.72386 1.27427,-0.0305 5.97531,0.93232 7.19325,1.37508 1.00412,0.36504 1.79765,1.62936 2.85276,1.46128 3.30399,-0.52634 6.29112,-2.27935 9.43668,-3.41903 2.16754,7.29671 -1.34009,-1.02626 10.2382,-0.42077 1.26673,0.0662 -0.89534,2.46826 -0.75751,3.7292 0.0842,0.77019 0.82031,1.33174 1.37033,1.87741 3.25333,3.22757 4.14722,0.43976 9.52911,-1.62234 -5.67229,9.9542 2.19189,-5.35859 6.0963,-0.33515 1.76843,2.27527 -6.50408,3.21284 -6.15274,6.07304 0.29151,2.37311 4.145,-2.92278 6.53572,-2.95529 -2.29854,3.66744 -2.94659,2.96902 0.93035,2.70267 23.98881,-12.56081 6.53151,-5.05582 6.71984,-1.35229 0.0562,1.10418 2.14953,-0.59987 3.2544,-0.64052 0.59071,-0.0217 1.14215,0.30517 1.71323,0.45776 1.24821,-0.35158 2.46907,-0.82114 3.74464,-1.05472 0.6566,-0.12024 1.33503,0.002 2.00255,0.002 -7.56212,7.4632 -4.80566,3.75696 0.51507,2.0828 0.278,-0.0875 0.83108,0.29605 0.68233,0.54666 -0.69786,1.17578 -1.86061,2.00398 -2.79092,3.00597 0,0 -1.07469,0.77304 -1.07469,0.77304 l 0,0 c 0.29688,-0.55013 0.49344,-1.16768 0.89064,-1.65039 0.97731,-1.18769 4.73458,-3.44842 3.20163,-3.32283 -3.51078,0.28763 -5.88837,4.42533 -9.63666,4.33697 -0.15241,-0.37159 -0.34842,-0.72816 -0.45725,-1.11477 -0.29714,-1.0556 -0.24534,-2.79779 -0.8748,-2.62026 -2.57218,0.72544 -4.57165,3.54585 -7.24208,3.44002 -1.52804,-0.0605 1.88309,-2.41005 2.82464,-3.61508 -2.57134,1.22873 -5.14267,2.45745 -7.71401,3.68618 2.38555,-2.2552 5.77328,-3.78851 7.15663,-6.76561 0.72913,-1.56914 -3.24014,1.21524 -4.86007,1.82323 -1.6775,0.62961 -3.30811,1.40187 -5.03222,1.88956 -1.02074,0.28874 -3.10209,1.48551 -3.15373,0.42598 -0.0805,-1.65221 4.01255,-2.67402 2.98116,-3.96728 -1.08235,-1.35717 -3.33942,0.94959 -5.00913,1.42439 -20.13729,8.35134 -2.69796,2.67973 -3.51754,-2.53363 -0.30637,-1.94883 -3.85411,1.58588 -5.79195,1.21634 -0.87346,-0.16656 -0.0847,-2.23403 -0.93357,-2.49888 -11.84288,-3.69529 -1.16733,3.90973 -7.75074,-1.30702 -2.41838,0.61135 -4.85237,1.16396 -7.25514,1.83405 -2.78931,0.77789 -5.42146,2.48551 -8.31711,2.50877 -0.92506,0.007 -0.55731,-1.9355 -1.33837,-2.43121 -1.00483,-0.63771 -2.41681,-0.17922 -3.51128,-0.64664 -5.17393,-2.20964 4.51953,-3.02699 -6.76187,-0.29747 -1.8717,0.0522 -5.62004,0.0639 -7.3367,0.54341 -2.69541,0.75295 -5.09849,2.65578 -7.88857,2.87404 -0.88863,0.0695 -0.97674,-1.50932 -1.61597,-2.13053 -2.88746,-2.80607 -2.96741,-1.82144 -7.53922,-1.91209 -5.60568,-1.00025 -5.2968,-1.462 -12.0296,0.4822 -3.77819,1.09101 -7.17546,4.70648 -11.06137,4.10258 -1.96748,-0.30576 3.75004,-3.90954 2.47312,-5.43726 -3.21419,-3.84551 -12.45489,8.124 -14.52498,3.88536 0.16133,-1.24054 1.72133,-3.53728 0.484,-3.72163 -2.94633,-0.43896 -5.68485,1.79467 -8.57499,2.51619 -2.56637,0.64068 -5.14051,1.38245 -7.77923,1.56659 -1.88811,0.13176 -3.76204,-0.41995 -5.64306,-0.62993 0.13071,-1.79104 2.18522,-5.47173 0.39212,-5.37312 -5.55708,0.30559 -10.33401,4.13599 -15.50101,6.20399 -10.66645,-2.44406 0.68895,-0.62357 -14.71365,0.88811 -1.68946,0.16581 -3.35352,-0.60601 -5.05038,-0.65553 -1.88826,-0.0551 -3.83509,0.84291 -5.65682,0.34302 -0.93454,-0.25644 -0.73557,-2.23638 -1.69663,-2.36085 -2.36483,-0.30628 -4.69832,0.81892 -7.04748,1.22838 -2.97423,0.81182 -5.94845,1.62365 -8.92268,2.43547 -0.86665,-0.8126 -1.41221,-2.41128 -2.59994,-2.43779 -5.34668,-0.11933 -13.32985,5.97106 -18.52181,1.51644 -0.70103,-0.60147 -0.94151,-1.58947 -1.41227,-2.38421 -0.71473,0.22765 -15.04458,4.94998 -16.29418,4.75369 -1.16619,-0.18319 0.32544,-3.32233 -0.84936,-3.43812 -3.23005,-0.31834 -6.18554,2.3471 -9.4303,2.42499 -1.28344,0.0308 -2.14298,-1.4143 -3.21447,-2.12145 -4.57791,1.88547 -9.15581,3.77095 -13.73372,5.65642 -0.35422,-0.97953 -0.25778,-2.27745 -1.06266,-2.9386 -0.88974,-0.73085 -3.03618,0.38783 -3.38033,-0.71096 -0.44745,-1.42861 3.36536,-4.26694 1.8802,-4.07862 -3.91526,0.49646 -7.09459,3.45974 -10.64188,5.18961 0.003,-0.88328 0.88856,-2.56291 0.01,-2.64984 -2.39024,-0.23638 -4.62168,1.31014 -6.93253,1.9652 -21.18125,5.49534 1.18422,1.02595 -11.44132,0.93616 -2.29045,-0.0163 -4.51443,1.00604 -6.80442,0.95784 -1.30262,-0.0274 -2.42374,-1.16009 -3.72651,-1.17953 -2.1489,-0.0321 -4.24554,1.38622 -6.36478,1.02898 -0.87305,-0.14717 -0.86226,-1.54661 -1.29339,-2.31992 -2.244,0.83914 -8.96653,3.77305 -12.27692,3.87067 -0.63692,0.0188 -1.13222,-0.59394 -1.73219,-0.80855 -1.88608,-0.67465 -2.71984,-0.38168 -3.36282,-2.56718 0,0 -2.59014,1.88185 -2.59014,1.88185 z"

580+ inkscape:connector-curvature="0" />

581+ <text

582+ xml:space="preserve"

583+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"

584+ x="351"

585+ y="282"

586+ id="text4003"

587+ sodipodi:linespacing="125%"><tspan

588+ sodipodi:role="line"

589+ id="tspan4005"

590+ x="351"

591+ y="282"

592+ style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic">Endpoint</tspan></text>

593+ <text

594+ sodipodi:linespacing="125%"

595+ id="text4030"

596+ y="316"

597+ x="373"

598+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"

599+ xml:space="preserve"><tspan

600+ style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic"

601+ y="316"

602+ x="373"

603+ id="tspan4032"

604+ sodipodi:role="line">Transport</tspan></text>

605+ <text

606+ xml:space="preserve"

607+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"

608+ x="454.58578"

609+ y="292.34314"

610+ id="text4050"

611+ sodipodi:linespacing="125%"><tspan

612+ sodipodi:role="line"

613+ id="tspan4052"

614+ x="454.58578"

615+ y="292.34314"

616+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">TCP connection</tspan><tspan

617+ sodipodi:role="line"

618+ x="454.58578"

619+ y="312.34314"

620+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"

621+ id="tspan4068">(bi-directional)</tspan></text>

622+ <path

623+ style="fill:#b3b3b3;stroke:#000000;stroke-width:1;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:2,1;stroke-dashoffset:0"

624+ d="m 554,248 86,108"

625+ id="path4054"

626+ inkscape:connector-curvature="0" />

627+ <text

628+ sodipodi:linespacing="125%"

629+ id="text4056"

630+ y="376"

631+ x="594"

632+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"

633+ xml:space="preserve"><tspan

634+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"

635+ y="376"

636+ x="594"

637+ id="tspan4058"

638+ sodipodi:role="line">Transport connection</tspan><tspan

639+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"

640+ y="396"

641+ x="594"

642+ sodipodi:role="line"

643+ id="tspan4070">(uni-directional)</tspan></text>

644+ <text

645+ xml:space="preserve"

646+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"

647+ x="794"

648+ y="226"

649+ id="text4062"

650+ sodipodi:linespacing="125%"><tspan

651+ sodipodi:role="line"

652+ id="tspan4064"

653+ x="794"

654+ y="226"

655+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">Chan</tspan></text>

656+ </g>

657+</svg>

doc/reconnect/reconnect.texnew file+409

@@ -0,0 +1,409 @@

1+\documentclass[10pt]{article}

2+\usepackage[margin=2.5cm]{geometry}

3+\usepackage{listings}

4+\usepackage{amsmath,amssymb,stmaryrd}

5+\usepackage{mathpazo,times}

7+\begin{document}

9+\newcommand{\semNs}{\mathit{ns}}

10+\newcommand{\semEth}{\mathit{eth}}

11+\newcommand{\semPg}{\mathit{pg}}

12+\newcommand{\semNid}{\mathit{nid}}

13+\newcommand{\semNc}{\mathit{nc}}

14+\newcommand{\semRecon}{\mathrm{reconnect}}

15+\newcommand{\semDisconnect}{\mathrm{disconnect}}

16+\newcommand{\semDropped}{\mathrm{dropped}}

17+\newcommand{\semMessage}{\mathrm{message}}

18+\newcommand{\semPid}{\mathit{pid}}

19+

20+\newcommand{\semSystem}[2]{\llbracket #1, #2 \rrbracket}

21+\newcommand{\semNode}[3]{[ #1, #2, #3 ]}

22+\newcommand{\semStdNode}[1]{\semNode{\semPg_{#1}}{\semNid_{#1}}{\semNc_{#1}}}

23+\newcommand{\semProc}[3]{\langle #1, #2, #3 \rangle}

24+\newcommand{\semStdProc}[1]{\semProc{e}{\semPid}{q}}

25+

26+\newcommand{\semDied}[2]{\mathrm{died}(#1, #2)}

27+\newcommand{\semParN}{\mathrel{{\parallel}_N}}

28+\newcommand{\semParP}{\mathrel{{\parallel}_P}}

29+\newcommand{\semEthMatch}[3]{\mathrm{ethMatch}(#1, #2, #3)}

30+

31+\lstset{basicstyle=\ttfamily\small}

32+

33+\title{An Explicit $\semRecon$ Primitive for Cloud Haskell \\ (or a Future Erlang)}

34+\author{\small \begin{tabular}{ll}

35+Edsko de Vries & Duncan Coutts \\

36+Well-Typed LLP & Well-Typed LLP \\

37+\texttt{edsko@well-typed.com} & \texttt{duncan@well-typed.com}

38+\end{tabular}}

39+\maketitle

40+

41+\section*{Introduction}

42+

43+The original Cloud Haskell paper stipulates that messages are ``asynchronous,

44+reliable, and buffered'', but does not describe how this can be achieved.

45+Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),

46+the reliability of message delivery comes from the reliability of the

47+underlying network protocol---up to a point.

48+

49+The problem is that the underlying network protocol is connection-oriented, but

50+Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a

51+reliable-ordered connection from $P$ to $Q$. Reliability of message delivery

52+now follows from reliability of the network protocol, until $P$ somehow gets

53+disconnected from $Q$. If $P$ now sends another message to $Q$, the

54+implementation cannot simply reconnect: after all, some messages that were sent

55+on the first connection might not have been delivered. This means that $P$

56+might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1, m_3$.

57+

58+One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and

59+remove messages from this buffer only when $Q$ acknowledges that it received

60+them. On a reconnect $P$ must ask which message $Q$ last received, and

61+retransmit the rest. This means that when $P$ gets disconnected from $Q$, it

62+must infinitely buffer all messages sent to $Q$ (until a connection is

63+reestablished). However, infinite buffering is too strong a requirement;

64+moreover, this is unsatisfactory because it means implementing a reliable

65+protocol on top of the underlying reliable network protocol. We would like a

66+different solution.

67+

68+But even more important than the exact solution we adopt is a precise

69+semantics of Cloud Haskell message delivery. A good starting point (one that

70+has been used in the new implementation of Cloud Haskell) is \textit{A

71+Unified Semantics for Future Erlang} by Hans Svensson, Lars-\AA{}ke Fredlund

72+and Clara Benac Earle (Erlang '10)---although this semantics leaves the issue

73+of reconnect open.

74+

75+Here we give an overview of the relevant aspects of the Unified semantics,

76+discuss where reconnect comes into the picture, and then propose a new

77+primitive for Cloud Haskell called $\semRecon$, which essentially gives the

78+programmer the ability to explicitly accept message loss.

79+

80+\section*{Overview of the original semantics}

81+

82+The top-level semantics is a labelled transition relation between

83+\textit{systems}

84+%

85+\begin{equation}

86+\semSystem{\semNs}{\semEth} \xrightarrow{\tilde{\mu}} \semSystem{\semNs'}{\semEth'}

87+\end{equation}

88+%

89+A system $\semSystem{\semNs}{\semEth}$ consists of a bunch of nodes $\semNs$

90+and an ``ether'' or system message queue $\semEth$. The ether models, globally,

91+all messages that have been sent but not yet delivered. The label $\tilde{\mu}$

92+is a list of actions, and is only used in the semantics to define fairness (see

93+below).

94+

95+A node is a triplet $\semStdNode{}$ consisting of a bunch of processes

96+$\semPg$, a node ID $\semNid$ and a node controller $\semNc$. The node

97+controller is responsible for all administrative actions on a node (spawning

98+new processes, establishing links, etc.).

99+A process $\semStdProc{}$ consists of an expression $e$, process ID $\semPid$

100+and message queue (mailbox) $q$. Finally, $(\semParN)$ is used for the parallel

101+composition of nodes, and $(\semParP)$ is used for the parallel composition of

102+processes.

103+

104+\subsubsection*{Ordering}

105+

106+The ether contains messages of the form

107+%

108+\begin{equation*}

109+(\mathit{recipient}, \mathit{sender}, \mathit{message})

110+\end{equation*}

111+%

112+where $\mathit{recipient}$ and $\mathit{sender}$ are process IDs or node IDs

113+(for messages to or from node controllers). Ordering of message delivery in

114+the semantics is embodied by a function

115+%

116+\begin{equation*}

117+\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}}

118+\end{equation*}

119+%

120+(Def.~11, p.~25) which selects the \emph{first} message in $\semEth$ from

121+$\mathit{from}$ to $\mathit{to}$. Many of the semantic rules look like

122+%

123+\begin{equation*}

124+\frac{%

125+\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}} = \mathit{sig}

126+}{%

127+\semSystem{\semNs}{\semEth} \rightarrow \text{(do something with $\mathit{sig}$)}

128+}

129+\end{equation*}

130+

131+where $\mathit{to}$ and $\mathit{from}$ are universally quantified over the

132+rule. This means that messages between pairs of processes (or nodes) are

133+ordered, but there is no global ordering guarantee.

134+

135+\subsubsection*{Disconnects}

136+

137+Although the semantics is not connection oriented, it includes a

138+non-deterministic rule $\mathit{node}_\mathit{disconnect}$ which models

139+arbitrary disconnects (Table 9, p.~28):

140+%

141+{\small

142+\begin{equation*}

143+\frac{}{%

144+ \begin{array}{l}

145+ \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}{\semEth}

146+\xrightarrow{\semDisconnect(nid_1, nid_2)} \\[0.5em]

147+ \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}

148+ {\semEth \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})

149+ \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})

150+ }

151+ \end{array}

152+}

153+\end{equation*}

154+}

155+%

156+So at any one point a node controller may receive a message that it got

157+disconnected from another node controller. These messages are handled by the

158+bottom rule in Table 12 (p.~30): local processes that link to (or monitor)

159+processes on the disconnected remote node are killed (or notified).

160+

161+\subsubsection*{Node or process failure}

162+

163+When a process dies (throws an exception) a message is sent to its local node

164+controller (rule $\mathit{exiting}$, Table~4, p.~27). Failure of an entire

165+node is handled by a non-deterministic rule like the one above (rule

166+$\mathit{node}_\mathit{failure}$, Table~9, p.~28). The resulting message is

167+handled in a similar way to a disconnect (Table~12, p.~30).

168+

169+When a process or a node \emph{dies} (but \emph{not} when it gets disconnected)

170+messages to that process (or node) can be removed from the ether (rules

171+$\mathit{missing}_\mathit{process}$ and $\mathit{missing}_\mathit{node}$,

172+Table~6, p.~28).

173+

174+\subsubsection*{Fairness}

175+

176+Since the semantic rules pick an (more or less) arbitrary message from the

177+ether to process, the rules do not guarantee that all messages are eventually

178+delivered. In the paper this is added ``on top'' of the semantic rules by Def.~20

179+(p.~29), which essentially states that all messages that have been sent must be

180+delivered (or explicitly removed by rules $\mathit{missing}_\mathit{process}$

181+and $\mathit{missing}_\mathit{node}$).

182+

183+\section*{Reconnect}

184+

185+\subsubsection*{In the Unified semantics}

186+

187+The original semantics state that

188+

189+\begin{enumerate}

190+\item all messages sent must eventually be delivered or explicitly removed from the ether (fairness)

191+\item only messages to died (not disconnected) processes or nodes can be removed from the ether

192+\end{enumerate}

193+

194+From a practical perspective this means that messages sent from process $P$ to

195+process $Q$ must be infinitely buffered when $P$ gets disconnected to $Q$, and

196+the system should keep retrying to connect to $Q$ until it receives evidence

197+(for instance, from $Q$'s node controller) that $Q$ has died.

198+

199+For messages sent to node controllers (such as attempts to spawn new processes)

200+this is even more problematic: when process $P$ gets disconnected from node

201+$N$, all messages from $P$ to $N$ must be infinitely buffered until a

202+reconnection is established, or dropped when $P$ learns $N$ has died. However,

203+process $P$ might never be able to distinguish a (temporary) disconnect from

204+$N$ from a crash of $N$.

205+

206+\subsubsection*{Permanent disconnects}

207+

208+The simplest solution to avoid infinite buffering is to drop the fairness

209+requirement from the semantics. Now the implementation is free to attempt to

210+reconnect only a finite number of times---or indeed never---and then simply

211+drop all subsequent messages and never reconnect again. This is a correct

212+implementation of the semantics, because without the fairness requirement

213+messages sent from $P$ to $Q$ can be left in the ether forever.\footnote{From a

214+purely formal perspective, the semantics without the fairness guarantee is too

215+permissive: it would allow a message never to be sent even when no disconnect

216+occurs. If we wanted to fix this, we would have to remove messages from the

217+ether on a disconnect, so that fairness can be satisfied, and keep an explicit

218+history of disconnects.}

219+

220+\subsubsection*{Implicit reconnect with potential message loss (Erlang-style)}

221+

222+The solution adopted by Erlang is an implicit reconnect but without

223+buffering. As described in the introduction, this means that it is possible for

224+$P$ to send messages $m_1, m_2, m_3$ to $Q$ and for $Q$ to receive messages

225+$m_1$ and $m_3$, but not $m_2$. We could model this in the semantics by

226+modifying the rule for disconnect so that it removes messages from the ether.

227+

228+\subsubsection*{Explicit Reconnects}

229+

230+Erlang-style implicit reconnects are not very satisfying semantically because

231+it means we cannot really make any claims about the reliability of message

232+delivery. Permanent disconnects are nicer semantically, but might be too

233+limiting (some musings on that below). The solution we propose is to introduce

234+a new primitive called $\semRecon$. Here's the rule:

235+%

236+\begin{equation*}

237+\frac{%

238+e \xrightarrow{\semRecon(i)} e' \qquad

239+(\semEth_0, \semEth_1) = \mathrm{partition} \; (\lambda (\mathit{to}, \mathit{from}, \_) \rightarrow \mathit{to} = i \wedge \mathit{from} = \semPid) \; \semEth

240+}{%

241+ \semSystem{\semNode{\semProc{e}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth}

242+\xrightarrow{\semDropped(\semEth_0)}

243+ \semSystem{\semNode{\semProc{e'}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth_1}

244+}

245+\end{equation*}

246+%

247+Semantically, when process $P$ calls $\semRecon(Q)$ it explicitly accepts that

248+some the messages it sent to $Q$ might be lost. Note that this is the only

249+change we need to make the Unified semantics. In particular, the fairness

250+requirement stays: since the rule explicitly records that some messages have

251+been dropped, fairness now means:

252+

253+\begin{quote}

254+All messages sent must eventually be delivered, removed from the ether because

255+a process or a node died, or removed from the ether by an explicit $\semRecon$.

256+\end{quote}

257+

258+From an implementation point of view, once $P$'s connection to $Q$ breaks we do

259+not implicitly reconnect (because doing so would mean losing the reliability

260+guarantee). When $P$ calls $\semRecon(Q)$, however, the implementation is

261+free to reestablish a connection from $P$ to $Q$, either immediately or when

262+$P$ sends its next message to $Q$.

263+

264+\section*{Example}

265+

266+Suppose we start with two nodes, both of which run a single process. The system

267+ether and both process queues are empty ($\epsilon$):

268+%

269+\begin{equation*}

270+\semSystem

271+ {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}

272+ \semParN

273+ \underbrace{\semNode{\semProc{p_2}{\semPid_2}{\epsilon}}{\semNid_2}{\semNc_2}}_{N_2}

274+ }

275+ {\epsilon}

276+\end{equation*}

277+%

278+Now $p_1$ sends a message to $p_2$ (Rule $\mathit{output}$, Table~5, p.~28):

279+%

280+\begin{equation*}

281+\frac{%

282+ p_1 \xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)} p_1'

283+}{%

284+\semSystem

285+ {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}

286+ \semParN

287+ N_2

288+ }

289+ {\epsilon}

290+\xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)}

291+\semSystem

292+ {\underbrace{\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}}_{N_1'}

293+ \semParN

294+ N_2

295+ }

296+ {\underbrace{(\semPid_2, \semPid_1, \semMessage(v))}_{M_1}}

297+}

298+\end{equation*}

299+%

300+Note that the message has been sent but not yet delivered (i.e., it is in the

301+ether, not in $p_2$'s queue). Now suppose that node $\semNid_1$ gets

302+disconnected from node $\semNid_2$ (Table~9, p.~28):

303+%

304+\begin{equation*}

305+\frac{%

306+}{%

307+\begin{array}{l}

308+\semSystem{N_1' \semParN N_2}{M_1}

309+\xrightarrow{\semDisconnect(\semNid_1, \semNid_2)} \\

310+\semSystem{N_1' \semParN N_2}{M_1 \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})

311+ \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})}

312+\end{array}

313+}

314+\end{equation*}

315+%

316+Assume that $p_1$ had previously set up monitoring for $p_2$. It gets notified of the disconnect (Table 12), and it receives the monitor message; at this point we're in a state

317+%

318+\begin{equation*}

319+\semSystem{N_1'' \semParN N_2}{M_1}

320+\end{equation*}

321+%

322+where the original message $M_1$ is still in the ether. If at this point $p_1$ sends another message to $p_2$ we end up with an ether

323+%

324+\begin{equation*}

325+M_1 \cdot \underbrace{(\semPid_2, \semPid_1, \semMessage(v_2))}_{M_2}

326+\end{equation*}

327+%

328+which implies that we must deliver $M_1$ before $M_2$. This is of course

329+precisely the ``ordered'' reliability guarantee. If however, $p_1$ calls

330+$\semRecon$ when it receives the monitor message, we remove $M_1$ from the ether;

331+when $p_1$ then sends the next message we can establish a new connection.

332+

333+\section*{The Need for Reconnect}

334+

335+Ordering guarantees are between pairs of processes/nodes. Thus, when $P$ gets

336+disconnected from $Q$, the easiest way to reestablish a connection is for $P$

337+to restart to become a new process $P'$. This will happen naturally when $P$

338+links to $Q$ and can be restarted by some supervisor process.

339+

340+However, if there are many processes connected to $P$, then $P$ might not want

341+to restart (breaking all connections with its own clients) simply in order to

342+be able to reconnect to Q. For instance, maybe $P$ is a webserver and $Q$ is a

343+domain name server; if $P$ gets temporarily disconnected from $Q$, it does not

344+make much sense to require $P$ to restart (and get a new process ID) before it

345+can send new domain name requests (indeed, in this particular example, lost

346+messages to a domain name server may not matter at all).

347+

348+The situation is even more severe for messages sent from processes to

349+\emph{nodes}. For instance, suppose process $P$ does

350+%

351+\begin{lstlisting}[mathescape,keywords={do}]

352+do spawnAsync nid p1 ; spawnAsync nid p2 ; spawnAsync nid p3

353+\end{lstlisting}

354+%

355+and receives a confirmation that $p_3$ was spawned successfully.\footnote{In

356+the unified paper spawn is asynchronous, which is why the new implementation of

357+Cloud Haskell offers \texttt{spawnAsync}; \texttt{spawn} is then implemented in

358+terms of \texttt{spawnAsync} and \texttt{expect}.} Intuitively this seems to

359+suggest that \emph{all} of $p_1$, $p_2$ and $p_3$ should have been spawned, and

360+this is guaranteed by the reliable-ordered guarantee for messages:

361+\texttt{spawnAsync} is nothing more than a message from the process to the node

362+controller of the node $\mathit{nid}$.

363+

364+But the same problem with reconnect occurs here, too. If the connection from

365+the process to the remote node controller is lost, we cannot guarantee ordered

366+delivery. Permanent disconnect would mean that the process would have to

367+restart before it can spawn new processes on this remote node; if the process

368+is some sort of supervisor process, then this might not be what we want to do.

369+Implicit reconnects means we lose the reliability guarantee; an explicit

370+reconnect (probably after a monitor notification about the disconnect from the

371+remote node) allows the process to reestablish a connection to the remote node

372+controller, and forces the programmer of the process to think about how to

373+handle the potential loss of messages.

374+

375+\section*{Alternative Solutions}

376+

377+\begin{itemize}

378+

379+\item A hybrid solution is possible, too. For instance, we might guarantee

380+reliable-ordered message passing for messages sent from process-to-process, but

381+not for process-to-node. In other words, no explicit call is necessary when

382+spawning a new process on a remote node after a disconnect from that remote

383+node. This might muddle the semantics (in particular, if processes don't

384+monitor remote nodes, programmers might get a false sense of security and rely

385+on non-existing ordering guarantees). On the other hand, requiring an explicit

386+reconnect to a remote node before a spawn (or similar primitive) might be

387+confusing.

388+

389+\item Another hybrid solution is to have an implicit reconnect when sending a

390+monitor notification. So, if $P$ monitors $Q$, and gets a monitor notification,

391+then it must expect potential message loss. If $P$ does not monitor $Q$ then

392+disconnects are permanent.

393+

394+\item Since Cloud Haskell supports typed channels as well as sending messages

395+directly to processes, we could decide not to offer any reliability guarantees

396+for messages sent directly to processes, but provide reliable-ordered message

397+delivery on typed channels. This is an attractive solution, because a typed

398+channel could be considered a connection. When $P$ wants to communicate with

399+$Q$, it sends a message to $Q$ requesting a send port. It then communicates

400+with $Q$ through this send port; when it gets disconnected, it could request a

401+\empty{new} typed channel. Importantly, the send port $P$ receives must indeed

402+be a \emph{new} channel (at least from $P$s perspective).

403+

404+\end{itemize}

405+

406+

407+

408+

409+\end{document}

doc/semantics/CloudHaskellSemantics.texdeleted−706

@@ -1,706 +0,0 @@

1−\documentclass{article}

2−\usepackage[margin=2.5cm]{geometry}

3−\usepackage{amsmath, amssymb, stmaryrd}

4−\usepackage{mathpazo, times}

5−\usepackage{float}

6−\usepackage{listings}

7−

8−\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}

9−\newcommand{\sApp}[2]{{#1} {#2}}

10−\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}

11−\newcommand{\sReturn}{\mathtt{return}}

12−\newcommand{\sThrow}[1]{\mathtt{throw} \; {#1}}

13−\newcommand{\sCatch}[2]{\mathtt{catch} \; {#1} \; {#2}}

14−

15−\newcommand{\sExpect}{\mathtt{expect}}

16−\newcommand{\sSend}{\mathtt{send}}

17−\newcommand{\sSpawn}{\mathtt{spawn}}

18−\newcommand{\sLink}{\mathtt{link}}

19−\newcommand{\sReconnect}{\mathtt{reconnect}}

20−\newcommand{\sNewChan}{\mathtt{newChan}}

21−\newcommand{\sSendChan}{\mathtt{sendChan}}

22−\newcommand{\sReceiveChan}{\mathtt{receiveChan}}

23−\newcommand{\sMonitor}{\mathtt{monitor}}

24−

25−\DeclareMathOperator{\sNodeOf}{node}

26−\DeclareMathOperator{\sProcessOf}{process}

27−

28−\newcommand{\sSpawned}{\mathtt{spawned}}

29−

30−\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}}

31−

32−\newcommand{\sPar}{\mathrel{\parallel}}

33−\newcommand{\sProc}[2]{{#1}_{#2}}

34−

35−\newcommand{\sNid}{\ensuremath{\mathit{nid}}}

36−\newcommand{\sPid}{\ensuremath{\mathit{pid}}}

37−\newcommand{\sCid}{\ensuremath{\mathit{cid}}}

38−

39−\newcommand{\sId}{\ensuremath{\mathit{id}}}

40−\newcommand{\sRef}{\ensuremath{\mathit{ref}}}

41−

42−\newcommand{\sLinks}{\ensuremath{\mathit{links}}}

43−\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}

44−\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle}

45−\newcommand{\sNodes}{\mathcal{N}}

46−\newcommand{\sQueue}{\mathcal{Q}}

47−\newcommand{\sProcesses}{\mathcal{P}}

48−\newcommand{\sBlacklist}{\mathcal{B}}

49−\newcommand{\sMonitors}{\mathcal{M}}

50−

51−\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}

52−\newcommand{\sNothing}{\mathtt{Nothing}}

53−

54−\newcommand{\sCtxt}[1]{\mathbb{#1}}

55−

56−\newcommand{\sSenders}{\mathit{senders}}

57−

58−\newcommand{\OR}{\mathrel{|}}

59−\newcommand{\where}{\mathrel{|}}

60−

61−\floatstyle{boxed}

62−\restylefloat{figure}

63−

64−\lstset{basicstyle=\ttfamily\small}

65−

66−\begin{document}

67−

68−\title{Cloud Haskell Semantics (DRAFT)}

69−\author{Well-Typed LLP}

70−\date{\today}

71−

72−\maketitle

73−

74−\section{Introduction}

75−

76−Cloud Haskell brings Erlang-style concurrency to Haskell in the form of a

77−library.\footnote{\texttt{http://hackage.haskell.org/package/distributed-process}}

78−The original publication \cite{cloudhaskell} is a good introduction to Cloud

79−Haskell, and is accompanied by an ever-growing number of resouces, collected on

80−the Haskell

81−Wiki.\footnote{\texttt{http://www.haskell.org/haskellwiki/Cloud\_Haskell}} The

82−current document augments the original publication about Cloud Haskell by

83−giving a precise semantics to the Cloud Haskell primitives. It is meant as a

84−reference, not an introduction.

85−

86−The original Cloud Haskell paper stipulates that messages are ``asynchronous,

87−reliable, and buffered'', but does not describe how this can be achieved.

88−Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),

89−the reliability of message delivery comes from the reliability of the

90−underlying network protocol---up to a point.

91−

92−The problem is that the underlying network protocol is connection-oriented, but

93−Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a

94−reliable-ordered connection from $P$ to $Q$. Reliability of message delivery

95−now follows from reliability of the network protocol, until $P$ somehow gets

96−disconnected from $Q$. If $P$ now sends another message to $Q$, the

97−implementation cannot simply reconnect: after all, some messages that were sent

98−on the first connection might not have been delivered. This means that $P$

99−might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1,

100−m_3$.\footnote{Indeed, message passing in Erlang is ordered but unreliable for

101−the same reason \cite{erlang}.}

102−

103−One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and

104−remove messages from this buffer only when $Q$ acknowledges that it received

105−them. On a reconnect $P$ must ask which message $Q$ last received, and

106−retransmit the rest. This means that when $P$ gets disconnected from $Q$, it

107−must infinitely buffer all messages sent to $Q$ (until a connection is

108−reestablished). However, infinite buffering is too strong a requirement;

109−moreover, this is unsatisfactory because it means implementing a reliable

110−protocol on top of the underlying reliable network protocol. We would like a

111−different solution.

112−

113−Instead, Cloud Haskell does \emph{not} attempt to reconnect automatically, but

114−provides a $\sReconnect$ primitive which gives programmers the option of

115−reconnecting manually. This is an explicit acknowledgement from the programmer

116−that message loss might occur, and forces them to consider how such loss might

117−be dealt with.

118−

119−The semantics we present is based on \cite{unified}, which we will refer to the

120−as the ``Unified'' semantics. However, we will present the semantics in a more

121−``Haskell'' style following the semantics for STM \cite{stm}. It differs from

122−the Unified semantics in that

123−%

124−\begin{enumerate}

125−\item We introduce an explicit notion of \textit{reconnecting} (with potential

126−message loss)

127−\item We simplify the semantics: we ``flatten'' sets of nodes of processes as

128−sets of processes (but assume a mapping from process identifiers to node

129−identifiers), do not have per-process mailboxes (but only the system queue or

130−``ether'') and do not have an explicit concept of node controllers

131−\end{enumerate}

132−%

133−Our semantics differs from the STM semantics in that we pretend that the Cloud

134−Haskell \texttt{Process} monad is the top-level monad, and do not consider the

135−\texttt{IO} monad at all. Current imprecisions with respect to the ``real''

136−Cloud Haskell are

137−%

138−\begin{enumerate}

139−\item We ignore the issue of serializability, other than to say that the

140−semantics will get stuck when trying to send a non-serializable payload;

141−consequently, we do not formalize $\mathtt{static}$

142−\item We do not formalize all Cloud Haskell primitives (merging of ports,

143−``advanced messaging'', and others)

144−\item Some of the concepts that we do formalize are lower-level concepts; for

145−instance, the primitive $\sSpawn$ that we formalize is asynchronous (following

146−the Unified semantics); a synchronous construct can be derived.

147−\end{enumerate}

148−

149−\section{Preliminaries}

150−

151−Cloud Haskell Processes run on \emph{nodes}. Processes communicate by sending

152−messages to each other (directly or using typed channels). Processes can also

153−send messages to nodes (for instance, a request to spawn or monitor a process).

154−

155−We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and

156−$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively,

157−and representing process identifiers, node identifiers, and (typed) channel

158−identifiers. We assume the existence of total functions

159−%

160−\begin{equation*}

161−\begin{array}{r@{\;:\;}l}

162−\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\

163−\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId}

164−\end{array}

165−\end{equation*}

166−%

167−and define

168−$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$

169−and let $\sId$ range over $\mathtt{Identifier}$.

170−

171−We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process

172−ID $\sPid$. We will denote a set of processes as

173−%

174− $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$

175−%

176−A \emph{system}

177− $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$

178−is a tuple containing a set $\sProcesses$ of processes, a \emph{system

179−queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors

180−$\sMonitors$.

181−The set of monitors $\sMonitors$ is a set of tuples

182− $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$

183−which records that node \sNid{} knows that process $\sPid_\mathit{fr}$ is

184−monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor reference). The system

185−queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr},

186−\mathit{message})$ of messages that have been sent but not yet processed. The

187−blacklist records disconnections and is represented as a of pairs

188−$(\sId_\mathit{to}, \sId_\mathit{fr})$.

189−

190−\section{Semantics}

191−

192−We follow the STM semantics as closely as possible. The language is the same

193−except for the primitives considered, and we use the same concept of evaluation

194−contexts:

195−

196−\begin{equation*}

197−\begin{array}{llll}

198−\text{value} & V & ::= & \sId \OR

199− \sLam{x}{M} \OR

200− \sReturn \; M \OR

201− \sBind{M}{N} \OR

202− \sThrow{M} \OR \sCatch{M}{N} \OR \\

203− &&& \sExpect \OR

204− \sSend \; \sPid \; M \OR

205− \sSpawn \; \sNid \; M \OR

206− \sMonitor \; \sId

207−\\

208−\text{term} & M, N & ::= & x \OR

209− V \OR

210− \sApp{M}{N} \OR

211− \cdots \\

212−\\

213−\text{Evaluation} & \sCtxt{E} & ::= & [] \OR \sBind{\sCtxt{E}}{M} \OR \sCatch{\sCtxt{E}}{M} \\

214−\text{context} & \sCtxt{P}_\sPid & ::= & \sCtxt{E}[]_\sPid \sPar \sProcesses

215−\end{array}

216−\end{equation*}

217−%

218−Indeed, the ``administrative'' transitions are identical

219−(Figure~\ref{fig:administrative}).

220−

221−\begin{figure}

222−\small

223−\begin{equation*}

224−\frac{

225− \llbracket M \rrbracket = V \qquad

226− M \neq V

227−}{

228− M \rightarrow V

229−} \textsc{Eval}

230−\qquad

231−\frac{

232− M \rightarrow N

233−}{

234− \sSystem{\sCtxt{P}[M]_\sPid}

235− {\sQueue}

236− {\sBlacklist}

237− {\sMonitors}

238−\rightarrow

239− \sSystem{\sCtxt{P}[N]_\sPid}

240− {\sQueue}

241− {\sBlacklist}

242− {\sMonitors}

243−} \textsc{Admin}

244−\end{equation*}

245−%

246−\begin{equation*}

247−\begin{array}{r@{\;\rightarrow\;}ll@{\hspace{2em}}r@{\;\rightarrow\;}ll}

248−\sBind{\sReturn \; N}{M} & M \; N & \textsc{Bind} & \sCatch{(\sReturn \; M)}{N} & \sReturn \; M & \textsc{Catch}_1 \\

249−\sBind{\sThrow{N}}{M} & \sThrow{N} & \textsc{Throw} & \sCatch{(\sThrow M)}{N} & N \; M & \textsc{Catch}_2 \\

250−\end{array}

251−\end{equation*}

252−%

253−\caption{\label{fig:administrative}Administrative Transitions}

254−\end{figure}

255−

256−\subsection{Disconnect and Reconnect}

257−

258−Figure~\ref{fig:disconnect} gives the semantics for disconnecting and

259−reconnecting. Rule \textsc{Disconnect} models random network disconnect

260−between nodes $\sNid_1$ and $\sNid_2$. We assume that entire \emph{nodes} get

261−disconnected from each other, not individual processes. \emph{Reconnecting}

262−however is on a per connection basis (\textsc{Recon-Ex}). Connections to and

263−from node controllers can be implicitly reconnected ($\textsc{Recon-Im}_1$ and

264−$\textsc{Recon-Im}_2$).

265−

266−\begin{figure}

267−\small

268−\begin{equation*}

269−\frac{

270− \sNid_1 \neq \sNid_2

271−}{

272− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}

273−\rightarrow

274− \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors}

275−} \textsc{Disconnect}

276−\end{equation*}

277−%

278−\begin{equation*}

279−\frac{

280−}{

281− \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}

282− {\sQueue}

283− {\sBlacklist}

284− {\sMonitors}

285−\rightarrow

286− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}

287− {\sQueue}

288− {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})}

289− {\sMonitors}

290−} \textsc{Recon-Ex}

291−\end{equation*}

292−%

293−\begin{equation*}

294−\frac{

295−}{

296− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors}

297−\rightarrow

298− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}

299−} \textsc{Recon-Im}_1

300−\qquad

301−\frac{

302−}{

303− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors}

304−\rightarrow

305− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}

306−} \textsc{Recon-Im}_2

307−\end{equation*}

308−%

309−where

310−%

311−\begin{equation*}

312−\overline{\sNid} \subset \mathtt{Identifier}

313− = \{ \sNid \} \cup

314− \{ \sPid \where \sNodeOf(\sPid) = \sNid \} \cup

315− \{ \sCid \where \sNodeOf(\sCid) = \sNid \}

316−\end{equation*}

317−\caption{\label{fig:disconnect}Disconnect and Reconnect}

318−\end{figure}

319−

320−\subsection{Communication}

321−

322−The semantics for the basic primitives are listed in Figure~\ref{fig:basic}.

323−Once a connection has been blacklisted, no further messages can be sent across

324−that connection (until an explicit or implicit reconnect).

325−

326−Message passing is ordered but only for a given sender and receiver; no

327−ordering guarantees exist between messages sent by different processes. For

328−that reason rules \textsc{Expect}, \textsc{ReceiveChan} and \textsc{Spawn-Exec}

329−choose the \emph{first} message of a \emph{randomly chosen} sender.

330−

331−Since the semantics is not type-driven, we represent typed channels simply as

332−an identifier with an annotation whether it is the send-end ($\sCid^s$) or the

333−receive end ($\sCid^r$) of the channel (rules \textsc{NewChan},

334−\textsc{SendChan} and \textsc{ReceiveChan}).

335−

336−Spawning finally is asynchronous. When process $P$ spawns process $Q$ on node

337−$\sNid$ (rule \textsc{Spawn-Async}) a message is sent to node $\sNid$ (which

338−may, of course, never arrive). When the remote node receives the message and

339−actually spawns $Q$ (rule \textsc{Spawn-Exec}) it sends a message back to $P$

340−with $Q$'s process ID. In Cloud Haskell this primitive is called

341−\texttt{spawnAsync}, and the Cloud Haskell \texttt{spawn} primitive is defined

342−in terms of \texttt{spawnAsync} (we do not consider the synchronous version in

343−this document).

344−

345−\begin{figure}

346−\small

347−\begin{equation*}

348−\frac{

349−}{

350− \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}}

351− {\sQueue}

352− {\sBlacklist}

353− {\sMonitors}

354−\rightarrow

355− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}

356− {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)}

357− {\sBlacklist}

358− {\sMonitors}

359−} \textsc{Send}

360−\end{equation*}

361−%

362−\begin{equation*}

363−\frac{

364− \sId_{\mathit{fr}} \notin \sSenders(\sQueue)

365−}{

366− \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}}

367− {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'}

368− {\sBlacklist}

369− {\sMonitors}

370−\rightarrow

371− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}}

372− {\sQueue, \sQueue'}

373− {\sBlacklist}

374− {\sMonitors}

375−} \textsc{Expect}

376−\end{equation*}

377−%

378−\begin{equation*}

379−\frac{

380− \sCid \text{ fresh}

381−\qquad

382− \sProcessOf(\sCid) = \sPid

383−}{

384− \sSystem{\sCtxt{P}[\sNewChan]_\sPid}

385− {\sQueue}

386− {\sBlacklist}

387− {\sMonitors}

388−\rightarrow

389− \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid}

390− {\sQueue}

391− {\sBlacklist}

392− {\sMonitors}

393−} \textsc{NewChan}

394−\end{equation*}

395−

396−\begin{equation*}

397−\frac{

398−}{

399− \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}}

400− {\sQueue}

401− {\sBlacklist}

402− {\sMonitors}

403−\rightarrow

404− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}

405− {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)}

406− {\sBlacklist}

407− {\sMonitors}

408−} \textsc{SendChan}

409−\end{equation*}

410−

411−\begin{equation*}

412−\frac{

413− \sPid_{\mathit{fr}} \notin \sSenders(\sQueue)

414−}{

415− \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}}

416− {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'}

417− {\sBlacklist}

418− {\sMonitors}

419−\rightarrow

420− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}}

421− {\sQueue, \sQueue'}

422− {\sBlacklist}

423− {\sMonitors}

424−} \textsc{ReceiveChan}

425−\end{equation*}

426−%

427−\begin{equation*}

428−\frac{

429− \sRef \text{ fresh}

430−}{

431− \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}

432− {\sQueue}

433− {\sBlacklist}

434− {\sMonitors}

435−\rightarrow

436− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid}

437− {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)}

438− {\sBlacklist}

439− {\sMonitors}

440−} \textsc{Spawn-Async}

441−\end{equation*}

442−%

443−\begin{equation*}

444−\frac{

445− \sPid \notin \sSenders(\sQueue)

446−\qquad

447− \sPid' \text{ fresh}

448−\qquad

449− \sNodeOf(\sPid') = \sNid

450−}{

451− \sSystem{\sProcesses}

452− {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'}

453− {\sBlacklist}

454− {\sMonitors}

455−\rightarrow

456− \sSystem{\sProcesses \sPar M_{\sPid'}}

457− {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')}

458− {\sBlacklist}

459− {\sMonitors}

460−} \textsc{Spawn-Exec}

461−\end{equation*}

462−%

463−where

464−%

465−\begin{equation*}

466−\begin{array}{l@{\;=\;}l@{\hspace{3em}}l}

467− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)

468−&

469− \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M)

470−&

471− \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist

472−\\

473− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)

474−&

475− \sQueue

476−&

477− \text{otherwise}

478−\end{array}

479−\end{equation*}

480−%

481−$(\sExtend{\sBlacklist})$ is only defined for serializable payloads.

482−\caption{\label{fig:basic}Basic Primitives}

483−\end{figure}

484−

485−\subsection{Monitoring}

486−

487−When process $P$ on node $\sNid_P$ wants to monitor process $Q$ on node

488−$\sNid_Q$ \emph{both} nodes must be notified. The local node it notified

489−immediately, and a message is sent to to the remote node (rules

490−\textsc{Mon-Loc} and \textsc{Mon-Rem}). As with all messages, the

491−message to the remote node might be lost. When $P$ is disconnected from $Q$ it

492−is the responsibility of $P$'s local node $\sNid_P$ to notify $P$

493−(\textsc{Mon-Dis}); when $Q$ terminates (\textsc{Mon-Ret}) or crashes

494−(\textsc{Mon-Throw}) it is the responsibility of the remote node $\sNid_Q$ to

495−notify $P$.

496−

497−\begin{figure}

498−\small

499−\begin{equation*}

500−\frac{

501− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})

502−\qquad

503− \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to})

504−\qquad

505− \sRef \text{ fresh}

506−}{

507−\sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}

508− {\sQueue}

509− {\sBlacklist}

510− {\sMonitors}

511−\rightarrow

512− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}}

513− {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})}

514− {\sBlacklist}

515− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}

516−} \textsc{Mon-Loc}

517−\end{equation*}

518−%

519−\begin{equation*}

520−\frac{

521− \sPid_\mathit{fr} \notin \sSenders(\sQueue)

522−}{

523− \sSystem{\sProcesses}

524− {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'}

525− {\sBlacklist}

526− {\sMonitors}

527−\rightarrow

528− \sSystem{\sProcesses}

529− {\sQueue, \sQueue'}

530− {\sBlacklist}

531− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)}

532−} \textsc{Mon-Rem}

533−\end{equation*}

534−%

535−\begin{equation*}

536−\frac{

537− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})

538−\qquad

539− (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist

540−}{

541− \sSystem{\sProcesses}

542− {\sQueue}

543− {\sBlacklist}

544− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}

545−\rightarrow

546− \sSystem{\sProcesses}

547− {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)}

548− {\sBlacklist}

549− {\sMonitors}

550−} \textsc{Mon-Dis}

551−\end{equation*}

552−%

553−\begin{equation*}

554−\frac{

555− \sNodeOf(\sPid) = \sNid

556−}{

557− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}

558− {\sQueue}

559− {\sBlacklist}

560− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}

561−\rightarrow

562− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}

563− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{died} \; \sRef)}

564− {\sBlacklist}

565− {\sMonitors}

566−} \textsc{Mon-Ret}

567−\end{equation*}

568−%

569−\begin{equation*}

570−\frac{

571− \sNodeOf(\sPid) = \sNid

572−}{

573− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}

574− {\sQueue}

575− {\sBlacklist}

576− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}

577−\rightarrow

578− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}

579− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{exc} \; \sRef \; M)}

580− {\sBlacklist}

581− {\sMonitors}

582−} \textsc{Mon-Throw}

583−\end{equation*}

584−%

585−\begin{equation*}

586−\frac{

587− \sNodeOf(\sPid) = \sNid

588−\qquad

589− \sPid \notin \sProcesses

590−}{

591− \sSystem{\sProcesses}

592− {\sQueue}

593− {\sBlacklist}

594− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}

595−\rightarrow

596− \sSystem{\sProcesses}

597− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{unknown} \; \sRef)}

598− {\sBlacklist}

599− {\sMonitors}

600−} \textsc{Mon-Unknown}

601−\end{equation*}

602−%

603−\caption{Monitoring}

604−\end{figure}

605−

606−\subsection{Process Termination}

607−

608−The rules for normal and abnormal process termination are defined in

609−Figure~\ref{fig:termination}. When a process crashes it dies

610−silently, unless monitors are setup.

611−

612−\begin{figure}

613−\small

614−%

615−\begin{equation*}

616−\frac{

617− \sNodeOf(\sPid) = \sNid

618−\qquad

619− \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors

620−}{

621− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}

622− {\sQueue}

623− {\sBlacklist}

624− {\sMonitors}

625−\rightarrow

626− \sSystem{\sProcesses}

627− {\sQueue}

628− {\sBlacklist}

629− {\sMonitors}

630−} \textsc{TermRet}

631−\end{equation*}

632−%

633−\begin{equation*}

634−\frac{

635− \sNodeOf(\sPid) = \sNid

636−\qquad

637− \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors

638−}{

639− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}

640− {\sQueue}

641− {\sBlacklist}

642− {\sMonitors}

643−\rightarrow

644− \sSystem{\sProcesses}

645− {\sQueue}

646− {\sBlacklist}

647− {\sMonitors}

648−} \textsc{TermThrow}

649−\end{equation*}

650−%

651−\caption{\label{fig:termination}Process Termination}

652−\end{figure}

653−

654−\section{Open Issues}

655−

656−\subsection{Ordering of Monitor/Link Notifications}

657−

658−The semantics as described above, like the original Unified semantics, does not

659−guarantee that messages send from process $P$ to process $Q$ (\textsc{Send})

660−are ordered with respect to the link or monitor notification sent when process

661−$P$ terminates normally or abnormally (\textsc{Mon-Ret}, \textsc{Mon-Throw}). This means that if process $P$ does

662−

663−\begin{lstlisting}

664−receiveWait [

665− match $ \(Reply reply) -> ...

666− , match $ \(ProcessMonitorNotification ..) -> ...

667− ]

668−\end{lstlisting}

669−

670−and process $Q$ does

671−

672−\begin{lstlisting}

673−send pidA (Reply reply)

674−// terminate or indeed throw an exception

675−\end{lstlisting}

676−

677−then the semantics does not guarantee that the reply from process $Q$ will

678−arrive at process $P$ before the monitor notification; hence, this results in

679−an (artificial) race condition in process $P$.

680−

681−One possible solution is to regard such a link notification as a message from

682−process $Q$ to process $P$, which should be ordered along with the other

683−messages.

684−

685−\subsection{Ordering and Typed Channels}

686−

687−The situation is more tricky still than sketched above because we of typed

688−channels. The semantics does not provide ordering guarantees between messages

689−sent directly to the process and messages sent on typed channels. That means

690−that even if we consider a link or monitor notification as a message sent to

691−the process, to be ordered with other messages sent to that process, it is

692−still unordered with respect to messages sent on typed channels. This means

693−that we have similar race conditions\footnote{Even ignoring the fact that we

694−currently don't even provide a way to wait for a message on a typed channel

695−\emph{or} a direct message.}

696−

697−A possible solution is to insist that \emph{all} messages from process $P$ to

698−process $Q$ are ordered, no matter how they are sent. From a implementation

699−point of view, this would entail the use of a single ordered network connection

700−for all messages from $P$ to $Q$, rather than using an ordered connection per

701−typed channel plus one for direct messages.

702−

703−\bibliographystyle{apalike}

704−\bibliography{references}

705−

706−\end{document}

doc/semantics/Makefiledeleted−11

@@ -1,11 +0,0 @@

1−CloudHaskellSemantics.pdf: *.tex *.bib

2− pdflatex CloudHaskellSemantics

3− bibtex CloudHaskellSemantics

4− pdflatex CloudHaskellSemantics

5− pdflatex CloudHaskellSemantics

6−

7−.PHONY: clean

8−clean:

9− rm -f *.aux *.bbl *.blg *.log

10−

11−# vi:set noexpandtab:

doc/semantics/references.bibdeleted−72

@@ -1,72 +0,0 @@

1−@inproceedings{cloudhaskell,

2− author = {Epstein, Jeff and Black, Andrew P. and Peyton-Jones, Simon},

3− title = {Towards {H}askell in the cloud},

4− booktitle = {Proceedings of the 4th ACM symposium on Haskell},

5− series = {Haskell '11},

6− year = {2011},

7− isbn = {978-1-4503-0860-1},

8− location = {Tokyo, Japan},

9− pages = {118--129},

10− numpages = {12},

11− url = {http://doi.acm.org/10.1145/2034675.2034690},

12− doi = {10.1145/2034675.2034690},

13− acmid = {2034690},

14− publisher = {ACM},

15− address = {New York, NY, USA},

16− keywords = {erlang, haskell, message-passing},

17−}

18−

19−@inproceedings{unified,

20− author = {Svensson, Hans and Fredlund, Lars-{\AA}ke and Benac Earle, Clara},

21− title = {A unified semantics for future {E}rlang},

22− booktitle = {Proceedings of the 9th ACM SIGPLAN workshop on Erlang},

23− series = {Erlang '10},

24− year = {2010},

25− isbn = {978-1-4503-0253-1},

26− location = {Baltimore, Maryland, USA},

27− pages = {23--32},

28− numpages = {10},

29− url = {http://doi.acm.org/10.1145/1863509.1863514},

30− doi = {10.1145/1863509.1863514},

31− acmid = {1863514},

32− publisher = {ACM},

33− address = {New York, NY, USA},

34− keywords = {erlang, semantics},

35−}

36−

37−@article{stm,

38− author = {Harris, Tim and Marlow, Simon and Jones, Simon Peyton and Herlihy, Maurice},

39− title = {Composable memory transactions},

40− journal = {Commun. ACM},

41− issue_date = {August 2008},

42− volume = {51},

43− number = {8},

44− month = aug,

45− year = {2008},

46− issn = {0001-0782},

47− pages = {91--100},

48− numpages = {10},

49− url = {http://doi.acm.org/10.1145/1378704.1378725},

50− doi = {10.1145/1378704.1378725},

51− acmid = {1378725},

52− publisher = {ACM},

53− address = {New York, NY, USA},

54−}

55−

56−@inproceedings{erlang,

57− author = {Svensson, Hans and Fredlund, Lars-\AAke},

58− title = {A more accurate semantics for distributed erlang},

59− booktitle = {Proceedings of the 2007 SIGPLAN workshop on ERLANG Workshop},

60− series = {ERLANG '07},

61− year = {2007},

62− isbn = {978-1-59593-675-2},

63− location = {Freiburg, Germany},

64− pages = {43--54},

65− numpages = {12},

66− url = {http://doi.acm.org/10.1145/1292520.1292528},

67− doi = {10.1145/1292520.1292528},

68− acmid = {1292528},

69− publisher = {ACM},

70− address = {New York, NY, USA},

71− keywords = {distributed systems, erlang, model checking, semantics, verification},

72−}

doc/tutorial/tutorial-client.hsnew file+20

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

1+import Network.Transport

2+import Network.Transport.TCP (createTransport)

3+import System.Environment

4+import Control.Monad

5+import Data.ByteString.Char8

7+main :: IO ()

8+main = do

9+ [host, port, serverAddr] <- getArgs

10+ Right transport <- createTransport host port

11+ Right endpoint <- newEndPoint transport

12+

13+ let addr = EndPointAddress (pack serverAddr)

14+ Right conn <- connect endpoint addr ReliableOrdered

15+ send conn [pack "Hello world"]

16+ close conn

17+

18+ replicateM_ 3 $ receive endpoint >>= print

19+

20+ closeTransport transport

doc/tutorial/tutorial-server.hsnew file+52

@@ -0,0 +1,52 @@

1+import Network.Transport

2+import Network.Transport.TCP (createTransport)

3+import Control.Concurrent

4+import Data.Map

5+import Control.Exception

6+import System.Environment

8+-- | Server that echoes messages straight back to the origin endpoint.

9+echoServer :: EndPoint -> MVar () -> IO ()

10+echoServer endpoint serverDone = go empty

11+ where

12+ go :: Map ConnectionId (MVar Connection) -> IO ()

13+ go cs = do

14+ event <- receive endpoint

15+ case event of

16+ ConnectionOpened cid rel addr -> do

17+ connMVar <- newEmptyMVar

18+ forkIO $ do

19+ Right conn <- connect endpoint addr rel

20+ putMVar connMVar conn

21+ go (insert cid connMVar cs)

22+ Received cid payload -> do

23+ forkIO $ do

24+ conn <- readMVar (cs ! cid)

25+ send conn payload

26+ return ()

27+ go cs

28+ ConnectionClosed cid -> do

29+ forkIO $ do

30+ conn <- readMVar (cs ! cid)

31+ close conn

32+ go (delete cid cs)

33+ EndPointClosed -> do

34+ putStrLn "Echo server exiting"

35+ putMVar serverDone ()

36+

37+onCtrlC :: IO a -> IO () -> IO a

38+p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)

39+ where

40+ isUserInterrupt :: AsyncException -> Maybe ()

41+ isUserInterrupt UserInterrupt = Just ()

42+ isUserInterrupt _ = Nothing

43+

44+main :: IO ()

45+main = do

46+ [host, port] <- getArgs

47+ serverDone <- newEmptyMVar

48+ Right transport <- createTransport host port

49+ Right endpoint <- newEndPoint transport

50+ forkIO $ echoServer endpoint serverDone

51+ putStrLn $ "Echo server started at " ++ show (address endpoint)

52+ readMVar serverDone `onCtrlC` closeTransport transport

network-transport-inmemory/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Well-Typed LLP, 2011-2012

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of the owner nor the names of other