git.iko.soy/distributed-process
on master help sign in
swap
660d554699 ahead, 0 behind
171 files changed+13723−17281
since splitsnapshots
unifiedsplit
.gitignore+3−13 .travis.yml+43 CONTRIBUTING.md+1 ChangeLog+236 network-transport-inmemory/LICENSE → LICENSE+1 README.md+11−27 azure-service-api/Setup.hs → Setup.hs azure-service-api/LICENSE−30 azure-service-api/azure-service-api.cabal−36 azure-service-api/src/Network/Azure/ServiceManagement.hs−291 benchmarks/Channels.hs+43 benchmarks/Latency.hs+39 benchmarks/ProcessRing.hs+117 benchmarks/Spawns.hs+49 benchmarks/Throughput.hs+74 benchmarks/erlang/latency.erl+35 benchmarks/erlang/ring.erl+62 benchmarks/erlang/throughput.erl+39 benchmarks/remote/Latency.hs+32 benchmarks/remote/Throughput.hs+39 distributed-process-azure/demos/Conway.hs−51 distributed-process-azure/demos/Echo.hs−49 distributed-process-azure/demos/Ping.hs−85 distributed-process-azure/distributed-process-azure.cabal−90 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs−904 distributed-process-simplelocalnet/ChangeLog−27 distributed-process-simplelocalnet/LICENSE−31 distributed-process-simplelocalnet/Setup.hs−2 distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal−63 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs−355 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs−126 distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hs−24 distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hs−11 distributed-process-tests/.gitignore+4 distributed-process-tests/CONTRIBUTING.md+1 distributed-process-azure/LICENSE → distributed-process-tests/LICENSE distributed-process-tests/README.md+14 distributed-process-azure/Setup.hs → distributed-process-tests/Setup.hs distributed-process-tests/distributed-process-tests.cabal+158 distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs+1879 distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+589 distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+243 distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+542 distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs+154 distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+129 distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+431 distributed-process-tests/src/Network/Transport/Test.hs+12 distributed-process-tests/tests/runInMemory.hs+30 distributed-process-tests/tests/runTCP.hs+47 distributed-process.cabal+168 distributed-process/ChangeLog−64 distributed-process/LICENSE−31 distributed-process/Setup.hs−2 distributed-process/distributed-process.cabal−115 distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs−105 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs−257 distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs−169 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−615 distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs−51 distributed-process/src/Control/Distributed/Process/Internal/Types.hs−544 distributed-process/src/Control/Distributed/Process/Node.hs−757 distributed-process/tests/TestAuxiliary.hs−75 distributed-process/tests/TestCH.hs−706 distributed-process/tests/TestClosure.hs−412 distributed-static/ChangeLog−8 distributed-static/LICENSE−30 distributed-static/Setup.hs−2 distributed-static/distributed-static.cabal−37 distributed-static/src/Control/Distributed/Static.hs−441 doc/InternalsTransportMulticast.txt−181 doc/InternalsTransportTCP.txt−81 doc/NetworkTCP.png doc/NetworkTCP.svg−657 doc/reconnect/blacklist.tex−525 doc/reconnect/reconnect.tex−409 doc/semantics/CloudHaskellSemantics.tex+706 doc/semantics/Makefile+11 doc/semantics/references.bib+72 doc/tutorial/tutorial-client.hs−24 doc/tutorial/tutorial-server.hs−54 install_all.sh−11 network-transport-composed/LICENSE−30 network-transport-composed/Setup.hs−2 network-transport-composed/network-transport-composed.cabal−22 network-transport-composed/src/Network/Transport/Composed.hs−181 network-transport-inmemory/Setup.hs−2 network-transport-inmemory/network-transport-inmemory.cabal−64 network-transport-inmemory/src/Network/Transport/Chan.hs−157 network-transport-inmemory/tests/TestAuxiliary.hs−108 network-transport-inmemory/tests/TestInMemory.hs−8 network-transport-inmemory/tests/TestMulticast.hs−72 network-transport-inmemory/tests/TestMulticastInMemory.hs−7 network-transport-inmemory/tests/TestTransport.hs−956 network-transport-inmemory/tests/Traced.hs−191 network-transport-tcp/ChangeLog−20 network-transport-tcp/LICENSE−31 network-transport-tcp/Setup.hs−2 network-transport-tcp/benchmarks/Headers.gnuplot−16 network-transport-tcp/benchmarks/Indirection.gnuplot−16 network-transport-tcp/benchmarks/JustPingC.c−150 network-transport-tcp/benchmarks/JustPingCacheHeader.hs−134 network-transport-tcp/benchmarks/JustPingHaskell.hs−105 network-transport-tcp/benchmarks/JustPingOneRecv.hs−131 network-transport-tcp/benchmarks/JustPingThroughChan.hs−127 network-transport-tcp/benchmarks/JustPingThroughMVar.hs−127 network-transport-tcp/benchmarks/JustPingTransport.hs−95 network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs−151 network-transport-tcp/benchmarks/JustPingWithHeader.hs−131 network-transport-tcp/benchmarks/Makefile−55 network-transport-tcp/benchmarks/NewTransport.gnuplot−8 network-transport-tcp/benchmarks/cabal_macros.h−5 network-transport-tcp/network-transport-tcp.cabal−47 network-transport-tcp/src/Network/Transport/TCP.hs−1667 network-transport-tcp/src/Network/Transport/TCP/Internal.hs−119 network-transport-tcp/tests/TestTCP.hs−794 network-transport-tests/LICENSE−30 network-transport-tests/Setup.hs−2 network-transport-tests/network-transport-tests.cabal−35 network-transport-tests/src/Network/Transport/Tests.hs−964 network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs−112 network-transport-tests/src/Network/Transport/Tests/Traced.hs−200 network-transport/ChangeLog−16 network-transport/LICENSE−31 network-transport/Setup.hs−2 network-transport/network-transport.cabal−81 network-transport/src/Network/Transport.hs−264 network-transport/src/Network/Transport/Internal.hs−153 network-transport/src/Network/Transport/Util.hs−24 network-transport/tests/chat/ChatClient.hs−107 network-transport/tests/chat/ChatServer.hs−28 network-transport/tests/sumeuler/SumEulerMaster.hs−44 network-transport/tests/sumeuler/SumEulerWorker.hs−52 network-transport/tests/sumeuler/sumeuler.sh−20 rank1dynamic/LICENSE−30 rank1dynamic/Setup.hs−2 rank1dynamic/rank1dynamic.cabal−28 rank1dynamic/src/Data/Rank1Dynamic.hs−120 rank1dynamic/src/Data/Rank1Typeable.hs−362 distributed-process/src/Control/Distributed/Process.hs → src/Control/Distributed/Process.hs+209−171 distributed-process/src/Control/Distributed/Process/Closure.hs → src/Control/Distributed/Process/Closure.hs+65−39 src/Control/Distributed/Process/Debug.hs+288 src/Control/Distributed/Process/Internal/BiMultiMap.hs+135 src/Control/Distributed/Process/Internal/CQueue.hs+300 distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs → src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+121−39 src/Control/Distributed/Process/Internal/Closure/Explicit.hs+147 src/Control/Distributed/Process/Internal/Closure/TH.hs+330 src/Control/Distributed/Process/Internal/Messaging.hs+207 src/Control/Distributed/Process/Internal/Primitives.hs+1363 src/Control/Distributed/Process/Internal/Spawn.hs+165 src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs+21 src/Control/Distributed/Process/Internal/StrictList.hs+27 src/Control/Distributed/Process/Internal/StrictMVar.hs+93 src/Control/Distributed/Process/Internal/Types.hs+887 src/Control/Distributed/Process/Internal/WeakTQueue.hs+107 src/Control/Distributed/Process/Management.hs+509 src/Control/Distributed/Process/Management/Internal/Agent.hs+157 src/Control/Distributed/Process/Management/Internal/Bus.hs+21 src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+179 src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs+61 src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs+354 src/Control/Distributed/Process/Management/Internal/Trace/Types.hs+159 src/Control/Distributed/Process/Management/Internal/Types.hs+141 src/Control/Distributed/Process/Node.hs+1304 distributed-process/src/Control/Distributed/Process/Serializable.hs → src/Control/Distributed/Process/Serializable.hs+26−16 src/Control/Distributed/Process/UnsafePrimitives.hs+200 stack-ghc-7.10.3.yaml+21 stack-ghc-8.0.2.yaml+23 stack-ghc-8.2.2.yaml+21 stack-ghc-8.4.4.yaml+20 stack-nightly.yaml+26 stack.yaml+22
.gitignore+3−13
@@ -1,14 +1,4 @@
1−tags
2−TAGS
31dist/
4−\#*#
5−*~
6−*.aux
7−*.hp
8−*.hi
9−*.o
10−*.prof
11−*.ps
12−*.swp
13−cabal-dev
14−.DS_Store
2+.cabal-sandbox
3+cabal.sandbox.config
4+.stack*
.travis.ymlnew file+43
@@ -0,0 +1,43 @@
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.mdnew file+1
@@ -0,0 +1 @@
1+See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
ChangeLognew file+236
@@ -0,0 +1,236 @@
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.
network-transport-inmemory/LICENSE → LICENSErenamed+1
@@ -1,4 +1,5 @@
11Copyright Well-Typed LLP, 2011-2012
2+Copyright Tweag I/O Limited, 2015
23
34All rights reserved.
45
README.md+11−27
@@ -1,32 +1,16 @@
1−Haskell Distributed Project
2−===========================
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)
34
4−This repository holds an implementation of [Cloud Haskell][1].
5+This repository is part of Cloud Haskell.
56
6−At present, this repository hosts
7+See http://haskell-distributed.github.com for documentation, user guides,
8+tutorials and assistance.
79
8−* network-transport: Generic Network.Transport API
9−* network-transport-tcp: TCP instantiation of Network.Transport
10−* network-transport-inmemory: In-memory instantiation of Network.Transport (incomplete)
11−* distributed-static: Support for static values
12−* distributed-process: The main Cloud Haskell package
13−* distributed-process-simplelocalnet: Simple backend for local networks
14−* distributed-process-azure: Azure backend for Cloud Haskell (work in progress)
15−* azure-service-api: Haskell bindings for the Azure service API (work in progress)
16−* rank1dynamic: Like Data.Dynamic and Data.Typeable but with support for polymorphic values
10+## Getting Help / Raising Issues
1711
18−For more detailed information about the interfaces provided by these packages,
19−please refer to the [distributed-process repository wiki][2]. People who wish
20−to get started with Cloud Haskell should cabal install
21−distributed-process and possibly distributed-process-simplelocalnet and refer
22−to the corresponding Haddock documentation ([Control.Distributed.Process][3],
23−[Control.Distributed.Process.Closure][4],
24−[Control.Distributed.Process.Node][5], and
25−[Control.Distributed.Process.Backend.SimpleLocalnet][6]).
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.
2613
27−[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
28−[2]: https://github.com/haskell-distributed/distributed-process/wiki
29−[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html
30−[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html
31−[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html
32−[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html
14+## License
15+
16+This package is made available under a 3-clause BSD-style license.
azure-service-api/Setup.hs → Setup.hsrenamed

The content is the same.

azure-service-api/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2012, Edsko de Vries
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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.
azure-service-api/azure-service-api.cabaldeleted−36
@@ -1,36 +0,0 @@
1−-- Initial azure-service-api.cabal generated by cabal init. For further
2−-- documentation, see http://haskell.org/cabal/users-guide/
3−
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− http-conduit >= 1.5.1 && < 1.6,
22− tls >= 1.0 && < 1.1,
23− tls-extra >= 0.5 && < 0.6,
24− bytestring >= 0.9 && < 1.0,
25− certificate >= 1.2 && < 1.3,
26− case-insensitive >= 0.4 && < 0.5,
27− hxt >= 9.2 && < 9.3,
28− pretty >= 1.1 && < 1.2,
29− crypto-pubkey-types >= 0.1 && < 0.2,
30− binary >= 0.5 && < 0.6,
31− resourcet,
32− transformers,
33− hxt-xpath
34− HS-Source-Dirs: src
35− ghc-options: -Wall
36− Extensions: RankNTypes
azure-service-api/src/Network/Azure/ServiceManagement.hsdeleted−291
@@ -1,291 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−module Network.Azure.ServiceManagement
3− ( -- * Data types
4− HostedService(..)
5− , CloudService(..)
6− , VirtualMachine(..)
7− , Endpoint(..)
8− -- * Pure functions
9− , vmSshEndpoint
10− -- * Setup
11− , AzureSetup(..)
12− , azureSetup
13− -- * High-level API
14− , hostedServices
15− , cloudServices
16− ) where
17−
18−import Prelude hiding (id, (.))
19−import Control.Category (id, (.))
20−import Control.Arrow (arr)
21−import Control.Monad (forM)
22−import Control.Applicative ((<$>), (<*>))
23−import Data.Maybe (listToMaybe)
24−import Data.ByteString.Lazy (ByteString)
25−import Data.ByteString.Char8 as BSC (pack)
26−import Data.ByteString.Lazy.Char8 as BSLC (unpack)
27−import Data.Binary (Binary(get,put))
28−import Data.Binary.Put (runPut)
29−import Data.Binary.Get (Get, runGet)
30−import Network.TLS (PrivateKey(PrivRSA))
31−import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
32−import Data.Certificate.X509 (X509, encodeCertificate, decodeCertificate)
33−import qualified Crypto.Types.PubKey.RSA as RSA (PrivateKey(..))
34−import Control.Monad.Trans.Resource (ResourceT)
35−import Control.Monad.IO.Class (liftIO)
36−import Control.Arrow.ArrowList (listA, arr2A)
37−import Text.PrettyPrint
38− ( Doc
39− , text
40− , (<+>)
41− , ($$)
42− , vcat
43− , hang
44− , doubleQuotes
45− )
46−import Network.HTTP.Conduit
47− ( parseUrl
48− , clientCertificates
49− , requestHeaders
50− , withManager
51− , Response(Response)
52− , httpLbs
53− , Manager
54− )
55−import Data.CaseInsensitive as CI (mk)
56−import Text.XML.HXT.Core
57− ( runX
58− , readString
59− , withValidate
60− , no
61− , XmlTree
62− , IOSArrow
63− , ArrowXml
64− , getText
65−-- , writeDocumentToString
66−-- , withIndent
67−-- , yes
68− )
69−-- import Control.Arrow.ArrowIO (arrIO)
70−import Text.XML.HXT.XPath (getXPathTrees)
71−
72−--------------------------------------------------------------------------------
73−-- Data types --
74−--------------------------------------------------------------------------------
75−
76−data HostedService = HostedService {
77− hostedServiceName :: String
78− }
79−
80−data CloudService = CloudService {
81− cloudServiceName :: String
82− , cloudServiceVMs :: [VirtualMachine]
83− }
84−
85−data VirtualMachine = VirtualMachine {
86− vmName :: String
87− , vmIpAddress :: String
88− , vmInputEndpoints :: [Endpoint]
89− }
90−
91−data Endpoint = Endpoint {
92− endpointName :: String
93− , endpointPort :: String
94− , endpointVip :: String
95− }
96−
97−--------------------------------------------------------------------------------
98−-- Pretty-printing --
99−--------------------------------------------------------------------------------
100−
101−instance Show HostedService where
102− show = show . ppHostedService
103−
104−instance Show CloudService where
105− show = show . ppCloudService
106−
107−instance Show VirtualMachine where
108− show = show . ppVirtualMachine
109−
110−instance Show Endpoint where
111− show = show . ppEndpoint
112−
113−ppHostedService :: HostedService -> Doc
114−ppHostedService = text . hostedServiceName
115−
116−ppCloudService :: CloudService -> Doc
117−ppCloudService cs =
118− (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))
119− `hang2`
120− ( text "VIRTUAL MACHINES"
121− `hang2`
122− (vcat . map ppVirtualMachine . cloudServiceVMs $ cs)
123− )
124−
125−ppVirtualMachine :: VirtualMachine -> Doc
126−ppVirtualMachine vm =
127− (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
128− `hang2`
129− ( text "IP" <+> text (vmIpAddress vm)
130− $$ ( text "INPUT ENDPOINTS"
131− `hang2`
132− (vcat . map ppEndpoint . vmInputEndpoints $ vm)
133− )
134− )
135−
136−ppEndpoint :: Endpoint -> Doc
137−ppEndpoint ep =
138− (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
139− `hang2`
140− ( text "Port" <+> text (endpointPort ep)
141− $$ text "VIP" <+> text (endpointVip ep)
142− )
143−
144−hang2 :: Doc -> Doc -> Doc
145−hang2 d1 = hang d1 2
146−
147−--------------------------------------------------------------------------------
148−-- Pure operations --
149−--------------------------------------------------------------------------------
150−
151−vmSshEndpoint :: VirtualMachine -> Maybe Endpoint
152−vmSshEndpoint vm = listToMaybe
153− [ ep
154− | ep <- vmInputEndpoints vm
155− , endpointName ep == "SSH"
156− ]
157−
158−--------------------------------------------------------------------------------
159−-- Setup --
160−--------------------------------------------------------------------------------
161−
162−-- | Azure setup
163−data AzureSetup = AzureSetup
164− { subscriptionId :: String
165− , certificate :: X509
166− , privateKey :: PrivateKey
167− , baseUrl :: String
168− }
169−
170−-- TODO: it's dubious to be transferring private keys, but we transfer them
171−-- over a secure connection and it can be argued that it's safer than actually
172−-- storing the private key on each remote server
173−
174−encodePrivateKey :: PrivateKey -> ByteString
175−encodePrivateKey (PrivRSA pkey) = runPut $ do
176− put (RSA.private_size pkey)
177− put (RSA.private_n pkey)
178− put (RSA.private_d pkey)
179− put (RSA.private_p pkey)
180− put (RSA.private_q pkey)
181− put (RSA.private_dP pkey)
182− put (RSA.private_dQ pkey)
183− put (RSA.private_qinv pkey)
184−
185−decodePrivateKey :: ByteString -> PrivateKey
186−decodePrivateKey = PrivRSA . runGet getPrivateKey
187− where
188− getPrivateKey :: Get RSA.PrivateKey
189− getPrivateKey =
190− RSA.PrivateKey <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
191−
192−instance Binary AzureSetup where
193− put (AzureSetup sid cert pkey url) = do
194− put sid
195− put (encodeCertificate cert)
196− put (encodePrivateKey pkey)
197− put url
198− get = do
199− sid <- get
200− Right cert <- decodeCertificate <$> get
201− pkey <- decodePrivateKey <$> get
202− url <- get
203− return $ AzureSetup sid cert pkey url
204−
205−-- | Initialize Azure
206−azureSetup :: String -- ^ Subscription ID
207− -> String -- ^ Path to certificate
208− -> String -- ^ Path to private key
209− -> IO AzureSetup
210−azureSetup sid certPath pkeyPath = do
211− cert <- fileReadCertificate certPath
212− pkey <- fileReadPrivateKey pkeyPath
213− return AzureSetup {
214− subscriptionId = sid
215− , certificate = cert
216− , privateKey = pkey
217− , baseUrl = "https://management.core.windows.net"
218− }
219−
220−--------------------------------------------------------------------------------
221−-- High-level API --
222−--------------------------------------------------------------------------------
223−
224−-- | Get a list of virtual machines
225−cloudServices :: AzureSetup -> IO [CloudService]
226−cloudServices setup = azureExecute setup $ \exec -> do
227− services <- exec hostedServicesRequest
228− forM services $ \service -> do
229− roles <- exec AzureRequest {
230− relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
231− ++ "?embed-detail=true"
232− , apiVersion = "2012-03-01"
233− , parser = proc xml -> do
234− role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
235− name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
236− roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)
237− ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst
238− endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
239− id -< VirtualMachine name ip endpoints
240− }
241− return $ CloudService (hostedServiceName service) roles
242−
243−-- | Get list of available hosted services
244−hostedServices :: AzureSetup -> IO [HostedService]
245−hostedServices setup = azureExecute setup (\exec -> exec hostedServicesRequest)
246−
247−hostedServicesRequest :: AzureRequest HostedService
248−hostedServicesRequest = AzureRequest
249− { relativeUrl = "/services/hostedservices"
250− , apiVersion = "2012-03-01"
251− , parser = arr HostedService
252− . getText
253− . getXPathTrees "//ServiceName/text()"
254− }
255−
256−parseEndpoint :: ArrowXml t => t XmlTree Endpoint
257−parseEndpoint = proc endpoint -> do
258− name <- getText . getXPathTrees "//Name/text()" -< endpoint
259− port <- getText . getXPathTrees "//Port/text()" -< endpoint
260− vip <- getText . getXPathTrees "//Vip/text()" -< endpoint
261− id -< Endpoint name port vip
262−
263−--------------------------------------------------------------------------------
264−-- Low-level API --
265−--------------------------------------------------------------------------------
266−
267−data AzureRequest c = AzureRequest {
268− relativeUrl :: String
269− , apiVersion :: String
270− , parser :: IOSArrow XmlTree c
271− }
272−
273−azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a
274−azureExecute setup f = withManager (\manager -> f (go manager))
275− where
276− go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]
277− go manager request = do
278− req <- parseUrl $ baseUrl setup
279− ++ "/" ++ subscriptionId setup
280− ++ "/" ++ relativeUrl request
281− let req' = req {
282− clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
283− , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack $ apiVersion request)
284− , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
285− ]
286− }
287− Response _ _ _ lbs <- httpLbs req' manager
288− liftIO . runX $ proc _ -> do
289− xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
290− -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml
291− parser request -< xml
benchmarks/Channels.hsnew file+43
@@ -0,0 +1,43 @@
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.hsnew file+39
@@ -0,0 +1,39 @@
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.hsnew file+117
@@ -0,0 +1,117 @@
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.hsnew file+49
@@ -0,0 +1,49 @@
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.hsnew file+74
@@ -0,0 +1,74 @@
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.erlnew file+35
@@ -0,0 +1,35 @@
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.erlnew file+62
@@ -0,0 +1,62 @@
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.erlnew file+39
@@ -0,0 +1,39 @@
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.hsnew file+32
@@ -0,0 +1,32 @@
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.hsnew file+39
@@ -0,0 +1,39 @@
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-azure/demos/Conway.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
2−import System.Environment (getArgs)
3−import Data.Data (Typeable, Data)
4−import Data.Binary (Binary(get, put))
5−import Data.Binary.Generic (getGeneric, putGeneric)
6−import Control.Monad (forever)
7−import Control.Monad.IO.Class (liftIO)
8−import Control.Distributed.Process
9− ( Process
10− , expect
11− )
12−import Control.Distributed.Process.Closure
13− ( remotable
14− , mkClosure
15− )
16−import Control.Distributed.Process.Backend.Azure
17−
18−data ControllerMsg =
19− ControllerExit
20− deriving (Typeable, Data)
21−
22−instance Binary ControllerMsg where
23− get = getGeneric
24− put = putGeneric
25−
26−conwayStart :: () -> Backend -> Process ()
27−conwayStart () backend = do
28− vms <- liftIO $ findVMs backend
29− remoteSend (show vms)
30−
31−remotable ['conwayStart]
32−
33−echo :: LocalProcess ()
34−echo = forever $ do
35− msg <- localExpect
36− liftIO $ putStrLn msg
37−
38−main :: IO ()
39−main = do
40− args <- getArgs
41− case args of
42− "onvm":args' -> onVmMain __remoteTable args'
43− cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
44− params <- defaultAzureParameters sid x509 pkey
45− let params' = params { azureSshUserName = user }
46− backend <- initializeBackend params' cloudService
47− Just vm <- findNamedVM backend virtualMachine
48− case cmd of
49− "start" -> callOnVM backend vm port $
50− ProcessPair ($(mkClosure 'conwayStart) ())
51− echo
distributed-process-azure/demos/Echo.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−import System.IO (hFlush, stdout)
4−import System.Environment (getArgs)
5−import Control.Monad (unless, forever)
6−import Control.Monad.IO.Class (liftIO)
7−import Control.Distributed.Process (Process, expect)
8−import Control.Distributed.Process.Closure (remotable, mkClosure)
9−import Control.Distributed.Process.Backend.Azure
10−
11−echoRemote :: () -> Backend -> Process ()
12−echoRemote () _backend = forever $ do
13− str <- expect
14− remoteSend (str :: String)
15−
16−remotable ['echoRemote]
17−
18−echoLocal :: LocalProcess ()
19−echoLocal = do
20− str <- liftIO $ putStr "# " >> hFlush stdout >> getLine
21− unless (null str) $ do
22− localSend str
23− liftIO $ putStr "Echo: " >> hFlush stdout
24− echo <- localExpect
25− liftIO $ putStrLn echo
26− echoLocal
27−
28−main :: IO ()
29−main = do
30− args <- getArgs
31− case args of
32− "onvm":args' ->
33− -- Pass execution to 'onVmMain' if we are running on the VM
34− -- ('callOnVM' will provide the right arguments)
35− onVmMain __remoteTable args'
36−
37− sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
38− -- Initialize the Azure backend
39− params <- defaultAzureParameters sid x509 pkey
40− let params' = params { azureSshUserName = user }
41− backend <- initializeBackend params' cloudService
42−
43− -- Find the specified virtual machine
44− Just vm <- findNamedVM backend virtualMachine
45−
46− -- Run the echo client proper
47− callOnVM backend vm port $
48− ProcessPair ($(mkClosure 'echoRemote) ())
49− echoLocal
distributed-process-azure/demos/Ping.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−import System.Environment (getArgs)
4−import Data.Binary (encode, decode)
5−import Control.Monad (forever)
6−import Control.Monad.IO.Class (liftIO)
7−import Control.Exception (try, IOException)
8−import Control.Distributed.Process
9− ( Process
10− , getSelfPid
11− , expect
12− , send
13− , monitor
14− , receiveWait
15− , match
16− , ProcessMonitorNotification(..)
17− )
18−import Control.Distributed.Process.Closure (remotable, mkClosure)
19−import Control.Distributed.Process.Backend.Azure
20−import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
21−
22−pingServer :: () -> Backend -> Process ()
23−pingServer () _backend = do
24− us <- getSelfPid
25− liftIO $ BSL.writeFile "pingServer.pid" (encode us)
26− forever $ do
27− them <- expect
28− send them ()
29−
30−pingClientRemote :: () -> Backend -> Process ()
31−pingClientRemote () _backend = do
32− mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
33− case mPingServerEnc of
34− Left err ->
35− remoteSend $ "Ping server not found: " ++ show (err :: IOException)
36− Right pingServerEnc -> do
37− let pingServerPid = decode pingServerEnc
38− pid <- getSelfPid
39− _ref <- monitor pingServerPid
40− send pingServerPid pid
41− gotReply <- receiveWait
42− [ match (\() -> return True)
43− , match (\(ProcessMonitorNotification {}) -> return False)
44− ]
45− if gotReply
46− then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"
47− else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"
48−
49−remotable ['pingClientRemote, 'pingServer]
50−
51−pingClientLocal :: LocalProcess ()
52−pingClientLocal = localExpect >>= liftIO . putStrLn
53−
54−main :: IO ()
55−main = do
56− args <- getArgs
57− case args of
58− "onvm":args' ->
59− -- Pass execution to 'onVmMain' if we are running on the VM
60− onVmMain __remoteTable args'
61−
62− "list":sid:x509:pkey:_ -> do
63− -- List all available cloud services
64− -- (useful, but not strictly necessary for the example)
65− params <- defaultAzureParameters sid x509 pkey
66− css <- cloudServices (azureSetup params)
67− mapM_ print css
68−
69− cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
70− -- Initialize the backend and find the right VM
71− params <- defaultAzureParameters sid x509 pkey
72− let params' = params { azureSshUserName = user }
73− backend <- initializeBackend params' cloudService
74− Just vm <- findNamedVM backend virtualMachine
75−
76− -- The same binary can behave as the client or the server,
77− -- depending on the command line arguments
78− case cmd of
79− "server" -> do
80− pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
81− putStrLn $ "Ping server started at " ++ show pid
82− "client" ->
83− callOnVM backend vm port $
84− ProcessPair ($(mkClosure 'pingClientRemote) ())
85− pingClientLocal
distributed-process-azure/distributed-process-azure.cabaldeleted−90
@@ -1,90 +0,0 @@
1−Name: distributed-process-azure
2−Version: 0.1.0
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: Microsoft Azure backend for Cloud Haskell
14−Category: Control
15−
16−Source-Repository head
17− Type: git
18− Location: https://github.com/haskell-distributed/distributed-process
19− SubDir: distributed-process-azure
20−
21−Flag build-demos
22− description: Build the demos
23− default: False
24−
25−Library
26− Build-Depends: base >= 4.4 && < 5,
27− azure-service-api >= 0.1 && < 0.2,
28− filepath >= 1.3 && < 1.4,
29− executable-path >= 0.0.3 && < 0.1,
30− libssh2 >= 0.2 && < 0.3,
31− pureMD5 >= 2.1 && < 2.2,
32− bytestring >= 0.9 && < 0.11,
33− distributed-process >= 0.2.3 && < 0.3,
34− binary >= 0.5 && < 0.6,
35− network-transport-tcp >= 0.2 && < 0.3,
36− optparse-applicative >= 0.2 && < 0.4,
37− transformers >= 0.3 && < 0.4,
38− certificate >= 1.2.4 && < 1.3,
39− unix >= 2.5 && < 2.6,
40− network-transport >= 0.2 && < 0.3,
41− mtl >= 2.1 && < 2.2
42− Exposed-modules: Control.Distributed.Process.Backend.Azure
43− Extensions: ViewPatterns,
44− RankNTypes,
45− ExistentialQuantification,
46− ScopedTypeVariables,
47− DeriveDataTypeable,
48− GeneralizedNewtypeDeriving
49− ghc-options: -Wall
50− HS-Source-Dirs: src
51−
52−Executable cloud-haskell-azure-echo
53− if flag(build-demos)
54− Build-Depends: base >= 4.4 && < 5,
55− distributed-process-azure >= 0.1 && < 0.2,
56− distributed-process >= 0.2 && < 0.3,
57− transformers >= 0.3 && < 0.4
58− else
59− buildable: False
60− Main-Is: demos/Echo.hs
61− ghc-options: -Wall
62−
63−Executable cloud-haskell-azure-ping
64− if flag(build-demos)
65− Build-Depends: base >= 4.4 && < 5,
66− distributed-process-azure >= 0.1 && < 0.2,
67− distributed-process >= 0.2 && < 0.3,
68− transformers >= 0.3 && < 0.4,
69− bytestring >= 0.9 && < 0.11,
70− binary >= 0.5 && < 0.6,
71− mtl,
72− libssh2
73− else
74− buildable: False
75− Main-Is: demos/Ping.hs
76− ghc-options: -Wall
77−
78−Executable cloud-haskell-azure-conway
79− if flag(build-demos)
80− Build-Depends: base >= 4.4 && < 5,
81− distributed-process-azure >= 0.1 && < 0.2,
82− distributed-process >= 0.2 && < 0.3,
83− transformers >= 0.3 && < 0.4,
84− bytestring >= 0.9 && < 0.11,
85− binary >= 0.5 && < 0.6,
86− binary-generic >= 0.2 && < 0.3
87− else
88− buildable: False
89− Main-Is: demos/Conway.hs
90− ghc-options: -Wall
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hsdeleted−904
@@ -1,904 +0,0 @@
1−-- | This module provides the API for running Cloud Haskell on Microsoft Azure
2−-- virtual machines (<http://www.windowsazure.com>). Virtual machines within an
3−-- Azure cloud service can talk to each other directly using standard Cloud
4−-- Haskell primitives (using TCP/IP under the hood); to talk to the remote
5−-- machines from your local machine you can use the primitives provided in this
6−-- module (which use ssh under the hood). It looks something like
7−--
8−-- > _ _
9−-- > ( ` )_
10−-- > ( ) `) Azure cloud service
11−-- > (_ (_ . _) _)
12−-- >
13−-- > |
14−-- > | ssh connection
15−-- > |
16−-- >
17−-- > +---+
18−-- > | | Local machine
19−-- > +---+
20−--
21−-- /NOTE/: It is unfortunate that the local machine cannot talk to the remote
22−-- machine using the standard Cloud Haskell primitives. In an ideal world, we
23−-- could just start a Cloud Haskell node on the local machine, too.
24−-- Unfortunately, Cloud Haskell does not yet support using multiple network
25−-- transports within the same system (i.e. both TCP/IP and SSH). This is a
26−-- temporary workaround.
27−--
28−-- [Azure Setup]
29−--
30−-- In this section we describe how to set up an Azure Cloud Service for use
31−-- with Cloud Haskell, starting from a brand new Azure account. It is not
32−-- intended as an Azure tutorial, but as a guide to making the right choices to
33−-- get Cloud Haskell up and running as quickly as possible.
34−--
35−-- An Azure /Cloud Service/ is a set of virtual machines that can talk to each
36−-- other directly over TCP/IP (they are part of the same private network). You
37−-- don't create the cloud service directly; instead, after you have set up your
38−-- first virtual machine as a /stand alone/ virtual machine, you can /connect/
39−-- subsequent virtual machines to the first virtual machine, thereby implicitly
40−-- setting up a Cloud Service.
41−--
42−-- We have only tested Cloud Haskell with Linux based virtual machines;
43−-- Windows based virtual machines /might/ work, but you'll be entering
44−-- unchartered territory. Cloud Haskell assumes that all nodes run the same
45−-- binary code; hence, you must use the same OS on all virtual machines,
46−-- /as well as on your local machine/. We use Ubuntu Server 12.04 LTS for our
47−-- tests (running on VirtualBox on our local machine).
48−--
49−-- When you set up your virtual machine, you can pick an arbitrary virtual
50−-- machine name; these names are for your own use only and do not need to be
51−-- globally unique. Set a username and password; you should use the same
52−-- username on all virtual machines. You should also upload an SSH key for
53−-- authentication (see
54−-- /Converting OpenSSH keys for use on Windows Azure Linux VM's/,
55−-- <http://utlemming.azurewebsites.net/?p=91>, for
56−-- information on how to convert a standard Linux @id_rsa.pub@ public key to
57−-- X509 format suitable for Azure). For the first VM you create select
58−-- /Standalone Virtual Machine/, and pick an appropriate DNS name. The DNS name
59−-- /does/ have to be globally unique, and will also be the name of the Cloud
60−-- Service. For subsequent virtual machines, select
61−-- /Connect to Existing Virtual Machine/ instead and then select the first VM
62−-- you created.
63−--
64−-- Once your virtual machines have been set up, you have to make sure that the
65−-- user you created when you created the VM can ssh from any virtual machine to
66−-- any other using public key authentication. Moreover, you have to make sure
67−-- that @libssh2@ is installed; if you are using the Ubuntu image you can
68−-- install @libssh2@ using
69−--
70−-- > sudo apt-get install libssh2-1
71−--
72−-- (TODO: if you don't install libssh2 things will break without a clear error
73−-- message.)
74−--
75−-- In these notes, we assume three virtual machines called @CHDemo1@,
76−-- @CHDemo2@, and @CHDemo3@, all part of a @CloudHaskellDemo@ cloud service.
77−--
78−-- [Obtaining a Management Certificate]
79−--
80−-- Azure authentication is by means of an X509 certificate and corresponding
81−-- private key. /Create management certificates for Linux in Windows Azure/,
82−-- <https://www.windowsazure.com/en-us/manage/linux/common-tasks/manage-certificates/>,
83−-- describes how you can create a management certificate for Azure, download it
84−-- as a @.publishsettings@ file, and extract an @.pfx@ file from it. You cannot
85−-- use this @.pfx@ directly; instead, you will need to extract an X509
86−-- certificate from it and a private key in suitable format. You can use the
87−-- @openssl@ command line tool for both tasks; assuming that you stored the
88−-- @.pfx@ file as @credentials.pfx@, to extract the X509 certificate:
89−--
90−-- > openssl pkcs12 -in credentials.pfx -nokeys -out credentials.x509
91−--
92−-- And to extract the private key:
93−--
94−-- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private
95−--
96−-- (@openssl pkcs12@ outputs the private key in PKCS#8 format (BEGIN PRIVATE
97−-- KEY), but we need it in PKCS#1 format (BEGIN RSA PRIVATE KEY).
98−--
99−-- [Testing the Setup]
100−--
101−-- Build and install the @distributed-process-azure@ package, making sure to
102−-- pass the @build-demos@ flag to Cabal.
103−--
104−-- > cabal-dev install distributed-process-azure -f build-demos
105−--
106−-- We can the @cloud-haskell-azure-ping@ demo to test our setup:
107−--
108−-- > cloud-haskell-azure-ping list \
109−-- > <<your subscription ID>> \
110−-- > /path/to/credentials.x509 \
111−-- > /path/to/credentials.private
112−--
113−-- (you can find your subscription ID in the @.publishsettings@ file from the previous step).
114−-- If everything went well, this will output something like
115−--
116−-- > Cloud Service "CloudHaskellDemo"
117−-- > VIRTUAL MACHINES
118−-- > Virtual Machine "CHDemo3"
119−-- > IP 10.119.182.127
120−-- > INPUT ENDPOINTS
121−-- > Input endpoint "SSH"
122−-- > Port 50136
123−-- > VIP 168.63.31.38
124−-- > Virtual Machine "CHDemo2"
125−-- > IP 10.59.238.125
126−-- > INPUT ENDPOINTS
127−-- > Input endpoint "SSH"
128−-- > Port 63365
129−-- > VIP 168.63.31.38
130−-- > Virtual Machine "CHDemo1"
131−-- > IP 10.59.224.122
132−-- > INPUT ENDPOINTS
133−-- > Input endpoint "SSH"
134−-- > Port 22
135−-- > VIP 168.63.31.38
136−--
137−-- The IP addresses listed are /internal/ IP addresses; they can be used by the
138−-- virtual machines to talk to each other, but not by the outside world to talk
139−-- to the virtual machines. To do that, you will need to use the VIP (Virtual
140−-- IP) address instead, which you will notice is the same for all virtual
141−-- machines that are part of the cloud service. The corresponding DNS name
142−-- (here @CloudHaskellDemo.cloudapp.net@) will also resolve to this (V)IP
143−-- address. To login to individual machines (through SSH) you will need to use
144−-- the specific port mentioned under INPUT ENDPOINTS.
145−--
146−-- [Overview of the API]
147−--
148−-- The Azure 'Backend' provides low-level functionality for interacting with
149−-- Azure virtual machines. 'findVMs' finds all currently available virtual
150−-- machines; 'copyToVM' copies the executable to a specified VM (recall that
151−-- all VMs, as well as the local machine, are assumed to run the same OS so
152−-- that they can all run the same binary), and 'checkMD5' checks the MD5 hash
153−-- of the executable on a remote machine.
154−--
155−-- 'callOnVM' and 'spawnOnVM' deal with setting up Cloud Haskell nodes.
156−-- 'spawnOnVM' takes a virtual machine and a port number, as well as a
157−-- @RemoteProcess ()@, starts the executable on the remote node, sets up a new
158−-- Cloud Haskell node, and then runs the specified process. The Cloud Haskell
159−-- node will be shut down when the given process terminates. 'RemoteProcess' is
160−-- defined as
161−--
162−-- > type RemoteProcess a = Closure (Backend -> Process a)
163−--
164−-- (If you don't know what a 'Closure' is you should read
165−-- "Control.Distributed.Process.Closure".); the remote process will be supplied
166−-- with an Azure backend initialized with the same parameters. 'spawnOnVM'
167−-- returns once the Cloud Haskell node has been set up.
168−--
169−-- 'callOnVM' is similar to 'spawnOnVM', but it takes a /pair/ of processes:
170−-- one to run on the remote host (on a newly created Cloud Haskell node), and
171−-- one to run on the local machine. In this case, the new Cloud Haskell node
172−-- will be terminated when the /local/ process terminates. 'callOnVM' is useful
173−-- because the remote process and the local process can communicate through a
174−-- set of primitives provided in this module ('localSend', 'localExpect', and
175−-- 'remoteSend' -- there is no 'remoteExpect'; instead the remote process can
176−-- use the standard Cloud Haskell 'expect' primitive).
177−--
178−-- [First Example: Echo]
179−--
180−-- When we run the @cloud-haskell-azure-echo@ demo on our local machine, it
181−-- starts a new Cloud Haskell node on the specified remote virtual machine. It
182−-- then repeatedly waits for input from the user on the local machine, sends
183−-- this to the remote virtual machine which will echo it back, and wait for and
184−-- show the echo.
185−--
186−-- Before you can try it you will first need to copy the executable (for
187−-- example, using scp, although the Azure backend also provides this natively
188−-- in Haskell). Once that's done, you can run the demo as follows:
189−--
190−-- > cloud-haskell-azure-echo \
191−-- > <<subscription ID>> \
192−-- > /path/to/credentials.x509 \
193−-- > /path/to/credentials.private \
194−-- > <<remote username>> \
195−-- > <<cloud service name>> \
196−-- > <<virtual machine name>> \
197−-- > <<port number>>
198−-- > # Everything I type gets echoed back
199−-- > Echo: Everything I type gets echoed back
200−-- > # Until I enter a blank line
201−-- > Echo: Until I enter a blank line
202−-- > #
203−--
204−-- The full @echo@ demo is
205−--
206−-- > {-# LANGUAGE TemplateHaskell #-}
207−-- >
208−-- > import System.IO (hFlush, stdout)
209−-- > import System.Environment (getArgs)
210−-- > import Control.Monad (unless, forever)
211−-- > import Control.Monad.IO.Class (liftIO)
212−-- > import Control.Distributed.Process (Process, expect)
213−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
214−-- > import Control.Distributed.Process.Backend.Azure
215−-- >
216−-- > echoRemote :: () -> Backend -> Process ()
217−-- > echoRemote () _backend = forever $ do
218−-- > str <- expect
219−-- > remoteSend (str :: String)
220−-- >
221−-- > remotable ['echoRemote]
222−-- >
223−-- > echoLocal :: LocalProcess ()
224−-- > echoLocal = do
225−-- > str <- liftIO $ putStr "# " >> hFlush stdout >> getLine
226−-- > unless (null str) $ do
227−-- > localSend str
228−-- > liftIO $ putStr "Echo: " >> hFlush stdout
229−-- > echo <- localExpect
230−-- > liftIO $ putStrLn echo
231−-- > echoLocal
232−-- >
233−-- > main :: IO ()
234−-- > main = do
235−-- > args <- getArgs
236−-- > case args of
237−-- > "onvm":args' ->
238−-- > -- Pass execution to 'onVmMain' if we are running on the VM
239−-- > -- ('callOnVM' will provide the right arguments)
240−-- > onVmMain __remoteTable args'
241−-- >
242−-- > sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
243−-- > -- Initialize the Azure backend
244−-- > params <- defaultAzureParameters sid x509 pkey
245−-- > let params' = params { azureSshUserName = user }
246−-- > backend <- initializeBackend params' cloudService
247−-- >
248−-- > -- Find the specified virtual machine
249−-- > Just vm <- findNamedVM backend virtualMachine
250−-- >
251−-- > -- Run the echo client proper
252−-- > callOnVM backend vm port $
253−-- > ProcessPair ($(mkClosure 'echoRemote) ())
254−-- > echoLocal
255−--
256−-- The most important part of this code is the last three lines
257−--
258−-- > callOnVM backend vm port $
259−-- > ProcessPair ($(mkClosure 'echoRemote) ())
260−-- > echoLocal
261−--
262−-- 'callOnVM' creats a new Cloud Haskell node on the specified virtual machine,
263−-- then runs @echoRemote@ on the remote machine and @echoLocal@ on the local
264−-- machine.
265−--
266−-- [Second Example: Ping]
267−--
268−-- The second example differs from the @echo@ demo in that it uses both
269−-- 'callOnVM' and 'spawnOnVM'. It uses the latter to
270−-- install a ping server which keeps running in the background; it uses the
271−-- former to run a ping client which sends a request to the ping server and
272−-- outputs the response.
273−--
274−-- As with the @echo@ demo, make sure to copy the executable to the remote server first.
275−-- Once that is done, you can start a ping server on a virtual machine using
276−--
277−-- > cloud-haskell-azure-ping server \
278−-- > <<subscription ID>> \
279−-- > /path/to/credentials.x509 \
280−-- > /path/to/credentials.private \
281−-- > <<remote username>> \
282−-- > <<cloud service name>> \
283−-- > <<virtual machine name>> \
284−-- > <<port number>>
285−--
286−-- As before, when we execute this on our local machine, it starts a new Cloud
287−-- Haskell node on the specified remote virtual machine and then executes the
288−-- ping server. Unlike with the echo example, however, this command will
289−-- terminate once the Cloud Haskell node has been set up, leaving the ping
290−-- server running in the background.
291−--
292−-- Once the ping server is running we can run the ping client:
293−--
294−-- > cloud-haskell-azure-ping client \
295−-- > <<subscription ID>> \
296−-- > /path/to/credentials.x509 \
297−-- > /path/to/credentials.private \
298−-- > <<remote username>> \
299−-- > <<cloud service name>> \
300−-- > <<virtual machine name>> \
301−-- > <<DIFFERENT port number>>
302−-- > Ping server at pid://10.59.224.122:8080:0:2 ok
303−--
304−-- Note that we must pass a different port number, because the client will run
305−-- within its own Cloud Haskell instance.
306−--
307−-- The code for the @ping@ demo is similar to the @echo@ demo, but uses both
308−-- 'callOnVM' and 'spawnOnVM' and demonstrates a way to discover processes (in
309−-- this case, through a PID file).
310−--
311−-- > {-# LANGUAGE TemplateHaskell #-}
312−-- >
313−-- > import System.Environment (getArgs)
314−-- > import Data.Binary (encode, decode)
315−-- > import Control.Monad (forever)
316−-- > import Control.Monad.IO.Class (liftIO)
317−-- > import Control.Exception (try, IOException)
318−-- > import Control.Distributed.Process
319−-- > ( Process
320−-- > , getSelfPid
321−-- > , expect
322−-- > , send
323−-- > , monitor
324−-- > , receiveWait
325−-- > , match
326−-- > , ProcessMonitorNotification(..)
327−-- > )
328−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
329−-- > import Control.Distributed.Process.Backend.Azure
330−-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
331−-- >
332−-- > pingServer :: () -> Backend -> Process ()
333−-- > pingServer () _backend = do
334−-- > us <- getSelfPid
335−-- > liftIO $ BSL.writeFile "pingServer.pid" (encode us)
336−-- > forever $ do
337−-- > them <- expect
338−-- > send them ()
339−-- >
340−-- > pingClientRemote :: () -> Backend -> Process ()
341−-- > pingClientRemote () _backend = do
342−-- > mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
343−-- > case mPingServerEnc of
344−-- > Left err ->
345−-- > remoteSend $ "Ping server not found: " ++ show (err :: IOException)
346−-- > Right pingServerEnc -> do
347−-- > let pingServerPid = decode pingServerEnc
348−-- > pid <- getSelfPid
349−-- > _ref <- monitor pingServerPid
350−-- > send pingServerPid pid
351−-- > gotReply <- receiveWait
352−-- > [ match (\() -> return True)
353−-- > , match (\(ProcessMonitorNotification {}) -> return False)
354−-- > ]
355−-- > if gotReply
356−-- > then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"
357−-- > else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"
358−-- >
359−-- > remotable ['pingClientRemote, 'pingServer]
360−-- >
361−-- > pingClientLocal :: LocalProcess ()
362−-- > pingClientLocal = localExpect >>= liftIO . putStrLn
363−-- >
364−-- > main :: IO ()
365−-- > main = do
366−-- > args <- getArgs
367−-- > case args of
368−-- > "onvm":args' ->
369−-- > -- Pass execution to 'onVmMain' if we are running on the VM
370−-- > onVmMain __remoteTable args'
371−-- >
372−-- > "list":sid:x509:pkey:_ -> do
373−-- > -- List all available cloud services
374−-- > -- (useful, but not strictly necessary for the example)
375−-- > params <- defaultAzureParameters sid x509 pkey
376−-- > css <- cloudServices (azureSetup params)
377−-- > mapM_ print css
378−-- >
379−-- > cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
380−-- > -- Initialize the backend and find the right VM
381−-- > params <- defaultAzureParameters sid x509 pkey
382−-- > let params' = params { azureSshUserName = user }
383−-- > backend <- initializeBackend params' cloudService
384−-- > Just vm <- findNamedVM backend virtualMachine
385−-- >
386−-- > -- The same binary can behave as the client or the server,
387−-- > -- depending on the command line arguments
388−-- > case cmd of
389−-- > "server" -> spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
390−-- > "client" -> callOnVM backend vm port $
391−-- > ProcessPair ($(mkClosure 'pingClientRemote) ())
392−-- > pingClientLocal
393−module Control.Distributed.Process.Backend.Azure
394− ( -- * Initialization
395− Backend(..)
396− , AzureParameters(..)
397− , defaultAzureParameters
398− , initializeBackend
399− -- * Utilities
400− , findNamedVM
401− -- * On-VM main
402− , onVmMain
403− -- * Re-exports from Azure Service Management
404− , CloudService(..)
405− , VirtualMachine(..)
406− , Endpoint(..)
407− , AzureSetup
408− , Azure.cloudServices
409− -- * Remote and local processes
410− , ProcessPair(..)
411− , RemoteProcess
412− , LocalProcess
413− , localSend
414− , localExpect
415− , remoteSend
416− ) where
417−
418−import Prelude hiding (catch)
419−import System.Environment (getEnv)
420−import System.FilePath ((</>), takeFileName)
421−import System.Environment.Executable (getExecutablePath)
422−import System.IO
423− ( stdout
424− , hFlush
425− , hSetBinaryMode
426− , stdin
427− , stdout
428− , stderr
429− , Handle
430− , hClose
431− )
432−import qualified System.Posix.Process as Posix (forkProcess, createSession)
433−import Data.Maybe (listToMaybe)
434−import Data.Binary (Binary(get, put), encode, decode)
435−import Data.Digest.Pure.MD5 (md5, MD5Digest)
436−import qualified Data.ByteString as BSS
437− ( ByteString
438− , length
439− , concat
440− , hPut
441− , hGet
442− )
443−import qualified Data.ByteString.Char8 as BSSC (pack)
444−import qualified Data.ByteString.Lazy as BSL
445− ( ByteString
446− , readFile
447− , length
448− , fromChunks
449− , toChunks
450− , hPut
451− , hGet
452− )
453−import Data.Typeable (Typeable)
454−import Data.Foldable (forM_)
455−import Control.Applicative ((<$>), (<*>))
456−import Control.Monad (void, when)
457−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
458−import Control.Exception
459− ( Exception
460− , catches
461− , Handler(Handler)
462− , throwIO
463− , SomeException
464− )
465−import Control.Monad.IO.Class (MonadIO, liftIO)
466−import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)
467−
468−-- Azure
469−import Network.Azure.ServiceManagement
470− ( CloudService(..)
471− , VirtualMachine(..)
472− , Endpoint(..)
473− , AzureSetup
474− )
475−import qualified Network.Azure.ServiceManagement as Azure
476− ( cloudServices
477− , azureSetup
478− , vmSshEndpoint
479− )
480−
481−-- SSH
482−import qualified Network.SSH.Client.LibSSH2 as SSH
483− ( withSSH2
484− , scpSendFile
485− , withChannelBy
486− , Session
487− , readAllChannel
488− , writeAllChannel
489− , Channel
490− )
491−import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
492− ( openChannelSession
493− , channelExecute
494− , writeChannel
495− , readChannel
496− , channelSendEOF
497− )
498−import qualified Network.SSH.Client.LibSSH2.Errors as SSH
499− ( ErrorCode
500− , NULL_POINTER
501− , getLastError
502− )
503−
504−-- CH
505−import Control.Distributed.Process
506− ( Process
507− , Closure
508− , RemoteTable
509− , catch
510− , unClosure
511− , ProcessId
512− , getSelfPid
513− )
514−import Control.Distributed.Process.Serializable (Serializable)
515−import qualified Control.Distributed.Process.Internal.Types as CH
516− ( LocalNode
517− , LocalProcess(processQueue)
518− , Message
519− , payloadToMessage
520− , messageToPayload
521− , createMessage
522− )
523−import Control.Distributed.Process.Node
524− ( runProcess
525− , forkProcess
526− , newLocalNode
527− , initRemoteTable
528− )
529−import Control.Distributed.Process.Internal.CQueue (CQueue, enqueue)
530−import Network.Transport.TCP (createTransport, defaultTCPParameters)
531−import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)
532−
533−-- | Azure backend
534−data Backend = Backend {
535− -- | Find virtual machines
536− findVMs :: IO [VirtualMachine]
537− -- | Copy the executable to a virtual machine
538− , copyToVM :: VirtualMachine -> IO ()
539− -- | Check the MD5 hash of the remote executable
540− , checkMD5 :: VirtualMachine -> IO Bool
541− -- | @runOnVM vm port pp@ starts a new CH node on machine @vm@ and then
542− -- runs the specified process pair. The CH node will shut down when the
543− -- /local/ process exists. @callOnVM@ returns the returned by the local
544− -- process on exit.
545− , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
546− -- | Create a new CH node and run the specified process.
547− -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
548− -- returns as soon as the process has been spawned.
549− , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId
550− } deriving (Typeable)
551−
552−-- | Azure connection parameters
553−data AzureParameters = AzureParameters {
554− azureSetup :: AzureSetup
555− , azureSshUserName :: FilePath
556− , azureSshPublicKey :: FilePath
557− , azureSshPrivateKey :: FilePath
558− , azureSshPassphrase :: String
559− , azureSshKnownHosts :: FilePath
560− , azureSshRemotePath :: FilePath
561− , azureSshLocalPath :: FilePath
562− }
563−
564−instance Binary AzureParameters where
565− put params = do
566− put (azureSetup params)
567− put (azureSshUserName params)
568− put (azureSshPublicKey params)
569− put (azureSshPrivateKey params)
570− put (azureSshPassphrase params)
571− put (azureSshKnownHosts params)
572− put (azureSshRemotePath params)
573− put (azureSshLocalPath params)
574− get =
575− AzureParameters <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
576−
577−-- | Create default azure parameters
578−defaultAzureParameters :: String -- ^ Azure subscription ID
579− -> FilePath -- ^ Path to X509 certificate
580− -> FilePath -- ^ Path to private key
581− -> IO AzureParameters
582−defaultAzureParameters sid x509 pkey = do
583− home <- getEnv "HOME"
584− user <- getEnv "USER"
585− self <- getExecutablePath
586− setup <- Azure.azureSetup sid x509 pkey
587− return AzureParameters
588− { azureSetup = setup
589− , azureSshUserName = user
590− , azureSshPublicKey = home </> ".ssh" </> "id_rsa.pub"
591− , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"
592− , azureSshPassphrase = ""
593− , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"
594− , azureSshRemotePath = takeFileName self
595− , azureSshLocalPath = self
596− }
597−
598−-- | Initialize the backend
599−initializeBackend :: AzureParameters -- ^ Connection parameters
600− -> String -- ^ Cloud service name
601− -> IO Backend
602−initializeBackend params cloudService =
603− return Backend {
604− findVMs = apiFindVMs params cloudService
605− , copyToVM = apiCopyToVM params
606− , checkMD5 = apiCheckMD5 params
607− , callOnVM = apiCallOnVM params cloudService
608− , spawnOnVM = apiSpawnOnVM params cloudService
609− }
610−
611−-- | Find virtual machines
612−apiFindVMs :: AzureParameters -> String -> IO [VirtualMachine]
613−apiFindVMs params cloudService = do
614− css <- Azure.cloudServices (azureSetup params)
615− case filter ((== cloudService) . cloudServiceName) css of
616− [cs] -> return $ cloudServiceVMs cs
617− _ -> return []
618−
619−-- | Start a CH node on the given virtual machine
620−apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()
621−apiCopyToVM params vm =
622− void . withSSH2 params vm $ \s -> catchSshError s $
623− SSH.scpSendFile s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)
624−
625−-- | Call a process on a VM
626−apiCallOnVM :: AzureParameters
627− -> String
628− -> VirtualMachine
629− -> String
630− -> ProcessPair a
631− -> IO a
632−apiCallOnVM = runOnVM False
633−
634−apiSpawnOnVM :: AzureParameters
635− -> String
636− -> VirtualMachine
637− -> String
638− -> Closure (Backend -> Process ())
639− -> IO ProcessId
640−apiSpawnOnVM params cloudService vm port rproc =
641− runOnVM True params cloudService vm port $
642− ProcessPair rproc localExpect
643−
644−-- | Internal generalization of 'spawnOnVM' and 'callOnVM'
645−runOnVM :: Bool
646− -> AzureParameters
647− -> String
648− -> VirtualMachine
649− -> String
650− -> ProcessPair a
651− -> IO a
652−runOnVM bg params cloudService vm port ppair =
653− withSSH2 params vm $ \s -> do
654− -- TODO: reduce duplication with apiCallOnVM
655− let exe = "PATH=. " ++ azureSshRemotePath params
656− ++ " onvm"
657− ++ " " ++ vmIpAddress vm
658− ++ " " ++ port
659− ++ " " ++ cloudService
660− ++ " " ++ show bg
661− ++ " 2>&1"
662− let paramsEnc = encode params
663− let rprocEnc = encode (ppairRemote ppair)
664− (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
665− SSH.channelExecute ch exe
666− SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))
667− SSH.writeAllChannel ch rprocEnc
668− SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
669− SSH.writeAllChannel ch paramsEnc
670− runLocalProcess (ppairLocal ppair) ch
671− if status == 0
672− then return r
673− else error "runOnVM: Non-zero exit status" -- This would a bug
674−
675−-- | Check the MD5 hash of the executable on the remote machine
676−apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
677−apiCheckMD5 params vm = do
678− hash <- localHash params
679− withSSH2 params vm $ \s -> do
680− (r, _) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
681− SSH.channelExecute ch "md5sum -c --status"
682− SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params
683− SSH.channelSendEOF ch
684− SSH.readAllChannel ch
685− return (r == 0)
686−
687−withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a
688−withSSH2 params (Azure.vmSshEndpoint -> Just ep) =
689− SSH.withSSH2 (azureSshKnownHosts params)
690− (azureSshPublicKey params)
691− (azureSshPrivateKey params)
692− (azureSshPassphrase params)
693− (azureSshUserName params)
694− (endpointVip ep)
695− (read $ endpointPort ep)
696−withSSH2 _ vm =
697− error $ "withSSH2: No SSH endpoint for virtual machine " ++ vmName vm
698−
699−catchSshError :: SSH.Session -> IO a -> IO a
700−catchSshError s io =
701− catches io [ Handler handleErrorCode
702− , Handler handleNullPointer
703− ]
704− where
705− handleErrorCode :: SSH.ErrorCode -> IO a
706− handleErrorCode _ = do
707− (_, str) <- SSH.getLastError s
708− error str
709−
710− handleNullPointer :: SSH.NULL_POINTER -> IO a
711− handleNullPointer _ = do
712− (_, str) <- SSH.getLastError s
713− error str
714−
715−localHash :: AzureParameters -> IO MD5Digest
716−localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
717−
718−--------------------------------------------------------------------------------
719−-- Utilities --
720−--------------------------------------------------------------------------------
721−
722−-- | Find a virtual machine with a particular name
723−findNamedVM :: Backend -> String -> IO (Maybe VirtualMachine)
724−findNamedVM backend vm =
725− listToMaybe . filter ((== vm) . vmName) <$> findVMs backend
726−
727−--------------------------------------------------------------------------------
728−-- Local and remote processes --
729−--------------------------------------------------------------------------------
730−
731−-- | A process pair consists of a remote process and a local process. The local
732−-- process can send messages to the remote process using 'localSend' and wait
733−-- for messages from the remote process using 'localExpect'. The remote process
734−-- can send messages to the local process using 'remoteSend', and wait for
735−-- messages from the local process using the standard Cloud Haskell primitives.
736−--
737−-- See also 'callOnVM'.
738−data ProcessPair a = ProcessPair {
739− ppairRemote :: RemoteProcess ()
740− , ppairLocal :: LocalProcess a
741− }
742−
743−-- | The process to run on the remote node (see 'ProcessPair' and 'callOnVM').
744−type RemoteProcess a = Closure (Backend -> Process a)
745−
746−-- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').
747−newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
748− deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
749−
750−runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
751−runLocalProcess = runReaderT . unLocalProcess
752−
753−-- | Send a messages from the local process to the remote process
754−-- (see 'ProcessPair')
755−localSend :: Serializable a => a -> LocalProcess ()
756−localSend x = LocalProcess $ do
757− ch <- ask
758− liftIO $ mapM_ (SSH.writeChannel ch)
759− . prependLength
760− . CH.messageToPayload
761− . CH.createMessage
762− $ x
763−
764−-- | Wait for a message from the remote process (see 'ProcessPair').
765−-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
766−-- runtime error if the remote process sends a message of type other than @a@.
767−--
768−-- Since it is relatively easy for the remote process to mess up the
769−-- communication protocol (for instance, by doing a putStr) we ask for the
770−-- length twice, as some sort of sanity check.
771−localExpect :: Serializable a => LocalProcess a
772−localExpect = LocalProcess $ do
773− ch <- ask
774− liftIO $ do
775− isE <- readIntChannel ch
776− len <- readIntChannel ch
777− lenAgain <- readIntChannel ch
778− when (len /= lenAgain) $ throwIO (userError "Protocol violation")
779− msg <- readSizeChannel ch len
780− if isE /= 0
781− then error (decode msg)
782− else return (decode msg)
783−
784−-- | Send a message from the remote process to the local process (see
785−-- 'ProcessPair'). Note that the remote process can use the standard Cloud
786−-- Haskell primitives to /receive/ messages from the local process.
787−remoteSend :: Serializable a => a -> Process ()
788−remoteSend = liftIO . remoteSend'
789−
790−remoteSend' :: Serializable a => a -> IO ()
791−remoteSend' = remoteSendFlagged 0
792−
793−-- | If the remote process encounters an error it can use 'remoteThrow'. This
794−-- will cause the exception to be raised (as a user-exception, not as the
795−-- original type) in the local process (as well as in the remote process).
796−remoteThrow :: Exception e => e -> IO ()
797−remoteThrow e = remoteSendFlagged 1 (show e) >> throwIO e
798−
799−remoteSendFlagged :: Serializable a => Int -> a -> IO ()
800−remoteSendFlagged flags x = do
801− let enc = encode x
802− BSS.hPut stdout (encodeInt32 flags)
803− -- See 'localExpect' for why we send the length twice
804− BSS.hPut stdout (encodeInt32 (BSL.length enc))
805− BSS.hPut stdout (encodeInt32 (BSL.length enc))
806− BSL.hPut stdout enc
807− hFlush stdout
808−
809−--------------------------------------------------------------------------------
810−-- On-VM main --
811−--------------------------------------------------------------------------------
812−
813−-- | Program main when run on the VM. A typical 'main' function looks like
814−--
815−-- > main :: IO ()
816−-- > main = do
817−-- > args <- getArgs
818−-- > case args of
819−-- > "onvm":args' -> onVmMain __remoteTable args'
820−-- > _ -> -- your normal main
821−onVmMain :: (RemoteTable -> RemoteTable) -> [String] -> IO ()
822−onVmMain rtable [host, port, cloudService, bg] = do
823− hSetBinaryMode stdin True
824− hSetBinaryMode stdout True
825− Just rprocEnc <- getWithLength stdin
826− Just paramsEnc <- getWithLength stdin
827− backend <- initializeBackend (decode paramsEnc) cloudService
828− let rproc = decode rprocEnc
829− lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)
830− if read bg
831− then
832− void . Posix.forkProcess $ do
833− -- We inherit the file descriptors from the parent, so the SSH
834− -- session will not be terminated until we close them
835− void Posix.createSession
836− startCH rproc lprocMVar backend
837− (\node proc -> runProcess node $ do
838− us <- getSelfPid
839− liftIO $ do
840− remoteSend' us
841− mapM_ hClose [stdin, stdout, stderr]
842− proc)
843− else do
844− startCH rproc lprocMVar backend forkProcess
845− lproc <- readMVar lprocMVar
846− queueFromHandle stdin (CH.processQueue lproc)
847− where
848− startCH :: RemoteProcess ()
849− -> MVar CH.LocalProcess
850− -> Backend
851− -> (CH.LocalNode -> Process () -> IO a)
852− -> IO ()
853− startCH rproc lprocMVar backend go = do
854− mTransport <- createTransport host port defaultTCPParameters
855− case mTransport of
856− Left err -> remoteThrow err
857− Right transport -> do
858− node <- newLocalNode transport (rtable initRemoteTable)
859− void . go node $ do
860− ask >>= liftIO . putMVar lprocMVar
861− proc <- unClosure rproc :: Process (Backend -> Process ())
862− catch (proc backend)
863− (liftIO . (remoteThrow :: SomeException -> IO ()))
864−onVmMain _ _
865− = error "Invalid arguments passed on onVmMain"
866−
867−-- | Read a 4-byte length @l@ and then an @l@-byte payload
868−--
869−-- Returns Nothing on EOF
870−getWithLength :: Handle -> IO (Maybe BSL.ByteString)
871−getWithLength h = do
872− lenEnc <- BSS.hGet h 4
873− if BSS.length lenEnc < 4
874− then return Nothing
875− else do
876− let len = decodeInt32 lenEnc
877− bs <- BSL.hGet h len
878− if BSL.length bs < fromIntegral len
879− then return Nothing
880− else return (Just bs)
881−
882−queueFromHandle :: Handle -> CQueue CH.Message -> IO ()
883−queueFromHandle h q = do
884− mPayload <- getWithLength stdin
885− forM_ mPayload $ \payload -> do
886− enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
887− queueFromHandle h q
888−
889−--------------------------------------------------------------------------------
890−-- SSH utilities --
891−--------------------------------------------------------------------------------
892−
893−readSizeChannel :: SSH.Channel -> Int -> IO BSL.ByteString
894−readSizeChannel ch = go []
895− where
896− go :: [BSS.ByteString] -> Int -> IO BSL.ByteString
897− go acc 0 = return (BSL.fromChunks $ reverse acc)
898− go acc size = do
899− bs <- SSH.readChannel ch (fromIntegral (0x400 `min` size))
900− go (bs : acc) (size - BSS.length bs)
901−
902−readIntChannel :: SSH.Channel -> IO Int
903−readIntChannel ch =
904− decodeInt32 . BSS.concat . BSL.toChunks <$> readSizeChannel ch 4
distributed-process-simplelocalnet/ChangeLogdeleted−27
@@ -1,27 +0,0 @@
1−<<date>> Edsko de Vries <edsko@well-typed.com> 0.2.0.6
2−
3−* Use new version of network-transport
4−
5−2012-08-22 Edsko de Vries <edsko@well-typed.com> 0.2.0.5
6−
7−* Don't assume slaves are still alive in findSlaves
8−
9−2012-08-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.4
10−
11−* Relax version bounds for distributed-process
12−
13−2012-07-17 Edsko de Vries <edsko@well-typed.com> 0.2.0.3
14−
15−* Improve documentation
16−
17−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2
18−
19−* Relax contraints on bytestring and containers
20−
21−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
22−
23−* Bugfix: Documentation referred to old module name
24−
25−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
26−
27−* Initial release.
distributed-process-simplelocalnet/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Well-Typed LLP, 2011-2012
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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
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.
31−
distributed-process-simplelocalnet/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabaldeleted−63
@@ -1,63 +0,0 @@
1−Name: distributed-process-simplelocalnet
2−Version: 0.2.0.6
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.3 && < 0.4,
36− network-transport-tcp >= 0.3 && < 0.4,
37− distributed-process >= 0.2 && < 0.4
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.3 && < 0.4,
58− network-transport-tcp >= 0.3 && < 0.4,
59− distributed-process >= 0.2 && < 0.4
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.hsdeleted−355
@@ -1,355 +0,0 @@
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, replicateM)
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− , match
118− , matchIf
119− , processNodeId
120− , monitorNode
121− , unmonitor
122− , NodeMonitorNotification(..)
123− )
124−import qualified Control.Distributed.Process.Node as Node
125− ( LocalNode
126− , newLocalNode
127− , localNodeId
128− , runProcess
129− )
130−import qualified Network.Transport.TCP as NT
131− ( createTransport
132− , defaultTCPParameters
133− )
134−import qualified Network.Transport as NT (Transport)
135−import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
136−import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)
137−
138−-- | Local backend
139−data Backend = Backend {
140− -- | Create a new local node
141− newLocalNode :: IO Node.LocalNode
142− -- | @findPeers t@ broadcasts a /who's there?/ message on the local
143− -- network, waits 't' msec, and then collects and returns the answers.
144− -- You can use this to dynamically discover peer nodes.
145− , findPeers :: Int -> IO [NodeId]
146− -- | Make sure that all log messages are printed by the logger on the
147− -- current node
148− , redirectLogsHere :: Process ()
149− }
150−
151−data BackendState = BackendState {
152− _localNodes :: [Node.LocalNode]
153− , _peers :: Set NodeId
154− , discoveryDaemon :: ThreadId
155− }
156−
157−-- | Initialize the backend
158−initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend
159−initializeBackend host port rtable = do
160− mTransport <- NT.createTransport host port NT.defaultTCPParameters
161− (recv, send) <- initMulticast "224.0.0.99" 9999 1024
162− (_, backendState) <- fixIO $ \ ~(tid, _) -> do
163− backendState <- newMVar BackendState
164− { _localNodes = []
165− , _peers = Set.empty
166− , discoveryDaemon = tid
167− }
168− tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
169− return (tid', backendState)
170− case mTransport of
171− Left err -> throw err
172− Right transport ->
173− let backend = Backend {
174− newLocalNode = apiNewLocalNode transport rtable backendState
175− , findPeers = apiFindPeers send backendState
176− , redirectLogsHere = apiRedirectLogsHere backend
177− }
178− in return backend
179−
180−-- | Create a new local node
181−apiNewLocalNode :: NT.Transport
182− -> RemoteTable
183− -> MVar BackendState
184− -> IO Node.LocalNode
185−apiNewLocalNode transport rtable backendState = do
186− localNode <- Node.newLocalNode transport rtable
187− modifyMVar_ backendState $ return . (localNodes ^: (localNode :))
188− return localNode
189−
190−-- | Peer discovery
191−apiFindPeers :: (PeerDiscoveryMsg -> IO ())
192− -> MVar BackendState
193− -> Int
194− -> IO [NodeId]
195−apiFindPeers send backendState delay = do
196− send PeerDiscoveryRequest
197− threadDelay delay
198− Set.toList . (^. peers) <$> readMVar backendState
199−
200−data PeerDiscoveryMsg =
201− PeerDiscoveryRequest
202− | PeerDiscoveryReply NodeId
203−
204−instance Binary PeerDiscoveryMsg where
205− put PeerDiscoveryRequest = putWord8 0
206− put (PeerDiscoveryReply nid) = putWord8 1 >> put nid
207− get = do
208− header <- getWord8
209− case header of
210− 0 -> return PeerDiscoveryRequest
211− 1 -> PeerDiscoveryReply <$> get
212− _ -> fail "PeerDiscoveryMsg.get: invalid"
213−
214−-- | Respond to peer discovery requests sent by other nodes
215−peerDiscoveryDaemon :: MVar BackendState
216− -> IO (PeerDiscoveryMsg, N.SockAddr)
217− -> (PeerDiscoveryMsg -> IO ())
218− -> IO ()
219−peerDiscoveryDaemon backendState recv send = forever go
220− where
221− go = do
222− (msg, _) <- recv
223− case msg of
224− PeerDiscoveryRequest -> do
225− nodes <- (^. localNodes) <$> readMVar backendState
226− forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
227− PeerDiscoveryReply nid ->
228− modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
229−
230−--------------------------------------------------------------------------------
231−-- Back-end specific primitives --
232−--------------------------------------------------------------------------------
233−
234−-- | Make sure that all log messages are printed by the logger on this node
235−apiRedirectLogsHere :: Backend -> Process ()
236−apiRedirectLogsHere backend = do
237− mLogger <- whereis "logger"
238− forM_ mLogger $ \logger -> do
239− nids <- liftIO $ findPeers backend 1000000
240− forM_ nids $ \nid -> registerRemote nid "logger" logger
241−
242−--------------------------------------------------------------------------------
243−-- Slaves --
244−--------------------------------------------------------------------------------
245−
246−-- | Messages to slave nodes
247−--
248−-- This datatype is not exposed; instead, we expose primitives for dealing
249−-- with slaves.
250−data SlaveControllerMsg =
251− SlaveTerminate
252− deriving (Typeable, Show)
253−
254−instance Binary SlaveControllerMsg where
255− put SlaveTerminate = putWord8 0
256− get = do
257− header <- getWord8
258− case header of
259− 0 -> return SlaveTerminate
260− _ -> fail "SlaveControllerMsg.get: invalid"
261−
262−-- | Calling 'slave' sets up a new local node and then waits. You start
263−-- processes on the slave by calling 'spawn' from other nodes.
264−--
265−-- This function does not return. The only way to exit the slave is to CTRL-C
266−-- the process or call terminateSlave from another node.
267−startSlave :: Backend -> IO ()
268−startSlave backend = do
269− node <- newLocalNode backend
270− Node.runProcess node slaveController
271−
272−-- | The slave controller interprets 'SlaveControllerMsg's
273−slaveController :: Process ()
274−slaveController = do
275− pid <- getSelfPid
276− register "slaveController" pid
277− go
278− where
279− go = do
280− msg <- expect
281− case msg of
282− SlaveTerminate -> return ()
283−
284−-- | Terminate the slave at the given node ID
285−terminateSlave :: NodeId -> Process ()
286−terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate
287−
288−-- | Find slave nodes
289−findSlaves :: Backend -> Process [NodeId]
290−findSlaves backend = do
291− nodes <- liftIO $ findPeers backend 1000000
292− -- Fire of asynchronous requests for the slave controller
293− refs <- forM nodes $ \nid -> do
294− whereisRemoteAsync nid "slaveController"
295− ref <- monitorNode nid
296− return (nid, ref)
297− -- Wait for the replies
298− catMaybes <$> replicateM (length nodes) (
299− receiveWait
300− [ matchIf (\(WhereIsReply label _) -> label == "slaveController")
301− (\(WhereIsReply _ mPid) ->
302− case mPid of
303− Nothing ->
304− return Nothing
305− Just pid -> do
306− let nid = processNodeId pid
307− Just ref = lookup nid refs
308− unmonitor ref
309− return (Just nid))
310− , match (\(NodeMonitorNotification {}) -> return Nothing)
311− ])
312−
313−-- | Terminate all slaves
314−terminateAllSlaves :: Backend -> Process ()
315−terminateAllSlaves backend = do
316− slaves <- findSlaves backend
317− forM_ slaves terminateSlave
318− liftIO $ threadDelay 1000000
319−
320−--------------------------------------------------------------------------------
321−-- Master nodes
322−--------------------------------------------------------------------------------
323−
324−-- | 'startMaster' finds all slaves /currently/ available on the local network,
325−-- redirects all log messages to itself, and then calls the specified process,
326−-- passing the list of slaves nodes.
327−--
328−-- Terminates when the specified process terminates. If you want to terminate
329−-- the slaves when the master terminates, you should manually call
330−-- 'terminateAllSlaves'.
331−--
332−-- If you start more slave nodes after having started the master node, you can
333−-- discover them with later calls to 'findSlaves', but be aware that you will
334−-- need to call 'redirectLogHere' to redirect their logs to the master node.
335−--
336−-- Note that you can use functionality of "SimpleLocalnet" directly (through
337−-- 'Backend'), instead of using 'startMaster'/'startSlave', if the master/slave
338−-- distinction does not suit your application.
339−startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()
340−startMaster backend proc = do
341− node <- newLocalNode backend
342− Node.runProcess node $ do
343− slaves <- findSlaves backend
344− redirectLogsHere backend
345− proc slaves
346−
347−--------------------------------------------------------------------------------
348−-- Accessors --
349−--------------------------------------------------------------------------------
350−
351−localNodes :: Accessor BackendState [Node.LocalNode]
352−localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })
353−
354−peers :: Accessor BackendState (Set NodeId)
355−peers = accessor _peers (\ps st -> st { _peers = ps })
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hsdeleted−126
@@ -1,126 +0,0 @@
1−-- | Multicast utilities
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) where
4−
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.hsdeleted−24
@@ -1,24 +0,0 @@
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
5−
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.hsdeleted−11
@@ -1,11 +0,0 @@
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/.gitignorenew file+4
@@ -0,0 +1,4 @@
1+dist/
2+.cabal-sandbox
3+cabal.sandbox.config
4+.stack*
distributed-process-tests/CONTRIBUTING.mdnew file+1
@@ -0,0 +1 @@
1+See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
distributed-process-azure/LICENSE → distributed-process-tests/LICENSErenamed

The content is the same.

distributed-process-tests/README.mdnew file+14
@@ -0,0 +1,14 @@
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-azure/Setup.hs → distributed-process-tests/Setup.hsrenamed

The content is the same.

distributed-process-tests/distributed-process-tests.cabalnew file+158
@@ -0,0 +1,158 @@
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.hsnew file+1879
@@ -0,0 +1,1879 @@
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.hsnew file+589
@@ -0,0 +1,589 @@
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.hsnew file+243
@@ -0,0 +1,243 @@
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.hsnew file+542
@@ -0,0 +1,542 @@
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.hsnew file+154
@@ -0,0 +1,154 @@
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.hsnew file+129
@@ -0,0 +1,129 @@
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.hsnew file+431
@@ -0,0 +1,431 @@
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.hsnew file+12
@@ -0,0 +1,12 @@
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.hsnew file+30
@@ -0,0 +1,30 @@
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.hsnew file+47
@@ -0,0 +1,47 @@
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.cabalnew file+168
@@ -0,0 +1,168 @@
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-&#xc5;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/ChangeLogdeleted−64
@@ -1,64 +0,0 @@
1−<<date>> Edsko de Vries <edsko@well-typed.com> 0.3.2
2−
3−* Improved treatment of network failure, using new failure semantics of
4−Network.Transport.
5−
6−2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1
7−
8−* Fix memory leaks
9−* Make Template Haskell support optional
10−* Relax dependency constraints
11−
12−2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0
13−
14−* Extract 'static' into a separate package (C.D.Static)
15−* Use new package rank1dynamic to proper runtime checks for polymorphic values
16−
17−2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0
18−
19−* Expose the constructors of Closure
20−* Add instance (Typeable a => Serializable (Static a)) and make sure we only
21−use the internal representation of Static where really necessary
22−* Improved docs
23−
24−2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0
25−
26−* Add exception handling primitives
27−* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on
28−MVar' exception would be thrown.
29−
30−2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
31−
32−* Bugfix in the node controller
33−(one way this bug materialized: when using the SimpleLocalnet backend,
34−slave nodes could not be reused)
35−* Improved documentation in Control.Distributed.Process.Closure
36−
37−2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
38−
39−* Improve docs
40−* Local versions of spawn
41−
42−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
43−
44−* Base 4.6 compatibility
45−* Relax constraints on bytestring and containers
46−
47−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1
48−
49−* Relax upper bound on 'time' dependency
50−
51−2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1
52−
53−* Complete redesign of the underlying implementation of static values and
54−closures.
55−
56−* Add support for 'spawnChannel'
57−
58−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
59−
60−* Bugfix: Continue processing messages when a connection breaks.
61−
62−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
63−
64−* Initial release.
distributed-process/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Well-Typed LLP, 2011-2012
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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
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.
31−
distributed-process/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
distributed-process/distributed-process.cabaldeleted−115
@@ -1,115 +0,0 @@
1−Name: distributed-process
2−Version: 0.3.2
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−flag th
33− description: Build with Template Haskell support
34− default: True
35−
36−Library
37− Build-Depends: base >= 4.4 && < 5,
38− binary >= 0.5 && < 0.6,
39− network-transport >= 0.3 && < 0.4,
40− stm >= 2.3 && < 2.5,
41− transformers >= 0.2 && < 0.4,
42− mtl >= 2.0 && < 2.2,
43− data-accessor >= 0.2 && < 0.3,
44− bytestring >= 0.9 && < 0.11,
45− containers >= 0.4 && < 0.6,
46− old-locale >= 1.0 && < 1.1,
47− time >= 1.2 && < 1.5,
48− random >= 1.0 && < 1.1,
49− ghc-prim >= 0.2 && < 0.4,
50− distributed-static >= 0.2 && < 0.3,
51− rank1dynamic >= 0.1 && < 0.2,
52− syb >= 0.3 && < 0.4
53− Exposed-modules: Control.Distributed.Process,
54− Control.Distributed.Process.Serializable,
55− Control.Distributed.Process.Closure,
56− Control.Distributed.Process.Node,
57− Control.Distributed.Process.Internal.Primitives,
58− Control.Distributed.Process.Internal.CQueue,
59− Control.Distributed.Process.Internal.Types,
60− Control.Distributed.Process.Internal.Closure.BuiltIn,
61− Control.Distributed.Process.Internal.Messaging,
62− Control.Distributed.Process.Internal.StrictMVar
63− Extensions: RankNTypes,
64− ScopedTypeVariables,
65− FlexibleInstances,
66− UndecidableInstances,
67− ExistentialQuantification,
68− GADTs,
69− GeneralizedNewtypeDeriving,
70− DeriveDataTypeable,
71− CPP,
72− BangPatterns
73− ghc-options: -Wall
74− HS-Source-Dirs: src
75− if flag(th)
76− Build-Depends: template-haskell >= 2.6 && < 2.9
77− Exposed-modules: Control.Distributed.Process.Internal.Closure.TH
78− CPP-Options: -DTemplateHaskellSupport
79−
80−Test-Suite TestCH
81− Type: exitcode-stdio-1.0
82− Main-Is: TestCH.hs
83− Build-Depends: base >= 4.4 && < 5,
84− random >= 1.0 && < 1.1,
85− ansi-terminal >= 0.5 && < 0.6,
86− distributed-process >= 0.3 && < 0.4,
87− network-transport >= 0.3 && < 0.4,
88− network-transport-tcp >= 0.3 && < 0.4,
89− binary >= 0.5 && < 0.6,
90− network >= 2.3 && < 2.4
91− Other-modules: TestAuxiliary
92− Extensions: CPP,
93− ScopedTypeVariables,
94− DeriveDataTypeable,
95− GeneralizedNewtypeDeriving
96− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
97− HS-Source-Dirs: tests
98−
99−Test-Suite TestClosure
100− Type: exitcode-stdio-1.0
101− Main-Is: TestClosure.hs
102− Build-Depends: base >= 4.4 && < 5,
103− random >= 1.0 && < 1.1,
104− ansi-terminal >= 0.5 && < 0.6,
105− distributed-static >= 0.2 && < 0.3,
106− distributed-process >= 0.3 && < 0.4,
107− network-transport >= 0.3 && < 0.4,
108− network-transport-tcp >= 0.3 && < 0.4,
109− bytestring >= 0.9 && < 0.11,
110− network >= 2.3 && < 2.4
111− Other-modules: TestAuxiliary
112− Extensions: CPP,
113− ScopedTypeVariables
114− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
115− HS-Source-Dirs: tests
distributed-process/src/Control/Distributed/Process/Internal/CQueue.hsdeleted−105
@@ -1,105 +0,0 @@
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
9−
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/TH.hsdeleted−257
@@ -1,257 +0,0 @@
1−-- | Template Haskell support
2−{-# LANGUAGE TemplateHaskell #-}
3−module Control.Distributed.Process.Internal.Closure.TH
4− ( -- * User-level API
5− remotable
6− , mkStatic
7− , functionSDict
8− , functionTDict
9− , mkClosure
10− ) where
11−
12−import Prelude hiding (succ, any)
13−import Control.Applicative ((<$>))
14−import Language.Haskell.TH
15− ( -- Q monad and operations
16− Q
17− , reify
18− -- Names
19− , Name
20− , mkName
21− , nameBase
22− -- Algebraic data types
23− , Dec
24− , Exp
25− , Type(AppT, ForallT, VarT, ArrowT)
26− , Info(VarI)
27− , TyVarBndr(PlainTV, KindedTV)
28− , Pred(ClassP)
29− -- Lifted constructors
30− -- .. Literals
31− , stringL
32− -- .. Patterns
33− , normalB
34− , clause
35− -- .. Expressions
36− , varE
37− , litE
38− -- .. Top-level declarations
39− , funD
40− , sigD
41− )
42−import Data.Binary (encode)
43−import Data.Generics (everywhereM, mkM, gmapM)
44−import Data.Rank1Dynamic (toDynamic)
45−import Data.Rank1Typeable
46− ( Zero
47− , Succ
48− , TypVar
49− )
50−import Control.Distributed.Static
51− ( RemoteTable
52− , registerStatic
53− , Static
54− , staticLabel
55− , closure
56− , staticCompose
57− )
58−import Control.Distributed.Process.Internal.Types (Process)
59−import Control.Distributed.Process.Serializable
60− ( SerializableDict(SerializableDict)
61− )
62−import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
63−
64−--------------------------------------------------------------------------------
65−-- User-level API --
66−--------------------------------------------------------------------------------
67−
68−-- | Create the closure, decoder, and metadata definitions for the given list
69−-- of functions
70−remotable :: [Name] -> Q [Dec]
71−remotable ns = do
72− (closures, inserts) <- unzip <$> mapM generateDefs ns
73− rtable <- createMetaData (concat inserts)
74− return $ concat closures ++ rtable
75−
76−-- | Construct a static value.
77−--
78−-- If @f : forall a1 .. an. T@
79−-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
80−-- Be sure to pass 'f' to 'remotable'.
81−mkStatic :: Name -> Q Exp
82−mkStatic = varE . staticName
83−
84−-- | If @f : T1 -> T2@ is a monomorphic function
85−-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
86−--
87−-- Be sure to pass 'f' to 'remotable'.
88−functionSDict :: Name -> Q Exp
89−functionSDict = varE . sdictName
90−
91−-- | If @f : T1 -> Process T2@ is a monomorphic function
92−-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
93−--
94−-- Be sure to pass 'f' to 'remotable'.
95−functionTDict :: Name -> Q Exp
96−functionTDict = varE . tdictName
97−
98−mkClosure :: Name -> Q Exp
99−mkClosure n =
100− [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
101− . encode
102− |]
103−
104−--------------------------------------------------------------------------------
105−-- Internal (Template Haskell) --
106−--------------------------------------------------------------------------------
107−
108−-- | Generate the code to add the metadata to the CH runtime
109−createMetaData :: [Q Exp] -> Q [Dec]
110−createMetaData is =
111− [d| __remoteTable :: RemoteTable -> RemoteTable ;
112− __remoteTable = $(compose is)
113− |]
114−
115−generateDefs :: Name -> Q ([Dec], [Q Exp])
116−generateDefs n = do
117− proc <- [t| Process |]
118− mType <- getType n
119− case mType of
120− Just (origName, typ) -> do
121− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
122− _ -> ([], typ)
123−
124− -- The main "static" entry
125− (static, register) <- makeStatic origName typVars typ'
126−
127− -- If n :: T1 -> T2, static serializable dictionary for T1
128− -- TODO: we should check if arg is an instance of Serializable, but we cannot
129− -- http://hackage.haskell.org/trac/ghc/ticket/7066
130− (sdict, registerSDict) <- case (typVars, typ') of
131− ([], ArrowT `AppT` arg `AppT` _res) ->
132− makeDict (sdictName origName) arg
133− _ ->
134− return ([], [])
135−
136− -- If n :: T1 -> Process T2, static serializable dictionary for T2
137− -- TODO: check if T2 is serializable (same as above)
138− (tdict, registerTDict) <- case (typVars, typ') of
139− ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
140− makeDict (tdictName origName) res
141− _ ->
142− return ([], [])
143−
144− return ( concat [static, sdict, tdict]
145− , concat [register, registerSDict, registerTDict]
146− )
147− _ ->
148− fail $ "remotable: " ++ show n ++ " not found"
149− where
150− makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
151− makeStatic origName typVars typ = do
152− static <- generateStatic origName typVars typ
153− let dyn = case typVars of
154− [] -> [| toDynamic $(varE origName) |]
155− _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
156− return ( static
157− , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
158− )
159−
160− makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
161− makeDict dictName typ = do
162− sdict <- generateDict dictName typ
163− let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]
164− return ( sdict
165− , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
166− )
167−
168−-- | Turn a polymorphic type into a monomorphic type using ANY and co
169−monomorphize :: [TyVarBndr] -> Type -> Q Type
170−monomorphize tvs =
171− let subst = zip (map tyVarBndrName tvs) anys
172− in everywhereM (mkM (applySubst subst))
173− where
174− anys :: [Q Type]
175− anys = map typVar (iterate succ zero)
176−
177− typVar :: Q Type -> Q Type
178− typVar t = [t| TypVar $t |]
179−
180− zero :: Q Type
181− zero = [t| Zero |]
182−
183− succ :: Q Type -> Q Type
184− succ t = [t| Succ $t |]
185−
186− applySubst :: [(Name, Q Type)] -> Type -> Q Type
187− applySubst s (VarT n) =
188− case lookup n s of
189− Nothing -> return (VarT n)
190− Just t -> t
191− applySubst s t = gmapM (mkM (applySubst s)) t
192−
193−
194−
195−-- | Generate a static value
196−generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
197−generateStatic n xs typ = do
198− staticTyp <- [t| Static |]
199− sequence
200− [ sigD (staticName n) $
201− return (ForallT xs
202− (map typeable xs)
203− (staticTyp `AppT` typ)
204− )
205− , sfnD (staticName n) [| staticLabel $(stringE (show n)) |]
206− ]
207− where
208− typeable :: TyVarBndr -> Pred
209− typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
210−
211−-- | Generate a serialization dictionary with name 'n' for type 'typ'
212−generateDict :: Name -> Type -> Q [Dec]
213−generateDict n typ = do
214− sequence
215− [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
216− , sfnD n [| staticLabel $(stringE (show n)) |]
217− ]
218−
219−staticName :: Name -> Name
220−staticName n = mkName $ nameBase n ++ "__static"
221−
222−sdictName :: Name -> Name
223−sdictName n = mkName $ nameBase n ++ "__sdict"
224−
225−tdictName :: Name -> Name
226−tdictName n = mkName $ nameBase n ++ "__tdict"
227−
228−--------------------------------------------------------------------------------
229−-- Generic Template Haskell auxiliary functions --
230−--------------------------------------------------------------------------------
231−
232−-- | Compose a set of expressions
233−compose :: [Q Exp] -> Q Exp
234−compose [] = [| id |]
235−compose [e] = e
236−compose (e:es) = [| $e . $(compose es) |]
237−
238−-- | Literal string as an expression
239−stringE :: String -> Q Exp
240−stringE = litE . stringL
241−
242−-- | Look up the "original name" (module:name) and type of a top-level function
243−getType :: Name -> Q (Maybe (Name, Type))
244−getType name = do
245− info <- reify name
246− case info of
247− VarI origName typ _ _ -> return $ Just (origName, typ)
248− _ -> return Nothing
249−
250−-- | Variation on 'funD' which takes a single expression to define the function
251−sfnD :: Name -> Q Exp -> Q Dec
252−sfnD n e = funD n [clause [] (normalB e) []]
253−
254−-- | The name of a type variable binding occurrence
255−tyVarBndrName :: TyVarBndr -> Name
256−tyVarBndrName (PlainTV n) = n
257−tyVarBndrName (KindedTV n _) = n
distributed-process/src/Control/Distributed/Process/Internal/Messaging.hsdeleted−169
@@ -1,169 +0,0 @@
1−module Control.Distributed.Process.Internal.Messaging
2− ( sendPayload
3− , sendBinary
4− , sendMessage
5− , disconnect
6− , closeImplicitReconnections
7− , impliesDeathOf
8− ) where
9−
10−import Data.Accessor ((^.), (^=))
11−import Data.Binary (Binary, encode)
12−import qualified Data.Map as Map (partitionWithKey, elems)
13−import qualified Data.ByteString.Lazy as BSL (toChunks)
14−import qualified Data.ByteString as BSS (ByteString)
15−import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)
16−import Control.Concurrent.Chan (writeChan)
17−import Control.Monad (unless)
18−import qualified Network.Transport as NT
19− ( Connection
20− , send
21− , defaultConnectHints
22− , connect
23− , Reliability(ReliableOrdered)
24− , close
25− )
26−import Control.Distributed.Process.Internal.Types
27− ( LocalNode(localState, localEndPoint, localCtrlChan)
28− , Identifier
29− , localConnections
30− , localConnectionBetween
31− , nodeAddress
32− , nodeOf
33− , messageToPayload
34− , createMessage
35− , NCMsg(..)
36− , ProcessSignal(Died)
37− , DiedReason(DiedDisconnect)
38− , ImplicitReconnect(WithImplicitReconnect)
39− , NodeId
40− , ProcessId(processNodeId)
41− , SendPortId(sendPortProcessId)
42− , Identifier(NodeIdentifier, ProcessIdentifier, SendPortIdentifier)
43− )
44−import Control.Distributed.Process.Serializable (Serializable)
45−
46−--------------------------------------------------------------------------------
47−-- Message sending --
48−--------------------------------------------------------------------------------
49−
50−sendPayload :: LocalNode
51− -> Identifier
52− -> Identifier
53− -> ImplicitReconnect
54− -> [BSS.ByteString]
55− -> IO ()
56−sendPayload node from to implicitReconnect payload = do
57− mConn <- connBetween node from to implicitReconnect
58− didSend <- case mConn of
59− Just conn -> do
60− didSend <- NT.send conn payload
61− case didSend of
62− Left _err -> return False
63− Right () -> return True
64− Nothing -> return False
65− unless didSend $ do
66− writeChan (localCtrlChan node) NCMsg
67− { ctrlMsgSender = to
68− , ctrlMsgSignal = Died to DiedDisconnect
69− }
70−
71−sendBinary :: Binary a
72− => LocalNode
73− -> Identifier
74− -> Identifier
75− -> ImplicitReconnect
76− -> a
77− -> IO ()
78−sendBinary node from to implicitReconnect
79− = sendPayload node from to implicitReconnect . BSL.toChunks . encode
80−
81−sendMessage :: Serializable a
82− => LocalNode
83− -> Identifier
84− -> Identifier
85− -> ImplicitReconnect
86− -> a
87− -> IO ()
88−sendMessage node from to implicitReconnect =
89− sendPayload node from to implicitReconnect . messageToPayload . createMessage
90−
91−setupConnBetween :: LocalNode
92− -> Identifier
93− -> Identifier
94− -> ImplicitReconnect
95− -> IO (Maybe NT.Connection)
96−setupConnBetween node from to implicitReconnect = do
97− mConn <- NT.connect endPoint
98− (nodeAddress . nodeOf $ to)
99− NT.ReliableOrdered
100− NT.defaultConnectHints
101− case mConn of
102− Right conn -> do
103− didSend <- NT.send conn (BSL.toChunks . encode $ to)
104− case didSend of
105− Left _ ->
106− return Nothing
107− Right () -> do
108− modifyMVar_ nodeState $ return .
109− (localConnectionBetween from to ^= Just (conn, implicitReconnect))
110− return $ Just conn
111− Left _ ->
112− return Nothing
113− where
114− endPoint = localEndPoint node
115− nodeState = localState node
116−
117−connBetween :: LocalNode
118− -> Identifier
119− -> Identifier
120− -> ImplicitReconnect
121− -> IO (Maybe NT.Connection)
122−connBetween node from to implicitReconnect = do
123− mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)
124− case mConn of
125− Just (conn, _) ->
126− return $ Just conn
127− Nothing ->
128− setupConnBetween node from to implicitReconnect
129− where
130− nodeState = localState node
131−
132−disconnect :: LocalNode -> Identifier -> Identifier -> IO ()
133−disconnect node from to =
134− modifyMVar_ (localState node) $ \st ->
135− case st ^. localConnectionBetween from to of
136− Nothing ->
137− return st
138− Just (conn, _) -> do
139− NT.close conn
140− return (localConnectionBetween from to ^= Nothing $ st)
141−
142−closeImplicitReconnections :: LocalNode -> Identifier -> IO ()
143−closeImplicitReconnections node to =
144− modifyMVar_ (localState node) $ \st -> do
145− let shouldClose (_, to') (_, WithImplicitReconnect) = to `impliesDeathOf` to'
146− shouldClose _ _ = False
147− let (affected, unaffected) = Map.partitionWithKey shouldClose (st ^. localConnections)
148− mapM_ (NT.close . fst) (Map.elems affected)
149− return (localConnections ^= unaffected $ st)
150−
151−-- | @a `impliesDeathOf` b@ is true if the death of @a@ (for instance, a node)
152−-- implies the death of @b@ (for instance, a process on that node)
153−impliesDeathOf :: Identifier
154− -> Identifier
155− -> Bool
156−NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
157− nid' == nid
158−NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
159− processNodeId pid == nid
160−NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =
161− processNodeId (sendPortProcessId cid) == nid
162−ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =
163− pid' == pid
164−ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =
165− sendPortProcessId cid == pid
166−SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =
167− cid' == cid
168−_ `impliesDeathOf` _ =
169− False
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hsdeleted−615
@@ -1,615 +0,0 @@
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− , whereisRemoteAsync
42− , nsendRemote
43− -- * Closures
44− , unClosure
45− -- * Exception handling
46− , catch
47− , mask
48− , onException
49− , bracket
50− , bracket_
51− , finally
52− -- * Auxiliary API
53− , expectTimeout
54− , spawnAsync
55− , linkNode
56− , linkPort
57− , unlinkNode
58− , unlinkPort
59− , monitorNode
60− , monitorPort
61− -- * Reconnecting
62− , reconnect
63− , reconnectPort
64− ) where
65−
66−#if ! MIN_VERSION_base(4,6,0)
67−import Prelude hiding (catch)
68−#endif
69−
70−import Data.Binary (decode)
71−import Data.Time.Clock (getCurrentTime)
72−import Data.Time.Format (formatTime)
73−import System.Locale (defaultTimeLocale)
74−import Control.Monad.Reader (ask)
75−import Control.Monad.IO.Class (MonadIO, liftIO)
76−import Control.Applicative ((<$>))
77−import Control.Exception (Exception, throwIO, SomeException)
78−import qualified Control.Exception as Ex (catch, mask)
79−import Control.Distributed.Process.Internal.StrictMVar (modifyMVar)
80−import Control.Concurrent.Chan (writeChan)
81−import Control.Concurrent.STM
82− ( STM
83− , atomically
84− , orElse
85− , newTChan
86− , readTChan
87− , newTVar
88− , readTVar
89− , writeTVar
90− )
91−import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..))
92−import Control.Distributed.Process.Serializable (Serializable, fingerprint)
93−import Data.Accessor ((^.), (^:), (^=))
94−import Control.Distributed.Static (Closure)
95−import Data.Rank1Typeable (Typeable)
96−import qualified Control.Distributed.Static as Static (unclosure)
97−import Control.Distributed.Process.Internal.Types
98− ( NodeId(..)
99− , ProcessId(..)
100− , LocalNode(..)
101− , LocalProcess(..)
102− , Process(..)
103− , Message(..)
104− , MonitorRef(..)
105− , SpawnRef(..)
106− , NCMsg(..)
107− , ProcessSignal(..)
108− , monitorCounter
109− , spawnCounter
110− , SendPort(..)
111− , ReceivePort(..)
112− , channelCounter
113− , typedChannelWithId
114− , TypedChannel(..)
115− , SendPortId(..)
116− , Identifier(..)
117− , DidUnmonitor(..)
118− , DidUnlinkProcess(..)
119− , DidUnlinkNode(..)
120− , DidUnlinkPort(..)
121− , WhereIsReply(..)
122− , createMessage
123− , runLocalProcess
124− , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
125− )
126−import Control.Distributed.Process.Internal.Messaging
127− ( sendMessage
128− , sendBinary
129− , disconnect
130− )
131−
132−--------------------------------------------------------------------------------
133−-- Basic messaging --
134−--------------------------------------------------------------------------------
135−
136−-- | Send a message
137−send :: Serializable a => ProcessId -> a -> Process ()
138−-- This requires a lookup on every send. If we want to avoid that we need to
139−-- modify serializable to allow for stateful (IO) deserialization
140−send them msg = do
141− proc <- ask
142− liftIO $ sendMessage (processNode proc)
143− (ProcessIdentifier (processId proc))
144− (ProcessIdentifier them)
145− NoImplicitReconnect
146− msg
147−
148−-- | Wait for a message of a specific type
149−expect :: forall a. Serializable a => Process a
150−expect = receiveWait [match return]
151−
152−--------------------------------------------------------------------------------
153−-- Channels --
154−--------------------------------------------------------------------------------
155−
156−-- | Create a new typed channel
157−newChan :: Serializable a => Process (SendPort a, ReceivePort a)
158−newChan = do
159− proc <- ask
160− liftIO . modifyMVar (processState proc) $ \st -> do
161− chan <- liftIO . atomically $ newTChan
162− let lcid = st ^. channelCounter
163− cid = SendPortId { sendPortProcessId = processId proc
164− , sendPortLocalId = lcid
165− }
166− sport = SendPort cid
167− rport = ReceivePortSingle chan
168− tch = TypedChannel chan
169− return ( (channelCounter ^: (+ 1))
170− . (typedChannelWithId lcid ^= Just tch)
171− $ st
172− , (sport, rport)
173− )
174−
175−-- | Send a message on a typed channel
176−sendChan :: Serializable a => SendPort a -> a -> Process ()
177−sendChan (SendPort cid) msg = do
178− proc <- ask
179− liftIO $ sendBinary (processNode proc)
180− (ProcessIdentifier (processId proc))
181− (SendPortIdentifier cid)
182− NoImplicitReconnect
183− msg
184−
185−-- | Wait for a message on a typed channel
186−receiveChan :: Serializable a => ReceivePort a -> Process a
187−receiveChan = liftIO . atomically . receiveSTM
188− where
189− receiveSTM :: ReceivePort a -> STM a
190− receiveSTM (ReceivePortSingle c) =
191− readTChan c
192− receiveSTM (ReceivePortBiased ps) =
193− foldr1 orElse (map receiveSTM ps)
194− receiveSTM (ReceivePortRR psVar) = do
195− ps <- readTVar psVar
196− a <- foldr1 orElse (map receiveSTM ps)
197− writeTVar psVar (rotate ps)
198− return a
199−
200− rotate :: [a] -> [a]
201− rotate [] = []
202− rotate (x:xs) = xs ++ [x]
203−
204−-- | Merge a list of typed channels.
205−--
206−-- The result port is left-biased: if there are messages available on more
207−-- than one port, the first available message is returned.
208−mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
209−mergePortsBiased = return . ReceivePortBiased
210−
211−-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than
212−-- left-biased)
213−mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
214−mergePortsRR ps = liftIO . atomically $ ReceivePortRR <$> newTVar ps
215−
216−--------------------------------------------------------------------------------
217−-- Advanced messaging --
218−--------------------------------------------------------------------------------
219−
220−-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
221−newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }
222−
223−-- | Test the matches in order against each message in the queue
224−receiveWait :: [Match b] -> Process b
225−receiveWait ms = do
226− queue <- processQueue <$> ask
227− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
228− proc
229−
230−-- | Like 'receiveWait' but with a timeout.
231−--
232−-- If the timeout is zero do a non-blocking check for matching messages. A
233−-- non-zero timeout is applied only when waiting for incoming messages (that is,
234−-- /after/ we have checked the messages that are already in the mailbox).
235−receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
236−receiveTimeout t ms = do
237− queue <- processQueue <$> ask
238− let blockSpec = if t == 0 then NonBlocking else Timeout t
239− mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)
240− case mProc of
241− Nothing -> return Nothing
242− Just proc -> Just <$> proc
243−
244−-- | Match against any message of the right type
245−match :: forall a b. Serializable a => (a -> Process b) -> Match b
246−match = matchIf (const True)
247−
248−-- | Match against any message of the right type that satisfies a predicate
249−matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
250−matchIf c p = Match $ \msg ->
251− let decoded :: a
252− decoded = decode . messageEncoding $ msg in
253− if messageFingerprint msg == fingerprint (undefined :: a) && c decoded
254− then Just $ p decoded
255− else Nothing
256−
257−-- | Remove any message from the queue
258−matchUnknown :: Process b -> Match b
259−matchUnknown = Match . const . Just
260−
261−--------------------------------------------------------------------------------
262−-- Process management --
263−--------------------------------------------------------------------------------
264−
265−-- | Thrown by 'terminate'
266−data ProcessTerminationException = ProcessTerminationException
267− deriving (Show, Typeable)
268−
269−instance Exception ProcessTerminationException
270−
271−-- | Terminate (throws a ProcessTerminationException)
272−terminate :: Process a
273−terminate = liftIO $ throwIO ProcessTerminationException
274−
275−-- | Our own process ID
276−getSelfPid :: Process ProcessId
277−getSelfPid = processId <$> ask
278−
279−-- | Get the node ID of our local node
280−getSelfNode :: Process NodeId
281−getSelfNode = localNodeId . processNode <$> ask
282−
283−--------------------------------------------------------------------------------
284−-- Monitoring and linking --
285−--------------------------------------------------------------------------------
286−
287−-- | Link to a remote process (asynchronous)
288−--
289−-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').
290−-- Linking makes no distinction between normal and abnormal termination of
291−-- the remote process.
292−link :: ProcessId -> Process ()
293−link = sendCtrlMsg Nothing . Link . ProcessIdentifier
294−
295−-- | Monitor another process (asynchronous)
296−monitor :: ProcessId -> Process MonitorRef
297−monitor = monitor' . ProcessIdentifier
298−
299−-- | Remove a link
300−--
301−-- This is synchronous in the sense that once it returns you are guaranteed
302−-- that no exception will be raised if the remote process dies. However, it is
303−-- asynchronous in the sense that we do not wait for a response from the remote
304−-- node.
305−unlink :: ProcessId -> Process ()
306−unlink pid = do
307− unlinkAsync pid
308− receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
309− (\_ -> return ())
310− ]
311−
312−-- | Remove a node link
313−--
314−-- This has the same synchronous/asynchronous nature as 'unlink'.
315−unlinkNode :: NodeId -> Process ()
316−unlinkNode nid = do
317− unlinkNodeAsync nid
318− receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)
319− (\_ -> return ())
320− ]
321−
322−-- | Remove a channel (send port) link
323−--
324−-- This has the same synchronous/asynchronous nature as 'unlink'.
325−unlinkPort :: SendPort a -> Process ()
326−unlinkPort sport = do
327− unlinkPortAsync sport
328− receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)
329− (\_ -> return ())
330− ]
331−
332−-- | Remove a monitor
333−--
334−-- This has the same synchronous/asynchronous nature as 'unlink'.
335−unmonitor :: MonitorRef -> Process ()
336−unmonitor ref = do
337− unmonitorAsync ref
338− receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)
339− (\_ -> return ())
340− ]
341−
342−--------------------------------------------------------------------------------
343−-- Exception handling --
344−--------------------------------------------------------------------------------
345−
346−-- | Lift 'Control.Exception.catch'
347−catch :: Exception e => Process a -> (e -> Process a) -> Process a
348−catch p h = do
349− lproc <- ask
350− liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
351−
352−-- | Lift 'Control.Exception.mask'
353−mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b
354−mask p = do
355− lproc <- ask
356− liftIO $ Ex.mask $ \restore ->
357− runLocalProcess lproc (p (liftRestore lproc restore))
358− where
359− liftRestore :: LocalProcess -> (forall a. IO a -> IO a) -> (forall a. Process a -> Process a)
360− liftRestore lproc restoreIO = liftIO . restoreIO . runLocalProcess lproc
361−
362−-- | Lift 'Control.Exception.onException'
363−onException :: Process a -> Process b -> Process a
364−onException p what = p `catch` \e -> do _ <- what
365− liftIO $ throwIO (e :: SomeException)
366−
367−-- | Lift 'Control.Exception.bracket'
368−bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c
369−bracket before after thing =
370− mask $ \restore -> do
371− a <- before
372− r <- restore (thing a) `onException` after a
373− _ <- after a
374− return r
375−
376−-- | Lift 'Control.Exception.bracket_'
377−bracket_ :: Process a -> Process b -> Process c -> Process c
378−bracket_ before after thing = bracket before (const after) (const thing)
379−
380−-- | Lift 'Control.Exception.finally'
381−finally :: Process a -> Process b -> Process a
382−finally a sequel = bracket_ (return ()) sequel a
383−
384−--------------------------------------------------------------------------------
385−-- Auxiliary API --
386−--------------------------------------------------------------------------------
387−
388−-- | Like 'expect' but with a timeout
389−expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
390−expectTimeout timeout = receiveTimeout timeout [match return]
391−
392−-- | Asynchronous version of 'spawn'
393−--
394−-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
395−spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
396−spawnAsync nid proc = do
397− spawnRef <- getSpawnRef
398− sendCtrlMsg (Just nid) $ Spawn proc spawnRef
399− return spawnRef
400−
401−-- | Monitor a node (asynchronous)
402−monitorNode :: NodeId -> Process MonitorRef
403−monitorNode =
404− monitor' . NodeIdentifier
405−
406−-- | Monitor a typed channel (asynchronous)
407−monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
408−monitorPort (SendPort cid) =
409− monitor' (SendPortIdentifier cid)
410−
411−-- | Remove a monitor (asynchronous)
412−unmonitorAsync :: MonitorRef -> Process ()
413−unmonitorAsync =
414− sendCtrlMsg Nothing . Unmonitor
415−
416−-- | Link to a node (asynchronous)
417−linkNode :: NodeId -> Process ()
418−linkNode = link' . NodeIdentifier
419−
420−-- | Link to a channel (asynchronous)
421−linkPort :: SendPort a -> Process ()
422−linkPort (SendPort cid) =
423− link' (SendPortIdentifier cid)
424−
425−-- | Remove a process link (asynchronous)
426−unlinkAsync :: ProcessId -> Process ()
427−unlinkAsync =
428− sendCtrlMsg Nothing . Unlink . ProcessIdentifier
429−
430−-- | Remove a node link (asynchronous)
431−unlinkNodeAsync :: NodeId -> Process ()
432−unlinkNodeAsync =
433− sendCtrlMsg Nothing . Unlink . NodeIdentifier
434−
435−-- | Remove a channel (send port) link (asynchronous)
436−unlinkPortAsync :: SendPort a -> Process ()
437−unlinkPortAsync (SendPort cid) =
438− sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
439−
440−--------------------------------------------------------------------------------
441−-- Logging --
442−--------------------------------------------------------------------------------
443−
444−-- | Log a string
445−--
446−-- @say message@ sends a message (time, pid of the current process, message)
447−-- to the process registered as 'logger'. By default, this process simply
448−-- sends the string to 'stderr'. Individual Cloud Haskell backends might
449−-- replace this with a different logger process, however.
450−say :: String -> Process ()
451−say string = do
452− now <- liftIO getCurrentTime
453− us <- getSelfPid
454− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)
455−
456−--------------------------------------------------------------------------------
457−-- Registry --
458−--------------------------------------------------------------------------------
459−
460−-- | Register a process with the local registry (asynchronous).
461−--
462−-- The process to be registered does not have to be local itself.
463−register :: String -> ProcessId -> Process ()
464−register label pid =
465− sendCtrlMsg Nothing (Register label (Just pid))
466−
467−-- | Register a process with a remote registry (asynchronous).
468−--
469−-- The process to be registered does not have to live on the same remote node.
470−registerRemote :: NodeId -> String -> ProcessId -> Process ()
471−registerRemote nid label pid =
472− sendCtrlMsg (Just nid) (Register label (Just pid))
473−
474−-- | Remove a process from the local registry (asynchronous).
475−unregister :: String -> Process ()
476−unregister label =
477− sendCtrlMsg Nothing (Register label Nothing)
478−
479−-- | Remove a process from a remote registry (asynchronous).
480−unregisterRemote :: NodeId -> String -> Process ()
481−unregisterRemote nid label =
482− sendCtrlMsg (Just nid) (Register label Nothing)
483−
484−-- | Query the local process registry
485−whereis :: String -> Process (Maybe ProcessId)
486−whereis label = do
487− sendCtrlMsg Nothing (WhereIs label)
488− receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
489− (\(WhereIsReply _ mPid) -> return mPid)
490− ]
491−
492−-- | Query a remote process registry (asynchronous)
493−--
494−-- Reply will come in the form of a 'WhereIsReply' message.
495−--
496−-- There is currently no synchronous version of 'whereisRemoteAsync': if
497−-- you implement one yourself, be sure to take into account that the remote
498−-- node might die or get disconnect before it can respond (i.e. you should
499−-- use 'monitorNode' and take appropriate action when you receive a
500−-- 'NodeMonitorNotification').
501−whereisRemoteAsync :: NodeId -> String -> Process ()
502−whereisRemoteAsync nid label =
503− sendCtrlMsg (Just nid) (WhereIs label)
504−
505−-- | Named send to a process in the local registry (asynchronous)
506−nsend :: Serializable a => String -> a -> Process ()
507−nsend label msg =
508− sendCtrlMsg Nothing (NamedSend label (createMessage msg))
509−
510−-- | Named send to a process in a remote registry (asynchronous)
511−nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
512−nsendRemote nid label msg =
513− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
514−
515−--------------------------------------------------------------------------------
516−-- Closures --
517−--------------------------------------------------------------------------------
518−
519−-- | Deserialize a closure
520−unClosure :: forall a. Typeable a => Closure a -> Process a
521−unClosure closure = do
522− rtable <- remoteTable . processNode <$> ask
523− case Static.unclosure rtable closure of
524− Left err -> fail $ "Could not resolve closure: " ++ err
525− Right x -> return x
526−
527−--------------------------------------------------------------------------------
528−-- Reconnecting --
529−--------------------------------------------------------------------------------
530−
531−-- | Cloud Haskell provides the illusion of connection-less, reliable, ordered
532−-- message passing. However, when network connections get disrupted this
533−-- illusion cannot always be maintained. Once a network connection breaks (even
534−-- temporarily) no further communication on that connection will be possible.
535−-- For example, if process A sends a message to process B, and A is then
536−-- notified (by monitor notification) that it got disconnected from B, A will
537−-- not be able to send any further messages to B, /unless/ A explicitly
538−-- indicates that it is acceptable to attempt to reconnect to B using the
539−-- Cloud Haskell 'reconnect' primitive.
540−--
541−-- Importantly, when A calls 'reconnect' it acknowledges that some messages to
542−-- B might have been lost. For instance, if A sends messages m1 and m2 to B,
543−-- then receives a monitor notification that its connection to B has been lost,
544−-- calls 'reconnect' and then sends m3, it is possible that B will receive m1
545−-- and m3 but not m2.
546−--
547−-- Note that 'reconnect' does not mean /reconnect now/ but rather /it is okay
548−-- to attempt to reconnect on the next send/. In particular, if no further
549−-- communication attempts are made to B then A can use reconnect to clean up
550−-- its connection to B.
551−reconnect :: ProcessId -> Process ()
552−reconnect them = do
553− us <- getSelfPid
554− node <- processNode <$> ask
555− liftIO $ disconnect node (ProcessIdentifier us) (ProcessIdentifier them)
556−
557−-- | Reconnect to a sendport. See 'reconnect' for more information.
558−reconnectPort :: SendPort a -> Process ()
559−reconnectPort them = do
560− us <- getSelfPid
561− node <- processNode <$> ask
562− liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))
563−
564−--------------------------------------------------------------------------------
565−-- Auxiliary functions --
566−--------------------------------------------------------------------------------
567−
568−getMonitorRefFor :: Identifier -> Process MonitorRef
569−getMonitorRefFor ident = do
570− proc <- ask
571− liftIO $ modifyMVar (processState proc) $ \st -> do
572− let counter = st ^. monitorCounter
573− return ( monitorCounter ^: (+ 1) $ st
574− , MonitorRef ident counter
575− )
576−
577−getSpawnRef :: Process SpawnRef
578−getSpawnRef = do
579− proc <- ask
580− liftIO $ modifyMVar (processState proc) $ \st -> do
581− let counter = st ^. spawnCounter
582− return ( spawnCounter ^: (+ 1) $ st
583− , SpawnRef counter
584− )
585−
586−-- | Monitor a process/node/channel
587−monitor' :: Identifier -> Process MonitorRef
588−monitor' ident = do
589− monitorRef <- getMonitorRefFor ident
590− sendCtrlMsg Nothing $ Monitor monitorRef
591− return monitorRef
592−
593−-- | Link to a process/node/channel
594−link' :: Identifier -> Process ()
595−link' = sendCtrlMsg Nothing . Link
596−
597−-- Send a control message
598−sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
599− -> ProcessSignal -- ^ Message to send
600− -> Process ()
601−sendCtrlMsg mNid signal = do
602− proc <- ask
603− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
604− , ctrlMsgSignal = signal
605− }
606− case mNid of
607− Nothing -> do
608− ctrlChan <- localCtrlChan . processNode <$> ask
609− liftIO $ writeChan ctrlChan msg
610− Just nid ->
611− liftIO $ sendBinary (processNode proc)
612− (ProcessIdentifier (processId proc))
613− (NodeIdentifier nid)
614− WithImplicitReconnect
615− msg
distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hsdeleted−51
@@ -1,51 +0,0 @@
1−-- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF
2−module Control.Distributed.Process.Internal.StrictMVar
3− ( StrictMVar
4− , newEmptyMVar
5− , newMVar
6− , takeMVar
7− , putMVar
8− , withMVar
9− , modifyMVar_
10− , modifyMVar
11− ) where
12−
13−import Control.Applicative ((<$>))
14−import Control.Monad ((>=>))
15−import Control.Exception (evaluate)
16−import qualified Control.Concurrent.MVar as MVar
17− ( MVar
18− , newEmptyMVar
19− , newMVar
20− , takeMVar
21− , putMVar
22− , withMVar
23− , modifyMVar_
24− , modifyMVar
25− )
26−
27−newtype StrictMVar a = StrictMVar (MVar.MVar a)
28−
29−newEmptyMVar :: IO (StrictMVar a)
30−newEmptyMVar = StrictMVar <$> MVar.newEmptyMVar
31−
32−newMVar :: a -> IO (StrictMVar a)
33−newMVar x = evaluate x >> StrictMVar <$> MVar.newMVar x
34−
35−takeMVar :: StrictMVar a -> IO a
36−takeMVar (StrictMVar v) = MVar.takeMVar v
37−
38−putMVar :: StrictMVar a -> a -> IO ()
39−putMVar (StrictMVar v) x = evaluate x >> MVar.putMVar v x
40−
41−withMVar :: StrictMVar a -> (a -> IO b) -> IO b
42−withMVar (StrictMVar v) = MVar.withMVar v
43−
44−modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO ()
45−modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)
46−
47−modifyMVar :: StrictMVar a -> (a -> IO (a, b)) -> IO b
48−modifyMVar (StrictMVar v) f = MVar.modifyMVar v (f >=> evaluateFst)
49− where
50− evaluateFst :: (a, b) -> IO (a, b)
51− evaluateFst (x, y) = evaluate x >> return (x, y)
distributed-process/src/Control/Distributed/Process/Internal/Types.hsdeleted−544
@@ -1,544 +0,0 @@
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−module Control.Distributed.Process.Internal.Types
7− ( -- * Node and process identifiers
8− NodeId(..)
9− , LocalProcessId(..)
10− , ProcessId(..)
11− , Identifier(..)
12− , nodeOf
13− , firstNonReservedProcessId
14− , nullProcessId
15− -- * Local nodes and processes
16− , LocalNode(..)
17− , LocalNodeState(..)
18− , LocalProcess(..)
19− , LocalProcessState(..)
20− , Process(..)
21− , runLocalProcess
22− , ImplicitReconnect(..)
23− -- * Typed channels
24− , LocalSendPortId
25− , SendPortId(..)
26− , TypedChannel(..)
27− , SendPort(..)
28− , ReceivePort(..)
29− -- * Messages
30− , Message(..)
31− , createMessage
32− , messageToPayload
33− , payloadToMessage
34− -- * Node controller user-visible data types
35− , MonitorRef(..)
36− , ProcessMonitorNotification(..)
37− , NodeMonitorNotification(..)
38− , PortMonitorNotification(..)
39− , ProcessLinkException(..)
40− , NodeLinkException(..)
41− , PortLinkException(..)
42− , DiedReason(..)
43− , DidUnmonitor(..)
44− , DidUnlinkProcess(..)
45− , DidUnlinkNode(..)
46− , DidUnlinkPort(..)
47− , SpawnRef(..)
48− , DidSpawn(..)
49− , WhereIsReply(..)
50− -- * Node controller internal data types
51− , NCMsg(..)
52− , ProcessSignal(..)
53− -- * Accessors
54− , localProcesses
55− , localPidCounter
56− , localPidUnique
57− , localConnections
58− , localProcessWithId
59− , localConnectionBetween
60− , monitorCounter
61− , spawnCounter
62− , channelCounter
63− , typedChannels
64− , typedChannelWithId
65− ) where
66−
67−import Data.Map (Map)
68−import Data.Int (Int32)
69−import Data.Typeable (Typeable)
70−import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
71−import qualified Data.ByteString as BSS (ByteString, concat)
72−import qualified Data.ByteString.Lazy as BSL
73− ( ByteString
74− , toChunks
75− , splitAt
76− , fromChunks
77− )
78−import Data.Accessor (Accessor, accessor)
79−import qualified Data.Accessor.Container as DAC (mapMaybe)
80−import Control.Category ((>>>))
81−import Control.Exception (Exception)
82−import Control.Concurrent (ThreadId)
83−import Control.Concurrent.Chan (Chan)
84−import Control.Concurrent.STM (TChan, TVar)
85−import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
86−import Control.Applicative (Applicative, (<$>), (<*>))
87−import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
88−import Control.Monad.IO.Class (MonadIO)
89−import Control.Distributed.Process.Serializable
90− ( Fingerprint
91− , Serializable
92− , fingerprint
93− , encodeFingerprint
94− , sizeOfFingerprint
95− , decodeFingerprint
96− , showFingerprint
97− )
98−import Control.Distributed.Process.Internal.CQueue (CQueue)
99−import Control.Distributed.Process.Internal.StrictMVar (StrictMVar)
100−import Control.Distributed.Static (RemoteTable, Closure)
101−
102−--------------------------------------------------------------------------------
103−-- Node and process identifiers --
104−--------------------------------------------------------------------------------
105−
106−-- | Node identifier
107−newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
108− deriving (Eq, Ord, Binary)
109−
110−instance Show NodeId where
111− show (NodeId addr) = "nid://" ++ show addr
112−
113−-- | A local process ID consists of a seed which distinguishes processes from
114−-- different instances of the same local node and a counter
115−data LocalProcessId = LocalProcessId
116− { lpidUnique :: {-# UNPACK #-} !Int32
117− , lpidCounter :: {-# UNPACK #-} !Int32
118− }
119− deriving (Eq, Ord, Typeable, Show)
120−
121−-- | Process identifier
122−data ProcessId = ProcessId
123− { -- | The ID of the node the process is running on
124− processNodeId :: !NodeId
125− -- | Node-local identifier for the process
126− , processLocalId :: {-# UNPACK #-} !LocalProcessId
127− }
128− deriving (Eq, Ord, Typeable)
129−
130−instance Show ProcessId where
131− show (ProcessId (NodeId addr) (LocalProcessId _ lid))
132− = "pid://" ++ show addr ++ ":" ++ show lid
133−
134−-- | Union of all kinds of identifiers
135−data Identifier =
136− NodeIdentifier NodeId
137− | ProcessIdentifier ProcessId
138− | SendPortIdentifier SendPortId
139− deriving (Eq, Ord)
140−
141−instance Show Identifier where
142− show (NodeIdentifier nid) = show nid
143− show (ProcessIdentifier pid) = show pid
144− show (SendPortIdentifier cid) = show cid
145−
146−nodeOf :: Identifier -> NodeId
147−nodeOf (NodeIdentifier nid) = nid
148−nodeOf (ProcessIdentifier pid) = processNodeId pid
149−nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)
150−
151−--------------------------------------------------------------------------------
152−-- Special PIDs --
153−--------------------------------------------------------------------------------
154−
155−firstNonReservedProcessId :: Int32
156−firstNonReservedProcessId = 1
157−
158−nullProcessId :: NodeId -> ProcessId
159−nullProcessId nid =
160− ProcessId { processNodeId = nid
161− , processLocalId = LocalProcessId { lpidUnique = 0
162− , lpidCounter = 0
163− }
164− }
165−
166−--------------------------------------------------------------------------------
167−-- Local nodes and processes --
168−--------------------------------------------------------------------------------
169−
170−-- | Local nodes
171−data LocalNode = LocalNode
172− { -- | 'NodeId' of the node
173− localNodeId :: NodeId
174− -- | The network endpoint associated with this node
175− , localEndPoint :: NT.EndPoint
176− -- | Local node state
177− , localState :: StrictMVar LocalNodeState
178− -- | Channel for the node controller
179− , localCtrlChan :: Chan NCMsg
180− -- | Runtime lookup table for supporting closures
181− -- TODO: this should be part of the CH state, not the local endpoint state
182− , remoteTable :: RemoteTable
183− }
184−
185−data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
186− deriving (Eq, Show)
187−
188−-- | Local node state
189−data LocalNodeState = LocalNodeState
190− { -- | Processes running on this node
191− _localProcesses :: !(Map LocalProcessId LocalProcess)
192− -- | Counter to assign PIDs
193− , _localPidCounter :: !Int32
194− -- | The 'unique' value used to create PIDs (so that processes on
195− -- restarted nodes have new PIDs)
196− , _localPidUnique :: !Int32
197− -- | Outgoing connections
198− , _localConnections :: !(Map (Identifier, Identifier)
199− (NT.Connection, ImplicitReconnect))
200− }
201−
202−-- | Processes running on our local node
203−data LocalProcess = LocalProcess
204− { processQueue :: CQueue Message
205− , processId :: ProcessId
206− , processState :: StrictMVar LocalProcessState
207− , processThread :: ThreadId
208− , processNode :: LocalNode
209− }
210−
211−-- | Deconstructor for 'Process' (not exported to the public API)
212−runLocalProcess :: LocalProcess -> Process a -> IO a
213−runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
214−
215−-- | Local process state
216−data LocalProcessState = LocalProcessState
217− { _monitorCounter :: !Int32
218− , _spawnCounter :: !Int32
219− , _channelCounter :: !Int32
220− , _typedChannels :: !(Map LocalSendPortId TypedChannel)
221− }
222−
223−-- | The Cloud Haskell 'Process' type
224−newtype Process a = Process {
225− unProcess :: ReaderT LocalProcess IO a
226− }
227− deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
228−
229−--------------------------------------------------------------------------------
230−-- Typed channels --
231−--------------------------------------------------------------------------------
232−
233−type LocalSendPortId = Int32
234−
235−-- | A send port is identified by a SendPortId.
236−--
237−-- You cannot send directly to a SendPortId; instead, use 'newChan'
238−-- to create a SendPort.
239−data SendPortId = SendPortId {
240− -- | The ID of the process that will receive messages sent on this port
241− sendPortProcessId :: {-# UNPACK #-} !ProcessId
242− -- | Process-local ID of the channel
243− , sendPortLocalId :: {-# UNPACK #-} !LocalSendPortId
244− }
245− deriving (Eq, Ord)
246−
247−instance Show SendPortId where
248− show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
249− = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
250−
251−data TypedChannel = forall a. Serializable a => TypedChannel (TChan a)
252−
253−-- | The send send of a typed channel (serializable)
254−newtype SendPort a = SendPort {
255− -- | The (unique) ID of this send port
256− sendPortId :: SendPortId
257− }
258− deriving (Typeable, Binary, Show, Eq, Ord)
259−
260−-- | The receive end of a typed channel (not serializable)
261−data ReceivePort a =
262− -- | A single receive port
263− ReceivePortSingle (TChan a)
264− -- | A left-biased combination of receive ports
265− | ReceivePortBiased [ReceivePort a]
266− -- | A round-robin combination of receive ports
267− | ReceivePortRR (TVar [ReceivePort a])
268− deriving Typeable
269−
270−--------------------------------------------------------------------------------
271−-- Messages --
272−--------------------------------------------------------------------------------
273−
274−-- | Messages consist of their typeRep fingerprint and their encoding
275−data Message = Message
276− { messageFingerprint :: Fingerprint
277− , messageEncoding :: BSL.ByteString
278− }
279−
280−instance Show Message where
281− show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
282−
283−-- | Turn any serialiable term into a message
284−createMessage :: Serializable a => a -> Message
285−createMessage a = Message (fingerprint a) (encode a)
286−
287−-- | Serialize a message
288−messageToPayload :: Message -> [BSS.ByteString]
289−messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc
290−
291−-- | Deserialize a message
292−payloadToMessage :: [BSS.ByteString] -> Message
293−payloadToMessage payload = Message fp msg
294− where
295− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
296− $ BSL.fromChunks payload
297− fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
298−
299−--------------------------------------------------------------------------------
300−-- Node controller user-visible data types --
301−--------------------------------------------------------------------------------
302−
303−-- | MonitorRef is opaque for regular Cloud Haskell processes
304−data MonitorRef = MonitorRef
305− { -- | ID of the entity to be monitored
306− monitorRefIdent :: !Identifier
307− -- | Unique to distinguish multiple monitor requests by the same process
308− , monitorRefCounter :: !Int32
309− }
310− deriving (Eq, Ord, Show)
311−
312−-- | Message sent by process monitors
313−data ProcessMonitorNotification =
314− ProcessMonitorNotification MonitorRef ProcessId DiedReason
315− deriving (Typeable, Show)
316−
317−-- | Message sent by node monitors
318−data NodeMonitorNotification =
319− NodeMonitorNotification MonitorRef NodeId DiedReason
320− deriving (Typeable, Show)
321−
322−-- | Message sent by channel (port) monitors
323−data PortMonitorNotification =
324− PortMonitorNotification MonitorRef SendPortId DiedReason
325− deriving (Typeable, Show)
326−
327−-- | Exceptions thrown when a linked process dies
328−data ProcessLinkException =
329− ProcessLinkException ProcessId DiedReason
330− deriving (Typeable, Show)
331−
332−-- | Exception thrown when a linked node dies
333−data NodeLinkException =
334− NodeLinkException NodeId DiedReason
335− deriving (Typeable, Show)
336−
337−-- | Exception thrown when a linked channel (port) dies
338−data PortLinkException =
339− PortLinkException SendPortId DiedReason
340− deriving (Typeable, Show)
341−
342−instance Exception ProcessLinkException
343−instance Exception NodeLinkException
344−instance Exception PortLinkException
345−
346−-- | Why did a process die?
347−data DiedReason =
348− -- | Normal termination
349− DiedNormal
350− -- | The process exited with an exception
351− -- (provided as 'String' because 'Exception' does not implement 'Binary')
352− | DiedException String
353− -- | We got disconnected from the process node
354− | DiedDisconnect
355− -- | The process node died
356− | DiedNodeDown
357− -- | Invalid (process/node/channel) identifier
358− | DiedUnknownId
359− deriving (Show, Eq)
360−
361−-- | (Asynchronous) reply from unmonitor
362−newtype DidUnmonitor = DidUnmonitor MonitorRef
363− deriving (Typeable, Binary)
364−
365−-- | (Asynchronous) reply from unlink
366−newtype DidUnlinkProcess = DidUnlinkProcess ProcessId
367− deriving (Typeable, Binary)
368−
369−-- | (Asynchronous) reply from unlinkNode
370−newtype DidUnlinkNode = DidUnlinkNode NodeId
371− deriving (Typeable, Binary)
372−
373−-- | (Asynchronous) reply from unlinkPort
374−newtype DidUnlinkPort = DidUnlinkPort SendPortId
375− deriving (Typeable, Binary)
376−
377−-- | 'SpawnRef' are used to return pids of spawned processes
378−newtype SpawnRef = SpawnRef Int32
379− deriving (Show, Binary, Typeable, Eq)
380−
381−-- | (Asynchronius) reply from 'spawn'
382−data DidSpawn = DidSpawn SpawnRef ProcessId
383− deriving (Show, Typeable)
384−
385−-- | (Asynchronous) reply from 'whereis'
386−data WhereIsReply = WhereIsReply String (Maybe ProcessId)
387− deriving (Show, Typeable)
388−
389−--------------------------------------------------------------------------------
390−-- Node controller internal data types --
391−--------------------------------------------------------------------------------
392−
393−-- | Messages to the node controller
394−data NCMsg = NCMsg
395− { ctrlMsgSender :: Identifier
396− , ctrlMsgSignal :: ProcessSignal
397− }
398− deriving Show
399−
400−-- | Signals to the node controller (see 'NCMsg')
401−data ProcessSignal =
402− Link Identifier
403− | Unlink Identifier
404− | Monitor MonitorRef
405− | Unmonitor MonitorRef
406− | Died Identifier DiedReason
407− | Spawn (Closure (Process ())) SpawnRef
408− | WhereIs String
409− | Register String (Maybe ProcessId) -- Nothing to unregister
410− | NamedSend String Message
411− deriving Show
412−
413−--------------------------------------------------------------------------------
414−-- Binary instances --
415−--------------------------------------------------------------------------------
416−
417−instance Binary LocalProcessId where
418− put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
419− get = LocalProcessId <$> get <*> get
420−
421−instance Binary ProcessId where
422− put pid = put (processNodeId pid) >> put (processLocalId pid)
423− get = ProcessId <$> get <*> get
424−
425−instance Binary ProcessMonitorNotification where
426− put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
427− get = ProcessMonitorNotification <$> get <*> get <*> get
428−
429−instance Binary NodeMonitorNotification where
430− put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason
431− get = NodeMonitorNotification <$> get <*> get <*> get
432−
433−instance Binary PortMonitorNotification where
434− put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason
435− get = PortMonitorNotification <$> get <*> get <*> get
436−
437−instance Binary NCMsg where
438− put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)
439− get = NCMsg <$> get <*> get
440−
441−instance Binary MonitorRef where
442− put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)
443− get = MonitorRef <$> get <*> get
444−
445−instance Binary ProcessSignal where
446− put (Link pid) = putWord8 0 >> put pid
447− put (Unlink pid) = putWord8 1 >> put pid
448− put (Monitor ref) = putWord8 2 >> put ref
449− put (Unmonitor ref) = putWord8 3 >> put ref
450− put (Died who reason) = putWord8 4 >> put who >> put reason
451− put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
452− put (WhereIs label) = putWord8 6 >> put label
453− put (Register label pid) = putWord8 7 >> put label >> put pid
454− put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
455− get = do
456− header <- getWord8
457− case header of
458− 0 -> Link <$> get
459− 1 -> Unlink <$> get
460− 2 -> Monitor <$> get
461− 3 -> Unmonitor <$> get
462− 4 -> Died <$> get <*> get
463− 5 -> Spawn <$> get <*> get
464− 6 -> WhereIs <$> get
465− 7 -> Register <$> get <*> get
466− 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
467− _ -> fail "ProcessSignal.get: invalid"
468−
469−instance Binary DiedReason where
470− put DiedNormal = putWord8 0
471− put (DiedException e) = putWord8 1 >> put e
472− put DiedDisconnect = putWord8 2
473− put DiedNodeDown = putWord8 3
474− put DiedUnknownId = putWord8 4
475− get = do
476− header <- getWord8
477− case header of
478− 0 -> return DiedNormal
479− 1 -> DiedException <$> get
480− 2 -> return DiedDisconnect
481− 3 -> return DiedNodeDown
482− 4 -> return DiedUnknownId
483− _ -> fail "DiedReason.get: invalid"
484−
485−instance Binary DidSpawn where
486− put (DidSpawn ref pid) = put ref >> put pid
487− get = DidSpawn <$> get <*> get
488−
489−instance Binary SendPortId where
490− put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
491− get = SendPortId <$> get <*> get
492−
493−instance Binary Identifier where
494− put (ProcessIdentifier pid) = putWord8 0 >> put pid
495− put (NodeIdentifier nid) = putWord8 1 >> put nid
496− put (SendPortIdentifier cid) = putWord8 2 >> put cid
497− get = do
498− header <- getWord8
499− case header of
500− 0 -> ProcessIdentifier <$> get
501− 1 -> NodeIdentifier <$> get
502− 2 -> SendPortIdentifier <$> get
503− _ -> fail "Identifier.get: invalid"
504−
505−instance Binary WhereIsReply where
506− put (WhereIsReply label mPid) = put label >> put mPid
507− get = WhereIsReply <$> get <*> get
508−
509−--------------------------------------------------------------------------------
510−-- Accessors --
511−--------------------------------------------------------------------------------
512−
513−localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)
514−localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })
515−
516−localPidCounter :: Accessor LocalNodeState Int32
517−localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })
518−
519−localPidUnique :: Accessor LocalNodeState Int32
520−localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
521−
522−localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) (NT.Connection, ImplicitReconnect))
523−localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })
524−
525−localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
526−localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
527−
528−localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe (NT.Connection, ImplicitReconnect))
529−localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)
530−
531−monitorCounter :: Accessor LocalProcessState Int32
532−monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
533−
534−spawnCounter :: Accessor LocalProcessState Int32
535−spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })
536−
537−channelCounter :: Accessor LocalProcessState LocalSendPortId
538−channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })
539−
540−typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)
541−typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })
542−
543−typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)
544−typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid
distributed-process/src/Control/Distributed/Process/Node.hsdeleted−757
@@ -1,757 +0,0 @@
1−-- | Local nodes
2−--
3−-- TODO: Calls to 'sendBinary' and co by the node controller may stall the
4−-- node controller.
5−module Control.Distributed.Process.Node
6− ( LocalNode
7− , newLocalNode
8− , closeLocalNode
9− , forkProcess
10− , runProcess
11− , initRemoteTable
12− , localNodeId
13− ) where
14−
15−#if ! MIN_VERSION_base(4,6,0)
16−import Prelude hiding (catch)
17−#endif
18−
19−import System.IO (fixIO, hPutStrLn, stderr)
20−import qualified Data.ByteString.Lazy as BSL (fromChunks)
21−import Data.Binary (decode)
22−import Data.Map (Map)
23−import qualified Data.Map as Map
24− ( empty
25− , toList
26− , partitionWithKey
27− , elems
28− , filterWithKey
29− )
30−import Data.Set (Set)
31−import qualified Data.Set as Set (empty, insert, delete, member)
32−import Data.Foldable (forM_)
33−import Data.Maybe (isJust)
34−import Data.Typeable (Typeable)
35−import Control.Category ((>>>))
36−import Control.Applicative ((<$>))
37−import Control.Monad (void, when)
38−import Control.Monad.IO.Class (MonadIO, liftIO)
39−import Control.Monad.State.Strict (MonadState, StateT, evalStateT, gets)
40−import qualified Control.Monad.State.Strict as StateT (get, put)
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.Distributed.Process.Internal.StrictMVar
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− , Connection
69− , close
70− , EndPointAddress
71− , Reliability(ReliableOrdered)
72− )
73−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
74−import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)
75−import System.Random (randomIO)
76−import Control.Distributed.Static (RemoteTable, Closure)
77−import qualified Control.Distributed.Static as Static
78− ( unclosure
79− , initRemoteTable
80− )
81−import Control.Distributed.Process.Internal.Types
82− ( NodeId(..)
83− , LocalProcessId(..)
84− , ProcessId(..)
85− , LocalNode(..)
86− , LocalNodeState(..)
87− , LocalProcess(..)
88− , LocalProcessState(..)
89− , Process(..)
90− , DiedReason(..)
91− , NCMsg(..)
92− , ProcessSignal(..)
93− , localPidCounter
94− , localPidUnique
95− , localProcessWithId
96− , localConnections
97− , MonitorRef(..)
98− , ProcessMonitorNotification(..)
99− , NodeMonitorNotification(..)
100− , PortMonitorNotification(..)
101− , ProcessLinkException(..)
102− , NodeLinkException(..)
103− , PortLinkException(..)
104− , DidUnmonitor(..)
105− , DidUnlinkProcess(..)
106− , DidUnlinkNode(..)
107− , DidUnlinkPort(..)
108− , SpawnRef
109− , DidSpawn(..)
110− , Message
111− , TypedChannel(..)
112− , Identifier(..)
113− , nodeOf
114− , SendPortId(..)
115− , typedChannelWithId
116− , WhereIsReply(..)
117− , messageToPayload
118− , payloadToMessage
119− , createMessage
120− , runLocalProcess
121− , firstNonReservedProcessId
122− , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
123− )
124−import Control.Distributed.Process.Serializable (Serializable)
125−import Control.Distributed.Process.Internal.Messaging
126− ( sendBinary
127− , sendMessage
128− , sendPayload
129− , closeImplicitReconnections
130− , impliesDeathOf
131− )
132−import Control.Distributed.Process.Internal.Primitives (expect, register, finally)
133−import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)
134−
135−--------------------------------------------------------------------------------
136−-- Initialization --
137−--------------------------------------------------------------------------------
138−
139−initRemoteTable :: RemoteTable
140−initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable
141−
142−-- | Initialize a new local node.
143−newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode
144−newLocalNode transport rtable = do
145− mEndPoint <- NT.newEndPoint transport
146− case mEndPoint of
147− Left ex -> throwIO ex
148− Right endPoint -> do
149− localNode <- createBareLocalNode endPoint rtable
150− startServiceProcesses localNode
151− return localNode
152−
153−-- | Create a new local node (without any service processes running)
154−createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
155−createBareLocalNode endPoint rtable = do
156− unq <- randomIO
157− state <- newMVar LocalNodeState
158− { _localProcesses = Map.empty
159− , _localPidCounter = firstNonReservedProcessId
160− , _localPidUnique = unq
161− , _localConnections = Map.empty
162− }
163− ctrlChan <- newChan
164− let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
165− , localEndPoint = endPoint
166− , localState = state
167− , localCtrlChan = ctrlChan
168− , remoteTable = rtable
169− }
170− void . forkIO $ runNodeController node
171− void . forkIO $ handleIncomingMessages node
172− return node
173−
174−-- Like 'Control.Monad.forever' but sans space leak
175−{-# INLINE forever' #-}
176−forever' :: Monad m => m a -> m b
177−forever' a = let a' = a >> a' in a'
178−
179−-- | Start and register the service processes on a node
180−-- (for now, this is only the logger)
181−startServiceProcesses :: LocalNode -> IO ()
182−startServiceProcesses node = do
183− logger <- forkProcess node . forever' $ do
184− (time, pid, string) <- expect :: Process (String, ProcessId, String)
185− liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
186− runProcess node $ register "logger" logger
187−
188−-- | Force-close a local node
189−--
190−-- TODO: for now we just close the associated endpoint
191−closeLocalNode :: LocalNode -> IO ()
192−closeLocalNode node =
193− NT.closeEndPoint (localEndPoint node)
194−
195−-- | Run a process on a local node and wait for it to finish
196−runProcess :: LocalNode -> Process () -> IO ()
197−runProcess node proc = do
198− done <- newEmptyMVar
199− void $ forkProcess node (proc `finally` liftIO (putMVar done ()))
200− takeMVar done
201−
202−-- | Spawn a new process on a local node
203−forkProcess :: LocalNode -> Process () -> IO ProcessId
204−forkProcess node proc = modifyMVar (localState node) startProcess
205− where
206− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
207− startProcess st = do
208− let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter
209− , lpidUnique = st ^. localPidUnique
210− }
211− let pid = ProcessId { processNodeId = localNodeId node
212− , processLocalId = lpid
213− }
214− pst <- newMVar LocalProcessState { _monitorCounter = 0
215− , _spawnCounter = 0
216− , _channelCounter = 0
217− , _typedChannels = Map.empty
218− }
219− queue <- newCQueue
220− (_, lproc) <- fixIO $ \ ~(tid, _) -> do
221− let lproc = LocalProcess { processQueue = queue
222− , processId = pid
223− , processState = pst
224− , processThread = tid
225− , processNode = node
226− }
227− tid' <- forkIO $ do
228− reason <- Exception.catch
229− (runLocalProcess lproc proc >> return DiedNormal)
230− (return . DiedException . (show :: SomeException -> String))
231− -- [Unified: Table 4, rules termination and exiting]
232− modifyMVar_ (localState node) (cleanupProcess pid)
233− writeChan (localCtrlChan node) NCMsg
234− { ctrlMsgSender = ProcessIdentifier pid
235− , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
236− }
237− return (tid', lproc)
238−
239− if lpidCounter lpid == maxBound
240− then do
241− newUnique <- randomIO
242− return ( (localProcessWithId lpid ^= Just lproc)
243− . (localPidCounter ^= firstNonReservedProcessId)
244− . (localPidUnique ^= newUnique)
245− $ st
246− , pid
247− )
248− else
249− return ( (localProcessWithId lpid ^= Just lproc)
250− . (localPidCounter ^: (+ 1))
251− $ st
252− , pid
253− )
254−
255− cleanupProcess :: ProcessId -> LocalNodeState -> IO LocalNodeState
256− cleanupProcess pid st = do
257− let pid' = ProcessIdentifier pid
258− let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (st ^. localConnections)
259− mapM_ (NT.close . fst) (Map.elems affected)
260− return $ (localProcessWithId (processLocalId pid) ^= Nothing)
261− . (localConnections ^= unaffected)
262− $ st
263−
264−--------------------------------------------------------------------------------
265−-- Handle incoming messages --
266−--------------------------------------------------------------------------------
267−
268−type IncomingConnection = (NT.EndPointAddress, IncomingTarget)
269−
270−data IncomingTarget =
271− Uninit
272− | ToProc LocalProcess
273− | ToChan TypedChannel
274− | ToNode
275−
276−data ConnectionState = ConnectionState {
277− _incoming :: !(Map NT.ConnectionId IncomingConnection)
278− , _incomingFrom :: !(Map NT.EndPointAddress (Set NT.ConnectionId))
279− }
280−
281−initConnectionState :: ConnectionState
282−initConnectionState = ConnectionState {
283− _incoming = Map.empty
284− , _incomingFrom = Map.empty
285− }
286−
287−incoming :: Accessor ConnectionState (Map NT.ConnectionId IncomingConnection)
288−incoming = accessor _incoming (\conns st -> st { _incoming = conns })
289−
290−incomingAt :: NT.ConnectionId -> Accessor ConnectionState (Maybe IncomingConnection)
291−incomingAt cid = incoming >>> DAC.mapMaybe cid
292−
293−incomingFrom :: NT.EndPointAddress -> Accessor ConnectionState (Set NT.ConnectionId)
294−incomingFrom addr = aux >>> DAC.mapDefault Set.empty addr
295− where
296− aux = accessor _incomingFrom (\fr st -> st { _incomingFrom = fr })
297−
298−handleIncomingMessages :: LocalNode -> IO ()
299−handleIncomingMessages node = go initConnectionState
300− where
301− go :: ConnectionState -> IO ()
302− go !st = do
303− event <- NT.receive endpoint
304− case event of
305− NT.ConnectionOpened cid rel theirAddr ->
306− if rel == NT.ReliableOrdered
307− then go ( (incomingAt cid ^= Just (theirAddr, Uninit))
308− . (incomingFrom theirAddr ^: Set.insert cid)
309− $ st
310− )
311− else invalidRequest cid st
312− NT.Received cid payload ->
313− case st ^. incomingAt cid of
314− Just (_, ToProc proc) -> do
315− let msg = payloadToMessage payload
316− enqueue (processQueue proc) msg
317− go st
318− Just (_, ToChan (TypedChannel chan)) -> do
319− atomically $ writeTChan chan . decode . BSL.fromChunks $ payload
320− go st
321− Just (_, ToNode) -> do
322− let ctrlMsg = decode . BSL.fromChunks $ payload
323− writeChan ctrlChan ctrlMsg
324− go st
325− Just (src, Uninit) ->
326− case decode (BSL.fromChunks payload) of
327− ProcessIdentifier pid -> do
328− let lpid = processLocalId pid
329− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
330− case mProc of
331− Just proc ->
332− go (incomingAt cid ^= Just (src, ToProc proc) $ st)
333− Nothing ->
334− invalidRequest cid st
335− SendPortIdentifier chId -> do
336− let lcid = sendPortLocalId chId
337− lpid = processLocalId (sendPortProcessId chId)
338− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
339− case mProc of
340− Just proc -> do
341− mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
342− case mChannel of
343− Just channel ->
344− go (incomingAt cid ^= Just (src, ToChan channel) $ st)
345− Nothing ->
346− invalidRequest cid st
347− Nothing ->
348− invalidRequest cid st
349− NodeIdentifier nid ->
350− if nid == localNodeId node
351− then go (incomingAt cid ^= Just (src, ToNode) $ st)
352− else invalidRequest cid st
353− Nothing ->
354− invalidRequest cid st
355− NT.ConnectionClosed cid ->
356− case st ^. incomingAt cid of
357− Nothing ->
358− invalidRequest cid st
359− Just (src, _) ->
360− go ( (incomingAt cid ^= Nothing)
361− . (incomingFrom src ^: Set.delete cid)
362− $ st
363− )
364− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost theirAddr) _) -> do
365− -- [Unified table 9, rule node_disconnect]
366− let nid = NodeIdentifier $ NodeId theirAddr
367− writeChan ctrlChan NCMsg
368− { ctrlMsgSender = nid
369− , ctrlMsgSignal = Died nid DiedDisconnect
370− }
371− let notLost k = not (k `Set.member` (st ^. incomingFrom theirAddr))
372− closeImplicitReconnections node nid
373− go ( (incomingFrom theirAddr ^= Set.empty)
374− . (incoming ^: Map.filterWithKey (const . notLost))
375− $ st
376− )
377− NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
378− fail $ "Cloud Haskell fatal error: end point failed: " ++ str
379− NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
380− fail $ "Cloud Haskell fatal error: transport failed: " ++ str
381− NT.EndPointClosed ->
382− return ()
383− NT.ReceivedMulticast _ _ ->
384− -- If we received a multicast message, something went horribly wrong
385− -- and we just give up
386− fail "Cloud Haskell fatal error: received unexpected multicast"
387−
388− invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()
389− invalidRequest cid st = do
390− -- TODO: We should treat this as a fatal error on the part of the remote
391− -- node. That is, we should report the remote node as having died, and we
392− -- should close incoming connections (this requires a Transport layer
393− -- extension).
394− go ( (incomingAt cid ^= Nothing)
395− $ st
396− )
397−
398− state = localState node
399− endpoint = localEndPoint node
400− ctrlChan = localCtrlChan node
401−
402−--------------------------------------------------------------------------------
403−-- Top-level access to the node controller --
404−--------------------------------------------------------------------------------
405−
406−runNodeController :: LocalNode -> IO ()
407−runNodeController =
408− runReaderT (evalStateT (unNC nodeController) initNCState)
409−
410−--------------------------------------------------------------------------------
411−-- Internal data types --
412−--------------------------------------------------------------------------------
413−
414−data NCState = NCState
415− { -- Mapping from remote processes to linked local processes
416− _links :: !(Map Identifier (Set ProcessId))
417− -- Mapping from remote processes to monitoring local processes
418− , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))
419− -- Process registry
420− , _registry :: !(Map String ProcessId)
421− }
422−
423−newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }
424− deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)
425−
426−initNCState :: NCState
427−initNCState = NCState { _links = Map.empty
428− , _monitors = Map.empty
429− , _registry = Map.empty
430− }
431−
432−--------------------------------------------------------------------------------
433−-- Core functionality --
434−--------------------------------------------------------------------------------
435−
436−-- [Unified: Table 7]
437−nodeController :: NC ()
438−nodeController = do
439− node <- ask
440− forever' $ do
441− msg <- liftIO $ readChan (localCtrlChan node)
442−
443− -- [Unified: Table 7, rule nc_forward]
444− case destNid (ctrlMsgSignal msg) of
445− Just nid' | nid' /= localNodeId node ->
446− liftIO $ sendBinary node
447− (ctrlMsgSender msg)
448− (NodeIdentifier nid')
449− WithImplicitReconnect
450− msg
451− _ ->
452− return ()
453−
454− case msg of
455− NCMsg (ProcessIdentifier from) (Link them) ->
456− ncEffectMonitor from them Nothing
457− NCMsg (ProcessIdentifier from) (Monitor ref) ->
458− ncEffectMonitor from (monitorRefIdent ref) (Just ref)
459− NCMsg (ProcessIdentifier from) (Unlink them) ->
460− ncEffectUnlink from them
461− NCMsg (ProcessIdentifier from) (Unmonitor ref) ->
462− ncEffectUnmonitor from ref
463− NCMsg _from (Died ident reason) ->
464− ncEffectDied ident reason
465− NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
466− ncEffectSpawn from proc ref
467− NCMsg _from (Register label pid) ->
468− ncEffectRegister label pid
469− NCMsg (ProcessIdentifier from) (WhereIs label) ->
470− ncEffectWhereIs from label
471− NCMsg from (NamedSend label msg') ->
472− ncEffectNamedSend from label msg'
473− unexpected ->
474− error $ "nodeController: unexpected message " ++ show unexpected
475−
476−-- [Unified: Table 10]
477−ncEffectMonitor :: ProcessId -- ^ Who's watching?
478− -> Identifier -- ^ Who's being watched?
479− -> Maybe MonitorRef -- ^ 'Nothing' to link
480− -> NC ()
481−ncEffectMonitor from them mRef = do
482− node <- ask
483− shouldLink <-
484− if not (isLocal node them)
485− then return True
486− else isValidLocalIdentifier them
487− case (shouldLink, isLocal node (ProcessIdentifier from)) of
488− (True, _) -> -- [Unified: first rule]
489− case mRef of
490− Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)
491− Nothing -> modify' $ linksFor them ^: Set.insert from
492− (False, True) -> -- [Unified: second rule]
493− notifyDied from them DiedUnknownId mRef
494− (False, False) -> -- [Unified: third rule]
495− -- TODO: this is the right sender according to the Unified semantics,
496− -- but perhaps having 'them' as the sender would make more sense
497− -- (see also: notifyDied)
498− liftIO $ sendBinary node
499− (NodeIdentifier $ localNodeId node)
500− (NodeIdentifier $ processNodeId from)
501− WithImplicitReconnect
502− NCMsg
503− { ctrlMsgSender = NodeIdentifier (localNodeId node)
504− , ctrlMsgSignal = Died them DiedUnknownId
505− }
506−
507−-- [Unified: Table 11]
508−ncEffectUnlink :: ProcessId -> Identifier -> NC ()
509−ncEffectUnlink from them = do
510− node <- ask
511− when (isLocal node (ProcessIdentifier from)) $
512− case them of
513− ProcessIdentifier pid ->
514− postAsMessage from $ DidUnlinkProcess pid
515− NodeIdentifier nid ->
516− postAsMessage from $ DidUnlinkNode nid
517− SendPortIdentifier cid ->
518− postAsMessage from $ DidUnlinkPort cid
519− modify' $ linksFor them ^: Set.delete from
520−
521−-- [Unified: Table 11]
522−ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
523−ncEffectUnmonitor from ref = do
524− node <- ask
525− when (isLocal node (ProcessIdentifier from)) $
526− postAsMessage from $ DidUnmonitor ref
527− modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
528−
529−-- [Unified: Table 12]
530−ncEffectDied :: Identifier -> DiedReason -> NC ()
531−ncEffectDied ident reason = do
532− node <- ask
533− (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
534− (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
535−
536− let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False
537−
538− forM_ (Map.toList affectedLinks) $ \(them, uss) ->
539− forM_ uss $ \us ->
540− when (localOnly <= isLocal node (ProcessIdentifier us)) $
541− notifyDied us them reason Nothing
542−
543− forM_ (Map.toList affectedMons) $ \(them, refs) ->
544− forM_ refs $ \(us, ref) ->
545− when (localOnly <= isLocal node (ProcessIdentifier us)) $
546− notifyDied us them reason (Just ref)
547−
548− modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)
549−
550−-- [Unified: Table 13]
551−ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
552−ncEffectSpawn pid cProc ref = do
553− mProc <- unClosure cProc
554− -- If the closure does not exist, we spawn a process that throws an exception
555− -- This allows the remote node to find out what's happening
556− let proc = case mProc of
557− Left err -> fail $ "Error: Could not resolve closure: " ++ err
558− Right p -> p
559− node <- ask
560− pid' <- liftIO $ forkProcess node proc
561− liftIO $ sendMessage node
562− (NodeIdentifier (localNodeId node))
563− (ProcessIdentifier pid)
564− WithImplicitReconnect
565− (DidSpawn ref pid')
566−
567−-- Unified semantics does not explicitly describe how to implement 'register',
568−-- but mentions it's "very similar to nsend" (Table 14)
569−ncEffectRegister :: String -> Maybe ProcessId -> NC ()
570−ncEffectRegister label mPid =
571− modify' $ registryFor label ^= mPid
572− -- An acknowledgement is not necessary. If we want a synchronous register,
573− -- it suffices to send a whereis requiry immediately after the register
574− -- (that may not suffice if we do decide for unreliable messaging instead)
575−
576−-- Unified semantics does not explicitly describe 'whereis'
577−ncEffectWhereIs :: ProcessId -> String -> NC ()
578−ncEffectWhereIs from label = do
579− node <- ask
580− mPid <- gets (^. registryFor label)
581− liftIO $ sendMessage node
582− (NodeIdentifier (localNodeId node))
583− (ProcessIdentifier from)
584− WithImplicitReconnect
585− (WhereIsReply label mPid)
586−
587−-- [Unified: Table 14]
588−ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
589−ncEffectNamedSend from label msg = do
590− mPid <- gets (^. registryFor label)
591− -- If mPid is Nothing, we just ignore the named send (as per Table 14)
592− node <- ask
593− forM_ mPid $ \pid ->
594− liftIO $ sendPayload node
595− from
596− (ProcessIdentifier pid)
597− NoImplicitReconnect
598− (messageToPayload msg)
599−
600−--------------------------------------------------------------------------------
601−-- Auxiliary --
602−--------------------------------------------------------------------------------
603−
604−notifyDied :: ProcessId -- ^ Who to notify?
605− -> Identifier -- ^ Who died?
606− -> DiedReason -- ^ How did they die?
607− -> Maybe MonitorRef -- ^ 'Nothing' for linking
608− -> NC ()
609−notifyDied dest src reason mRef = do
610− node <- ask
611− case (isLocal node (ProcessIdentifier dest), mRef, src) of
612− (True, Just ref, ProcessIdentifier pid) ->
613− postAsMessage dest $ ProcessMonitorNotification ref pid reason
614− (True, Just ref, NodeIdentifier nid) ->
615− postAsMessage dest $ NodeMonitorNotification ref nid reason
616− (True, Just ref, SendPortIdentifier cid) ->
617− postAsMessage dest $ PortMonitorNotification ref cid reason
618− (True, Nothing, ProcessIdentifier pid) ->
619− throwException dest $ ProcessLinkException pid reason
620− (True, Nothing, NodeIdentifier pid) ->
621− throwException dest $ NodeLinkException pid reason
622− (True, Nothing, SendPortIdentifier pid) ->
623− throwException dest $ PortLinkException pid reason
624− (False, _, _) ->
625− -- The change in sender comes from [Unified: Table 10]
626− liftIO $ sendBinary node
627− (NodeIdentifier $ localNodeId node)
628− (NodeIdentifier $ processNodeId dest)
629− WithImplicitReconnect
630− NCMsg
631− { ctrlMsgSender = NodeIdentifier (localNodeId node)
632− , ctrlMsgSignal = Died src reason
633− }
634−
635−-- | [Unified: Table 8]
636−destNid :: ProcessSignal -> Maybe NodeId
637−destNid (Link ident) = Just $ nodeOf ident
638−destNid (Unlink ident) = Just $ nodeOf ident
639−destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
640−destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
641−destNid (Spawn _ _) = Nothing
642−destNid (Register _ _) = Nothing
643−destNid (WhereIs _) = Nothing
644−destNid (NamedSend _ _) = Nothing
645−-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
646−-- then when a local process dies the monitoring/linking machinery will take
647−-- care of notifying remote nodes
648−destNid (Died _ _) = Nothing
649−
650−-- | Check if a process is local to our own node
651−isLocal :: LocalNode -> Identifier -> Bool
652−isLocal nid ident = nodeOf ident == localNodeId nid
653−
654−-- | Lookup a local closure
655−unClosure :: Typeable a => Closure a -> NC (Either String a)
656−unClosure closure = do
657− rtable <- remoteTable <$> ask
658− return (Static.unclosure rtable closure)
659−
660−-- | Check if an identifier refers to a valid local object
661−isValidLocalIdentifier :: Identifier -> NC Bool
662−isValidLocalIdentifier ident = do
663− node <- ask
664− liftIO . withMVar (localState node) $ \nSt ->
665− case ident of
666− NodeIdentifier nid ->
667− return $ nid == localNodeId node
668− ProcessIdentifier pid -> do
669− let mProc = nSt ^. localProcessWithId (processLocalId pid)
670− return $ isJust mProc
671− SendPortIdentifier cid -> do
672− let pid = sendPortProcessId cid
673− mProc = nSt ^. localProcessWithId (processLocalId pid)
674− case mProc of
675− Nothing -> return False
676− Just proc -> withMVar (processState proc) $ \pSt -> do
677− let mCh = pSt ^. typedChannelWithId (sendPortLocalId cid)
678− return $ isJust mCh
679−
680−--------------------------------------------------------------------------------
681−-- Messages to local processes --
682−--------------------------------------------------------------------------------
683−
684−postAsMessage :: Serializable a => ProcessId -> a -> NC ()
685−postAsMessage pid = postMessage pid . createMessage
686−
687−postMessage :: ProcessId -> Message -> NC ()
688−postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
689−
690−throwException :: Exception e => ProcessId -> e -> NC ()
691−throwException pid e = withLocalProc pid $ \p ->
692− throwTo (processThread p) e
693−
694−withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
695−withLocalProc pid p = do
696− node <- ask
697− liftIO $ do
698− -- By [Unified: table 6, rule missing_process] messages to dead processes
699− -- can silently be dropped
700− let lpid = processLocalId pid
701− mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
702− forM_ mProc p
703−
704−--------------------------------------------------------------------------------
705−-- Accessors --
706−--------------------------------------------------------------------------------
707−
708−links :: Accessor NCState (Map Identifier (Set ProcessId))
709−links = accessor _links (\ls st -> st { _links = ls })
710−
711−monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))
712−monitors = accessor _monitors (\ms st -> st { _monitors = ms })
713−
714−registry :: Accessor NCState (Map String ProcessId)
715−registry = accessor _registry (\ry st -> st { _registry = ry })
716−
717−linksFor :: Identifier -> Accessor NCState (Set ProcessId)
718−linksFor ident = links >>> DAC.mapDefault Set.empty ident
719−
720−monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))
721−monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident
722−
723−registryFor :: String -> Accessor NCState (Maybe ProcessId)
724−registryFor ident = registry >>> DAC.mapMaybe ident
725−
726−-- | @splitNotif ident@ splits a notifications map into those
727−-- notifications that should trigger when 'ident' fails and those links that
728−-- should not.
729−--
730−-- There is a hierarchy between identifiers: failure of a node implies failure
731−-- of all processes on that node, and failure of a process implies failure of
732−-- all typed channels to that process. In other words, if 'ident' refers to a
733−-- node, then the /should trigger/ set will include
734−--
735−-- * the notifications for the node specifically
736−-- * the notifications for processes on that node, and
737−-- * the notifications for typed channels to processes on that node.
738−--
739−-- Similarly, if 'ident' refers to a process, the /should trigger/ set will
740−-- include
741−--
742−-- * the notifications for that process specifically and
743−-- * the notifications for typed channels to that process.
744−--
745−-- See https://github.com/haskell/containers/issues/14 for the bang on _v.
746−splitNotif :: Identifier
747− -> Map Identifier a
748− -> (Map Identifier a, Map Identifier a)
749−splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)
750−
751−--------------------------------------------------------------------------------
752−-- Strict evaluation of the state --
753−--------------------------------------------------------------------------------
754−
755−-- | Modify and evaluate the state
756−modify' :: MonadState s m => (s -> s) -> m ()
757−modify' f = StateT.get >>= \s -> StateT.put $! f s
distributed-process/tests/TestAuxiliary.hsdeleted−75
@@ -1,75 +0,0 @@
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.hsdeleted−706
@@ -1,706 +0,0 @@
1−module Main where
2−
3−#if ! MIN_VERSION_base(4,6,0)
4−import Prelude hiding (catch)
5−#endif
6−
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.Socket (sClose)
23−import Network.Transport.TCP
24− ( createTransportExposeInternals
25− , TransportInternals(socketBetween)
26− , defaultTCPParameters
27− )
28−import Control.Distributed.Process
29−import Control.Distributed.Process.Internal.Types
30− ( NodeId(nodeAddress)
31− , LocalNode(localEndPoint)
32− )
33−import Control.Distributed.Process.Node
34−import Control.Distributed.Process.Serializable (Serializable)
35−import TestAuxiliary
36−
37−newtype Ping = Ping ProcessId
38− deriving (Typeable, Binary, Show)
39−
40−newtype Pong = Pong ProcessId
41− deriving (Typeable, Binary, Show)
42−
43−-- | The ping server from the paper
44−ping :: Process ()
45−ping = do
46− Pong partner <- expect
47− self <- getSelfPid
48− send partner (Ping self)
49− ping
50−
51−-- | Quick and dirty synchronous version of whereisRemoteAsync
52−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
53−whereisRemote nid string = do
54− whereisRemoteAsync nid string
55− WhereIsReply _ mPid <- expect
56− return mPid
57−
58−-- | Basic ping test
59−testPing :: NT.Transport -> IO ()
60−testPing transport = do
61− serverAddr <- newEmptyMVar
62− clientDone <- newEmptyMVar
63−
64− -- Server
65− forkIO $ do
66− localNode <- newLocalNode transport initRemoteTable
67− addr <- forkProcess localNode ping
68− putMVar serverAddr addr
69−
70− -- Client
71− forkIO $ do
72− localNode <- newLocalNode transport initRemoteTable
73− pingServer <- readMVar serverAddr
74−
75− let numPings = 10000
76−
77− runProcess localNode $ do
78− pid <- getSelfPid
79− replicateM_ numPings $ do
80− send pingServer (Pong pid)
81− Ping _ <- expect
82− return ()
83−
84− putMVar clientDone ()
85−
86− takeMVar clientDone
87−
88−-- | Monitor or link to a remote node
89−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
90− -> ProcessId -- Process to monitor/link to
91− -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
92− -> Process (Maybe MonitorRef)
93−monitorOrLink mOrL pid mSignal = do
94− result <- if mOrL then Just <$> monitor pid
95− else link pid >> return Nothing
96− -- Monitor is asynchronous, which usually does not matter but if we want a
97− -- *specific* signal then it does. Therefore we wait an arbitrary delay and
98− -- hope that this means the monitor has been set up
99− forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
100− return result
101−
102−monitorTestProcess :: ProcessId -- Process to monitor/link to
103− -> Bool -- 'True' for monitor, 'False' for link
104− -> Bool -- Should we unmonitor?
105− -> DiedReason -- Expected cause of death
106− -> Maybe (MVar ()) -- Signal for 'monitor set up'
107− -> MVar () -- Signal for successful termination
108− -> Process ()
109−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
110− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
111− case (un, mRef) of
112− (True, Nothing) -> do
113− unlink theirAddr
114− liftIO $ putMVar done ()
115− (True, Just ref) -> do
116− unmonitor ref
117− liftIO $ putMVar done ()
118− (False, ref) -> do
119− ProcessMonitorNotification ref' pid reason' <- expect
120− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
121− liftIO $ putMVar done ()
122− )
123− (\(ProcessLinkException pid reason') -> do
124− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
125− liftIO $ putMVar done ()
126− )
127−
128−
129−-- | Monitor a process on an unreachable node
130−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
131−testMonitorUnreachable transport mOrL un = do
132− deadProcess <- newEmptyMVar
133− done <- newEmptyMVar
134−
135− forkIO $ do
136− localNode <- newLocalNode transport initRemoteTable
137− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
138− closeLocalNode localNode
139− putMVar deadProcess addr
140−
141− forkIO $ do
142− localNode <- newLocalNode transport initRemoteTable
143− theirAddr <- readMVar deadProcess
144− runProcess localNode $
145− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
146−
147− takeMVar done
148−
149−-- | Monitor a process which terminates normally
150−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
151−testMonitorNormalTermination transport mOrL un = do
152− monitorSetup <- newEmptyMVar
153− monitoredProcess <- newEmptyMVar
154− done <- newEmptyMVar
155−
156− forkIO $ do
157− localNode <- newLocalNode transport initRemoteTable
158− addr <- forkProcess localNode $
159− liftIO $ readMVar monitorSetup
160− putMVar monitoredProcess addr
161−
162− forkIO $ do
163− localNode <- newLocalNode transport initRemoteTable
164− theirAddr <- readMVar monitoredProcess
165− runProcess localNode $
166− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
167−
168− takeMVar done
169−
170−-- | Monitor a process which terminates abnormally
171−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
172−testMonitorAbnormalTermination transport mOrL un = do
173− monitorSetup <- newEmptyMVar
174− monitoredProcess <- newEmptyMVar
175− done <- newEmptyMVar
176−
177− let err = userError "Abnormal termination"
178−
179− forkIO $ do
180− localNode <- newLocalNode transport initRemoteTable
181− addr <- forkProcess localNode . liftIO $ do
182− readMVar monitorSetup
183− throwIO err
184− putMVar monitoredProcess addr
185−
186− forkIO $ do
187− localNode <- newLocalNode transport initRemoteTable
188− theirAddr <- readMVar monitoredProcess
189− runProcess localNode $
190− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
191−
192− takeMVar done
193−
194−-- | Monitor a local process that is already dead
195−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
196−testMonitorLocalDeadProcess transport mOrL un = do
197− processDead <- newEmptyMVar
198− processAddr <- newEmptyMVar
199− localNode <- newLocalNode transport initRemoteTable
200− done <- newEmptyMVar
201−
202− forkIO $ do
203− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
204− putMVar processAddr addr
205−
206− forkIO $ do
207− theirAddr <- readMVar processAddr
208− readMVar processDead
209− runProcess localNode $ do
210− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
211−
212− takeMVar done
213−
214−-- | Monitor a remote process that is already dead
215−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
216−testMonitorRemoteDeadProcess transport mOrL un = do
217− processDead <- newEmptyMVar
218− processAddr <- newEmptyMVar
219− done <- newEmptyMVar
220−
221− forkIO $ do
222− localNode <- newLocalNode transport initRemoteTable
223− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
224− putMVar processAddr addr
225−
226− forkIO $ do
227− localNode <- newLocalNode transport initRemoteTable
228− theirAddr <- readMVar processAddr
229− readMVar processDead
230− runProcess localNode $ do
231− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
232−
233− takeMVar done
234−
235−-- | Monitor a process that becomes disconnected
236−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
237−testMonitorDisconnect transport mOrL un = do
238− processAddr <- newEmptyMVar
239− monitorSetup <- newEmptyMVar
240− done <- newEmptyMVar
241−
242− forkIO $ do
243− localNode <- newLocalNode transport initRemoteTable
244− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
245− putMVar processAddr addr
246− readMVar monitorSetup
247− NT.closeEndPoint (localEndPoint localNode)
248−
249− forkIO $ do
250− localNode <- newLocalNode transport initRemoteTable
251− theirAddr <- readMVar processAddr
252− runProcess localNode $ do
253− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
254−
255− takeMVar done
256−
257−data Add = Add ProcessId Double Double deriving (Typeable)
258−data Divide = Divide ProcessId Double Double deriving (Typeable)
259−data DivByZero = DivByZero deriving (Typeable)
260−
261−instance Binary Add where
262− put (Add pid x y) = put pid >> put x >> put y
263− get = Add <$> get <*> get <*> get
264−
265−instance Binary Divide where
266− put (Divide pid x y) = put pid >> put x >> put y
267− get = Divide <$> get <*> get <*> get
268−
269−instance Binary DivByZero where
270− put DivByZero = return ()
271− get = return DivByZero
272−
273−math :: Process ()
274−math = do
275− receiveWait
276− [ match (\(Add pid x y) -> send pid (x + y))
277− , matchIf (\(Divide _ _ y) -> y /= 0)
278− (\(Divide pid x y) -> send pid (x / y))
279− , match (\(Divide pid _ _) -> send pid DivByZero)
280− ]
281− math
282−
283−-- | Test the math server (i.e., receiveWait)
284−testMath :: NT.Transport -> IO ()
285−testMath transport = do
286− serverAddr <- newEmptyMVar
287− clientDone <- newEmptyMVar
288−
289− -- Server
290− forkIO $ do
291− localNode <- newLocalNode transport initRemoteTable
292− addr <- forkProcess localNode math
293− putMVar serverAddr addr
294−
295− -- Client
296− forkIO $ do
297− localNode <- newLocalNode transport initRemoteTable
298− mathServer <- readMVar serverAddr
299−
300− runProcess localNode $ do
301− pid <- getSelfPid
302− send mathServer (Add pid 1 2)
303− 3 <- expect :: Process Double
304− send mathServer (Divide pid 8 2)
305− 4 <- expect :: Process Double
306− send mathServer (Divide pid 8 0)
307− DivByZero <- expect
308− liftIO $ putMVar clientDone ()
309−
310− takeMVar clientDone
311−
312−-- | Send first message (i.e. connect) to an already terminated process
313−-- (without monitoring); then send another message to a second process on
314−-- the same remote node (we're checking that the remote node did not die)
315−testSendToTerminated :: NT.Transport -> IO ()
316−testSendToTerminated transport = do
317− serverAddr1 <- newEmptyMVar
318− serverAddr2 <- newEmptyMVar
319− clientDone <- newEmptyMVar
320−
321− forkIO $ do
322− terminated <- newEmptyMVar
323− localNode <- newLocalNode transport initRemoteTable
324− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
325− addr2 <- forkProcess localNode $ ping
326− readMVar terminated
327− putMVar serverAddr1 addr1
328− putMVar serverAddr2 addr2
329−
330− forkIO $ do
331− localNode <- newLocalNode transport initRemoteTable
332− server1 <- readMVar serverAddr1
333− server2 <- readMVar serverAddr2
334− runProcess localNode $ do
335− pid <- getSelfPid
336− send server1 "Hi"
337− send server2 (Pong pid)
338− Ping pid' <- expect
339− True <- return $ pid' == server2
340− liftIO $ putMVar clientDone ()
341−
342− takeMVar clientDone
343−
344−-- | Test (non-zero) timeout
345−testTimeout :: NT.Transport -> IO ()
346−testTimeout transport = do
347− localNode <- newLocalNode transport initRemoteTable
348− runProcess localNode $ do
349− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
350− return ()
351−
352−-- | Test zero timeout
353−testTimeout0 :: NT.Transport -> IO ()
354−testTimeout0 transport = do
355− serverAddr <- newEmptyMVar
356− clientDone <- newEmptyMVar
357− messagesSent <- newEmptyMVar
358−
359− forkIO $ do
360− localNode <- newLocalNode transport initRemoteTable
361− addr <- forkProcess localNode $ do
362− liftIO $ readMVar messagesSent >> threadDelay 1000000
363− -- Variation on the venerable ping server which uses a zero timeout
364− -- Since we wait for all messages to be sent before doing this receive,
365− -- we should nevertheless find the right message immediately
366− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
367− self <- getSelfPid
368− send partner (Ping self)
369− putMVar serverAddr addr
370−
371− forkIO $ do
372− localNode <- newLocalNode transport initRemoteTable
373− server <- readMVar serverAddr
374− runProcess localNode $ do
375− pid <- getSelfPid
376− -- Send a bunch of messages. A large number of messages that the server
377− -- is not interested in, and then a single message that it wants
378− replicateM_ 10000 $ send server "Irrelevant message"
379− send server (Pong pid)
380− liftIO $ putMVar messagesSent ()
381− Ping _ <- expect
382− liftIO $ putMVar clientDone ()
383−
384− takeMVar clientDone
385−
386−-- | Test typed channels
387−testTypedChannels :: NT.Transport -> IO ()
388−testTypedChannels transport = do
389− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
390− clientDone <- newEmptyMVar
391−
392− forkIO $ do
393− localNode <- newLocalNode transport initRemoteTable
394− forkProcess localNode $ do
395− (serverSendPort, rport) <- newChan
396− liftIO $ putMVar serverChannel serverSendPort
397− (clientSendPort, i) <- receiveChan rport
398− sendChan clientSendPort (even i)
399− return ()
400−
401− forkIO $ do
402− localNode <- newLocalNode transport initRemoteTable
403− serverSendPort <- readMVar serverChannel
404− runProcess localNode $ do
405− (clientSendPort, rport) <- newChan
406− sendChan serverSendPort (clientSendPort, 5)
407− False <- receiveChan rport
408− liftIO $ putMVar clientDone ()
409−
410− takeMVar clientDone
411−
412−-- | Test merging receive ports
413−testMergeChannels :: NT.Transport -> IO ()
414−testMergeChannels transport = do
415− localNode <- newLocalNode transport initRemoteTable
416− testFlat localNode True "aaabbbccc"
417− testFlat localNode False "abcabcabc"
418− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
419− testNested localNode True False "adgadgadgbehbehbehcficficfi"
420− testNested localNode False True "abcabcabcdefdefdefghighighi"
421− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
422− testBlocked localNode True
423− testBlocked localNode False
424− where
425− -- Single layer of merging
426− testFlat :: LocalNode -> Bool -> String -> IO ()
427− testFlat localNode biased expected =
428− runProcess localNode $ do
429− rs <- mapM charChannel "abc"
430− m <- mergePorts biased rs
431− xs <- replicateM 9 $ receiveChan m
432− True <- return $ xs == expected
433− return ()
434−
435− -- Two layers of merging
436− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
437− testNested localNode biasedInner biasedOuter expected =
438− runProcess localNode $ do
439− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
440− ms <- mapM (mergePorts biasedInner) rss
441− m <- mergePorts biasedOuter ms
442− xs <- replicateM (9 * 3) $ receiveChan m
443− True <- return $ xs == expected
444− return ()
445−
446− -- Test that if no messages are (immediately) available, the scheduler makes no difference
447− testBlocked :: LocalNode -> Bool -> IO ()
448− testBlocked localNode biased = do
449− vs <- replicateM 3 newEmptyMVar
450−
451− forkProcess localNode $ do
452− [sa, sb, sc] <- liftIO $ mapM readMVar vs
453− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
454− [ -- a, b, c
455− (sa, 'a')
456− , (sb, 'b')
457− , (sc, 'c')
458− -- a, c, b
459− , (sa, 'a')
460− , (sc, 'c')
461− , (sb, 'b')
462− -- b, a, c
463− , (sb, 'b')
464− , (sa, 'a')
465− , (sc, 'c')
466− -- b, c, a
467− , (sb, 'b')
468− , (sc, 'c')
469− , (sa, 'a')
470− -- c, a, b
471− , (sc, 'c')
472− , (sa, 'a')
473− , (sb, 'b')
474− -- c, b, a
475− , (sc, 'c')
476− , (sb, 'b')
477− , (sa, 'a')
478− ]
479−
480− runProcess localNode $ do
481− (ss, rs) <- unzip <$> replicateM 3 newChan
482− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
483− m <- mergePorts biased rs
484− xs <- replicateM (6 * 3) $ receiveChan m
485− True <- return $ xs == "abcacbbacbcacabcba"
486− return ()
487−
488− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
489− mergePorts True = mergePortsBiased
490− mergePorts False = mergePortsRR
491−
492− charChannel :: Char -> Process (ReceivePort Char)
493− charChannel c = do
494− (sport, rport) <- newChan
495− replicateM_ 3 $ sendChan sport c
496− liftIO $ threadDelay 10000 -- Make sure messages have been sent
497− return rport
498−
499−testTerminate :: NT.Transport -> IO ()
500−testTerminate transport = do
501− localNode <- newLocalNode transport initRemoteTable
502−
503− pid <- forkProcess localNode $ do
504− liftIO $ threadDelay 100000
505− terminate
506−
507− runProcess localNode $ do
508− ref <- monitor pid
509− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
510− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
511− return ()
512−
513−testMonitorNode :: NT.Transport -> IO ()
514−testMonitorNode transport = do
515− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
516−
517− closeLocalNode node1
518−
519− runProcess node2 $ do
520− ref <- monitorNode (localNodeId node1)
521− NodeMonitorNotification ref' nid DiedDisconnect <- expect
522− True <- return $ ref == ref' && nid == localNodeId node1
523− return ()
524−
525−testMonitorChannel :: NT.Transport -> IO ()
526−testMonitorChannel transport = do
527− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
528− gotNotification <- newEmptyMVar
529−
530− pid <- forkProcess node1 $ do
531− sport <- expect :: Process (SendPort ())
532− ref <- monitorPort sport
533− PortMonitorNotification ref' port' DiedNormal <- expect
534− return $ ref' == ref && port' == sendPortId sport
535− liftIO $ putMVar gotNotification ()
536−
537− runProcess node2 $ do
538− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
539− send pid sport
540− liftIO $ threadDelay 100000
541−
542− takeMVar gotNotification
543−
544−testRegistry :: NT.Transport -> IO ()
545−testRegistry transport = do
546− node <- newLocalNode transport initRemoteTable
547−
548− pingServer <- forkProcess node ping
549−
550− runProcess node $ do
551− register "ping" pingServer
552− Just pid <- whereis "ping"
553− True <- return $ pingServer == pid
554− us <- getSelfPid
555− nsend "ping" (Pong us)
556− Ping pid' <- expect
557− True <- return $ pingServer == pid'
558− return ()
559−
560−testRemoteRegistry :: NT.Transport -> IO ()
561−testRemoteRegistry transport = do
562− node1 <- newLocalNode transport initRemoteTable
563− node2 <- newLocalNode transport initRemoteTable
564−
565− pingServer <- forkProcess node1 ping
566−
567− runProcess node2 $ do
568− let nid1 = localNodeId node1
569− registerRemote nid1 "ping" pingServer
570− Just pid <- whereisRemote nid1 "ping"
571− True <- return $ pingServer == pid
572− us <- getSelfPid
573− nsendRemote nid1 "ping" (Pong us)
574− Ping pid' <- expect
575− True <- return $ pingServer == pid'
576− return ()
577−
578−testSpawnLocal :: NT.Transport -> IO ()
579−testSpawnLocal transport = do
580− node <- newLocalNode transport initRemoteTable
581−
582− runProcess node $ do
583− us <- getSelfPid
584−
585− pid <- spawnLocal $ do
586− sport <- expect
587− sendChan sport (1234 :: Int)
588−
589− sport <- spawnChannelLocal $ \rport -> do
590− (1234 :: Int) <- receiveChan rport
591− send us ()
592−
593− send pid sport
594− expect
595−
596−testReconnect :: NT.Transport -> TransportInternals -> IO ()
597−testReconnect transport transportInternals = do
598− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
599− let nid1 = localNodeId node1
600− nid2 = localNodeId node2
601− processA <- newEmptyMVar
602− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
603−
604− forkProcess node1 $ do
605− us <- getSelfPid
606− liftIO $ putMVar processA us
607− msg1 <- expect
608− msg2 <- expect
609− True <- return $ msg1 == "message 1" && msg2 == "message 3"
610− liftIO $ putMVar sendTestOk ()
611−
612− forkProcess node2 $ do
613− {-
614− - Make sure there is no implicit reconnect on normal message sending
615− -}
616−
617− them <- liftIO $ readMVar processA
618− send them "message 1" >> liftIO (threadDelay 100000)
619−
620− -- Simulate network failure
621− liftIO $ do
622− sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
623− sClose sock
624− threadDelay 10000
625−
626− -- Should not arrive
627− send them "message 2"
628−
629− -- Should arrive
630− reconnect them
631− send them "message 3"
632−
633− liftIO $ takeMVar sendTestOk
634−
635− {-
636− - Test that there *is* implicit reconnect on node controller messages
637− -}
638−
639− us <- getSelfPid
640− registerRemote nid1 "a" us >> liftIO (threadDelay 100000) -- registerRemote is asynchronous
641−
642− -- Simulate network failure
643− liftIO $ do
644− sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
645− sClose sock
646− threadDelay 10000
647−
648− -- This will happen due to implicit reconnect
649− registerRemote nid1 "b" us
650−
651− -- Should happen
652− registerRemote nid1 "c" us
653−
654− -- Check
655− Just _ <- whereisRemote nid1 "a"
656− Just _ <- whereisRemote nid1 "b"
657− Just _ <- whereisRemote nid1 "c"
658−
659− liftIO $ putMVar registerTestOk ()
660−
661− takeMVar registerTestOk
662−
663−main :: IO ()
664−main = do
665− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
666− runTests
667− [ ("Ping", testPing transport)
668− , ("Math", testMath transport)
669− , ("Timeout", testTimeout transport)
670− , ("Timeout0", testTimeout0 transport)
671− , ("SendToTerminated", testSendToTerminated transport)
672− , ("TypedChannnels", testTypedChannels transport)
673− , ("MergeChannels", testMergeChannels transport)
674− , ("Terminate", testTerminate transport)
675− , ("Registry", testRegistry transport)
676− , ("RemoteRegistry", testRemoteRegistry transport)
677− , ("SpawnLocal", testSpawnLocal transport)
678− -- Monitoring processes
679− --
680− -- The "missing" combinations in the list below don't make much sense, as
681− -- we cannot guarantee that the monitor reply or link exception will not
682− -- happen before the unmonitor or unlink
683− , ("MonitorUnreachable", testMonitorUnreachable transport True False)
684− , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
685− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
686− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
687− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
688− , ("MonitorDisconnect", testMonitorDisconnect transport True False)
689− , ("LinkUnreachable", testMonitorUnreachable transport False False)
690− , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
691− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
692− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
693− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
694− , ("LinkDisconnect", testMonitorDisconnect transport False False)
695− , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
696− , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
697− , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
698− , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
699− , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
700− , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
701− -- Monitoring nodes and channels
702− , ("MonitorNode", testMonitorNode transport)
703− , ("MonitorChannel", testMonitorChannel transport)
704− -- Reconnect
705− , ("Reconnect", testReconnect transport transportInternals)
706− ]
distributed-process/tests/TestClosure.hsdeleted−412
@@ -1,412 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Main where
3−
4−import Data.ByteString.Lazy (empty)
5−import Data.Typeable (Typeable)
6−import Control.Monad (join, replicateM, forever)
7−import Control.Exception (IOException, throw)
8−import Control.Concurrent (forkIO, threadDelay)
9−import Control.Concurrent.MVar
10− ( MVar
11− , newEmptyMVar
12− , readMVar
13− , takeMVar
14− , putMVar
15− , modifyMVar_
16− , newMVar
17− )
18−import Control.Applicative ((<$>))
19−import Network.Transport (Transport)
20−import Network.Transport.TCP
21− ( createTransportExposeInternals
22− , defaultTCPParameters
23− , TransportInternals(socketBetween)
24− )
25−import Network.Socket (sClose)
26−import Control.Distributed.Process
27−import Control.Distributed.Process.Closure
28−import Control.Distributed.Process.Node
29−import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))
30−import Control.Distributed.Static (staticLabel, staticClosure)
31−import TestAuxiliary
32−
33−quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
34−quintuple a b c d e = (a, b, c, d, e)
35−
36−sdictInt :: SerializableDict Int
37−sdictInt = SerializableDict
38−
39−factorial :: Int -> Process Int
40−factorial 0 = return 1
41−factorial n = (n *) <$> factorial (n - 1)
42−
43−addInt :: Int -> Int -> Int
44−addInt x y = x + y
45−
46−putInt :: Int -> MVar Int -> IO ()
47−putInt = flip putMVar
48−
49−sendPid :: ProcessId -> Process ()
50−sendPid toPid = do
51− fromPid <- getSelfPid
52− send toPid fromPid
53−
54−wait :: Int -> Process ()
55−wait = liftIO . threadDelay
56−
57−isPrime :: Integer -> Process Bool
58−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
59− where
60− sieve :: [Integer] -> [Integer]
61− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
62− sieve [] = error "Uh oh -- we've run out of primes"
63−
64−-- | First argument indicates empty closure environment
65−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
66−typedPingServer () rport = forever $ do
67− sport <- receiveChan rport
68− sendChan sport ()
69−
70−signal :: ProcessId -> Process ()
71−signal pid = send pid ()
72−
73−remotable [ 'factorial
74− , 'addInt
75− , 'putInt
76− , 'sendPid
77− , 'sdictInt
78− , 'wait
79− , 'typedPingServer
80− , 'isPrime
81− , 'quintuple
82− , 'signal
83− ]
84−
85−-- Just try creating a static polymorphic value
86−staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
87− => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
88−staticQuintuple = $(mkStatic 'quintuple)
89−
90−factorialClosure :: Int -> Closure (Process Int)
91−factorialClosure = $(mkClosure 'factorial)
92−
93−addIntClosure :: Int -> Closure (Int -> Int)
94−addIntClosure = $(mkClosure 'addInt)
95−
96−putIntClosure :: Int -> Closure (MVar Int -> IO ())
97−putIntClosure = $(mkClosure 'putInt)
98−
99−sendPidClosure :: ProcessId -> Closure (Process ())
100−sendPidClosure = $(mkClosure 'sendPid)
101−
102−sendFac :: Int -> ProcessId -> Closure (Process ())
103−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid
104−
105−factorialOf :: Closure (Int -> Process Int)
106−factorialOf = staticClosure $(mkStatic 'factorial)
107−
108−factorial' :: Int -> Closure (Process Int)
109−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
110−
111−waitClosure :: Int -> Closure (Process ())
112−waitClosure = $(mkClosure 'wait)
113−
114−testUnclosure :: Transport -> RemoteTable -> IO ()
115−testUnclosure transport rtable = do
116− node <- newLocalNode transport rtable
117− done <- newEmptyMVar
118− forkProcess node $ do
119− 120 <- join . unClosure $ factorialClosure 5
120− liftIO $ putMVar done ()
121− takeMVar done
122−
123−testBind :: Transport -> RemoteTable -> IO ()
124−testBind transport rtable = do
125− node <- newLocalNode transport rtable
126− done <- newEmptyMVar
127− runProcess node $ do
128− us <- getSelfPid
129− join . unClosure $ sendFac 6 us
130− (720 :: Int) <- expect
131− liftIO $ putMVar done ()
132− takeMVar done
133−
134−testSendPureClosure :: Transport -> RemoteTable -> IO ()
135−testSendPureClosure transport rtable = do
136− serverAddr <- newEmptyMVar
137− serverDone <- newEmptyMVar
138−
139− forkIO $ do
140− node <- newLocalNode transport rtable
141− addr <- forkProcess node $ do
142− cl <- expect
143− fn <- unClosure cl :: Process (Int -> Int)
144− 13 <- return $ fn 6
145− liftIO $ putMVar serverDone ()
146− putMVar serverAddr addr
147−
148− forkIO $ do
149− node <- newLocalNode transport rtable
150− theirAddr <- readMVar serverAddr
151− runProcess node $ send theirAddr (addIntClosure 7)
152−
153− takeMVar serverDone
154−
155−testSendIOClosure :: Transport -> RemoteTable -> IO ()
156−testSendIOClosure transport rtable = do
157− serverAddr <- newEmptyMVar
158− serverDone <- newEmptyMVar
159−
160− forkIO $ do
161− node <- newLocalNode transport rtable
162− addr <- forkProcess node $ do
163− cl <- expect
164− io <- unClosure cl :: Process (MVar Int -> IO ())
165− liftIO $ do
166− someMVar <- newEmptyMVar
167− io someMVar
168− 5 <- readMVar someMVar
169− putMVar serverDone ()
170− putMVar serverAddr addr
171−
172− forkIO $ do
173− node <- newLocalNode transport rtable
174− theirAddr <- readMVar serverAddr
175− runProcess node $ send theirAddr (putIntClosure 5)
176−
177− takeMVar serverDone
178−
179−testSendProcClosure :: Transport -> RemoteTable -> IO ()
180−testSendProcClosure transport rtable = do
181− serverAddr <- newEmptyMVar
182− clientDone <- newEmptyMVar
183−
184− forkIO $ do
185− node <- newLocalNode transport rtable
186− addr <- forkProcess node $ do
187− cl <- expect
188− pr <- unClosure cl :: Process (Int -> Process ())
189− pr 5
190− putMVar serverAddr addr
191−
192− forkIO $ do
193− node <- newLocalNode transport rtable
194− theirAddr <- readMVar serverAddr
195− runProcess node $ do
196− pid <- getSelfPid
197− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
198− 5 <- expect :: Process Int
199− liftIO $ putMVar clientDone ()
200−
201− takeMVar clientDone
202−
203−testSpawn :: Transport -> RemoteTable -> IO ()
204−testSpawn transport rtable = do
205− serverNodeAddr <- newEmptyMVar
206− clientDone <- newEmptyMVar
207−
208− forkIO $ do
209− node <- newLocalNode transport rtable
210− putMVar serverNodeAddr (localNodeId node)
211−
212− forkIO $ do
213− node <- newLocalNode transport rtable
214− nid <- readMVar serverNodeAddr
215− runProcess node $ do
216− pid <- getSelfPid
217− pid' <- spawn nid (sendPidClosure pid)
218− pid'' <- expect
219− True <- return $ pid' == pid''
220− liftIO $ putMVar clientDone ()
221−
222− takeMVar clientDone
223−
224−testCall :: Transport -> RemoteTable -> IO ()
225−testCall transport rtable = do
226− serverNodeAddr <- newEmptyMVar
227− clientDone <- newEmptyMVar
228−
229− forkIO $ do
230− node <- newLocalNode transport rtable
231− putMVar serverNodeAddr (localNodeId node)
232−
233− forkIO $ do
234− node <- newLocalNode transport rtable
235− nid <- readMVar serverNodeAddr
236− runProcess node $ do
237− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
238− liftIO $ putMVar clientDone ()
239−
240− takeMVar clientDone
241−
242−testCallBind :: Transport -> RemoteTable -> IO ()
243−testCallBind transport rtable = do
244− serverNodeAddr <- newEmptyMVar
245− clientDone <- newEmptyMVar
246−
247− forkIO $ do
248− node <- newLocalNode transport rtable
249− putMVar serverNodeAddr (localNodeId node)
250−
251− forkIO $ do
252− node <- newLocalNode transport rtable
253− nid <- readMVar serverNodeAddr
254− runProcess node $ do
255− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
256− liftIO $ putMVar clientDone ()
257−
258− takeMVar clientDone
259−
260−testSeq :: Transport -> RemoteTable -> IO ()
261−testSeq transport rtable = do
262− node <- newLocalNode transport rtable
263− done <- newEmptyMVar
264− runProcess node $ do
265− us <- getSelfPid
266− join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
267− 120 :: Int <- expect
268− 720 :: Int <- expect
269− liftIO $ putMVar done ()
270− takeMVar done
271−
272−-- Test 'spawnSupervised'
273−--
274−-- Set up a supervisor, spawn a child, then have a third process monitor the
275−-- child. The supervisor then throws an exception, the child dies because it
276−-- was linked to the supervisor, and the third process notices that the child
277−-- dies.
278−testSpawnSupervised :: Transport -> RemoteTable -> IO ()
279−testSpawnSupervised transport rtable = do
280− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
281− [superPid, childPid] <- replicateM 2 $ newEmptyMVar
282− thirdProcessDone <- newEmptyMVar
283−
284− forkProcess node1 $ do
285− us <- getSelfPid
286− liftIO $ putMVar superPid us
287− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
288− liftIO $ do
289− putMVar childPid child
290− threadDelay 500000 -- Give the child a chance to link to us
291− throw supervisorDeath
292−
293− forkProcess node2 $ do
294− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
295− ref <- monitor child
296− ProcessMonitorNotification ref' pid' (DiedException e) <- expect
297− True <- return $ ref' == ref
298− && pid' == child
299− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
300− liftIO $ putMVar thirdProcessDone ()
301−
302− takeMVar thirdProcessDone
303− where
304− supervisorDeath :: IOException
305− supervisorDeath = userError "Supervisor died"
306−
307−testSpawnInvalid :: Transport -> RemoteTable -> IO ()
308−testSpawnInvalid transport rtable = do
309− node <- newLocalNode transport rtable
310− done <- newEmptyMVar
311− forkProcess node $ do
312− (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
313− ProcessMonitorNotification ref' pid' _reason <- expect
314− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
315− True <- return $ ref' == ref && pid == pid'
316− liftIO $ putMVar done ()
317− takeMVar done
318−
319−testClosureExpect :: Transport -> RemoteTable -> IO ()
320−testClosureExpect transport rtable = do
321− node <- newLocalNode transport rtable
322− done <- newEmptyMVar
323− runProcess node $ do
324− nodeId <- getSelfNode
325− us <- getSelfPid
326− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
327− send them (1234 :: Int)
328− (1234 :: Int) <- expect
329− liftIO $ putMVar done ()
330− takeMVar done
331−
332−testSpawnChannel :: Transport -> RemoteTable -> IO ()
333−testSpawnChannel transport rtable = do
334− done <- newEmptyMVar
335− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
336−
337− forkProcess node1 $ do
338− pingServer <- spawnChannel
339− (sdictSendPort sdictUnit)
340− (localNodeId node2)
341− ($(mkClosure 'typedPingServer) ())
342− (sendReply, receiveReply) <- newChan
343− sendChan pingServer sendReply
344− receiveChan receiveReply
345− liftIO $ putMVar done ()
346−
347− takeMVar done
348−
349−testTDict :: Transport -> RemoteTable -> IO ()
350−testTDict transport rtable = do
351− done <- newEmptyMVar
352− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
353− forkProcess node1 $ do
354− True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
355− liftIO $ putMVar done ()
356− takeMVar done
357−
358−simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()
359−simulateNetworkFailure transportInternals fr to = liftIO $ do
360− threadDelay 10000
361− sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
362− sClose sock
363− threadDelay 10000
364−
365−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> IO ()
366−testSpawnReconnect transport rtable transportInternals = do
367− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
368− let nid1 = localNodeId node1
369− nid2 = localNodeId node2
370− done <- newEmptyMVar
371− iv <- newMVar (0 :: Int)
372−
373− incr <- forkProcess node1 $ forever $ do
374− () <- expect
375− liftIO $ modifyMVar_ iv (return . (+ 1))
376−
377− forkProcess node2 $ do
378− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)
379− simulateNetworkFailure transportInternals nid2 nid1
380− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)
381− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)
382−
383− liftIO $ threadDelay 100000
384−
385− count <- liftIO $ takeMVar iv
386− True <- return $ count == 3
387−
388− liftIO $ putMVar done ()
389−
390− takeMVar done
391−
392−main :: IO ()
393−main = do
394− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
395− let rtable = __remoteTable initRemoteTable
396− runTests
397− [ ("Unclosure", testUnclosure transport rtable)
398− , ("Bind", testBind transport rtable)
399− , ("SendPureClosure", testSendPureClosure transport rtable)
400− , ("SendIOClosure", testSendIOClosure transport rtable)
401− , ("SendProcClosure", testSendProcClosure transport rtable)
402− , ("Spawn", testSpawn transport rtable)
403− , ("Call", testCall transport rtable)
404− , ("CallBind", testCallBind transport rtable)
405− , ("Seq", testSeq transport rtable)
406− , ("SpawnSupervised", testSpawnSupervised transport rtable)
407− , ("SpawnInvalid", testSpawnInvalid transport rtable)
408− , ("ClosureExpect", testClosureExpect transport rtable)
409− , ("SpawnChannel", testSpawnChannel transport rtable)
410− , ("TDict", testTDict transport rtable)
411− , ("SpawnReconnect", testSpawnReconnect transport rtable transportInternals)
412− ]
distributed-static/ChangeLogdeleted−8
@@ -1,8 +0,0 @@
1−2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.2
2−
3−* Hide the 'Closure' constructor and export 'closure' instead so that we are
4−free to change the internal representation
5−
6−2012-08-10 Edsko de Vries <edsko@well-typed.com> 0.1
7−
8−* Initial release
distributed-static/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2012, Edsko de Vries
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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.
distributed-static/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
distributed-static/distributed-static.cabaldeleted−37
@@ -1,37 +0,0 @@
1−Name: distributed-static
2−Version: 0.2.0.0
3−Synopsis: Compositional, type-safe, polymorphic static values and closures
4−Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell
5− Symposium 2011) introduces the concept of /static/ values:
6− values that are known at compile time. In a distributed
7− setting where all nodes are running the same executable,
8− static values can be serialized simply by transmitting a
9− code pointer to the value. This however requires special
10− compiler support, which is not yet available in ghc. We
11− can mimick the behaviour by keeping an explicit mapping
12− ('RemoteTable') from labels to values (and making sure
13− that all distributed nodes are using the same
14− 'RemoteTable'). In this module we implement this mimickry
15− and various extensions: type safety (including for
16− polymorphic static values) and compositionality.
17−Homepage: http://www.github.com/haskell-distributed/distributed-process
18−License: BSD3
19−License-File: LICENSE
20−Author: Edsko de Vries
21−Maintainer: edsko@well-typed.com
22−Copyright: Well-Typed LLP
23−Category: Control
24−Build-Type: Simple
25−Cabal-Version: >=1.8
26−
27−Library
28− Exposed-Modules: Control.Distributed.Static
29− Build-Depends: base >= 4 && < 5,
30− rank1dynamic >= 0.1 && < 0.2,
31− containers >= 0.4 && < 0.6,
32− bytestring >= 0.9 && < 0.11,
33− binary >= 0.5 && < 0.6
34− HS-Source-Dirs: src
35− Extensions: DeriveDataTypeable,
36− ScopedTypeVariables
37− GHC-Options: -Wall
distributed-static/src/Control/Distributed/Static.hsdeleted−441
@@ -1,441 +0,0 @@
1−-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)
2−-- introduces the concept of /static/ values: values that are known at compile
3−-- time. In a distributed setting where all nodes are running the same
4−-- executable, static values can be serialized simply by transmitting a code
5−-- pointer to the value. This however requires special compiler support, which
6−-- is not yet available in ghc. We can mimick the behaviour by keeping an
7−-- explicit mapping ('RemoteTable') from labels to values (and making sure that
8−-- all distributed nodes are using the same 'RemoteTable'). In this module
9−-- we implement this mimickry and various extensions.
10−--
11−-- [Dynamic type checking]
12−--
13−-- The paper stipulates that 'Static' values should have a free 'Binary'
14−-- instance:
15−--
16−-- > instance Binary (Static a)
17−--
18−-- This however is not (runtime) type safe: for instance, what would be the
19−-- behaviour of
20−--
21−-- > f :: Static Int -> Static Bool
22−-- > f = decode . encode
23−--
24−-- For this reason we work only with 'Typeable' terms in this module, and
25−-- implement runtime checks
26−--
27−-- > instance Typeable a => Binary (Static a)
28−--
29−-- The above function 'f' typechecks but throws an exception if executed. The
30−-- type representation we use, however, is not the standard
31−-- 'Data.Typeable.TypeRep' from "Data.Typeable" but
32−-- 'Data.Rank1Typeable.TypeRep' from "Data.Rank1Typeable". This means that we
33−-- can represent polymorphic static values (see below for an example).
34−--
35−-- Since the runtime mapping ('RemoteTable') contains values of different types,
36−-- it maps labels ('String's) to 'Data.Rank1Dynamic.Dynamic' values. Again, we
37−-- use the implementation from "Data.Rank1Dynamic" so that we can store
38−-- polymorphic dynamic values.
39−--
40−-- [Compositionality]
41−--
42−-- Static values as described in the paper are not compositional: there is no
43−-- way to combine two static values and get a static value out of it. This
44−-- makes sense when interpreting static strictly as /known at compile time/,
45−-- but it severely limits expressiveness. However, the main motivation for
46−-- 'static' is not that they are known at compile time but rather that
47−-- /they provide a free/ 'Binary' /instance/. We therefore provide two basic
48−-- constructors for 'Static' values:
49−--
50−-- > staticLabel :: String -> Static a
51−-- > staticApply :: Static (a -> b) -> Static a -> Static b
52−--
53−-- The first constructor refers to a label in a 'RemoteTable'. The second
54−-- allows to apply a static function to a static argument, and makes 'Static'
55−-- compositional: once we have 'staticApply' we can implement numerous derived
56−-- combinators on 'Static' values (we define a few in this module; see
57−-- 'staticCompose', 'staticSplit', and 'staticConst').
58−--
59−-- [Closures]
60−--
61−-- Closures in functional programming arise when we partially apply a function.
62−-- A closure is a code pointer together with a runtime data structure that
63−-- represents the value of the free variables of the function. A 'Closure'
64−-- represents these closures explicitly so that they can be serialized:
65−--
66−-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
67−--
68−-- See /Towards Haskell in the Cloud/ for the rationale behind representing
69−-- the function closure environment in serialized ('ByteString') form. Any
70−-- static value can trivially be turned into a 'Closure' ('staticClosure').
71−-- Moreover, since 'Static' is now compositional, we can also define derived
72−-- operators on 'Closure' values ('closureApplyStatic', 'closureApply',
73−-- 'closureCompose', 'closureSplit').
74−--
75−-- [Monomorphic example]
76−--
77−-- Suppose we are working in the context of some distributed environment, with
78−-- a monadic type 'Process' representing processes, 'NodeId' representing node
79−-- addresses and 'ProcessId' representing process addresses. Suppose further
80−-- that we have a primitive
81−--
82−-- > sendInt :: ProcessId -> Int -> Process ()
83−--
84−-- We might want to define
85−--
86−-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
87−--
88−-- In order to do that, we need a static version of 'send', and a static
89−-- decoder for 'ProcessId':
90−--
91−-- > sendIntStatic :: Static (ProcessId -> Int -> Process ())
92−-- > sendIntStatic = staticLabel "$send"
93−--
94−-- > decodeProcessIdStatic :: Static (ByteString -> Int)
95−-- > decodeProcessIdStatic = staticLabel "$decodeProcessId"
96−--
97−-- where of course we have to make sure to use an appropriate 'RemoteTable':
98−--
99−-- > rtable :: RemoteTable
100−-- > rtable = registerStatic "$send" (toDynamic sendInt)
101−-- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int))
102−-- > $ initRemoteTable
103−--
104−-- We can now define 'sendIntClosure':
105−--
106−-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
107−-- > sendIntClosure pid = closure decoder (encode pid)
108−-- > where
109−-- > decoder :: Static (ByteString -> Int -> Process ())
110−-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic
111−--
112−-- [Polymorphic example]
113−--
114−-- Suppose we wanted to define a primitive
115−--
116−-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
117−--
118−-- which turns a process that computes an integer into a process that computes
119−-- the integer and then sends it someplace else.
120−--
121−-- We can define
122−--
123−-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b)
124−-- > bindStatic = staticLabel "$bind"
125−--
126−-- provided that we register this label:
127−--
128−-- > rtable :: RemoteTable
129−-- > rtable = ...
130−-- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2)
131−-- > $ initRemoteTable
132−--
133−-- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and
134−-- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this
135−-- polymorphic value.) Once we have a static bind we can define
136−--
137−-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
138−-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid
139−--
140−-- [Dealing with qualified types]
141−--
142−-- In the above we were careful to avoid qualified types. Suppose that we have
143−-- instead
144−--
145−-- > send :: Binary a => ProcessId -> a -> Process ()
146−--
147−-- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above,
148−-- we somehow need to include the 'Binary' instance in the closure -- after
149−-- all, we can ship this closure someplace else, where it needs to accept an
150−-- 'a', /then encode it/, and send it off. In order to do this, we need to turn
151−-- the Binary instance into an explicit dictionary:
152−--
153−-- > data BinaryDict a where
154−-- > BinaryDict :: Binary a => BinaryDict a
155−-- >
156−-- > sendDict :: BinaryDict a -> ProcessId -> a -> Process ()
157−-- > sendDict BinaryDict = send
158−--
159−-- Now 'sendDict' is a normal polymorphic value:
160−--
161−-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ())
162−-- > sendDictStatic = staticLabel "$sendDict"
163−-- >
164−-- > rtable :: RemoteTable
165−-- > rtable = ...
166−-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ())
167−-- > $ initRemoteTable
168−--
169−-- so that we can define
170−--
171−-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ())
172−-- > sendClosure dict pid = closure decoder (encode pid)
173−-- > where
174−-- > decoder :: Static (ByteString -> a -> Process ())
175−-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic
176−--
177−-- [Word of Caution]
178−--
179−-- You should not /define/ functions on 'ANY' and co. For example, the following
180−-- definition of 'rtable' is incorrect:
181−--
182−-- > rtable :: RemoteTable
183−-- > rtable = registerStatic "$sdictSendPort" sdictSendPort
184−-- > $ initRemoteTable
185−-- > where
186−-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)
187−-- > sdictSendPort SerializableDict = SerializableDict
188−--
189−-- This definition of 'sdictSendPort' ignores its argument completely, and
190−-- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@,
191−-- which isn't what you want. Instead, you should do
192−--
193−-- > rtable :: RemoteTable
194−-- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY))
195−-- > $ initRemoteTable
196−-- > where
197−-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a)
198−-- > sdictSendPort SerializableDict = SerializableDict
199−module Control.Distributed.Static
200− ( -- * Static values
201− Static
202− , staticLabel
203− , staticApply
204− -- * Derived static combinators
205− , staticCompose
206− , staticSplit
207− , staticConst
208− -- * Closures
209− , Closure
210− , closure
211− -- * Derived closure combinators
212− , staticClosure
213− , closureApplyStatic
214− , closureApply
215− , closureCompose
216− , closureSplit
217− -- * Resolution
218− , RemoteTable
219− , initRemoteTable
220− , registerStatic
221− , unstatic
222− , unclosure
223− ) where
224−
225−import Data.Binary
226− ( Binary(get, put)
227− , Put
228− , Get
229− , putWord8
230− , getWord8
231− , encode
232− , decode
233− )
234−import Data.ByteString.Lazy (ByteString, empty)
235−import Data.Map (Map)
236−import qualified Data.Map as Map (lookup, empty, insert)
237−import Control.Applicative ((<$>), (<*>))
238−import Control.Arrow as Arrow ((***), app)
239−import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
240−import Data.Rank1Typeable
241− ( Typeable
242− , typeOf
243− , ANY1
244− , ANY2
245− , ANY3
246− , ANY4
247− , isInstanceOf
248− )
249−
250−--------------------------------------------------------------------------------
251−-- Introducing static values --
252−--------------------------------------------------------------------------------
253−
254−data StaticLabel =
255− StaticLabel String
256− | StaticApply StaticLabel StaticLabel
257− deriving (Typeable, Show)
258−
259−-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
260−newtype Static a = Static StaticLabel
261− deriving (Typeable, Show)
262−
263−instance Typeable a => Binary (Static a) where
264− put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))
265− get = do
266− label <- getStaticLabel
267− typeRep <- get
268− case typeOf (undefined :: a) `isInstanceOf` typeRep of
269− Left err -> fail $ "Static.get: type error: " ++ err
270− Right () -> return (Static label)
271−
272−-- We don't want StaticLabel to be its own Binary instance
273−putStaticLabel :: StaticLabel -> Put
274−putStaticLabel (StaticLabel string) =
275− putWord8 0 >> put string
276−putStaticLabel (StaticApply label1 label2) =
277− putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
278−
279−getStaticLabel :: Get StaticLabel
280−getStaticLabel = do
281− header <- getWord8
282− case header of
283− 0 -> StaticLabel <$> get
284− 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
285− _ -> fail "StaticLabel.get: invalid"
286−
287−-- | Create a primitive static value.
288−--
289−-- It is the responsibility of the client code to make sure the corresponding
290−-- entry in the 'RemoteTable' has the appropriate type.
291−staticLabel :: String -> Static a
292−staticLabel = Static . StaticLabel
293−
294−-- | Apply two static values
295−staticApply :: Static (a -> b) -> Static a -> Static b
296−staticApply (Static f) (Static x) = Static (StaticApply f x)
297−
298−--------------------------------------------------------------------------------
299−-- Eliminating static values --
300−--------------------------------------------------------------------------------
301−
302−-- | Runtime dictionary for 'unstatic' lookups
303−newtype RemoteTable = RemoteTable (Map String Dynamic)
304−
305−-- | Initial remote table
306−initRemoteTable :: RemoteTable
307−initRemoteTable =
308− registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))
309− . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))
310− . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))
311− . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2))
312− . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString)))
313− $ RemoteTable Map.empty
314−
315−-- | Register a static label
316−registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
317−registerStatic label dyn (RemoteTable rtable)
318− = RemoteTable (Map.insert label dyn rtable)
319−
320−-- Pseudo-type: RemoteTable -> Static a -> a
321−resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
322−resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
323− case Map.lookup label rtable of
324− Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
325− Just d -> Right d
326−resolveStaticLabel rtable (StaticApply label1 label2) = do
327− f <- resolveStaticLabel rtable label1
328− x <- resolveStaticLabel rtable label2
329− f `dynApply` x
330−
331−-- | Resolve a static value
332−unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
333−unstatic rtable (Static static) = do
334− dyn <- resolveStaticLabel rtable static
335− fromDynamic dyn
336−
337−--------------------------------------------------------------------------------
338−-- Closures --
339−--------------------------------------------------------------------------------
340−
341−-- | A closure is a static value and an encoded environment
342−data Closure a = Closure (Static (ByteString -> a)) ByteString
343− deriving (Typeable, Show)
344−
345−instance Typeable a => Binary (Closure a) where
346− put (Closure static env) = put static >> put env
347− get = Closure <$> get <*> get
348−
349−closure :: Static (ByteString -> a) -- ^ Decoder
350− -> ByteString -- ^ Encoded closure environment
351− -> Closure a
352−closure = Closure
353−
354−-- | Resolve a closure
355−unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
356−unclosure rtable (Closure static env) = do
357− f <- unstatic rtable static
358− return (f env)
359−
360−-- | Convert a static value into a closure.
361−staticClosure :: Typeable a => Static a -> Closure a
362−staticClosure static = closure (staticConst static) empty
363−
364−--------------------------------------------------------------------------------
365−-- Predefined static values --
366−--------------------------------------------------------------------------------
367−
368−-- | Static version of ('Prelude..')
369−composeStatic :: (Typeable a, Typeable b, Typeable c)
370− => Static ((b -> c) -> (a -> b) -> a -> c)
371−composeStatic = staticLabel "$compose"
372−
373−-- | Static version of 'const'
374−constStatic :: (Typeable a, Typeable b)
375− => Static (a -> b -> a)
376−constStatic = staticLabel "$const"
377−
378−-- | Static version of ('Arrow.***')
379−splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
380− => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
381−splitStatic = staticLabel "$split"
382−
383−-- | Static version of 'Arrow.app'
384−appStatic :: (Typeable a, Typeable b)
385− => Static ((a -> b, a) -> b)
386−appStatic = staticLabel "$app"
387−
388−--------------------------------------------------------------------------------
389−-- Combinators on static values --
390−--------------------------------------------------------------------------------
391−
392−-- | Static version of ('Prelude..')
393−staticCompose :: (Typeable a, Typeable b, Typeable c)
394− => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
395−staticCompose g f = composeStatic `staticApply` g `staticApply` f
396−
397−-- | Static version of ('Control.Arrow.***')
398−staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
399− => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
400−staticSplit f g = splitStatic `staticApply` f `staticApply` g
401−
402−-- | Static version of 'Prelude.const'
403−staticConst :: (Typeable a, Typeable b)
404− => Static a -> Static (b -> a)
405−staticConst x = constStatic `staticApply` x
406−
407−--------------------------------------------------------------------------------
408−-- Combinators on Closures --
409−--------------------------------------------------------------------------------
410−
411−-- | Apply a static function to a closure
412−closureApplyStatic :: (Typeable a, Typeable b)
413− => Static (a -> b) -> Closure a -> Closure b
414−closureApplyStatic f (Closure decoder env) =
415− closure (f `staticCompose` decoder) env
416−
417−decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
418−decodeEnvPairStatic = staticLabel "$decodeEnvPair"
419−
420−-- | Closure application
421−closureApply :: forall a b. (Typeable a, Typeable b)
422− => Closure (a -> b) -> Closure a -> Closure b
423−closureApply (Closure fdec fenv) (Closure xdec xenv) =
424− closure decoder (encode (fenv, xenv))
425− where
426− decoder :: Static (ByteString -> b)
427− decoder = appStatic
428− `staticCompose`
429− (fdec `staticSplit` xdec)
430− `staticCompose`
431− decodeEnvPairStatic
432−
433−-- | Closure composition
434−closureCompose :: (Typeable a, Typeable b, Typeable c)
435− => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
436−closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
437−
438−-- | Closure version of ('Arrow.***')
439−closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
440− => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
441−closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g
doc/InternalsTransportMulticast.txtdeleted−181
@@ -1,181 +0,0 @@
1−Adding Support for Multicast to the Transport API
2−=================================================
3−
4−This document describes various design options for adding support for multicast
5−to the Transport API.
6−
7−Creating a new multicast group
8−------------------------------
9−
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.txtdeleted−81
@@ -1,81 +0,0 @@
1−The TCP Transport
2−=================
3−
4−Overview
5−--------
6−
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.pngdeleted

Binary file not shown.

doc/NetworkTCP.svgdeleted−657
@@ -1,657 +0,0 @@
1−<?xml version="1.0" encoding="UTF-8" standalone="no"?>
2−<!-- Created with Inkscape (http://www.inkscape.org/) -->
3−
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/blacklist.texdeleted−525
@@ -1,525 +0,0 @@
1−\documentclass{article}
2−\usepackage[margin=2.5cm]{geometry}
3−\usepackage{amsmath, amssymb}
4−\usepackage{mathpazo, times}
5−
6−\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
7−\newcommand{\sApp}[2]{{#1} {#2}}
8−\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
9−\newcommand{\sReturn}{\mathtt{return}}
10−
11−\newcommand{\sExpect}{\mathtt{expect}}
12−\newcommand{\sSend}{\mathtt{send}}
13−\newcommand{\sSpawn}{\mathtt{spawn}}
14−\newcommand{\sLink}{\mathtt{link}}
15−\newcommand{\sThrow}{\mathtt{throw}}
16−\newcommand{\sReconnect}{\mathtt{reconnect}}
17−\newcommand{\sNewChan}{\mathtt{newChan}}
18−\newcommand{\sSendChan}{\mathtt{sendChan}}
19−\newcommand{\sReceiveChan}{\mathtt{receiveChan}}
20−\newcommand{\sMonitor}{\mathtt{monitor}}
21−
22−\DeclareMathOperator{\sNodeOf}{node}
23−\DeclareMathOperator{\sProcessOf}{process}
24−
25−\newcommand{\sSpawned}{\mathtt{spawned}}
26−
27−\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}}
28−
29−\newcommand{\sPar}{\mathrel{\parallel}}
30−\newcommand{\sProc}[2]{{#1}_{#2}}
31−
32−\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
33−\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
34−\newcommand{\sCid}{\ensuremath{\mathit{cid}}}
35−
36−\newcommand{\sId}{\ensuremath{\mathit{id}}}
37−\newcommand{\sRef}{\ensuremath{\mathit{ref}}}
38−
39−\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
40−\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
41−\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle}
42−\newcommand{\sNodes}{\mathcal{N}}
43−\newcommand{\sQueue}{\mathcal{Q}}
44−\newcommand{\sProcesses}{\mathcal{P}}
45−\newcommand{\sBlacklist}{\mathcal{B}}
46−\newcommand{\sMonitors}{\mathcal{M}}
47−
48−\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
49−\newcommand{\sNothing}{\mathtt{Nothing}}
50−
51−\newcommand{\sCtxt}[1]{\mathbb{#1}}
52−
53−\newcommand{\sSenders}{\mathit{senders}}
54−
55−\newcommand{\OR}{\mathrel{|}}
56−
57−
58−\begin{document}
59−
60−\title{Cloud Haskell Semantics (DRAFT)}
61−\author{Edsko de Vries, Well-Typed LLP}
62−\date{\today}
63−
64−\maketitle
65−
66−\section{Introduction}
67−
68−This is a semantics for Cloud Haskell, based on the \textit{Unified Semantics
69−for a Future Erlang} (Hans Svensson, Lars-\AA{}ke Fredlund and Clara Benac
70−Earle, Erlang '10) but using the semantics style of \textit{Composable Memory
71−Transactions} (Tim Harris, Simon Marlow, Simon Peyton-Jones, Maurice Herlihy,
72−PPoPP '05). It differs from the former in that
73−%
74−\begin{enumerate}
75−\item We introduce an explicit notion of \textit{reconnecting} (with potential
76−message loss)
77−\item We simplify the semantics: we ``flatten'' sets of nodes of processes as
78−sets of processes (but assume a mapping from process identifiers to node
79−identifiers), do not have per-process mailboxes (but only the system queue or
80−``ether'') and do not have an explicit concept of node controllers
81−\end{enumerate}
82−%
83−It differs from the latter in that
84−%
85−\begin{enumerate}
86−\item We pretend that the Cloud Haskell \texttt{Process} monad is the top-level
87−monad, and do not consider the \texttt{IO} monad at all
88−\item We ignore exceptions
89−\end{enumerate}
90−%
91−Current imprecisions with respect to the ``real'' Cloud Haskell are
92−%
93−\begin{enumerate}
94−\item We ignore the issue of serializability, other than to say that the
95−semantics will get stuck when trying to send a non-serializable payload;
96−consequently, we do not formalize $\mathtt{static}$
97−\item We do not formalize all Cloud Haskell primitives (merging of ports,
98−``advanced messaging'', and others)
99−\item Some of the concepts that we do formalize are lower-level concepts; for
100−instance, the primitive $\sSpawn$ that we formalize is asynchronous (following
101−the Unified semantics); a synchronous construct can be derived.
102−\end{enumerate}
103−
104−\section{Preliminaries}
105−
106−\subsection{Terms}
107−
108−We assume the usual definitions of values and terms.
109−
110−\begin{equation*}
111−\begin{array}{ll@{\;::=\;}l}
112−\text{value} & V & \sLam{x}{M} \OR
113− \sExpect \OR
114− \sSend \; \sPid \; M \OR
115− \sSpawn \; \sNid \; M \OR
116− \sReturn \; M \OR
117− \cdots
118−\\
119−\text{term} & M, N & \sApp{M}{N} \OR
120− \sBind{M}{N}
121−\end{array}
122−\end{equation*}
123−
124−\subsection{Processes, Nodes, Systems}
125−
126−Processes run on \emph{nodes}. We assume that nodes run a special process
127−called the \emph{node controller} which is responsible for issuing monitor
128−messages, spawning new processes, etc. In the semantics messages to node
129−controllers (for instance, requests to spawn new processes) are recorded as
130−messages sent to the node itself.
131−
132−We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and
133−$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively,
134−and representing process identifiers, node identifiers, and (typed) channel
135−identifiers. We assume the existence of total functions
136−%
137−\begin{equation*}
138−\begin{array}{r@{\;:\;}l}
139−\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\
140−\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId}
141−\end{array}
142−\end{equation*}
143−%
144−and define
145−$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$
146−and let $\sId$ range over $\mathtt{Identifier}$.
147−
148−We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process
149−ID $\sPid$. We will denote a set of processes as
150−%
151− $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$
152−%
153−A \emph{system}
154− $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$
155−is a tuple containing a set $\sProcesses$ of processes, a \emph{system
156−queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors
157−$\sMonitors$.
158−The set of monitors $\sMonitors$ is a set of tuples
159− $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$
160−which records that the node controller at \sNid{} knows that process
161−$\sPid_\mathit{fr}$ is monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor
162−reference).
163−The system queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr},
164−\mathit{message})$ of messages that have been sent but not yet processed. The
165−blacklist records disconnections and is represented as a of pairs
166−$(\sId_\mathit{to}, \sId_\mathit{fr})$.
167−
168−\section{Semantics}
169−
170−\subsection{Contexts}
171−
172−We define an evaluation context as in the \textit{Composable Memory
173−Transactions} paper, but note that we work with \emph{sets} of processes so the
174−definition of $\sCtxt{P}$ can be slightly simpler.
175−
176−\begin{align*}
177−\sCtxt{E} & ::= [] \OR \sBind{\sCtxt{E}}{M} \\
178−\sCtxt{P}_\sPid & ::= \sCtxt{E}[]_\sPid \sPar \sProcesses
179−\end{align*}
180−
181−\subsection{Disconnect}
182−
183−We assume that entire \emph{nodes} get disconnected from each other, not
184−individual processes. \emph{Reconnecting} however is on a per process basis. To
185−formalize this, let $\overline{\sNid}$ be the smallest set, given a set of
186−processes $\sProcesses$, such that
187−%
188−\begin{equation*}
189−\frac{
190−}{
191−\sNid \in \overline{\sNid}
192−}
193−%
194−\qquad
195−%
196−\frac{
197−\sPid \in \sProcesses \qquad
198−\sNodeOf(\sPid) = \sNid
199−}{
200−\sPid \in \overline{\sNid}
201−}
202−%
203−\qquad
204−%
205−\frac{
206−\sCid \in \sProcesses \qquad
207−\sNodeOf(\sCid) = \sNid
208−}{
209−\sCid \in \overline{\sNid}
210−}
211−\end{equation*}
212−
213−The following rule models random network disconnect between nodes $\sNid_1$ and
214−$\sNid_2$:
215−
216−\begin{equation*}
217−\frac{
218−}{
219− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
220−\rightarrow
221− \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors}
222−} \textsc{Disconnect}
223−\end{equation*}
224−
225−Once a connection has been blacklisted, no further messages can be sent across
226−that connection (until an explicit or implicit reconnect). To model this we
227−introduce a function
228−%
229−\begin{equation*}
230−\begin{array}{l@{\;=\;}l@{\hspace{3em}}l}
231− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
232−&
233− \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M)
234−&
235− \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist
236−\\
237− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
238−&
239− \sQueue
240−&
241− \text{otherwise}
242−\end{array}
243−\end{equation*}
244−%
245−$(\sExtend{\sBlacklist})$ is only defined for serializable payloads.
246−
247−We provide a primitive to remove a connection from the blacklist:
248−
249−\begin{equation*}
250−\frac{
251−}{
252− \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
253− {\sQueue}
254− {\sBlacklist}
255− {\sMonitors}
256−\rightarrow
257− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
258− {\sQueue}
259− {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})}
260− {\sMonitors}
261−} \textsc{Recon-Ex}
262−\end{equation*}
263−
264−Note that using this primitive means giving up on the reliability guarantee: a
265−call to $\sReconnect$ means that message loss is accepted.
266−
267−Connections to and from node controllers can be implicitly reconnected:
268−
269−\begin{equation*}
270−\frac{
271−}{
272− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors}
273−\rightarrow
274− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
275−} \textsc{Recon-Im1}
276−\qquad
277−\frac{
278−}{
279− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors}
280−\rightarrow
281− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
282−} \textsc{Recon-Im2}
283−\end{equation*}
284−
285−\subsection{Send and Receive}
286−
287−\begin{equation*}
288−\frac{
289−}{
290− \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}}
291− {\sQueue}
292− {\sBlacklist}
293− {\sMonitors}
294−\rightarrow
295− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
296− {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)}
297− {\sBlacklist}
298− {\sMonitors}
299−} \textsc{Send}
300−\end{equation*}
301−
302−We return the \emph{first} message of a randomly chosen sender.
303−
304−\begin{equation*}
305−\frac{
306− \sId_{\mathit{fr}} \notin \sSenders(\sQueue)
307−}{
308− \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}}
309− {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'}
310− {\sBlacklist}
311− {\sMonitors}
312−\rightarrow
313− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}}
314− {\sQueue, \sQueue'}
315− {\sBlacklist}
316− {\sMonitors}
317−} \textsc{Expect}
318−\end{equation*}
319−
320−\subsection{Spawning}
321−
322−Spawning is asynchronous
323−
324−\begin{equation*}
325−\frac{
326− \sRef \text{ fresh}
327−}{
328− \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
329− {\sQueue}
330− {\sBlacklist}
331− {\sMonitors}
332−\rightarrow
333− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid}
334− {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)}
335− {\sBlacklist}
336− {\sMonitors}
337−} \textsc{Spawn-Async}
338−\end{equation*}
339−
340−\begin{equation*}
341−\frac{
342− \sPid \notin \sSenders(\sQueue)
343−\qquad
344− \sPid' \text{ fresh}
345−\qquad
346− \sNodeOf(\sPid') = \sNid
347−}{
348− \sSystem{\sProcesses}
349− {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'}
350− {\sBlacklist}
351− {\sMonitors}
352−\rightarrow
353− \sSystem{\sProcesses \sPar M_{\sPid'}}
354− {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')}
355− {\sBlacklist}
356− {\sMonitors}
357−} \textsc{Spawn-Reply}
358−\end{equation*}
359−
360−\subsection{Typed Channels}
361−
362−Since the semantics is not type-driven, we represent typed channels simply as
363−an identifier with an annotation whether it is the send-end ($\sCid^s$) or the
364−receive end ($\sCid^r$) of the channel.
365−
366−\begin{equation*}
367−\frac{
368− \sCid \text{ fresh}
369−\qquad
370− \sProcessOf(\sCid) = \sPid
371−}{
372− \sSystem{\sCtxt{P}[\sNewChan]_\sPid}
373− {\sQueue}
374− {\sBlacklist}
375− {\sMonitors}
376−\rightarrow
377− \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid}
378− {\sQueue}
379− {\sBlacklist}
380− {\sMonitors}
381−} \textsc{NewChan}
382−\end{equation*}
383−
384−\begin{equation*}
385−\frac{
386−}{
387− \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}}
388− {\sQueue}
389− {\sBlacklist}
390− {\sMonitors}
391−\rightarrow
392− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
393− {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)}
394− {\sBlacklist}
395− {\sMonitors}
396−} \textsc{SendChan}
397−\end{equation*}
398−
399−\begin{equation*}
400−\frac{
401− \sPid_{\mathit{fr}} \notin \sSenders(\sQueue)
402−}{
403− \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}}
404− {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'}
405− {\sBlacklist}
406− {\sMonitors}
407−\rightarrow
408− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}}
409− {\sQueue, \sQueue'}
410− {\sBlacklist}
411− {\sMonitors}
412−} \textsc{ReceiveChan}
413−\end{equation*}
414−
415−\subsection{Monitoring}
416−
417−The local node controller is notified immediately of the new monitor, and the
418−remote monitor is sent a message (which may, of course, be lost).
419−
420−\begin{equation*}
421−\frac{
422− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
423−\qquad
424− \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to})
425−\qquad
426− \sRef \text{ fresh}
427−}{
428−\begin{array}{ll}
429−& \sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
430− {\sQueue}
431− {\sBlacklist}
432− {\sMonitors}
433−\\
434−\rightarrow &
435− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}}
436− {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})}
437− {\sBlacklist}
438− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
439−\end{array}
440−} \textsc{Monitor}
441−\end{equation*}
442−
443−\begin{equation*}
444−\frac{
445− \sPid_\mathit{fr} \notin \sSenders(\sQueue)
446−}{
447− \sSystem{\sProcesses}
448− {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'}
449− {\sBlacklist}
450− {\sMonitors}
451−\rightarrow
452− \sSystem{\sProcesses}
453− {\sQueue, \sQueue'}
454− {\sBlacklist}
455− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)}
456−} \textsc{Monitor-Remote}
457−\end{equation*}
458−
459−The \emph{local} node controller notifies a monitoring process when it gets
460−disconncted from a monitored remote process.
461−
462−\begin{equation*}
463−\frac{
464− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
465−\qquad
466− (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist
467−}{
468− \sSystem{\sProcesses}
469− {\sQueue}
470− {\sBlacklist}
471− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
472−\rightarrow
473− \sSystem{\sProcesses}
474− {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)}
475− {\sBlacklist}
476− {\sMonitors}
477−} \textsc{Discon}
478−\end{equation*}
479−
480−\subsection{Process Termination}
481−
482−We remove a terminated process only once all its monitors have been notified.
483−
484−\begin{equation*}
485−\frac{
486− \sNodeOf(\sPid) = \sNid
487−\qquad
488− \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
489−}{
490− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
491− {\sQueue}
492− {\sBlacklist}
493− {\sMonitors}
494−\rightarrow
495− \sSystem{\sProcesses}
496− {\sQueue}
497− {\sBlacklist}
498− {\sMonitors}
499−} \textsc{Term}
500−\end{equation*}
501−
502−The \emph{remote} node controller notifies a monitoring process when its
503−monitored remote process terminates.
504−
505−\begin{equation*}
506−\frac{
507− \sNodeOf(\sPid) = \sNid
508−}{
509− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
510− {\sQueue}
511− {\sBlacklist}
512− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
513−\rightarrow
514− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
515− {\sQueue \sExtend{\sBlacklist} (\sPid', \sPid, \mathtt{died} \; \sRef)}
516− {\sBlacklist}
517− {\sMonitors}
518−} \textsc{Died}
519−\end{equation*}
520−
521−\subsection{Administration}
522−
523−TODO: bind, pure evaluation, maybe exception handling
524−
525−\end{document}
doc/reconnect/reconnect.texdeleted−409
@@ -1,409 +0,0 @@
1−\documentclass[10pt]{article}
2−\usepackage[margin=2.5cm]{geometry}
3−\usepackage{listings}
4−\usepackage{amsmath,amssymb,stmaryrd}
5−\usepackage{mathpazo,times}
6−
7−\begin{document}
8−
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.texnew file+706
@@ -0,0 +1,706 @@
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/Makefilenew file+11
@@ -0,0 +1,11 @@
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.bibnew file+72
@@ -0,0 +1,72 @@
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.hsdeleted−24
@@ -1,24 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport, defaultTCPParameters)
3−import System.Environment
4−import Control.Monad
5−import Data.ByteString.Char8
6−
7−main :: IO ()
8−main = do
9− [host, port, serverAddr] <- getArgs
10− Right transport <- createTransport host port defaultTCPParameters
11− Right endpoint <- newEndPoint transport
12−
13− let addr = EndPointAddress (pack serverAddr)
14−-- Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints
15− x <- connect endpoint addr ReliableOrdered defaultConnectHints
16− let conn = case x of
17− Right conn -> conn
18− Left err -> error$ "Error connecting: "++show err
19− send conn [pack "Hello world"]
20− close conn
21−
22− replicateM_ 3 $ receive endpoint >>= print
23−
24− closeTransport transport
doc/tutorial/tutorial-server.hsdeleted−54
@@ -1,54 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport, defaultTCPParameters)
3−import Control.Concurrent
4−import Data.Map
5−import Control.Exception
6−import System.Environment
7−
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− putStrLn$ " New connection: ID "++show cid++", reliability: "++show rel++", address: "++ show addr
18− connMVar <- newEmptyMVar
19− forkIO $ do
20− Right conn <- connect endpoint addr rel defaultConnectHints
21− putMVar connMVar conn
22− go (insert cid connMVar cs)
23− Received cid payload -> do
24− forkIO $ do
25− conn <- readMVar (cs ! cid)
26− send conn payload
27− return ()
28− go cs
29− ConnectionClosed cid -> do
30− putStrLn$ " Closed connection: ID "++show cid
31− forkIO $ do
32− conn <- readMVar (cs ! cid)
33− close conn
34− go (delete cid cs)
35− EndPointClosed -> do
36− putStrLn "Echo server exiting"
37− putMVar serverDone ()
38−
39−onCtrlC :: IO a -> IO () -> IO a
40−p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
41− where
42− isUserInterrupt :: AsyncException -> Maybe ()
43− isUserInterrupt UserInterrupt = Just ()
44− isUserInterrupt _ = Nothing
45−
46−main :: IO ()
47−main = do
48− [host, port] <- getArgs
49− serverDone <- newEmptyMVar
50− Right transport <- createTransport host port defaultTCPParameters
51− Right endpoint <- newEndPoint transport
52− forkIO $ echoServer endpoint serverDone
53− putStrLn $ "Echo server started at " ++ show (address endpoint)
54− readMVar serverDone `onCtrlC` closeTransport transport
install_all.shdeleted−11
@@ -1,11 +0,0 @@
1−#!/bin/bash
2−
3−if [ "$GHC" == "" ]; then
4− GHC=ghc
5−fi
6−if [ "$CABAL" == "" ]; then
7− CABAL=cabal
8−fi
9−
10−$CABAL install --with-ghc=$GHC ./rank1dynamic ./distributed-static ./network-transport ./network-transport-tcp ./network-transport-inmemory ./distributed-process ./distributed-process-simplelocalnet --reinstall $*
11−
network-transport-composed/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2012, Edsko de Vries
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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.
network-transport-composed/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
network-transport-composed/network-transport-composed.cabaldeleted−22
@@ -1,22 +0,0 @@
1−name: network-transport-composed
2−version: 0.1.0.0
3−synopsis: Compose network transports
4−-- description:
5−homepage: http://github.com/haskell-distributed/distributed-process
6−license: BSD3
7−license-file: LICENSE
8−author: Edsko de Vries
9−maintainer: edsko@well-typed.com
10−copyright: Well-Typed LLP
11−category: Network
12−build-type: Simple
13−cabal-version: >=1.8
14−
15−library
16− exposed-modules: Network.Transport.Composed
17− -- other-modules:
18− build-depends: base ==4.5.*,
19− network-transport >= 0.3 && < 0.4
20− hs-source-dirs: src
21− ghc-options: -Wall
22− extensions: BangPatterns
network-transport-composed/src/Network/Transport/Composed.hsdeleted−181
@@ -1,181 +0,0 @@
1−-- | Combine two transports into a single new transport
2−--
3−-- Given two transports A and B, endpoints in the combined transport are
4−-- pairs of endpoints for the underlying transports. Consequently, the address
5−-- of an endpoint in the combined transport is a pair of addresses of the
6−-- two underlying endpoints. Events from both underlying endpoints are posted
7−-- to the combined endpoint.
8−--
9−-- When the address of combined endpoint C1 is sent to combined endpoint C2,
10−-- and C2 attempts to make a connection to C1, it needs to choice an underlying
11−-- endpoint to make the connection. The choice is made by a parameter
12−-- 'resolveAddress' of the composed transport.
13−--
14−-- When C2 connects to C1 then it is assumed that whatever transport C2 uses
15−-- to connect to C1, this is the same transport that C1 needs to use to connect
16−-- back to C2.
17−--
18−-- TODO: at the moment the address reported by a ConnectionOpened might differ
19−-- from the address reported by the remote endpoint itself. This might cause
20−-- difficulties?
21−module Network.Transport.Composed
22− ( ComposedTransport(..)
23− , createTransport
24− ) where
25−
26−import qualified Data.ByteString as BSS
27− ( concat
28− , length
29− , splitAt
30− , singleton
31− , uncons
32− )
33−import Control.Monad (void)
34−import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
35−import Control.Concurrent (forkIO)
36−import Network.Transport
37− ( Transport(..)
38− , EndPointAddress(EndPointAddress)
39− , TransportError(TransportError)
40− , NewEndPointErrorCode
41− , EndPoint(..)
42− , NewMulticastGroupErrorCode(NewMulticastGroupUnsupported)
43− , ResolveMulticastGroupErrorCode(ResolveMulticastGroupUnsupported)
44− , Event(EndPointClosed, ConnectionOpened, ErrorEvent)
45− , EventErrorCode(EventConnectionLost)
46− , Reliability
47− , ConnectHints
48− , ConnectErrorCode
49− , Connection
50− )
51−import Network.Transport.Internal (encodeInt32, decodeInt32)
52−
53−data ComposedTransport = ComposedTransport {
54− -- | The left transport
55− transportA :: Transport
56− -- | The right transport
57− , transportB :: Transport
58− -- | Pick a suitable transport for an address
59− , resolveAddress :: (EndPoint, EndPoint)
60− -> (EndPointAddress, EndPointAddress)
61− -> IO (EndPoint, EndPointAddress)
62− }
63−
64−data ComposedAddress =
65− LeftAddress EndPointAddress
66− | RightAddress EndPointAddress
67− | EitherAddress EndPointAddress EndPointAddress
68−
69−serializeComposedAddress :: ComposedAddress -> EndPointAddress
70−serializeComposedAddress (LeftAddress (EndPointAddress addr)) =
71− EndPointAddress $ BSS.concat [BSS.singleton 0, addr]
72−serializeComposedAddress (RightAddress (EndPointAddress addr)) =
73− EndPointAddress $ BSS.concat [BSS.singleton 1, addr]
74−serializeComposedAddress (EitherAddress (EndPointAddress addr1) (EndPointAddress addr2)) =
75− EndPointAddress $ BSS.concat [BSS.singleton 2, encodeInt32 (BSS.length addr1), addr1, addr2]
76−
77−deserializeComposedAddress :: EndPointAddress -> ComposedAddress
78−deserializeComposedAddress (EndPointAddress addr) =
79− let (header, remainder) = case BSS.uncons addr of
80− Just (x, xs) -> (x, xs)
81− Nothing -> error "deserializeComposedAddress"
82− in case header of
83− 0 -> LeftAddress (EndPointAddress remainder)
84− 1 -> RightAddress (EndPointAddress remainder)
85− 2 -> let (len, remainder') = BSS.splitAt 4 remainder
86− (a, b) = BSS.splitAt (decodeInt32 len) remainder'
87− in EitherAddress (EndPointAddress a) (EndPointAddress b)
88− _ -> error "deserializeComposedAddress"
89−
90−createTransport :: ComposedTransport -> IO Transport
91−createTransport composed =
92− return Transport {
93− newEndPoint = apiNewEndPoint composed
94− , closeTransport = apiCloseTransport composed
95− }
96−
97−apiNewEndPoint :: ComposedTransport -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
98−apiNewEndPoint composed = do
99− mEndPoints <- createEndPoints
100− case mEndPoints of
101− Left err ->
102− return $ Left err
103− Right (endPointA, endPointB) -> do
104− let addr = serializeComposedAddress (EitherAddress (address endPointA) (address endPointB))
105− chan <- newChan
106− void . forkIO $ forwardEvents endPointA chan LeftAddress
107− void . forkIO $ forwardEvents endPointB chan RightAddress
108− return . Right $ EndPoint {
109− receive = readChan chan
110− , address = addr
111− , connect = apiConnect composed endPointA endPointB
112− , closeEndPoint = apiCloseEndPoint endPointA endPointB
113− , newMulticastGroup = return . Left $ newMulticastGroupError
114− , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
115− }
116− where
117− newMulticastGroupError =
118− TransportError NewMulticastGroupUnsupported "Multicast not supported"
119− resolveMulticastGroupError =
120− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
121−
122− createEndPoints = do
123− mEndPointA <- newEndPoint (transportA composed)
124− case mEndPointA of
125− Left err -> return $ Left err
126− Right endPointA -> do
127− mEndPointB <- newEndPoint (transportB composed)
128− case mEndPointB of
129− Left err -> do
130− closeEndPoint endPointA
131− return $ Left err
132− Right endPointB ->
133− return $ Right (endPointA, endPointB)
134−
135− forwardEvents :: EndPoint -> Chan Event -> (EndPointAddress -> ComposedAddress) -> IO ()
136− forwardEvents endPoint chan inj = go
137− where
138− go = do
139− event <- receive endPoint
140− case event of
141− ConnectionOpened cid rel addr -> do
142− let addr' = serializeComposedAddress (inj addr)
143− writeChan chan (ConnectionOpened cid rel addr')
144− go
145− ErrorEvent (TransportError (EventConnectionLost addr) msg) -> do
146− let addr' = serializeComposedAddress (inj addr)
147− writeChan chan $ ErrorEvent (TransportError (EventConnectionLost addr') msg)
148− go
149− EndPointClosed -> do
150− writeChan chan event
151− return ()
152− _ -> do
153− writeChan chan event
154− go
155−
156−apiCloseTransport :: ComposedTransport -> IO ()
157−apiCloseTransport composed = do
158− closeTransport (transportA composed)
159− closeTransport (transportB composed)
160−
161−apiConnect :: ComposedTransport
162− -> EndPoint
163− -> EndPoint
164− -> EndPointAddress
165− -> Reliability
166− -> ConnectHints
167− -> IO (Either (TransportError ConnectErrorCode) Connection)
168−apiConnect composed endPointA endPointB theirComposedAddr rel hints =
169− case deserializeComposedAddress theirComposedAddr of
170− LeftAddress addr ->
171− connect endPointA addr rel hints
172− RightAddress addr ->
173− connect endPointB addr rel hints
174− EitherAddress addrA addrB -> do
175− (endPoint, addr) <- resolveAddress composed (endPointA, endPointB) (addrA, addrB)
176− connect endPoint addr rel hints
177−
178−apiCloseEndPoint :: EndPoint -> EndPoint -> IO ()
179−apiCloseEndPoint endPointA endPointB = do
180− closeEndPoint endPointA
181− closeEndPoint endPointB
network-transport-inmemory/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
network-transport-inmemory/network-transport-inmemory.cabaldeleted−64
@@ -1,64 +0,0 @@
1−Name: network-transport-inmemory
2−Version: 0.2.0
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: In-memory instantation of Network.Transport
14−Description: In-memory instantation of Network.Transport
15−Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
16−Category: Network
17−
18−Library
19− Build-Depends: base >= 4.3 && < 5,
20− network-transport >= 0.2 && < 0.3,
21− data-accessor >= 0.2 && < 0.3,
22− bytestring >= 0.9 && < 0.10,
23− containers >= 0.4 && < 0.5
24− Exposed-modules: Network.Transport.Chan
25− ghc-options: -Wall -fno-warn-unused-do-bind
26− HS-Source-Dirs: src
27−
28−Test-Suite TestMulticastInMemory
29− Type: exitcode-stdio-1.0
30− Build-Depends: base >= 4.3 && < 5,
31− network-transport >= 0.2 && < 0.3,
32− data-accessor >= 0.2 && < 0.3,
33− bytestring >= 0.9 && < 0.10,
34− containers >= 0.4 && < 0.5,
35− random >= 1.0 && < 1.1,
36− ansi-terminal >= 0.5 && < 0.6
37− Main-Is: TestMulticastInMemory.hs
38− ghc-options: -Wall -fno-warn-unused-do-bind
39− Extensions: ExistentialQuantification,
40− FlexibleInstances,
41− DeriveDataTypeable,
42− RankNTypes,
43− OverloadedStrings
44− HS-Source-Dirs: tests src
45−
46−Test-Suite TestInMemory
47− Type: exitcode-stdio-1.0
48− Build-Depends: base >= 4.3 && < 5,
49− network-transport >= 0.2 && < 0.3,
50− data-accessor >= 0.2 && < 0.3,
51− bytestring >= 0.9 && < 0.10,
52− containers >= 0.4 && < 0.5,
53− random >= 1.0 && < 1.1,
54− ansi-terminal >= 0.5 && < 0.6,
55− mtl >= 2.0 && < 2.2
56− Main-Is: TestInMemory.hs
57− ghc-options: -Wall -fno-warn-unused-do-bind
58− Extensions: ExistentialQuantification,
59− FlexibleInstances,
60− DeriveDataTypeable,
61− RankNTypes,
62− OverloadedStrings,
63− OverlappingInstances
64− HS-Source-Dirs: tests src
network-transport-inmemory/src/Network/Transport/Chan.hsdeleted−157
@@ -1,157 +0,0 @@
1−-- | In-memory implementation of the Transport API.
2−module Network.Transport.Chan (createTransport) where
3−
4−import Network.Transport
5−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
6−import Control.Applicative ((<$>))
7−import Control.Category ((>>>))
8−import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)
9−import Control.Exception (throwIO)
10−import Control.Monad (forM_, when)
11−import Data.Map (Map)
12−import qualified Data.Map as Map (empty, insert, size, delete, findWithDefault)
13−import Data.Set (Set)
14−import qualified Data.Set as Set (empty, elems, insert, delete)
15−import Data.ByteString (ByteString)
16−import qualified Data.ByteString.Char8 as BSC (pack)
17−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
18−import qualified Data.Accessor.Container as DAC (mapMaybe)
19−
20−-- Global state: next available "address", mapping from addresses to channels and next available connection
21−data TransportState = State { _channels :: Map EndPointAddress (Chan Event)
22− , _nextConnectionId :: Map EndPointAddress ConnectionId
23− , _multigroups :: Map MulticastAddress (MVar (Set EndPointAddress))
24− }
25−
26−-- | Create a new Transport.
27−--
28−-- Only a single transport should be created per Haskell process
29−-- (threads can, and should, create their own endpoints though).
30−createTransport :: IO Transport
31−createTransport = do
32− state <- newMVar State { _channels = Map.empty
33− , _nextConnectionId = Map.empty
34− , _multigroups = Map.empty
35− }
36− return Transport { newEndPoint = apiNewEndPoint state
37− , closeTransport = throwIO (userError "closeEndPoint not implemented")
38− }
39−
40−-- | Create a new end point
41−apiNewEndPoint :: MVar TransportState -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
42−apiNewEndPoint state = do
43− chan <- newChan
44− addr <- modifyMVar state $ \st -> do
45− let addr = EndPointAddress . BSC.pack . show . Map.size $ st ^. channels
46− return ((channelAt addr ^= chan) . (nextConnectionIdAt addr ^= 1) $ st, addr)
47− return . Right $ EndPoint { receive = readChan chan
48− , address = addr
49− , connect = apiConnect addr state
50− , closeEndPoint = throwIO (userError "closeEndPoint not implemented")
51− , newMulticastGroup = apiNewMulticastGroup state addr
52− , resolveMulticastGroup = apiResolveMulticastGroup state addr
53− }
54−
55−-- | Create a new connection
56−apiConnect :: EndPointAddress
57− -> MVar TransportState
58− -> EndPointAddress
59− -> Reliability
60− -> ConnectHints
61− -> IO (Either (TransportError ConnectErrorCode) Connection)
62−apiConnect myAddress state theirAddress _reliability _hints = do
63− (chan, conn) <- modifyMVar state $ \st -> do
64− let chan = st ^. channelAt theirAddress
65− let conn = st ^. nextConnectionIdAt theirAddress
66− return (nextConnectionIdAt theirAddress ^: (+ 1) $ st, (chan, conn))
67− writeChan chan $ ConnectionOpened conn ReliableOrdered myAddress
68− connAlive <- newMVar True
69− return . Right $ Connection { send = apiSend chan conn connAlive
70− , close = apiClose chan conn connAlive
71− }
72−
73−-- | Send a message over a connection
74−apiSend :: Chan Event -> ConnectionId -> MVar Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
75−apiSend chan conn connAlive msg =
76− modifyMVar connAlive $ \alive ->
77− if alive
78− then do
79− writeChan chan (Received conn msg)
80− return (alive, Right ())
81− else
82− return (alive, Left (TransportError SendFailed "Connection closed"))
83−
84−-- | Close a connection
85−apiClose :: Chan Event -> ConnectionId -> MVar Bool -> IO ()
86−apiClose chan conn connAlive =
87− modifyMVar_ connAlive $ \alive -> do
88− when alive . writeChan chan $ ConnectionClosed conn
89− return False
90−
91−-- | Create a new multicast group
92−apiNewMulticastGroup :: MVar TransportState -> EndPointAddress -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
93−apiNewMulticastGroup state ourAddress = do
94− group <- newMVar Set.empty
95− groupAddr <- modifyMVar state $ \st -> do
96− let addr = MulticastAddress . BSC.pack . show . Map.size $ st ^. multigroups
97− return (multigroupAt addr ^= group $ st, addr)
98− return . Right $ createMulticastGroup state ourAddress groupAddr group
99−
100−-- | Construct a multicast group
101−--
102−-- When the group is deleted some endpoints may still receive messages, but
103−-- subsequent calls to resolveMulticastGroup will fail. This mimicks the fact
104−-- that some multicast messages may still be in transit when the group is
105−-- deleted.
106−createMulticastGroup :: MVar TransportState -> EndPointAddress -> MulticastAddress -> MVar (Set EndPointAddress) -> MulticastGroup
107−createMulticastGroup state ourAddress groupAddress group =
108− MulticastGroup { multicastAddress = groupAddress
109− , deleteMulticastGroup = modifyMVar_ state $ return . (multigroups ^: Map.delete groupAddress)
110− , maxMsgSize = Nothing
111− , multicastSend = \payload -> do
112− cs <- (^. channels) <$> readMVar state
113− es <- readMVar group
114− forM_ (Set.elems es) $ \ep -> do
115− let ch = cs ^. at ep "Invalid endpoint"
116− writeChan ch (ReceivedMulticast groupAddress payload)
117− , multicastSubscribe = modifyMVar_ group $ return . Set.insert ourAddress
118− , multicastUnsubscribe = modifyMVar_ group $ return . Set.delete ourAddress
119− , multicastClose = return ()
120− }
121−
122−-- | Resolve a multicast group
123−apiResolveMulticastGroup :: MVar TransportState
124− -> EndPointAddress
125− -> MulticastAddress
126− -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
127−apiResolveMulticastGroup state ourAddress groupAddress = do
128− group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state
129− case group of
130− Nothing -> return . Left $ TransportError ResolveMulticastGroupNotFound ("Group " ++ show groupAddress ++ " not found")
131− Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar
132−
133−--------------------------------------------------------------------------------
134−-- Lens definitions --
135−--------------------------------------------------------------------------------
136−
137−channels :: Accessor TransportState (Map EndPointAddress (Chan Event))
138−channels = accessor _channels (\ch st -> st { _channels = ch })
139−
140−nextConnectionId :: Accessor TransportState (Map EndPointAddress ConnectionId)
141−nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid })
142−
143−multigroups :: Accessor TransportState (Map MulticastAddress (MVar (Set EndPointAddress)))
144−multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })
145−
146−at :: Ord k => k -> String -> Accessor (Map k v) v
147−at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)
148−
149−channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)
150−channelAt addr = channels >>> at addr "Invalid channel"
151−
152−nextConnectionIdAt :: EndPointAddress -> Accessor TransportState ConnectionId
153−nextConnectionIdAt addr = nextConnectionId >>> at addr "Invalid connection ID"
154−
155−multigroupAt :: MulticastAddress -> Accessor TransportState (MVar (Set EndPointAddress))
156−multigroupAt addr = multigroups >>> at addr "Invalid multigroup"
157−
network-transport-inmemory/tests/TestAuxiliary.hsdeleted−108
@@ -1,108 +0,0 @@
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−import Prelude hiding (catch)
12−import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
13−import Control.Concurrent.Chan (Chan)
14−import Control.Monad (liftM2, unless)
15−import Control.Exception (SomeException, try, catch)
16−import System.Timeout (timeout)
17−import System.IO (stdout, hFlush)
18−import System.Console.ANSI ( SGR(SetColor, Reset)
19− , Color(Red, Green)
20− , ConsoleLayer(Foreground)
21− , ColorIntensity(Vivid)
22− , setSGR
23− )
24−import System.Random (randomIO)
25−import Network.Transport
26−import Traced (Traceable(..), traceShow)
27−
28−-- | Like fork, but throw exceptions in the child thread to the parent
29−forkTry :: IO () -> IO ThreadId
30−forkTry p = do
31− tid <- myThreadId
32− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
33−
34−-- | Like try, but specialized to SomeException
35−trySome :: IO a -> IO (Either SomeException a)
36−trySome = try
37−
38−-- | Run the given test, catching timeouts and exceptions
39−runTest :: String -> IO () -> IO Bool
40−runTest description test = do
41− putStr $ "Running " ++ show description ++ ": "
42− hFlush stdout
43− done <- try . timeout 60000000 $ test -- 60 seconds
44− case done of
45− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
46− Right Nothing -> failed $ "(timeout)"
47− Right (Just ()) -> ok
48− where
49− failed :: String -> IO Bool
50− failed err = do
51− setSGR [SetColor Foreground Vivid Red]
52− putStr "failed "
53− setSGR [Reset]
54− putStrLn err
55− return False
56−
57− ok :: IO Bool
58− ok = do
59− setSGR [SetColor Foreground Vivid Green]
60− putStrLn "ok"
61− setSGR [Reset]
62− return True
63−
64−-- | Run a bunch of tests and throw an exception if any fails
65−runTests :: [(String, IO ())] -> IO ()
66−runTests tests = do
67− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
68− unless success $ fail "Some tests failed"
69−
70−-- | Random thread delay between 0 and the specified max
71−randomThreadDelay :: Int -> IO ()
72−randomThreadDelay maxDelay = do
73− delay <- randomIO :: IO Int
74− threadDelay (delay `mod` maxDelay)
75−
76−--------------------------------------------------------------------------------
77−-- traceShow instances --
78−--------------------------------------------------------------------------------
79−
80−instance Traceable EndPoint where
81− trace = const Nothing
82−
83−instance Traceable Transport where
84− trace = const Nothing
85−
86−instance Traceable Connection where
87− trace = const Nothing
88−
89−instance Traceable Event where
90− trace = traceShow
91−
92−instance Show err => Traceable (TransportError err) where
93− trace = traceShow
94−
95−instance Traceable EndPointAddress where
96− trace = traceShow . endPointAddressToByteString
97−
98−instance Traceable SomeException where
99− trace = traceShow
100−
101−instance Traceable ThreadId where
102− trace = const Nothing
103−
104−instance Traceable (Chan a) where
105− trace = const Nothing
106−
107−instance Traceable Float where
108− trace = traceShow
network-transport-inmemory/tests/TestInMemory.hsdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−import TestTransport
4−import Network.Transport.Chan
5−import Control.Applicative ((<$>))
6−
7−main :: IO ()
8−main = testTransport (Right <$> createTransport)
network-transport-inmemory/tests/TestMulticast.hsdeleted−72
@@ -1,72 +0,0 @@
1−module TestMulticast where
2−
3−import Network.Transport
4−import TestAuxiliary (runTests)
5−import Control.Monad (replicateM, replicateM_, forM_, when)
6−import Control.Concurrent (forkIO)
7−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, readMVar)
8−import Data.ByteString (ByteString)
9−import Data.List (elemIndex)
10−
11−-- | Node for the "No confusion" test
12−noConfusionNode :: Transport -- ^ Transport
13− -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to
14− -> [MVar ()] -- ^ I'm ready : others ready
15− -> Int -- ^ number of pings
16− -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to')
17− -> MVar () -- ^ I'm done
18− -> IO ()
19−noConfusionNode transport groups ready numPings msgs done = do
20− -- Create a new endpoint
21− Right endpoint <- newEndPoint transport
22−
23− -- Create a new multicast group and broadcast its address
24− Right myGroup <- newMulticastGroup endpoint
25− putMVar (head groups) (multicastAddress myGroup)
26−
27− -- Subscribe to the given multicast groups
28− addrs <- mapM readMVar (tail groups)
29− forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr
30− multicastSubscribe group
31−
32− -- Indicate that we're ready and wait for everybody else to be ready
33− putMVar (head ready) ()
34− mapM_ readMVar (tail ready)
35−
36− -- Send messages..
37− forkIO . replicateM_ numPings $ multicastSend myGroup [head msgs]
38−
39− -- ..while checking that the messages we receive are the right ones
40− replicateM_ (2 * numPings) $ do
41− event <- receive endpoint
42− case event of
43− ReceivedMulticast addr [msg] ->
44− let mix = addr `elemIndex` addrs in
45− case mix of
46− Nothing -> error "Message from unexpected source"
47− Just ix -> when (msgs !! (ix + 1) /= msg) $ error "Unexpected message"
48− _ ->
49− error "Unexpected event"
50−
51− -- Success
52− putMVar done ()
53−
54−-- | Test that distinct multicast groups are not confused
55−testNoConfusion :: Transport -> Int -> IO ()
56−testNoConfusion transport numPings = do
57− [group1, group2, group3] <- replicateM 3 newEmptyMVar
58− [readyA, readyB, readyC] <- replicateM 3 newEmptyMVar
59− [doneA, doneB, doneC] <- replicateM 3 newEmptyMVar
60− let [msgA, msgB, msgC] = ["A says hi", "B says hi", "C says hi"]
61−
62− forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA
63− forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB
64− forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC
65−
66− mapM_ takeMVar [doneA, doneB, doneC]
67−
68−-- | Test multicast
69−testMulticast :: Transport -> IO ()
70−testMulticast transport =
71− runTests
72− [ ("NoConfusion", testNoConfusion transport 10000) ]
network-transport-inmemory/tests/TestMulticastInMemory.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−import TestMulticast
4−import Network.Transport.Chan (createTransport)
5−
6−main :: IO ()
7−main = createTransport >>= testMulticast
network-transport-inmemory/tests/TestTransport.hsdeleted−956
@@ -1,956 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−module TestTransport where
3−
4−import Prelude hiding (catch, (>>=), (>>), return, fail)
5−import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)
6−import Control.Concurrent (forkIO, killThread, yield)
7−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar, modifyMVar_, newMVar)
8−import Control.Exception (evaluate, throw, throwIO, bracket)
9−import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless)
10−import Control.Monad.Error ()
11−import Control.Applicative ((<$>))
12−import Network.Transport
13−import Network.Transport.Internal (tlog, tryIO, timeoutMaybe)
14−import Network.Transport.Util (spawn)
15−import System.Random (randomIO)
16−import Data.ByteString (ByteString)
17−import Data.ByteString.Char8 (pack)
18−import Data.Map (Map)
19−import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
20−import Data.String (fromString)
21−import Data.List (permutations)
22−import Traced
23−
24−-- | Server that echoes messages straight back to the origin endpoint.
25−echoServer :: EndPoint -> IO ()
26−echoServer endpoint = do
27− go Map.empty
28− where
29− go :: Map ConnectionId Connection -> IO ()
30− go cs = do
31− event <- receive endpoint
32− case event of
33− ConnectionOpened cid rel addr -> do
34− tlog $ "Opened new connection " ++ show cid
35− Right conn <- connect endpoint addr rel defaultConnectHints
36− go (Map.insert cid conn cs)
37− Received cid payload -> do
38− send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
39− go cs
40− ConnectionClosed cid -> do
41− tlog $ "Close connection " ++ show cid
42− close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
43− go (Map.delete cid cs)
44− ReceivedMulticast _ _ ->
45− -- Ignore
46− go cs
47− ErrorEvent _ ->
48− putStrLn $ "Echo server received error event: " ++ show event
49− EndPointClosed ->
50− return ()
51−
52−-- | Ping client used in a few tests
53−ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
54−ping endpoint server numPings msg = do
55− -- Open connection to the server
56− tlog "Connect to echo server"
57− Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
58−
59− -- Wait for the server to open reply connection
60− tlog "Wait for ConnectionOpened message"
61− ConnectionOpened cid _ _ <- receive endpoint
62−
63− -- Send pings and wait for reply
64− tlog "Send ping and wait for reply"
65− replicateM_ numPings $ do
66− send conn [msg]
67− Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg
68− return ()
69−
70− -- Close the connection
71− tlog "Close the connection"
72− close conn
73−
74− -- Wait for the server to close its connection to us
75− tlog "Wait for ConnectionClosed message"
76− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
77−
78− -- Done
79− tlog "Ping client done"
80−
81−-- | Basic ping test
82−testPingPong :: Transport -> Int -> IO ()
83−testPingPong transport numPings = do
84− tlog "Starting ping pong test"
85− server <- spawn transport echoServer
86− result <- newEmptyMVar
87−
88− -- Client
89− forkTry $ do
90− tlog "Ping client"
91− Right endpoint <- newEndPoint transport
92− ping endpoint server numPings "ping"
93− putMVar result ()
94−
95− takeMVar result
96−
97−-- | Test that endpoints don't get confused
98−testEndPoints :: Transport -> Int -> IO ()
99−testEndPoints transport numPings = do
100− server <- spawn transport echoServer
101− dones <- replicateM 2 newEmptyMVar
102−
103− forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
104− let name' :: ByteString
105− name' = pack [name]
106− Right endpoint <- newEndPoint transport
107− tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)
108− ping endpoint server numPings name'
109− putMVar done ()
110−
111− forM_ dones takeMVar
112−
113−-- Test that connections don't get confused
114−testConnections :: Transport -> Int -> IO ()
115−testConnections transport numPings = do
116− server <- spawn transport echoServer
117− result <- newEmptyMVar
118−
119− -- Client
120− forkTry $ do
121− Right endpoint <- newEndPoint transport
122−
123− -- Open two connections to the server
124− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
125− ConnectionOpened serv1 _ _ <- receive endpoint
126−
127− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
128− ConnectionOpened serv2 _ _ <- receive endpoint
129−
130− -- One thread to send "pingA" on the first connection
131− forkTry $ replicateM_ numPings $ send conn1 ["pingA"]
132−
133− -- One thread to send "pingB" on the second connection
134− forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
135−
136− -- Verify server responses
137− let verifyResponse 0 = putMVar result ()
138− verifyResponse n = do
139− event <- receive endpoint
140− case event of
141− Received cid [payload] -> do
142− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
143− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
144− verifyResponse (n - 1)
145− _ ->
146− verifyResponse n
147− verifyResponse (2 * numPings)
148−
149− takeMVar result
150−
151−-- | Test that closing one connection does not close the other
152−testCloseOneConnection :: Transport -> Int -> IO ()
153−testCloseOneConnection transport numPings = do
154− server <- spawn transport echoServer
155− result <- newEmptyMVar
156−
157− -- Client
158− forkTry $ do
159− Right endpoint <- newEndPoint transport
160−
161− -- Open two connections to the server
162− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
163− ConnectionOpened serv1 _ _ <- receive endpoint
164−
165− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
166− ConnectionOpened serv2 _ _ <- receive endpoint
167−
168− -- One thread to send "pingA" on the first connection
169− forkTry $ do
170− replicateM_ numPings $ send conn1 ["pingA"]
171− close conn1
172−
173− -- One thread to send "pingB" on the second connection
174− forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
175−
176− -- Verify server responses
177− let verifyResponse 0 = putMVar result ()
178− verifyResponse n = do
179− event <- receive endpoint
180− case event of
181− Received cid [payload] -> do
182− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
183− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
184− verifyResponse (n - 1)
185− _ ->
186− verifyResponse n
187− verifyResponse (3 * numPings)
188−
189− takeMVar result
190−
191−-- | Test that if A connects to B and B connects to A, B can still send to A after
192−-- A closes its connection to B (for instance, in the TCP transport, the socket pair
193−-- connecting A and B should not yet be closed).
194−testCloseOneDirection :: Transport -> Int -> IO ()
195−testCloseOneDirection transport numPings = do
196− addrA <- newEmptyMVar
197− addrB <- newEmptyMVar
198− doneA <- newEmptyMVar
199− doneB <- newEmptyMVar
200−
201− -- A
202− forkTry $ do
203− tlog "A"
204− Right endpoint <- newEndPoint transport
205− tlog (show (address endpoint))
206− putMVar addrA (address endpoint)
207−
208− -- Connect to B
209− tlog "Connect to B"
210− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
211−
212− -- Wait for B to connect to us
213− tlog "Wait for B"
214− ConnectionOpened cid _ _ <- receive endpoint
215−
216− -- Send pings to B
217− tlog "Send pings to B"
218− replicateM_ numPings $ send conn ["ping"]
219−
220− -- Close our connection to B
221− tlog "Close connection"
222− close conn
223−
224− -- Wait for B's pongs
225− tlog "Wait for pongs from B"
226− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
227−
228− -- Wait for B to close it's connection to us
229− tlog "Wait for B to close connection"
230− ConnectionClosed cid' <- receive endpoint
231− guard (cid == cid')
232−
233− -- Done
234− tlog "Done"
235− putMVar doneA ()
236−
237− -- B
238− forkTry $ do
239− tlog "B"
240− Right endpoint <- newEndPoint transport
241− tlog (show (address endpoint))
242− putMVar addrB (address endpoint)
243−
244− -- Wait for A to connect
245− tlog "Wait for A to connect"
246− ConnectionOpened cid _ _ <- receive endpoint
247−
248− -- Connect to A
249− tlog "Connect to A"
250− Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
251−
252− -- Wait for A's pings
253− tlog "Wait for pings from A"
254− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
255−
256− -- Wait for A to close it's connection to us
257− tlog "Wait for A to close connection"
258− ConnectionClosed cid' <- receive endpoint
259− guard (cid == cid')
260−
261− -- Send pongs to A
262− tlog "Send pongs to A"
263− replicateM_ numPings $ send conn ["pong"]
264−
265− -- Close our connection to A
266− tlog "Close connection to A"
267− close conn
268−
269− -- Done
270− tlog "Done"
271− putMVar doneB ()
272−
273− mapM_ takeMVar [doneA, doneB]
274−
275−-- | Collect events and order them by connection ID
276−collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString]])]
277−collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
278− where
279− -- TODO: for more serious use of this function we'd need to make these arguments strict
280− go (Just 0) open closed = finish open closed
281− go n open closed = do
282− mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint
283− case mEvent of
284− Left _ -> finish open closed
285− Right event -> do
286− let n' = (\x -> x - 1) <$> n
287− case event of
288− ConnectionOpened cid _ _ ->
289− go n' (Map.insert cid [] open) closed
290− ConnectionClosed cid ->
291− let list = Map.findWithDefault (error "Invalid ConnectionClosed") cid open in
292− go n' (Map.delete cid open) (Map.insert cid list closed)
293− Received cid msg ->
294− go n' (Map.adjust (msg :) cid open) closed
295− ReceivedMulticast _ _ ->
296− fail "Unexpected multicast"
297− ErrorEvent _ ->
298− fail "Unexpected error"
299− EndPointClosed ->
300− fail "Unexpected endpoint closure"
301−
302− finish open closed =
303− if Map.null open
304− then return . Map.toList . Map.map reverse $ closed
305− else fail $ "Open connections: " ++ show (map fst . Map.toList $ open)
306−
307−-- | Open connection, close it, then reopen it
308−-- (In the TCP transport this means the socket will be closed, then reopened)
309−--
310−-- Note that B cannot expect to receive all of A's messages on the first connection
311−-- before receiving the messages on the second connection. What might (and sometimes
312−-- does) happen is that finishes sending all of its messages on the first connection
313−-- (in the TCP transport, the first socket pair) while B is behind on reading _from_
314−-- this connection (socket pair) -- the messages are "in transit" on the network
315−-- (these tests are done on localhost, so there are in some OS buffer). Then when
316−-- A opens the second connection (socket pair) B will spawn a new thread for this
317−-- connection, and hence might start interleaving messages from the first and second
318−-- connection.
319−--
320−-- This is correct behaviour, however: the transport API guarantees reliability and
321−-- ordering _per connection_, but not _across_ connections.
322−testCloseReopen :: Transport -> Int -> IO ()
323−testCloseReopen transport numPings = do
324− addrB <- newEmptyMVar
325− doneB <- newEmptyMVar
326−
327− let numRepeats = 2 :: Int
328−
329− -- A
330− forkTry $ do
331− Right endpoint <- newEndPoint transport
332−
333− forM_ [1 .. numRepeats] $ \i -> do
334− tlog "A connecting"
335− -- Connect to B
336− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
337−
338− tlog "A pinging"
339− -- Say hi
340− forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]
341−
342− tlog "A closing"
343− -- Disconnect again
344− close conn
345−
346− tlog "A finishing"
347−
348− -- B
349− forkTry $ do
350− Right endpoint <- newEndPoint transport
351− putMVar addrB (address endpoint)
352−
353− eventss <- collect endpoint (Just (numRepeats * (numPings + 2))) Nothing
354−
355− forM_ (zip [1 .. numRepeats] eventss) $ \(i, (_, events)) -> do
356− forM_ (zip [1 .. numPings] events) $ \(j, event) -> do
357− guard (event == [pack $ "ping" ++ show i ++ "/" ++ show j])
358−
359− putMVar doneB ()
360−
361− takeMVar doneB
362−
363−-- | Test lots of parallel connection attempts
364−testParallelConnects :: Transport -> Int -> IO ()
365−testParallelConnects transport numPings = do
366− server <- spawn transport echoServer
367− done <- newEmptyMVar
368−
369− Right endpoint <- newEndPoint transport
370−
371− -- Spawn lots of clients
372− forM_ [1 .. numPings] $ \i -> forkTry $ do
373− Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
374− send conn [pack $ "ping" ++ show i]
375− send conn [pack $ "ping" ++ show i]
376− close conn
377−
378− forkTry $ do
379− eventss <- collect endpoint (Just (numPings * 4)) Nothing
380− -- Check that no pings got sent to the wrong connection
381− forM_ eventss $ \(_, [[ping1], [ping2]]) ->
382− guard (ping1 == ping2)
383− putMVar done ()
384−
385− takeMVar done
386−
387−-- | Test that sending on a closed connection gives an error
388−testSendAfterClose :: Transport -> Int -> IO ()
389−testSendAfterClose transport numRepeats = do
390− server <- spawn transport echoServer
391− clientDone <- newEmptyMVar
392−
393− forkTry $ do
394− Right endpoint <- newEndPoint transport
395−
396− -- We request two lightweight connections
397− replicateM numRepeats $ do
398− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
399− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
400−
401− -- Close the second, but leave the first open; then output on the second
402− -- connection (i.e., on a closed connection while there is still another
403− -- connection open)
404− close conn2
405− Left (TransportError SendClosed _) <- send conn2 ["ping2"]
406−
407− -- Now close the first connection, and output on it (i.e., output while
408− -- there are no lightweight connection at all anymore)
409− close conn1
410− Left (TransportError SendClosed _) <- send conn2 ["ping2"]
411−
412− return ()
413−
414− putMVar clientDone ()
415−
416− takeMVar clientDone
417−
418−-- | Test that closing the same connection twice has no effect
419−testCloseTwice :: Transport -> Int -> IO ()
420−testCloseTwice transport numRepeats = do
421− server <- spawn transport echoServer
422− clientDone <- newEmptyMVar
423−
424− forkTry $ do
425− Right endpoint <- newEndPoint transport
426−
427− replicateM numRepeats $ do
428− -- We request two lightweight connections
429− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
430− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
431−
432− -- Close the second one twice
433− close conn2
434− close conn2
435−
436− -- Then send a message on the first and close that twice too
437− send conn1 ["ping"]
438− close conn1
439−
440− -- Verify expected response from the echo server
441− ConnectionOpened cid1 _ _ <- receive endpoint
442− ConnectionOpened cid2 _ _ <- receive endpoint
443− ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
444− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
445− ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
446−
447− return ()
448−
449− putMVar clientDone ()
450−
451− takeMVar clientDone
452−
453−-- | Test that we can connect an endpoint to itself
454−testConnectToSelf :: Transport -> Int -> IO ()
455−testConnectToSelf transport numPings = do
456− done <- newEmptyMVar
457− Right endpoint <- newEndPoint transport
458−
459− tlog "Creating self-connection"
460− Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
461−
462− tlog "Talk to myself"
463−
464− -- One thread to write to the endpoint
465− forkTry $ do
466− tlog $ "writing"
467−
468− tlog $ "Sending ping"
469− replicateM_ numPings $ send conn ["ping"]
470−
471− tlog $ "Closing connection"
472− close conn
473−
474− -- And one thread to read
475− forkTry $ do
476− tlog $ "reading"
477−
478− tlog "Waiting for ConnectionOpened"
479− ConnectionOpened cid _ addr <- receive endpoint ; True <- return $ addr == address endpoint
480−
481− tlog "Waiting for Received"
482− replicateM_ numPings $ do
483− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
484− return ()
485−
486− tlog "Waiting for ConnectionClosed"
487− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
488−
489− tlog "Done"
490− putMVar done ()
491−
492− takeMVar done
493−
494−-- | Test that we can connect an endpoint to itself multiple times
495−testConnectToSelfTwice :: Transport -> Int -> IO ()
496−testConnectToSelfTwice transport numPings = do
497− done <- newEmptyMVar
498− Right endpoint <- newEndPoint transport
499−
500− tlog "Creating self-connection"
501− Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
502− Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
503−
504− tlog "Talk to myself"
505−
506− -- One thread to write to the endpoint using the first connection
507− forkTry $ do
508− tlog $ "writing"
509−
510− tlog $ "Sending ping"
511− replicateM_ numPings $ send conn1 ["pingA"]
512−
513− tlog $ "Closing connection"
514− close conn1
515−
516− -- One thread to write to the endpoint using the second connection
517− forkTry $ do
518− tlog $ "writing"
519−
520− tlog $ "Sending ping"
521− replicateM_ numPings $ send conn2 ["pingB"]
522−
523− tlog $ "Closing connection"
524− close conn2
525−
526− -- And one thread to read
527− forkTry $ do
528− tlog $ "reading"
529−
530− [(_, events1), (_, events2)] <- collect endpoint (Just (2 * (numPings + 2))) Nothing
531− True <- return $ events1 == replicate numPings ["pingA"]
532− True <- return $ events2 == replicate numPings ["pingB"]
533−
534− tlog "Done"
535− putMVar done ()
536−
537− takeMVar done
538−
539−-- | Test that we self-connections no longer work once we close our endpoint
540−-- or our transport
541−testCloseSelf :: IO (Either String Transport) -> IO ()
542−testCloseSelf newTransport = do
543− Right transport <- newTransport
544− Right endpoint1 <- newEndPoint transport
545− Right endpoint2 <- newEndPoint transport
546− Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
547− Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
548− Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
549−
550− -- Close the conneciton and try to send
551− close conn1
552− Left (TransportError SendClosed _) <- send conn1 ["ping"]
553−
554− -- Close the first endpoint. We should not be able to use the first
555− -- connection anymore, or open more self connections, but the self connection
556− -- to the second endpoint should still be fine
557− closeEndPoint endpoint1
558− Left (TransportError SendFailed _) <- send conn2 ["ping"]
559− Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
560− Right () <- send conn3 ["ping"]
561−
562− -- Close the transport; now the second should no longer work
563− closeTransport transport
564− Left (TransportError SendFailed _) <- send conn3 ["ping"]
565− Left (TransportError ConnectFailed _) <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
566−
567− return ()
568−
569−-- | Test various aspects of 'closeEndPoint'
570−testCloseEndPoint :: Transport -> Int -> IO ()
571−testCloseEndPoint transport _ = do
572− serverDone <- newEmptyMVar
573− clientDone <- newEmptyMVar
574− clientAddr1 <- newEmptyMVar
575− clientAddr2 <- newEmptyMVar
576− serverAddr <- newEmptyMVar
577−
578− -- Server
579− forkTry $ do
580− Right endpoint <- newEndPoint transport
581− putMVar serverAddr (address endpoint)
582−
583− -- First test (see client)
584− do
585− theirAddr <- readMVar clientAddr1
586− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
587− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
588− return ()
589−
590− -- Second test
591− do
592− theirAddr <- readMVar clientAddr2
593−
594− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
595− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
596−
597− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
598− send conn ["pong"]
599−
600− ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''
601− ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint ; True <- return $ addr' == theirAddr
602−
603− Left (TransportError SendFailed _) <- send conn ["pong2"]
604−
605− return ()
606−
607− putMVar serverDone ()
608−
609− -- Client
610− forkTry $ do
611− theirAddr <- readMVar serverAddr
612−
613− -- First test: close endpoint with one outgoing but no incoming connections
614− do
615− Right endpoint <- newEndPoint transport
616− putMVar clientAddr1 (address endpoint)
617−
618− -- Connect to the server, then close the endpoint without disconnecting explicitly
619− Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
620− closeEndPoint endpoint
621− EndPointClosed <- receive endpoint
622− return ()
623−
624− -- Second test: close endpoint with one outgoing and one incoming connection
625− do
626− Right endpoint <- newEndPoint transport
627− putMVar clientAddr2 (address endpoint)
628−
629− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
630− send conn ["ping"]
631−
632− -- Reply from the server
633− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
634− Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'
635−
636− -- Close the endpoint
637− closeEndPoint endpoint
638− EndPointClosed <- receive endpoint
639−
640− -- Attempt to send should fail with connection closed
641− Left (TransportError SendFailed _) <- send conn ["ping2"]
642−
643− -- An attempt to close the already closed connection should just return
644− () <- close conn
645−
646− -- And so should an attempt to connect
647− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
648−
649− return ()
650−
651− putMVar clientDone ()
652−
653− mapM_ takeMVar [serverDone, clientDone]
654−
655−-- Test closeTransport
656−--
657−-- This tests many of the same things that testEndPoint does, and some more
658−testCloseTransport :: IO (Either String Transport) -> IO ()
659−testCloseTransport newTransport = do
660− serverDone <- newEmptyMVar
661− clientDone <- newEmptyMVar
662− clientAddr1 <- newEmptyMVar
663− clientAddr2 <- newEmptyMVar
664− serverAddr <- newEmptyMVar
665−
666− -- Server
667− forkTry $ do
668− Right transport <- newTransport
669− Right endpoint <- newEndPoint transport
670− putMVar serverAddr (address endpoint)
671−
672− -- Client sets up first endpoint
673− theirAddr1 <- readMVar clientAddr1
674− ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
675−
676− -- Client sets up second endpoint
677− theirAddr2 <- readMVar clientAddr2
678−
679− ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
680− Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
681−
682− Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints
683− send conn ["pong"]
684−
685− -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however)
686− evs <- replicateM 3 $ receive endpoint
687− let expected = [ ConnectionClosed cid1
688− , ConnectionClosed cid2
689− , ErrorEvent (TransportError (EventConnectionLost (Just theirAddr2) []) "")
690− ]
691− True <- return $ any (== expected) (permutations evs)
692−
693− -- An attempt to send to the endpoint should now fail
694− Left (TransportError SendFailed _) <- send conn ["pong2"]
695−
696− putMVar serverDone ()
697−
698− -- Client
699− forkTry $ do
700− Right transport <- newTransport
701− theirAddr <- readMVar serverAddr
702−
703− -- Set up endpoint with one outgoing but no incoming connections
704− Right endpoint1 <- newEndPoint transport
705− putMVar clientAddr1 (address endpoint1)
706−
707− -- Connect to the server, then close the endpoint without disconnecting explicitly
708− Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
709−
710− -- Set up an endpoint with one outgoing and out incoming connection
711− Right endpoint2 <- newEndPoint transport
712− putMVar clientAddr2 (address endpoint2)
713−
714− Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
715− send conn ["ping"]
716−
717− -- Reply from the server
718− ConnectionOpened cid ReliableOrdered addr <- receive endpoint2 ; True <- return $ addr == theirAddr
719− Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid'
720−
721− -- Now shut down the entire transport
722− closeTransport transport
723−
724− -- Both endpoints should report that they have been closed
725− EndPointClosed <- receive endpoint1
726− EndPointClosed <- receive endpoint2
727−
728− -- Attempt to send should fail with connection closed
729− Left (TransportError SendFailed _) <- send conn ["ping2"]
730−
731− -- An attempt to close the already closed connection should just return
732− () <- close conn
733−
734− -- And so should an attempt to connect on either endpoint
735− Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
736− Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
737−
738− -- And finally, so should an attempt to create a new endpoint
739− Left (TransportError NewEndPointFailed _) <- newEndPoint transport
740−
741− putMVar clientDone ()
742−
743− mapM_ takeMVar [serverDone, clientDone]
744−
745−-- | Remote node attempts to connect to a closed local endpoint
746−testConnectClosedEndPoint :: Transport -> IO ()
747−testConnectClosedEndPoint transport = do
748− serverAddr <- newEmptyMVar
749− serverClosed <- newEmptyMVar
750− clientDone <- newEmptyMVar
751−
752− -- Server
753− forkTry $ do
754− Right endpoint <- newEndPoint transport
755− putMVar serverAddr (address endpoint)
756−
757− closeEndPoint endpoint
758− putMVar serverClosed ()
759−
760− -- Client
761− forkTry $ do
762− Right endpoint <- newEndPoint transport
763− readMVar serverClosed
764−
765− Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
766−
767− putMVar clientDone ()
768−
769− takeMVar clientDone
770−
771−-- | We should receive an exception when doing a 'receive' after we have been
772−-- notified that an endpoint has been closed
773−testExceptionOnReceive :: IO (Either String Transport) -> IO ()
774−testExceptionOnReceive newTransport = do
775− Right transport <- newTransport
776−
777− -- Test one: when we close an endpoint specifically
778− Right endpoint1 <- newEndPoint transport
779− closeEndPoint endpoint1
780− EndPointClosed <- receive endpoint1
781− Left _ <- trySome (receive endpoint1 >>= evaluate)
782−
783− -- Test two: when we close the entire transport
784− Right endpoint2 <- newEndPoint transport
785− closeTransport transport
786− EndPointClosed <- receive endpoint2
787− Left _ <- trySome (receive endpoint2 >>= evaluate)
788−
789− return ()
790−
791−-- | Test what happens when the argument to 'send' is an exceptional value
792−testSendException :: IO (Either String Transport) -> IO ()
793−testSendException newTransport = do
794− Right transport <- newTransport
795− Right endpoint1 <- newEndPoint transport
796− Right endpoint2 <- newEndPoint transport
797−
798− -- Connect endpoint1 to endpoint2
799− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
800− ConnectionOpened _ _ _ <- receive endpoint2
801−
802− -- Send an exceptional value
803− Left (TransportError SendFailed _) <- send conn (throw $ userError "uhoh")
804−
805− -- This will have been as a failure to send by endpoint1, which will
806− -- therefore have closed the socket. In turn this will have caused endpoint2
807− -- to report that the connection was lost
808− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint1
809− ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2
810−
811− -- A new connection will re-establish the connection
812− Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
813− send conn2 ["ping"]
814− close conn2
815−
816− ConnectionOpened _ _ _ <- receive endpoint2
817− Received _ ["ping"] <- receive endpoint2
818− ConnectionClosed _ <- receive endpoint2
819−
820− return ()
821−
822−-- | If threads get killed while executing a 'connect', 'send', or 'close', this
823−-- should not affect other threads.
824−--
825−-- The intention of this test is to see what happens when a asynchronous
826−-- exception happes _while executing a send_. This is exceedingly difficult to
827−-- guarantee, however. Hence we run a large number of tests and insert random
828−-- thread delays -- and even then it might not happen. Moreover, it will only
829−-- happen when we run on multiple cores.
830−testKill :: IO (Either String Transport) -> Int -> IO ()
831−testKill newTransport numThreads = do
832− Right transport1 <- newTransport
833− Right transport2 <- newTransport
834− Right endpoint1 <- newEndPoint transport1
835− Right endpoint2 <- newEndPoint transport2
836−
837− threads <- replicateM numThreads . forkIO $ do
838− randomThreadDelay 100
839− bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)
840− -- Note that we should not insert a randomThreadDelay into the
841− -- exception handler itself as this means that the exception handler
842− -- could be interrupted and we might not close
843− (\(Right conn) -> close conn)
844− (\(Right conn) -> do randomThreadDelay 100
845− Right () <- send conn ["ping"]
846− randomThreadDelay 100)
847−
848− numAlive <- newMVar (0 :: Int)
849−
850− -- Kill half of those threads
851− forkIO . forM_ threads $ \tid -> do
852− shouldKill <- randomIO
853− if shouldKill
854− then randomThreadDelay 600 >> killThread tid
855− else modifyMVar_ numAlive (return . (+ 1))
856−
857− -- Since it is impossible to predict when the kill exactly happens, we don't
858− -- know how many connects were opened and how many pings were sent. But we
859− -- should not have any open connections (if we do, collect will throw an
860− -- error) and we should have at least the number of pings equal to the number
861− -- of threads we did *not* kill
862− eventss <- collect endpoint2 Nothing (Just 1000000)
863− let actualPings = sum . map (length . snd) $ eventss
864− expectedPings <- takeMVar numAlive
865− unless (actualPings >= expectedPings) $
866− throwIO (userError "Missing pings")
867−
868−-- print (actualPings, expectedPings)
869−
870−
871−-- | Set up conditions with a high likelyhood of "crossing" (for transports
872−-- that multiplex lightweight connections across heavyweight connections)
873−testCrossing :: Transport -> Int -> IO ()
874−testCrossing transport numRepeats = do
875− [aAddr, bAddr] <- replicateM 2 newEmptyMVar
876− [aDone, bDone] <- replicateM 2 newEmptyMVar
877− [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar
878− go <- newEmptyMVar
879−
880− let hints = defaultConnectHints {
881− connectTimeout = Just 5000000
882− }
883−
884− -- A
885− forkTry $ do
886− Right endpoint <- newEndPoint transport
887− putMVar aAddr (address endpoint)
888− theirAddress <- readMVar bAddr
889−
890− replicateM_ numRepeats $ do
891− takeMVar go >> yield
892− -- Because we are creating lots of connections, it's possible that
893− -- connect times out (for instance, in the TCP transport,
894− -- Network.Socket.connect may time out). We shouldn't regard this as an
895− -- error in the Transport, though.
896− connectResult <- connect endpoint theirAddress ReliableOrdered hints
897− case connectResult of
898− Right conn -> close conn
899− Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()
900− Left (TransportError ConnectFailed _) -> readMVar bTimeout
901− Left err -> throwIO . userError $ "testCrossed: " ++ show err
902− putMVar aDone ()
903−
904− -- B
905− forkTry $ do
906− Right endpoint <- newEndPoint transport
907− putMVar bAddr (address endpoint)
908− theirAddress <- readMVar aAddr
909−
910− replicateM_ numRepeats $ do
911− takeMVar go >> yield
912− connectResult <- connect endpoint theirAddress ReliableOrdered hints
913− case connectResult of
914− Right conn -> close conn
915− Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
916− Left (TransportError ConnectFailed _) -> readMVar aTimeout
917− Left err -> throwIO . userError $ "testCrossed: " ++ show err
918− putMVar bDone ()
919−
920− -- Driver
921− forM_ [1 .. numRepeats] $ \_i -> do
922− -- putStrLn $ "Round " ++ show _i
923− tryTakeMVar aTimeout
924− tryTakeMVar bTimeout
925− putMVar go ()
926− putMVar go ()
927− takeMVar aDone
928− takeMVar bDone
929−
930−-- Transport tests
931−testTransport :: IO (Either String Transport) -> IO ()
932−testTransport newTransport = do
933− Right transport <- newTransport
934− runTests
935− [ ("PingPong", testPingPong transport numPings)
936− , ("EndPoints", testEndPoints transport numPings)
937− , ("Connections", testConnections transport numPings)
938− , ("CloseOneConnection", testCloseOneConnection transport numPings)
939− , ("CloseOneDirection", testCloseOneDirection transport numPings)
940− , ("CloseReopen", testCloseReopen transport numPings)
941− , ("ParallelConnects", testParallelConnects transport numPings)
942− , ("SendAfterClose", testSendAfterClose transport 1000)
943− , ("Crossing", testCrossing transport 100)
944− , ("CloseTwice", testCloseTwice transport 100)
945− , ("ConnectToSelf", testConnectToSelf transport numPings)
946− , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
947− , ("CloseSelf", testCloseSelf newTransport)
948− , ("CloseEndPoint", testCloseEndPoint transport numPings)
949− , ("CloseTransport", testCloseTransport newTransport)
950− , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
951− , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
952− , ("SendException", testSendException newTransport)
953− , ("Kill", testKill newTransport 10000)
954− ]
955− where
956− numPings = 10000 :: Int
network-transport-inmemory/tests/Traced.hsdeleted−191
@@ -1,191 +0,0 @@
1−-- | Add tracing to the IO monad (see examples).
2−--
3−-- [Usage]
4−--
5−-- > {-# LANGUAGE RebindableSyntax #-}
6−-- > import Prelude hiding (catch, (>>=), (>>), return, fail)
7−-- > import Traced
8−--
9−-- [Example]
10−--
11−-- > test1 :: IO Int
12−-- > test1 = do
13−-- > Left x <- return (Left 1 :: Either Int Int)
14−-- > putStrLn "Hello world"
15−-- > Right y <- return (Left 2 :: Either Int Int)
16−-- > return (x + y)
17−--
18−-- outputs
19−--
20−-- > Hello world
21−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9)
22−-- > Trace:
23−-- > 0 Left 2
24−-- > 1 Left 1
25−--
26−-- [Guards]
27−--
28−-- Use the following idiom instead of using 'Control.Monad.guard':
29−--
30−-- > test2 :: IO Int
31−-- > test2 = do
32−-- > Left x <- return (Left 1 :: Either Int Int)
33−-- > True <- return (x == 3)
34−-- > return x
35−--
36−-- The advantage of this idiom is that it gives you line number information when the guard fails:
37−--
38−-- > *Traced> test2
39−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6)
40−-- > Trace:
41−-- > 0 Left 1
42−module Traced ( MonadS(..)
43− , return
44− , (>>=)
45− , (>>)
46− , fail
47− , ifThenElse
48− , Showable(..)
49− , Traceable(..)
50− , traceShow
51− ) where
52−
53−import Prelude hiding ((>>=), return, fail, catch, (>>))
54−import qualified Prelude
55−import Control.Exception (catches, Handler(..), SomeException, throwIO, Exception(..), IOException)
56−import Control.Applicative ((<$>))
57−import Data.Typeable (Typeable)
58−import Data.Maybe (catMaybes)
59−import Data.ByteString (ByteString)
60−import Data.Int (Int32)
61−import Control.Concurrent.MVar (MVar)
62−
63−--------------------------------------------------------------------------------
64−-- MonadS class --
65−--------------------------------------------------------------------------------
66−
67−-- | Like 'Monad' but bind is only defined for 'Trace'able instances
68−class MonadS m where
69− returnS :: a -> m a
70− bindS :: Traceable a => m a -> (a -> m b) -> m b
71− failS :: String -> m a
72− seqS :: m a -> m b -> m b
73−
74−-- | Redefinition of 'Prelude.>>='
75−(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
76−(>>=) = bindS
77−
78−-- | Redefinition of 'Prelude.>>'
79−(>>) :: MonadS m => m a -> m b -> m b
80−(>>) = seqS
81−
82−-- | Redefinition of 'Prelude.return'
83−return :: MonadS m => a -> m a
84−return = returnS
85−
86−-- | Redefinition of 'Prelude.fail'
87−fail :: MonadS m => String -> m a
88−fail = failS
89−
90−--------------------------------------------------------------------------------
91−-- Trace typeclass (for adding elements to a trace --
92−--------------------------------------------------------------------------------
93−
94−data Showable = forall a. Show a => Showable a
95−
96−instance Show Showable where
97− show (Showable x) = show x
98−
99−mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
100−mapShowable f (Showable x) = f x
101−
102−traceShow :: Show a => a -> Maybe Showable
103−traceShow = Just . Showable
104−
105−class Traceable a where
106− trace :: a -> Maybe Showable
107−
108−instance (Traceable a, Traceable b) => Traceable (Either a b) where
109− trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
110− trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
111−
112−instance (Traceable a, Traceable b) => Traceable (a, b) where
113− trace (x, y) = case (trace x, trace y) of
114− (Nothing, Nothing) -> Nothing
115− (Just t1, Nothing) -> traceShow t1
116− (Nothing, Just t2) -> traceShow t2
117− (Just t1, Just t2) -> traceShow (t1, t2)
118−
119−instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
120− trace (x, y, z) = case (trace x, trace y, trace z) of
121− (Nothing, Nothing, Nothing) -> Nothing
122− (Just t1, Nothing, Nothing) -> traceShow t1
123− (Nothing, Just t2, Nothing) -> traceShow t2
124− (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
125− (Nothing, Nothing, Just t3) -> traceShow t3
126− (Just t1, Nothing, Just t3) -> traceShow (t1, t3)
127− (Nothing, Just t2, Just t3) -> traceShow (t2, t3)
128− (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
129−
130−instance Traceable a => Traceable (Maybe a) where
131− trace Nothing = traceShow (Nothing :: Maybe ())
132− trace (Just x) = mapShowable (Showable . Just) <$> trace x
133−
134−instance Traceable a => Traceable [a] where
135− trace = traceShow . catMaybes . map trace
136−
137−instance Traceable () where
138− trace = const Nothing
139−
140−instance Traceable Int where
141− trace = traceShow
142−
143−instance Traceable Int32 where
144− trace = traceShow
145−
146−instance Traceable Bool where
147− trace = const Nothing
148−
149−instance Traceable ByteString where
150− trace = traceShow
151−
152−instance Traceable (MVar a) where
153− trace = const Nothing
154−
155−instance Traceable [Char] where
156− trace = traceShow
157−
158−instance Traceable IOException where
159− trace = traceShow
160−
161−--------------------------------------------------------------------------------
162−-- IO instance for MonadS --
163−--------------------------------------------------------------------------------
164−
165−data TracedException = TracedException [String] SomeException
166− deriving Typeable
167−
168−instance Exception TracedException
169−
170−-- | Add tracing to 'IO' (see examples)
171−instance MonadS IO where
172− returnS = Prelude.return
173− bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
174− failS = Prelude.fail
175− seqS = (Prelude.>>)
176−
177−instance Show TracedException where
178− show (TracedException ts ex) =
179− show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))
180−
181−traceHandlers :: Traceable a => a -> [Handler b]
182−traceHandlers a = case trace a of
183− Nothing -> [ Handler $ \ex -> throwIO (ex :: SomeException) ]
184− Just t -> [ Handler $ \(TracedException ts ex) -> throwIO $ TracedException (show t : ts) ex
185− , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)
186− ]
187−
188−-- | Definition of 'ifThenElse' for use with RebindableSyntax
189−ifThenElse :: Bool -> a -> a -> a
190−ifThenElse True x _ = x
191−ifThenElse False _ y = y
network-transport-tcp/ChangeLogdeleted−20
@@ -1,20 +0,0 @@
1−<<date>> Edsko de Vries <edsko@well-typed.com> 0.3.0
2−
3−* Implement new disconnection semantics
4−
5−2012-08-20 Edsko de Vries <edsko@well-typed.com> 0.2.0.3
6−
7−* Allow for colons in hostnames (for IPv6)
8−
9−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2
10−
11−* Base 4.6 compatibility
12−* Relax package contraints on bytestring and containers
13−
14−2012-07-12 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
15−
16−* Fix bug in recvExact
17−
18−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
19−
20−* Initial release.
network-transport-tcp/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Well-Typed LLP, 2011-2012
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
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
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.
31−
network-transport-tcp/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
network-transport-tcp/benchmarks/Headers.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
4− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
5− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
6− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
7− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
8− "JustPingC.data" smooth bezier with lines title "JustPingC"
9−set terminal postscript color
10−set output "Headers.ps"
11−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
12− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
13− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
14− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
15− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
16− "JustPingC.data" smooth bezier with lines title "JustPingC"
network-transport-tcp/benchmarks/Indirection.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
4− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
5− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
6− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
7− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
8− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
9−set terminal postscript color
10−set output "Indirection.ps"
11−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
12− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
13− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
14− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
15− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
16− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
network-transport-tcp/benchmarks/JustPingC.cdeleted−150
@@ -1,150 +0,0 @@
1−#include <stdio.h>
2−#include <stdlib.h>
3−#include <sys/types.h>
4−#include <sys/socket.h>
5−#include <netdb.h>
6−#include <string.h>
7−#include <unistd.h>
8−#include <signal.h>
9−#include <errno.h>
10−#include <time.h>
11−#include <sys/time.h>
12−#include <math.h>
13−
14−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
15−double timestamp() {
16− struct timeval tp;
17− gettimeofday(&tp, NULL);
18− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
19−}
20−
21−int server() {
22− printf("starting server\n");
23−
24− struct addrinfo hints, *res;
25− int error, server_socket;
26−
27− memset(&hints, 0, sizeof(hints));
28− hints.ai_family = PF_INET;
29− hints.ai_socktype = SOCK_STREAM;
30− hints.ai_flags = AI_PASSIVE;
31−
32− error = getaddrinfo(NULL, "8080", &hints, &res);
33− if(error) {
34− printf("server error: %s\n", gai_strerror(error));
35− return -1;
36− }
37−
38− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
39− if(server_socket < 0) {
40− printf("server error: could not create socket\n");
41− return -1;
42− }
43−
44− int yes = 1;
45− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
46− printf("server error: could not set socket options\n");
47− return -1;
48− }
49−
50− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
51− printf("server error: could not bind to socket\n");
52− return -1;
53− }
54−
55− listen(server_socket, 5);
56−
57− int client_socket;
58− struct sockaddr_storage client_addr;
59− socklen_t addr_size;
60− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
61−
62− for(;;) {
63− char* buf = malloc(8);
64− ssize_t read = recv(client_socket, buf, 8, 0);
65− if(read == 0) {
66− free(buf);
67− break;
68− }
69− // printf("server received '%s'\n", buf);
70− send(client_socket, buf, 8, 0);
71− free(buf);
72− }
73−
74− freeaddrinfo(res);
75− return 0;
76−}
77−
78−int client(int pings) {
79− printf("starting client\n");
80−
81− struct addrinfo hints, *res;
82− int error, client_socket, i;
83−
84− memset(&hints, 0, sizeof(hints));
85− hints.ai_family = PF_INET;
86− hints.ai_socktype = SOCK_STREAM;
87−
88− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
89− if(error) {
90− printf("client error: %s\n", gai_strerror(error));
91− return -1;
92− }
93−
94− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
95− if(client_socket < 0) {
96− printf("client error: could not create socket\n");
97− return -1;
98− }
99−
100− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
101− printf("client error: could not connect: %s\n", strerror(errno));
102− return -1;
103− }
104−
105− for(i = 0; i < pings; i++) {
106− double timestamp_before = timestamp();
107−
108− send(client_socket, "ping123", 8, 0);
109−
110− char *buf = malloc(8);
111− ssize_t read = recv(client_socket, buf, 8, 0);
112−
113− if(read == 0) {
114− printf("server exited prematurely\n");
115− free(buf);
116− break;
117− }
118−
119− // printf("client received '%s'\n", buf);
120− free(buf);
121−
122− double timestamp_after = timestamp();
123− fprintf(stderr, "%i %lf\n", i, timestamp_after - timestamp_before);
124− }
125−
126− printf("client did %d pings\n", pings);
127−
128− freeaddrinfo(res);
129− return 0;
130−}
131−
132−int usage(int argc, char** argv) {
133− printf("usage: %s <number of pings>\n", argv[0]);
134− return -1;
135−}
136−
137−int main(int argc, char** argv) {
138− if(argc != 2) {
139− return usage(argc, argv);
140− }
141−
142− if(fork() == 0) {
143− // TODO: we should wait until we know the server is ready
144− int pings = 0;
145− sscanf(argv[1], "%d", &pings);
146− return client(pings);
147− } else {
148− return server();
149− }
150−}
network-transport-tcp/benchmarks/JustPingCacheHeader.hsdeleted−134
@@ -1,134 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− -- Ignore header
111− return payload
112−
113−-- | Cached header
114−header :: ByteString
115−header = pack "fake"
116−
117−-- | Wrapper around NBS.send (for profiling)
118−send :: Socket -> ByteString -> IO ()
119−send sock bs = do
120− NBS.sendMany sock [header, bs]
121−
122−-- | Encode length (manual for now)
123−encodeLength :: Int32 -> IO ByteString
124−encodeLength i32 =
125− BSI.create 4 $ \p ->
126− pokeByteOff p 0 (htonl (fromIntegral i32))
127−
128−-- | Decode length (manual for now)
129−decodeLength :: ByteString -> IO Int32
130−decodeLength bs =
131− let (fp, _, _) = BSI.toForeignPtr bs in
132− withForeignPtr fp $ \p -> do
133− w32 <- peekByteOff p 0
134− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingHaskell.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−
27−main :: IO ()
28−main = do
29− [pingsStr] <- getArgs
30− serverReady <- newEmptyMVar
31− clientDone <- newEmptyMVar
32−
33− -- Start the server
34− forkIO $ do
35− putStrLn "server: creating TCP connection"
36− serverAddrs <- getAddrInfo
37− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
38− Nothing
39− (Just "8080")
40− let serverAddr = head serverAddrs
41− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
42− setSocketOption sock ReuseAddr 1
43− bindSocket sock (addrAddress serverAddr)
44−
45− putStrLn "server: awaiting client connection"
46− putMVar serverReady ()
47− listen sock 1
48− (clientSock, clientAddr) <- accept sock
49−
50− putStrLn "server: listening for pings"
51− pong clientSock
52−
53− -- Start the client
54− forkIO $ do
55− takeMVar serverReady
56− let pings = read pingsStr
57− serverAddrs <- getAddrInfo
58− Nothing
59− (Just "127.0.0.1")
60− (Just "8080")
61− let serverAddr = head serverAddrs
62− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
63−
64− N.connect sock (addrAddress serverAddr)
65−
66− ping sock pings
67− putMVar clientDone ()
68−
69− -- Wait for the client to finish
70− takeMVar clientDone
71−
72−pingMessage :: ByteString
73−pingMessage = pack "ping123"
74−
75−ping :: Socket -> Int -> IO ()
76−ping sock pings = go pings
77− where
78− go :: Int -> IO ()
79− go 0 = do
80− putStrLn $ "client did " ++ show pings ++ " pings"
81− go !i = do
82− before <- getCurrentTime
83− send sock pingMessage
84− bs <- recv sock 8
85− after <- getCurrentTime
86− -- putStrLn $ "client received " ++ unpack bs
87− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
88− hPutStrLn stderr $ show i ++ " " ++ show latency
89− go (i - 1)
90−
91−pong :: Socket -> IO ()
92−pong sock = do
93− bs <- recv sock 8
94− -- putStrLn $ "server received " ++ unpack bs
95− when (BS.length bs > 0) $ do
96− send sock bs
97− pong sock
98−
99−-- | Wrapper around NBS.recv (for profiling)
100−recv :: Socket -> Int -> IO ByteString
101−recv = NBS.recv
102−
103−-- | Wrapper around NBS.send (for profiling)
104−send :: Socket -> ByteString -> IO Int
105−send = NBS.send
network-transport-tcp/benchmarks/JustPingOneRecv.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− length <- decodeLength header -- Ignored
111− return payload
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingThroughChan.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexChannel <- newChan
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToChan clientSock multiplexChannel
59−
60− -- Reply to the client
61− forever $ readChan multiplexChannel >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToChan :: Socket -> Chan ByteString -> IO ()
76−socketToChan sock chan = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− writeChan chan bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingThroughMVar.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexMVar <- newEmptyMVar
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToMVar clientSock multiplexMVar
59−
60− -- Reply to the client
61− forever $ takeMVar multiplexMVar >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToMVar :: Socket -> MVar ByteString -> IO ()
76−socketToMVar sock mvar = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− putMVar mvar bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingTransport.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import System.Environment (getArgs, withArgs)
9−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
10−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
11−import Control.Concurrent (forkIO)
12−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
13−import qualified Network.Socket as N
14−import Debug.Trace
15−import Data.ByteString (ByteString)
16−import Data.ByteString.Char8 (pack, unpack)
17−import qualified Data.ByteString as BS
18−import qualified Network.Socket.ByteString as NBS
19−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
20−import Network.Transport
21−import Network.Transport.TCP
22−
23−main :: IO ()
24−main = do
25− [pingsStr] <- getArgs
26− serverAddr <- newEmptyMVar
27− clientAddr <- newEmptyMVar
28− clientDone <- newEmptyMVar
29−
30− -- Start the server
31− forkIO $ do
32− -- establish transport and endpoint
33− putStrLn "server: creating TCP connection"
34− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35− Right endpoint <- newEndPoint transport
36− putMVar serverAddr (address endpoint)
37−
38− -- Connect to the client so that we can reply
39− theirAddr <- takeMVar clientAddr
40− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
41−
42− -- reply to pings with pongs
43− putStrLn "server: awaiting client connection"
44− ConnectionOpened _ _ _ <- receive endpoint
45− pong endpoint conn
46−
47− -- Start the client
48− forkIO $ do
49− let pings = read pingsStr
50−
51− -- establish transport and endpoint
52− Right transport <- createTransport "127.0.0.1" "8081" defaultTCPParameters
53− Right endpoint <- newEndPoint transport
54− putMVar clientAddr (address endpoint)
55−
56− -- Connect to the server to send pings
57− theirAddr <- takeMVar serverAddr
58− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
59−
60− -- Send pings, waiting for a reply after every ping
61− ConnectionOpened _ _ _ <- receive endpoint
62− ping endpoint conn pings
63− putMVar clientDone ()
64−
65− -- Wait for the client to finish
66− takeMVar clientDone
67−
68−pingMessage :: [ByteString]
69−pingMessage = [pack "ping123"]
70−
71−ping :: EndPoint -> Connection -> Int -> IO ()
72−ping endpoint conn pings = go pings
73− where
74− go :: Int -> IO ()
75− go 0 = do
76− putStrLn $ "client did " ++ show pings ++ " pings"
77− go !i = do
78− before <- getCurrentTime
79− send conn pingMessage
80− Received _ _payload <- receive endpoint
81− after <- getCurrentTime
82− -- putStrLn $ "client received " ++ show _payload
83− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
84− hPutStrLn stderr $ show i ++ " " ++ show latency
85− go (i - 1)
86−
87−pong :: EndPoint -> Connection -> IO ()
88−pong endpoint conn = go
89− where
90− go = do
91− msg <- receive endpoint
92− case msg of
93− Received _ payload -> send conn payload >> go
94− ConnectionClosed _ -> return ()
95− _ -> fail "Unexpected message"
network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hsdeleted−151
@@ -1,151 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr, NoDelay)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− pingsStr:args <- getArgs
40− serverReady <- newEmptyMVar
41− clientReady <- newEmptyMVar
42− clientDone <- newEmptyMVar
43−
44− -- Start the server
45− forkIO $ do
46− -- Initialize the server
47− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51− listen sock 1
52−
53− -- Set up multiplexing channel
54− multiplexChannel <- newChan
55−
56− -- Connect to the client (to reply)
57− forkIO $ do
58− takeMVar clientReady
59− clientAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8081")
60− pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol
61− N.connect pongSock (addrAddress clientAddr)
62− when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1
63− forever $ readChan multiplexChannel >>= send pongSock
64−
65− -- Wait for incoming connections (pings from the client)
66− putMVar serverReady ()
67− (pingSock, pingAddr) <- accept sock
68− socketToChan pingSock multiplexChannel
69−
70− -- Start the client
71− forkIO $ do
72− clientAddr:_ <- getAddrInfo passive Nothing (Just "8081")
73− sock <- socket (addrFamily clientAddr) Stream defaultProtocol
74− setSocketOption sock ReuseAddr 1
75− bindSocket sock (addrAddress clientAddr)
76− listen sock 1
77−
78− -- Set up multiplexing channel
79− multiplexChannel <- newChan
80−
81− -- Connect to the server (to send pings)
82− forkIO $ do
83− takeMVar serverReady
84− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
85− pingSock <- socket (addrFamily serverAddr) Stream defaultProtocol
86− N.connect pingSock (addrAddress serverAddr)
87− when ("--NoDelay" `elem` args) $ setSocketOption pingSock NoDelay 1
88− ping pingSock multiplexChannel (read pingsStr)
89− putMVar clientDone ()
90−
91− -- Wait for incoming connections (pongs from the server)
92− putMVar clientReady ()
93− (pongSock, pongAddr) <- accept sock
94− socketToChan pongSock multiplexChannel
95−
96− -- Wait for the client to finish
97− takeMVar clientDone
98−
99−socketToChan :: Socket -> Chan ByteString -> IO ()
100−socketToChan sock chan = go
101− where
102− go = do bs <- recv sock
103− when (BS.length bs > 0) $ do
104− writeChan chan bs
105− go
106−
107−pingMessage :: ByteString
108−pingMessage = pack "ping123"
109−
110−ping :: Socket -> Chan ByteString -> Int -> IO ()
111−ping sock chan pings = go pings
112− where
113− go :: Int -> IO ()
114− go 0 = do
115− putStrLn $ "client did " ++ show pings ++ " pings"
116− go !i = do
117− before <- getCurrentTime
118− send sock pingMessage
119− bs <- readChan chan
120− after <- getCurrentTime
121− -- putStrLn $ "client received " ++ unpack bs
122− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
123− hPutStrLn stderr $ show i ++ " " ++ show latency
124− go (i - 1)
125−
126−-- | Receive a package
127−recv :: Socket -> IO ByteString
128−recv sock = do
129− header <- NBS.recv sock 4
130− length <- decodeLength header
131− NBS.recv sock (fromIntegral (length :: Int32))
132−
133−-- | Send a package
134−send :: Socket -> ByteString -> IO ()
135−send sock bs = do
136− length <- encodeLength (fromIntegral (BS.length bs))
137− NBS.sendMany sock [length, bs]
138−
139−-- | Encode length (manual for now)
140−encodeLength :: Int32 -> IO ByteString
141−encodeLength i32 =
142− BSI.create 4 $ \p ->
143− pokeByteOff p 0 (htonl (fromIntegral i32))
144−
145−-- | Decode length (manual for now)
146−decodeLength :: ByteString -> IO Int32
147−decodeLength bs =
148− let (fp, _, _) = BSI.toForeignPtr bs in
149− withForeignPtr fp $ \p -> do
150− w32 <- peekByteOff p 0
151− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingWithHeader.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock _ = do
109− header <- NBS.recv sock 4
110− length <- decodeLength header
111− NBS.recv sock (fromIntegral (length :: Int32))
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/Makefiledeleted−55
@@ -1,55 +0,0 @@
1−# The "Just Ping" tests measure ping latency with as little overhead as possible
2−
3−NUMPINGS=100000
4−ROOT=../..
5−INCLUDES=-i${ROOT}/network-transport/src -i${ROOT}/network-transport-tcp/src
6−
7−# Enable for profiling
8−# PROF_GHC=-prof -fprof-auto
9−# PROF_EXE=+RTS -pa -RTS
10−
11−GCC=gcc
12−GHC=ghc -rtsopts -XRankNTypes -XScopedTypeVariables -XDeriveDataTypeable -XCPP -XGeneralizedNewtypeDeriving -optP-include -optPcabal_macros.h
13−
14−all: NewTransport.ps Indirection.ps Headers.ps
15−
16−NewTransport.ps: JustPingHaskell.data \
17− JustPingTransport.data
18− gnuplot ./NewTransport.gnuplot
19−
20−Indirection.ps: JustPingWithHeader.data \
21− JustPingThroughChan.data \
22− JustPingThroughMVar.data \
23− JustPingTwoSocketPairs.data \
24− JustPingTwoSocketPairsND.data \
25− JustPingTransport.data
26− gnuplot ./Indirection.gnuplot
27−
28−Headers.ps: JustPingC.data \
29− JustPingHaskellNT.data \
30− JustPingHaskell.data \
31− JustPingWithHeader.data \
32− JustPingOneRecv.data \
33− JustPingCacheHeader.data
34− gnuplot ./Headers.gnuplot
35−
36−JustPingC.exe: JustPingC.c
37− $(GCC) -O2 -o JustPingC.exe JustPingC.c
38−
39−JustPingHaskellNT.exe: JustPingHaskell.hs
40− $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs
41−
42−JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe
43− time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@
44−
45−%.data : %.exe
46− time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@
47−
48−%.exe :: %.hs
49− $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES)
50−
51−.PHONY: clean
52−clean:
53− rm -f *.data *.ps *.pdf *.o *.hi *.exe
54−
55−# vi:set noexpandtab:
network-transport-tcp/benchmarks/NewTransport.gnuplotdeleted−8
@@ -1,8 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
4− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
5−set terminal postscript color
6−set output "NewTransport.ps"
7−plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
8− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
network-transport-tcp/benchmarks/cabal_macros.hdeleted−5
@@ -1,5 +0,0 @@
1−#define VERSION_base "4.5.0.0"
2−#define MIN_VERSION_base(major1,major2,minor) (\
3− (major1) < 4 || \
4− (major1) == 4 && (major2) < 5 || \
5− (major1) == 4 && (major2) == 5 && (minor) <= 0)
network-transport-tcp/network-transport-tcp.cabaldeleted−47
@@ -1,47 +0,0 @@
1−Name: network-transport-tcp
2−Version: 0.3.0
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: TCP instantiation of Network.Transport
14−Description: TCP instantiation of Network.Transport
15−Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
16−Category: Network
17−
18−Source-Repository head
19− Type: git
20− Location: https://github.com/haskell-distributed/distributed-process
21− SubDir: network-transport-tcp
22−
23−Library
24− Build-Depends: base >= 4.3 && < 5,
25− network-transport >= 0.3 && < 0.4,
26− data-accessor >= 0.2 && < 0.3,
27− containers >= 0.4 && < 0.6,
28− bytestring >= 0.9 && < 0.11,
29− network >= 2.3 && < 2.4
30− Exposed-modules: Network.Transport.TCP,
31− Network.Transport.TCP.Internal
32− Extensions: CPP
33− ghc-options: -Wall -fno-warn-unused-do-bind
34− HS-Source-Dirs: src
35−
36−Test-Suite TestTCP
37− Type: exitcode-stdio-1.0
38− Main-Is: TestTCP.hs
39− Build-Depends: base >= 4.3 && < 5,
40− network-transport-tests >= 0.1 && < 0.2,
41− network >= 2.3 && < 2.4,
42− network-transport >= 0.3 && < 0.4,
43− network-transport-tcp >= 0.3 && < 0.4
44− ghc-options: -threaded -rtsopts -with-rtsopts=-N
45− HS-Source-Dirs: tests
46− Extensions: CPP,
47− OverloadedStrings
network-transport-tcp/src/Network/Transport/TCP.hsdeleted−1667
@@ -1,1667 +0,0 @@
1−-- | TCP implementation of the transport layer.
2−--
3−-- The TCP implementation guarantees that only a single TCP connection (socket)
4−-- will be used between endpoints, provided that the addresses specified are
5−-- canonical. If /A/ connects to /B/ and reports its address as
6−-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as
7−-- @client1.local:http-alt@ then the transport layer will not realize that the
8−-- TCP connection can be reused.
9−--
10−-- Applications that use the TCP transport should use
11−-- 'Network.Socket.withSocketsDo' in their main function for Windows
12−-- compatibility (see "Network.Socket").
13−module Network.Transport.TCP ( -- * Main API
14− createTransport
15− , TCPParameters(..)
16− , defaultTCPParameters
17− -- * Internals (exposed for unit tests)
18− , createTransportExposeInternals
19− , TransportInternals(..)
20− , EndPointId
21− , encodeEndPointAddress
22− , decodeEndPointAddress
23− , ControlHeader(..)
24− , ConnectionRequestResponse(..)
25− , firstNonReservedConnectionId
26− , socketToEndPoint
27− -- * Design notes
28− -- $design
29− ) where
30−
31−import Prelude hiding
32− ( mapM_
33−#if ! MIN_VERSION_base(4,6,0)
34− , catch
35−#endif
36− )
37−
38−import Network.Transport
39−import Network.Transport.TCP.Internal ( forkServer
40− , recvWithLength
41− , recvInt32
42− , tryCloseSocket
43− )
44−import Network.Transport.Internal ( encodeInt32
45− , decodeInt32
46− , prependLength
47− , mapIOException
48− , tryIO
49− , tryToEnum
50− , void
51− , timeoutMaybe
52− , asyncWhenCancelled
53− )
54−import qualified Network.Socket as N ( HostName
55− , ServiceName
56− , Socket
57− , getAddrInfo
58− , socket
59− , addrFamily
60− , addrAddress
61− , SocketType(Stream)
62− , defaultProtocol
63− , setSocketOption
64− , SocketOption(ReuseAddr)
65− , connect
66− , sOMAXCONN
67− , AddrInfo
68− )
69−import Network.Socket.ByteString (sendMany)
70−import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
71−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
72−import Control.Concurrent.MVar ( MVar
73− , newMVar
74− , modifyMVar
75− , modifyMVar_
76− , readMVar
77− , takeMVar
78− , putMVar
79− , newEmptyMVar
80− , withMVar
81− )
82−import Control.Category ((>>>))
83−import Control.Applicative ((<$>))
84−import Control.Monad (when, unless)
85−import Control.Exception ( IOException
86− , SomeException
87− , AsyncException
88− , handle
89− , throw
90− , throwIO
91− , try
92− , bracketOnError
93− , mask
94− , onException
95− , fromException
96− )
97−import Data.IORef (IORef, newIORef, writeIORef, readIORef)
98−import Data.ByteString (ByteString)
99−import qualified Data.ByteString as BS (concat)
100−import qualified Data.ByteString.Char8 as BSC (pack, unpack)
101−import Data.Int (Int32)
102−import Data.IntMap (IntMap)
103−import qualified Data.IntMap as IntMap (empty)
104−import Data.IntSet (IntSet)
105−import qualified Data.IntSet as IntSet ( empty
106− , insert
107− , elems
108− , singleton
109− , null
110− , delete
111− , member
112− )
113−import Data.Map (Map)
114−import qualified Data.Map as Map (empty)
115−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
116−import qualified Data.Accessor.Container as DAC (mapMaybe, intMapMaybe)
117−import Data.Foldable (forM_, mapM_)
118−
119−-- $design
120−--
121−-- [Goals]
122−--
123−-- The TCP transport maps multiple logical connections between /A/ and /B/ (in
124−-- either direction) to a single TCP connection:
125−--
126−-- > +-------+ +-------+
127−-- > | A |==========================| B |
128−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
129−-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q |
130−-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
131−-- > | |==========================| |
132−-- > +-------+ +-------+
133−--
134−-- Ignoring the complications detailed below, the TCP connection is set up is
135−-- when the first lightweight connection is created (in either direction), and
136−-- torn down when the last lightweight connection (in either direction) is
137−-- closed.
138−--
139−-- [Connecting]
140−--
141−-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to
142−-- connect to /B/, it locally records that it is trying to connect to /B/ and
143−-- sends a request to /B/. As part of the request /A/ sends its own endpoint
144−-- address to /B/ (so that /B/ can reuse the connection in the other direction).
145−--
146−-- When /B/ receives the connection request it first checks if it did not
147−-- already initiate a connection request to /A/. If not it will acknowledge the
148−-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record
149−-- that it has a TCP connection to /A/.
150−--
151−-- The tricky case arises when /A/ sends a connection request to /B/ and /B/
152−-- finds that it had already sent a connection request to /A/. In this case /B/
153−-- will accept the connection request from /A/ if /A/s endpoint address is
154−-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects
155−-- it, it sends a 'ConnectionRequestCrossed' message to /A/. (The
156−-- lexicographical ordering is an arbitrary but convenient way to break the
157−-- tie.)
158−--
159−-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that
160−-- initiated the request just needs to wait until the /A/ thread that is dealing
161−-- with /B/'s connection request completes.
162−--
163−-- [Disconnecting]
164−--
165−-- The TCP connection is created as soon as the first logical connection from
166−-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
167−-- spawned that listens for incoming connections from /B/:
168−--
169−-- > +-------+ +-------+
170−-- > | A |==========================| B |
171−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
172−-- > | | | Q |
173−-- > | #| | |
174−-- > | |==========================| |
175−-- > +-------+ +-------+
176−--
177−-- The question is when the TCP connection can be closed again. Conceptually,
178−-- we want to do reference counting: when there are no logical connections left
179−-- between /A/ and /B/ we want to close the socket (possibly after some
180−-- timeout).
181−--
182−-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
183−-- might happen that /B/ sends a connection request over the existing socket at
184−-- the same time that /A/ closes its logical connection to /B/ and closes the
185−-- socket. This will cause a failure in /B/ (which will have to retry) which is
186−-- not caused by a network failure, which is unfortunate. (Note that the
187−-- connection request from /B/ might succeed even if /A/ closes the socket.)
188−--
189−-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
190−-- request to /B/ and records that its connection to /B/ is closing. If /A/
191−-- receives a new connection request from /B/ after having sent the
192−-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
193−-- and increments the reference count of the connection again.
194−--
195−-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
196−-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
197−-- and then actually close the socket. /A/ meanwhile will not send any more
198−-- requests to /B/ after having sent a 'CloseSocket' request, and will actually
199−-- close its end of the socket only when receiving the 'CloseSocket' message
200−-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
201−-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
202−-- reciprocal 'CloseSocket' message.)
203−--
204−-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
205−-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
206−-- whether to reuse the old socket (if /B/ sends a new connection request
207−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
208−
209−--------------------------------------------------------------------------------
210−-- Internal datatypes --
211−--------------------------------------------------------------------------------
212−
213−-- We use underscores for fields that we might update (using accessors)
214−--
215−-- All data types follow the same structure:
216−--
217−-- * A top-level data type describing static properties (TCPTransport,
218−-- LocalEndPoint, RemoteEndPoint)
219−-- * The 'static' properties include an MVar containing a data structure for
220−-- the dynamic properties (TransportState, LocalEndPointState,
221−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
222−-- * For the case of "valid" we use third data structure to give more details
223−-- about the state (ValidTransportState, ValidLocalEndPointState,
224−-- ValidRemoteEndPointState).
225−
226−data TCPTransport = TCPTransport
227− { transportHost :: N.HostName
228− , transportPort :: N.ServiceName
229− , transportState :: MVar TransportState
230− , transportParams :: TCPParameters
231− }
232−
233−data TransportState =
234− TransportValid ValidTransportState
235− | TransportClosed
236−
237−data ValidTransportState = ValidTransportState
238− { _localEndPoints :: Map EndPointAddress LocalEndPoint
239− , _nextEndPointId :: EndPointId
240− }
241−
242−data LocalEndPoint = LocalEndPoint
243− { localAddress :: EndPointAddress
244− , localChannel :: Chan Event
245− , localState :: MVar LocalEndPointState
246− }
247−
248−data LocalEndPointState =
249− LocalEndPointValid ValidLocalEndPointState
250− | LocalEndPointClosed
251−
252−data ValidLocalEndPointState = ValidLocalEndPointState
253− { _nextConnectionId :: !ConnectionId
254− , _localConnections :: Map EndPointAddress RemoteEndPoint
255− , _nextRemoteId :: !Int
256− }
257−
258−-- REMOTE ENDPOINTS
259−--
260−-- Remote endpoints (basically, TCP connections) have the following lifecycle:
261−--
262−-- Init ---+---> Invalid
263−-- |
264−-- +-------------------------------\
265−-- | |
266−-- | /----------\ |
267−-- | | | |
268−-- | v | v
269−-- +---> Valid ---> Closing ---> Closed
270−-- | | | |
271−-- | | | v
272−-- \-------+----------+--------> Failed
273−--
274−-- Init: There are two places where we create new remote endpoints: in
275−-- requestConnectionTo (in response to an API 'connect' call) and in
276−-- handleConnectionRequest (when a remote node tries to connect to us).
277−-- 'Init' carries an MVar () 'resolved' which concurrent threads can use to
278−-- wait for the remote endpoint to finish initialization. We record who
279−-- requested the connection (the local endpoint or the remote endpoint).
280−--
281−-- Invalid: We put the remote endpoint in invalid state only during
282−-- requestConnectionTo when we fail to connect.
283−--
284−-- Valid: This is the "normal" state for a working remote endpoint.
285−--
286−-- Closing: When we detect that a remote endpoint is no longer used, we send a
287−-- CloseSocket request across the connection and put the remote endpoint in
288−-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which
289−-- concurrent threads can use to wait for the remote endpoint to either be
290−-- closed fully (if the communication parnet responds with another
291−-- CloseSocket) or be put back in 'Valid' state if the remote endpoint denies
292−-- the request.
293−--
294−-- We also put the endpoint in Closed state, directly from Init, if we our
295−-- outbound connection request crossed an inbound connection request and we
296−-- decide to keep the inbound (i.e., the remote endpoint sent us a
297−-- ConnectionRequestCrossed message).
298−--
299−-- Closed: The endpoint is put in Closed state after a successful garbage
300−-- collection.
301−--
302−-- Failed: If the connection to the remote endpoint is lost, or the local
303−-- endpoint (or the whole transport) is closed manually, the remote endpoint is
304−-- put in Failed state, and we record the reason.
305−--
306−-- Invariants for dealing with remote endpoints:
307−--
308−-- INV-SEND: Whenever we send data the remote endpoint must be locked (to avoid
309−-- interleaving bits of payload).
310−--
311−-- INV-CLOSE: Local endpoints should never point to remote endpoint in closed
312−-- state. Whenever we put an endpoint in Closed state we remove that
313−-- endpoint from localConnections first, so that if a concurrent thread reads
314−-- the MVar, finds RemoteEndPointClosed, and then looks up the endpoint in
315−-- localConnections it is guaranteed to either find a different remote
316−-- endpoint, or else none at all (if we don't insist in this order some
317−-- threads might start spinning).
318−--
319−-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is
320−-- locked, and the remote endpoint must be in Valid or Closed state once
321−-- unlocked. This guarantees that there will not be two threads attempting to
322−-- both signal on 'resolved'.
323−--
324−-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we
325−-- first put the remote endpoint in Closed state, and then send a
326−-- EventConnectionLost event. This guarantees that we only send this event
327−-- once.
328−--
329−-- INV-CLOSING: An endpoint in closing state is for all intents and purposes
330−-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
331−-- acceptable, of course -- as we are waiting for the remote endpoint to
332−-- confirm or deny the request).
333−--
334−-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints.
335−-- In other words: it is okay to call modifyMVar on a local endpoint inside a
336−-- modifyMVar on a remote endpoint, but not the other way around. In
337−-- particular, it is okay to call removeRemoteEndPoint inside
338−-- modifyRemoteState.
339−
340−data RemoteEndPoint = RemoteEndPoint
341− { remoteAddress :: EndPointAddress
342− , remoteState :: MVar RemoteState
343− , remoteId :: Int
344− }
345−
346−data RequestedBy = RequestedByUs | RequestedByThem
347− deriving (Eq, Show)
348−
349−data RemoteState =
350− -- | Invalid remote endpoint (for example, invalid address)
351− RemoteEndPointInvalid (TransportError ConnectErrorCode)
352− -- | The remote endpoint is being initialized
353− | RemoteEndPointInit (MVar ()) RequestedBy
354− -- | "Normal" working endpoint
355− | RemoteEndPointValid ValidRemoteEndPointState
356− -- | The remote endpoint is being closed (garbage collected)
357− | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
358− -- | The remote endpoint has been closed (garbage collected)
359− | RemoteEndPointClosed
360− -- | The remote endpoint has failed, or has been forcefully shutdown
361− -- using a closeTransport or closeEndPoint API call
362− | RemoteEndPointFailed IOException
363−
364−data ValidRemoteEndPointState = ValidRemoteEndPointState
365− { _remoteOutgoing :: !Int
366− , _remoteIncoming :: IntSet
367− , remoteSocket :: N.Socket
368− , sendOn :: [ByteString] -> IO ()
369− , _pendingCtrlRequests :: IntMap (MVar (Either IOException [ByteString]))
370− , _nextCtrlRequestId :: !ControlRequestId
371− }
372−
373−-- | Local identifier for an endpoint within this transport
374−type EndPointId = Int32
375−
376−-- | Control request ID
377−--
378−-- Control requests are asynchronous; the request ID makes it possible to match
379−-- requests and replies
380−type ControlRequestId = Int32
381−
382−-- | Pair of local and a remote endpoint (for conciseness in signatures)
383−type EndPointPair = (LocalEndPoint, RemoteEndPoint)
384−
385−-- | Control headers
386−data ControlHeader =
387− -- | Request a new connection ID from the remote endpoint
388− RequestConnectionId
389− -- | Tell the remote endpoint we will no longer be using a connection
390− | CloseConnection
391− -- | Respond to a control request /from/ the remote endpoint
392− | ControlResponse
393− -- | Request to close the connection (see module description)
394− | CloseSocket
395− deriving (Enum, Bounded, Show)
396−
397−-- | Response sent by /B/ to /A/ when /A/ tries to connect
398−data ConnectionRequestResponse =
399− -- | /B/ accepts the connection
400− ConnectionRequestAccepted
401− -- | /A/ requested an invalid endpoint
402− | ConnectionRequestInvalid
403− -- | /A/s request crossed with a request from /B/ (see protocols)
404− | ConnectionRequestCrossed
405− deriving (Enum, Bounded, Show)
406−
407−-- | Parameters for setting up the TCP transport
408−data TCPParameters = TCPParameters {
409− -- | Backlog for 'listen'.
410− -- Defaults to SOMAXCONN.
411− tcpBacklog :: Int
412− -- | Should we set SO_REUSEADDR on the server socket?
413− -- Defaults to True.
414− , tcpReuseServerAddr :: Bool
415− -- | Should we set SO_REUSEADDR on client sockets?
416− -- Defaults to True.
417− , tcpReuseClientAddr :: Bool
418− }
419−
420−-- | Internal functionality we expose for unit testing
421−data TransportInternals = TransportInternals
422− { -- | The ID of the thread that listens for new incoming connections
423− transportThread :: ThreadId
424− -- | Find the socket between a local and a remote endpoint
425− , socketBetween :: EndPointAddress
426− -> EndPointAddress
427− -> IO N.Socket
428− }
429−
430−--------------------------------------------------------------------------------
431−-- Top-level functionality --
432−--------------------------------------------------------------------------------
433−
434−-- | Create a TCP transport
435−createTransport :: N.HostName
436− -> N.ServiceName
437− -> TCPParameters
438− -> IO (Either IOException Transport)
439−createTransport host port params =
440− either Left (Right . fst) <$> createTransportExposeInternals host port params
441−
442−-- | You should probably not use this function (used for unit testing only)
443−createTransportExposeInternals
444− :: N.HostName
445− -> N.ServiceName
446− -> TCPParameters
447− -> IO (Either IOException (Transport, TransportInternals))
448−createTransportExposeInternals host port params = do
449− state <- newMVar . TransportValid $ ValidTransportState
450− { _localEndPoints = Map.empty
451− , _nextEndPointId = 0
452− }
453− let transport = TCPTransport { transportState = state
454− , transportHost = host
455− , transportPort = port
456− , transportParams = params
457− }
458− tryIO $ bracketOnError (forkServer
459− host
460− port
461− (tcpBacklog params)
462− (tcpReuseServerAddr params)
463− (terminationHandler transport)
464− (handleConnectionRequest transport))
465− killThread
466− (mkTransport transport)
467− where
468− mkTransport :: TCPTransport
469− -> ThreadId
470− -> IO (Transport, TransportInternals)
471− mkTransport transport tid = return
472− ( Transport
473− { newEndPoint = apiNewEndPoint transport
474− , closeTransport = let evs = [ EndPointClosed
475− , throw $ userError "Transport closed"
476− ] in
477− apiCloseTransport transport (Just tid) evs
478− }
479− , TransportInternals
480− { transportThread = tid
481− , socketBetween = internalSocketBetween transport
482− }
483− )
484−
485− terminationHandler :: TCPTransport -> SomeException -> IO ()
486− terminationHandler transport ex = do
487− let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))
488− , throw $ userError "Transport closed"
489− ]
490− apiCloseTransport transport Nothing evs
491−
492−-- | Default TCP parameters
493−defaultTCPParameters :: TCPParameters
494−defaultTCPParameters = TCPParameters {
495− tcpBacklog = N.sOMAXCONN
496− , tcpReuseServerAddr = True
497− , tcpReuseClientAddr = True
498− }
499−
500−--------------------------------------------------------------------------------
501−-- API functions --
502−--------------------------------------------------------------------------------
503−
504−-- | Close the transport
505−apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()
506−apiCloseTransport transport mTransportThread evs =
507− asyncWhenCancelled return $ do
508− mTSt <- modifyMVar (transportState transport) $ \st -> case st of
509− TransportValid vst -> return (TransportClosed, Just vst)
510− TransportClosed -> return (TransportClosed, Nothing)
511− forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
512− -- This will invoke the termination handler, which in turn will call
513− -- apiCloseTransport again, but then the transport will already be closed
514− -- and we won't be passed a transport thread, so we terminate immmediate
515− forM_ mTransportThread killThread
516−
517−-- | Create a new endpoint
518−apiNewEndPoint :: TCPTransport
519− -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
520−apiNewEndPoint transport =
521− try . asyncWhenCancelled closeEndPoint $ do
522− ourEndPoint <- createLocalEndPoint transport
523− return EndPoint
524− { receive = readChan (localChannel ourEndPoint)
525− , address = localAddress ourEndPoint
526− , connect = apiConnect (transportParams transport) ourEndPoint
527− , closeEndPoint = let evs = [ EndPointClosed
528− , throw $ userError "Endpoint closed"
529− ] in
530− apiCloseEndPoint transport evs ourEndPoint
531− , newMulticastGroup = return . Left $ newMulticastGroupError
532− , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
533− }
534− where
535− newMulticastGroupError =
536− TransportError NewMulticastGroupUnsupported "Multicast not supported"
537− resolveMulticastGroupError =
538− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
539−
540−-- | Connnect to an endpoint
541−apiConnect :: TCPParameters -- ^ Parameters
542− -> LocalEndPoint -- ^ Local end point
543− -> EndPointAddress -- ^ Remote address
544− -> Reliability -- ^ Reliability (ignored)
545− -> ConnectHints -- ^ Hints
546− -> IO (Either (TransportError ConnectErrorCode) Connection)
547−apiConnect params ourEndPoint theirAddress _reliability hints =
548− try . asyncWhenCancelled close $
549− if localAddress ourEndPoint == theirAddress
550− then connectToSelf ourEndPoint
551− else do
552− resetIfBroken ourEndPoint theirAddress
553− (theirEndPoint, connId) <-
554− requestConnectionTo params ourEndPoint theirAddress hints
555− -- connAlive can be an IORef rather than an MVar because it is protected
556− -- by the remoteState MVar. We don't need the overhead of locking twice.
557− connAlive <- newIORef True
558− return Connection
559− { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
560− , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
561− }
562−
563−-- | Close a connection
564−apiClose :: EndPointPair -> ConnectionId -> IORef Bool -> IO ()
565−apiClose (ourEndPoint, theirEndPoint) connId connAlive =
566− void . tryIO . asyncWhenCancelled return $ do
567− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
568− { caseValid = \vst -> do
569− alive <- readIORef connAlive
570− if alive
571− then do
572− writeIORef connAlive False
573− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
574− return ( RemoteEndPointValid
575− . (remoteOutgoing ^: (\x -> x - 1))
576− $ vst
577− )
578− else
579− return (RemoteEndPointValid vst)
580− }
581− closeIfUnused (ourEndPoint, theirEndPoint)
582−
583−-- | Send data across a connection
584−apiSend :: EndPointPair -- ^ Local and remote endpoint
585− -> ConnectionId -- ^ Connection ID (supplied by remote endpoint)
586− -> IORef Bool -- ^ Is the connection still alive?
587− -> [ByteString] -- ^ Payload
588− -> IO (Either (TransportError SendErrorCode) ())
589−apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
590− -- We don't need the overhead of asyncWhenCancelled here
591− try . mapIOException sendFailed $
592− withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
593− { caseInvalid = \_ ->
594− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
595− , caseInit = \_ _ ->
596− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
597− , caseValid = \vst -> do
598− alive <- readIORef connAlive
599− if alive
600− then sendOn vst (encodeInt32 connId : prependLength payload)
601− else throwIO $ TransportError SendClosed "Connection closed"
602− , caseClosing = \_ _ -> do
603− alive <- readIORef connAlive
604− if alive
605− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
606− else throwIO $ TransportError SendClosed "Connection closed"
607− , caseClosed = do
608− alive <- readIORef connAlive
609− if alive
610− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
611− else throwIO $ TransportError SendClosed "Connection closed"
612− , caseFailed = \err -> do
613− alive <- readIORef connAlive
614− if alive
615− then throwIO $ TransportError SendFailed (show err)
616− else throwIO $ TransportError SendClosed "Connection closed"
617− }
618− where
619− sendFailed = TransportError SendFailed . show
620−
621−-- | Force-close the endpoint
622−apiCloseEndPoint :: TCPTransport -- ^ Transport
623− -> [Event] -- ^ Events used to report closure
624− -> LocalEndPoint -- ^ Local endpoint
625− -> IO ()
626−apiCloseEndPoint transport evs ourEndPoint =
627− asyncWhenCancelled return $ do
628− -- Remove the reference from the transport state
629− removeLocalEndPoint transport ourEndPoint
630− -- Close the local endpoint
631− mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
632− case st of
633− LocalEndPointValid vst ->
634− return (LocalEndPointClosed, Just vst)
635− LocalEndPointClosed ->
636− return (LocalEndPointClosed, Nothing)
637− forM_ mOurState $ \vst -> do
638− forM_ (vst ^. localConnections) tryCloseRemoteSocket
639− forM_ evs $ writeChan (localChannel ourEndPoint)
640− where
641− -- Close the remote socket and return the set of all incoming connections
642− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
643− tryCloseRemoteSocket theirEndPoint = do
644− -- We make an attempt to close the connection nicely
645− -- (by sending a CloseSocket first)
646− let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"
647− modifyMVar_ (remoteState theirEndPoint) $ \st ->
648− case st of
649− RemoteEndPointInvalid _ ->
650− return st
651− RemoteEndPointInit resolved _ -> do
652− putMVar resolved ()
653− return closed
654− RemoteEndPointValid conn -> do
655− tryIO $ sendOn conn [encodeInt32 CloseSocket]
656− tryCloseSocket (remoteSocket conn)
657− return closed
658− RemoteEndPointClosing resolved conn -> do
659− putMVar resolved ()
660− tryCloseSocket (remoteSocket conn)
661− return closed
662− RemoteEndPointClosed ->
663− return st
664− RemoteEndPointFailed err ->
665− return $ RemoteEndPointFailed err
666−
667−--------------------------------------------------------------------------------
668−-- As soon as a remote connection fails, we want to put notify our endpoint --
669−-- and put it into a closed state. Since this may happen in many places, we --
670−-- provide some abstractions. --
671−--------------------------------------------------------------------------------
672−
673−data RemoteStatePatternMatch a = RemoteStatePatternMatch
674− { caseInvalid :: TransportError ConnectErrorCode -> IO a
675− , caseInit :: MVar () -> RequestedBy -> IO a
676− , caseValid :: ValidRemoteEndPointState -> IO a
677− , caseClosing :: MVar () -> ValidRemoteEndPointState -> IO a
678− , caseClosed :: IO a
679− , caseFailed :: IOException -> IO a
680− }
681−
682−remoteStateIdentity :: RemoteStatePatternMatch RemoteState
683−remoteStateIdentity =
684− RemoteStatePatternMatch
685− { caseInvalid = return . RemoteEndPointInvalid
686− , caseInit = (return .) . RemoteEndPointInit
687− , caseValid = return . RemoteEndPointValid
688− , caseClosing = (return .) . RemoteEndPointClosing
689− , caseClosed = return RemoteEndPointClosed
690− , caseFailed = return . RemoteEndPointFailed
691− }
692−
693−-- | Like modifyMVar, but if an I/O exception occurs don't restore the remote
694−-- endpoint to its original value but close it instead
695−modifyRemoteState :: EndPointPair
696− -> RemoteStatePatternMatch (RemoteState, a)
697− -> IO a
698−modifyRemoteState (ourEndPoint, theirEndPoint) match =
699− mask $ \restore -> do
700− st <- takeMVar theirState
701− case st of
702− RemoteEndPointValid vst -> do
703− mResult <- try $ restore (caseValid match vst)
704− case mResult of
705− Right (st', a) -> do
706− putMVar theirState st'
707− return a
708− Left ex -> do
709− case fromException ex of
710− Just ioEx -> handleIOException ioEx vst
711− Nothing -> putMVar theirState st
712− throwIO ex
713− -- The other cases are less interesting, because unless the endpoint is
714− -- in Valid state we're not supposed to do any IO on it
715− RemoteEndPointInit resolved origin -> do
716− (st', a) <- onException (restore $ caseInit match resolved origin)
717− (putMVar theirState st)
718− putMVar theirState st'
719− return a
720− RemoteEndPointClosing resolved vst -> do
721− (st', a) <- onException (restore $ caseClosing match resolved vst)
722− (putMVar theirState st)
723− putMVar theirState st'
724− return a
725− RemoteEndPointInvalid err -> do
726− (st', a) <- onException (restore $ caseInvalid match err)
727− (putMVar theirState st)
728− putMVar theirState st'
729− return a
730− RemoteEndPointClosed -> do
731− (st', a) <- onException (restore $ caseClosed match)
732− (putMVar theirState st)
733− putMVar theirState st'
734− return a
735− RemoteEndPointFailed err -> do
736− (st', a) <- onException (restore $ caseFailed match err)
737− (putMVar theirState st)
738− putMVar theirState st'
739− return a
740− where
741− theirState :: MVar RemoteState
742− theirState = remoteState theirEndPoint
743−
744− handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()
745− handleIOException ex vst = do
746− tryCloseSocket (remoteSocket vst)
747− putMVar theirState (RemoteEndPointFailed ex)
748− let code = EventConnectionLost (remoteAddress theirEndPoint)
749− err = TransportError code (show ex)
750− writeChan (localChannel ourEndPoint) $ ErrorEvent err
751−
752−-- | Like 'modifyRemoteState' but without a return value
753−modifyRemoteState_ :: EndPointPair
754− -> RemoteStatePatternMatch RemoteState
755− -> IO ()
756−modifyRemoteState_ (ourEndPoint, theirEndPoint) match =
757− modifyRemoteState (ourEndPoint, theirEndPoint)
758− RemoteStatePatternMatch
759− { caseInvalid = u . caseInvalid match
760− , caseInit = \resolved origin -> u $ caseInit match resolved origin
761− , caseValid = u . caseValid match
762− , caseClosing = \resolved vst -> u $ caseClosing match resolved vst
763− , caseClosed = u $ caseClosed match
764− , caseFailed = u . caseFailed match
765− }
766− where
767− u :: IO a -> IO (a, ())
768− u p = p >>= \a -> return (a, ())
769−
770−-- | Like 'modifyRemoteState' but without the ability to change the state
771−withRemoteState :: EndPointPair
772− -> RemoteStatePatternMatch a
773− -> IO a
774−withRemoteState (ourEndPoint, theirEndPoint) match =
775− modifyRemoteState (ourEndPoint, theirEndPoint)
776− RemoteStatePatternMatch
777− { caseInvalid = \err -> do
778− a <- caseInvalid match err
779− return (RemoteEndPointInvalid err, a)
780− , caseInit = \resolved origin -> do
781− a <- caseInit match resolved origin
782− return (RemoteEndPointInit resolved origin, a)
783− , caseValid = \vst -> do
784− a <- caseValid match vst
785− return (RemoteEndPointValid vst, a)
786− , caseClosing = \resolved vst -> do
787− a <- caseClosing match resolved vst
788− return (RemoteEndPointClosing resolved vst, a)
789− , caseClosed = do
790− a <- caseClosed match
791− return (RemoteEndPointClosed, a)
792− , caseFailed = \err -> do
793− a <- caseFailed match err
794− return (RemoteEndPointFailed err, a)
795− }
796−
797−--------------------------------------------------------------------------------
798−-- Incoming requests --
799−--------------------------------------------------------------------------------
800−
801−-- | Handle a connection request (that is, a remote endpoint that is trying to
802−-- establish a TCP connection with us)
803−--
804−-- 'handleConnectionRequest' runs in the context of the transport thread, which
805−-- can be killed asynchronously by 'closeTransport'. We fork a separate thread
806−-- as soon as we have located the lcoal endpoint that the remote endpoint is
807−-- interested in. We cannot fork any sooner because then we have no way of
808−-- storing the thread ID and hence no way of killing the thread when we take
809−-- the transport down. We must be careful to close the socket when a (possibly
810−-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
811−-- handleConnectionRequest the transport will be shut down.)
812−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
813−handleConnectionRequest transport sock = handle handleException $ do
814− ourEndPointId <- recvInt32 sock
815− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
816− let ourAddress = encodeEndPointAddress (transportHost transport)
817− (transportPort transport)
818− ourEndPointId
819− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
820− TransportValid vst ->
821− case vst ^. localEndPointAt ourAddress of
822− Nothing -> do
823− sendMany sock [encodeInt32 ConnectionRequestInvalid]
824− throwIO $ userError "handleConnectionRequest: Invalid endpoint"
825− Just ourEndPoint ->
826− return ourEndPoint
827− TransportClosed ->
828− throwIO $ userError "Transport closed"
829− void . forkIO $ go ourEndPoint theirAddress
830− where
831− go :: LocalEndPoint -> EndPointAddress -> IO ()
832− go ourEndPoint theirAddress = do
833− -- This runs in a thread that will never be killed
834− mEndPoint <- handle ((>> return Nothing) . handleException) $ do
835− resetIfBroken ourEndPoint theirAddress
836− (theirEndPoint, isNew) <-
837− findRemoteEndPoint ourEndPoint theirAddress RequestedByThem
838−
839− if not isNew
840− then do
841− tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
842− tryCloseSocket sock
843− return Nothing
844− else do
845− let vst = ValidRemoteEndPointState
846− { remoteSocket = sock
847− , _remoteOutgoing = 0
848− , _remoteIncoming = IntSet.empty
849− , sendOn = sendMany sock
850− , _pendingCtrlRequests = IntMap.empty
851− , _nextCtrlRequestId = 0
852− }
853− sendMany sock [encodeInt32 ConnectionRequestAccepted]
854− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
855− return (Just theirEndPoint)
856− -- If we left the scope of the exception handler with a return value of
857− -- Nothing then the socket is already closed; otherwise, the socket has
858− -- been recorded as part of the remote endpoint. Either way, we no longer
859− -- have to worry about closing the socket on receiving an asynchronous
860− -- exception from this point forward.
861− forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
862−
863− handleException :: SomeException -> IO ()
864− handleException ex = do
865− tryCloseSocket sock
866− rethrowIfAsync (fromException ex)
867−
868− rethrowIfAsync :: Maybe AsyncException -> IO ()
869− rethrowIfAsync = mapM_ throwIO
870−
871−-- | Handle requests from a remote endpoint.
872−--
873−-- Returns only if the remote party closes the socket or if an error occurs.
874−-- This runs in a thread that will never be killed.
875−handleIncomingMessages :: EndPointPair -> IO ()
876−handleIncomingMessages (ourEndPoint, theirEndPoint) = do
877− mSock <- withMVar theirState $ \st ->
878− case st of
879− RemoteEndPointInvalid _ ->
880− relyViolation (ourEndPoint, theirEndPoint)
881− "handleIncomingMessages (invalid)"
882− RemoteEndPointInit _ _ ->
883− relyViolation (ourEndPoint, theirEndPoint)
884− "handleIncomingMessages (init)"
885− RemoteEndPointValid ep ->
886− return . Just $ remoteSocket ep
887− RemoteEndPointClosing _ ep ->
888− return . Just $ remoteSocket ep
889− RemoteEndPointClosed ->
890− return Nothing
891− RemoteEndPointFailed _ ->
892− return Nothing
893−
894− forM_ mSock $ \sock ->
895− tryIO (go sock) >>= either (prematureExit sock) return
896− where
897− -- Dispatch
898− --
899− -- If a recv throws an exception this will be caught top-level and
900− -- 'prematureExit' will be invoked. The same will happen if the remote
901− -- endpoint is put into a Closed (or Closing) state by a concurrent thread
902− -- (because a 'send' failed) -- the individual handlers below will throw a
903− -- user exception which is then caught and handled the same way as an
904− -- exception thrown by 'recv'.
905− go :: N.Socket -> IO ()
906− go sock = do
907− connId <- recvInt32 sock
908− if connId >= firstNonReservedConnectionId
909− then do
910− readMessage sock connId
911− go sock
912− else
913− case tryToEnum (fromIntegral connId) of
914− Just RequestConnectionId -> do
915− recvInt32 sock >>= createNewConnection
916− go sock
917− Just ControlResponse -> do
918− recvInt32 sock >>= readControlResponse sock
919− go sock
920− Just CloseConnection -> do
921− recvInt32 sock >>= closeConnection
922− go sock
923− Just CloseSocket -> do
924− didClose <- closeSocket sock
925− unless didClose $ go sock
926− Nothing ->
927− throwIO $ userError "Invalid control request"
928−
929− -- Create a new connection
930− createNewConnection :: ControlRequestId -> IO ()
931− createNewConnection reqId = do
932− newId <- getNextConnectionId ourEndPoint
933− modifyMVar_ theirState $ \st -> do
934− vst <- case st of
935− RemoteEndPointInvalid _ ->
936− relyViolation (ourEndPoint, theirEndPoint)
937− "handleIncomingMessages:createNewConnection (invalid)"
938− RemoteEndPointInit _ _ ->
939− relyViolation (ourEndPoint, theirEndPoint)
940− "handleIncomingMessages:createNewConnection (init)"
941− RemoteEndPointValid vst ->
942− return (remoteIncoming ^: IntSet.insert newId $ vst)
943− RemoteEndPointClosing resolved vst -> do
944− -- If the endpoint is in closing state that means we send a
945− -- CloseSocket request to the remote endpoint. If the remote
946− -- endpoint replies with the request to create a new connection, it
947− -- either ignored our request or it sent the request before it got
948− -- ours. Either way, at this point we simply restore the endpoint
949− -- to RemoteEndPointValid
950− putMVar resolved ()
951− return (remoteIncoming ^= IntSet.singleton newId $ vst)
952− RemoteEndPointFailed err ->
953− throwIO err
954− RemoteEndPointClosed ->
955− relyViolation (ourEndPoint, theirEndPoint)
956− "createNewConnection (closed)"
957− sendOn vst ( encodeInt32 ControlResponse
958− : encodeInt32 reqId
959− : prependLength [encodeInt32 newId]
960− )
961− return (RemoteEndPointValid vst)
962− writeChan ourChannel (ConnectionOpened newId ReliableOrdered theirAddr)
963−
964− -- Read a control response
965− readControlResponse :: N.Socket -> ControlRequestId -> IO ()
966− readControlResponse sock reqId = do
967− response <- recvWithLength sock
968− mmvar <- modifyMVar theirState $ \st -> case st of
969− RemoteEndPointInvalid _ ->
970− relyViolation (ourEndPoint, theirEndPoint)
971− "readControlResponse (invalid)"
972− RemoteEndPointInit _ _ ->
973− relyViolation (ourEndPoint, theirEndPoint)
974− "readControlResponse (init)"
975− RemoteEndPointValid vst ->
976− return ( RemoteEndPointValid
977− . (pendingCtrlRequestsAt reqId ^= Nothing)
978− $ vst
979− , vst ^. pendingCtrlRequestsAt reqId
980− )
981− RemoteEndPointClosing _ _ ->
982− throwIO $ userError "Invalid control response"
983− RemoteEndPointFailed err ->
984− throwIO err
985− RemoteEndPointClosed ->
986− relyViolation (ourEndPoint, theirEndPoint)
987− "readControlResponse (closed)"
988− case mmvar of
989− Nothing ->
990− throwIO $ userError "Invalid request ID"
991− Just mvar ->
992− putMVar mvar (Right response)
993−
994− -- Close a connection
995− -- It is important that we verify that the connection is in fact open,
996− -- because otherwise we should not decrement the reference count
997− closeConnection :: ConnectionId -> IO ()
998− closeConnection cid = do
999− modifyMVar_ theirState $ \st -> case st of
1000− RemoteEndPointInvalid _ ->
1001− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"
1002− RemoteEndPointInit _ _ ->
1003− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"
1004− RemoteEndPointValid vst -> do
1005− unless (IntSet.member cid (vst ^. remoteIncoming)) $
1006− throwIO $ userError "Invalid CloseConnection"
1007− return ( RemoteEndPointValid
1008− . (remoteIncoming ^: IntSet.delete cid)
1009− $ vst
1010− )
1011− RemoteEndPointClosing _ _ ->
1012− -- If the remote endpoint is in Closing state, that means that are as
1013− -- far as we are concerned there are no incoming connections. This
1014− -- means that a CloseConnection request at this point is invalid.
1015− throwIO $ userError "Invalid CloseConnection request"
1016− RemoteEndPointFailed err ->
1017− throwIO err
1018− RemoteEndPointClosed ->
1019− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (closed)"
1020− writeChan ourChannel (ConnectionClosed cid)
1021− closeIfUnused (ourEndPoint, theirEndPoint)
1022−
1023− -- Close the socket (if we don't have any outgoing connections)
1024− closeSocket :: N.Socket -> IO Bool
1025− closeSocket sock =
1026− modifyMVar theirState $ \st ->
1027− case st of
1028− RemoteEndPointInvalid _ ->
1029− relyViolation (ourEndPoint, theirEndPoint)
1030− "handleIncomingMessages:closeSocket (invalid)"
1031− RemoteEndPointInit _ _ ->
1032− relyViolation (ourEndPoint, theirEndPoint)
1033− "handleIncomingMessages:closeSocket (init)"
1034− RemoteEndPointValid vst -> do
1035− -- We regard a CloseSocket message as an (optimized) way for the
1036− -- remote endpoint to indicate that all its connections to us are
1037− -- now properly closed
1038− forM_ (IntSet.elems $ vst ^. remoteIncoming) $
1039− writeChan ourChannel . ConnectionClosed
1040− let vst' = remoteIncoming ^= IntSet.empty $ vst
1041− -- Check if we agree that the connection should be closed
1042− if vst' ^. remoteOutgoing == 0
1043− then do
1044− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1045− -- Attempt to reply (but don't insist)
1046− tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1047− tryCloseSocket sock
1048− return (RemoteEndPointClosed, True)
1049− else
1050− return (RemoteEndPointValid vst', False)
1051− RemoteEndPointClosing resolved _ -> do
1052− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1053− tryCloseSocket sock
1054− putMVar resolved ()
1055− return (RemoteEndPointClosed, True)
1056− RemoteEndPointFailed err ->
1057− throwIO err
1058− RemoteEndPointClosed ->
1059− relyViolation (ourEndPoint, theirEndPoint)
1060− "handleIncomingMessages:closeSocket (closed)"
1061−
1062− -- Read a message and output it on the endPoint's channel. By rights we
1063− -- should verify that the connection ID is valid, but this is unnecessary
1064− -- overhead
1065− readMessage :: N.Socket -> ConnectionId -> IO ()
1066− readMessage sock connId =
1067− recvWithLength sock >>= writeChan ourChannel . Received connId
1068−
1069− -- Arguments
1070− ourChannel = localChannel ourEndPoint
1071− theirState = remoteState theirEndPoint
1072− theirAddr = remoteAddress theirEndPoint
1073−
1074− -- Deal with a premature exit
1075− prematureExit :: N.Socket -> IOException -> IO ()
1076− prematureExit sock err = do
1077− tryCloseSocket sock
1078− modifyMVar_ theirState $ \st ->
1079− case st of
1080− RemoteEndPointInvalid _ ->
1081− relyViolation (ourEndPoint, theirEndPoint)
1082− "handleIncomingMessages:prematureExit"
1083− RemoteEndPointInit _ _ ->
1084− relyViolation (ourEndPoint, theirEndPoint)
1085− "handleIncomingMessages:prematureExit"
1086− RemoteEndPointValid vst -> do
1087− let code = EventConnectionLost (remoteAddress theirEndPoint)
1088− writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1089− forM_ (vst ^. pendingCtrlRequests) $ flip putMVar (Left err)
1090− return (RemoteEndPointFailed err)
1091− RemoteEndPointClosing resolved _ -> do
1092− putMVar resolved ()
1093− return (RemoteEndPointFailed err)
1094− RemoteEndPointClosed ->
1095− relyViolation (ourEndPoint, theirEndPoint)
1096− "handleIncomingMessages:prematureExit"
1097− RemoteEndPointFailed err' ->
1098− return (RemoteEndPointFailed err')
1099−
1100−--------------------------------------------------------------------------------
1101−-- Uninterruptable auxiliary functions --
1102−-- --
1103−-- All these functions assume they are running in a thread which will never --
1104−-- be killed.
1105−--------------------------------------------------------------------------------
1106−
1107−-- | Request a connection to a remote endpoint
1108−--
1109−-- This will block until we get a connection ID from the remote endpoint; if
1110−-- the remote endpoint was in 'RemoteEndPointClosing' state then we will
1111−-- additionally block until that is resolved.
1112−--
1113−-- May throw a TransportError ConnectErrorCode exception.
1114−requestConnectionTo :: TCPParameters
1115− -> LocalEndPoint
1116− -> EndPointAddress
1117− -> ConnectHints
1118− -> IO (RemoteEndPoint, ConnectionId)
1119−requestConnectionTo params ourEndPoint theirAddress hints = go
1120− where
1121− go = do
1122− (theirEndPoint, isNew) <- mapIOException connectFailed $
1123− findRemoteEndPoint ourEndPoint theirAddress RequestedByUs
1124−
1125− if isNew
1126− then do
1127− forkIO . handle absorbAllExceptions $
1128− setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
1129− go
1130− else do
1131− reply <- mapIOException connectFailed $
1132− doRemoteRequest (ourEndPoint, theirEndPoint) RequestConnectionId
1133− return (theirEndPoint, decodeInt32 . BS.concat $ reply)
1134−
1135− connectFailed :: IOException -> TransportError ConnectErrorCode
1136− connectFailed = TransportError ConnectFailed . show
1137−
1138− absorbAllExceptions :: SomeException -> IO ()
1139− absorbAllExceptions _ex =
1140− return ()
1141−
1142−-- | Set up a remote endpoint
1143−setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
1144−setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
1145− result <- socketToEndPoint ourAddress
1146− theirAddress
1147− (tcpReuseClientAddr params)
1148− (connectTimeout hints)
1149− didAccept <- case result of
1150− Right (sock, ConnectionRequestAccepted) -> do
1151− let vst = ValidRemoteEndPointState
1152− { remoteSocket = sock
1153− , _remoteOutgoing = 0
1154− , _remoteIncoming = IntSet.empty
1155− , sendOn = sendMany sock
1156− , _pendingCtrlRequests = IntMap.empty
1157− , _nextCtrlRequestId = 0
1158− }
1159− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
1160− return True
1161− Right (sock, ConnectionRequestInvalid) -> do
1162− let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"
1163− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1164− tryCloseSocket sock
1165− return False
1166− Right (sock, ConnectionRequestCrossed) -> do
1167− resolveInit (ourEndPoint, theirEndPoint) RemoteEndPointClosed
1168− tryCloseSocket sock
1169− return False
1170− Left err -> do
1171− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1172− return False
1173−
1174− when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
1175− where
1176− ourAddress = localAddress ourEndPoint
1177− theirAddress = remoteAddress theirEndPoint
1178− invalidAddress = TransportError ConnectNotFound
1179−
1180−-- | Do a (blocking) remote request
1181−--
1182−-- May throw IO (user) exception if the local or the remote endpoint is closed,
1183−-- if the send fails, or if the remote endpoint fails before it replies.
1184−doRemoteRequest :: EndPointPair -> ControlHeader -> IO [ByteString]
1185−doRemoteRequest (ourEndPoint, theirEndPoint) header = do
1186− replyMVar <- newEmptyMVar
1187− modifyRemoteState_ (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
1188− { caseValid = \vst -> do
1189− let reqId = vst ^. nextCtrlRequestId
1190− sendOn vst [encodeInt32 header, encodeInt32 reqId]
1191− return ( RemoteEndPointValid
1192− . (nextCtrlRequestId ^: (+ 1))
1193− . (pendingCtrlRequestsAt reqId ^= Just replyMVar)
1194− $ vst
1195− )
1196− -- Error cases
1197− , caseInvalid =
1198− throwIO
1199− , caseInit = \_ _ ->
1200− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (init)"
1201− , caseClosing = \_ _ ->
1202− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closing)"
1203− , caseClosed =
1204− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closed)"
1205− , caseFailed =
1206− throwIO
1207− }
1208− mReply <- takeMVar replyMVar
1209− case mReply of
1210− Left err -> throwIO err
1211− Right reply -> return reply
1212−
1213−-- | Send a CloseSocket request if the remote endpoint is unused
1214−closeIfUnused :: EndPointPair -> IO ()
1215−closeIfUnused (ourEndPoint, theirEndPoint) =
1216− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
1217− { caseValid = \vst ->
1218− if vst ^. remoteOutgoing == 0 && IntSet.null (vst ^. remoteIncoming)
1219− then do
1220− sendOn vst [encodeInt32 CloseSocket]
1221− resolved <- newEmptyMVar
1222− return $ RemoteEndPointClosing resolved vst
1223− else
1224− return $ RemoteEndPointValid vst
1225− }
1226−
1227−-- | Reset a remote endpoint if it is in Invalid mode
1228−--
1229−-- If the remote endpoint is currently in broken state, and
1230−--
1231−-- - a user calls the API function 'connect', or and the remote endpoint is
1232−-- - an inbound connection request comes in from this remote address
1233−--
1234−-- we remove the remote endpoint first.
1235−--
1236−-- Throws a TransportError ConnectFailed exception if the local endpoint is
1237−-- closed.
1238−resetIfBroken :: LocalEndPoint -> EndPointAddress -> IO ()
1239−resetIfBroken ourEndPoint theirAddress = do
1240− mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1241− LocalEndPointValid vst ->
1242− return (vst ^. localConnectionTo theirAddress)
1243− LocalEndPointClosed ->
1244− throwIO $ TransportError ConnectFailed "Endpoint closed"
1245− forM_ mTheirEndPoint $ \theirEndPoint ->
1246− withMVar (remoteState theirEndPoint) $ \st -> case st of
1247− RemoteEndPointInvalid _ ->
1248− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1249− RemoteEndPointFailed _ ->
1250− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1251− _ ->
1252− return ()
1253−
1254−-- | Special case of 'apiConnect': connect an endpoint to itself
1255−--
1256−-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)
1257−connectToSelf :: LocalEndPoint
1258− -> IO Connection
1259−connectToSelf ourEndPoint = do
1260− connAlive <- newIORef True -- Protected by the local endpoint lock
1261− connId <- mapIOException connectFailed $ getNextConnectionId ourEndPoint
1262− writeChan ourChan $
1263− ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)
1264− return Connection
1265− { send = selfSend connAlive connId
1266− , close = selfClose connAlive connId
1267− }
1268− where
1269− selfSend :: IORef Bool
1270− -> ConnectionId
1271− -> [ByteString]
1272− -> IO (Either (TransportError SendErrorCode) ())
1273− selfSend connAlive connId msg =
1274− try . withMVar ourState $ \st -> case st of
1275− LocalEndPointValid _ -> do
1276− alive <- readIORef connAlive
1277− if alive
1278− then writeChan ourChan (Received connId msg)
1279− else throwIO $ TransportError SendClosed "Connection closed"
1280− LocalEndPointClosed ->
1281− throwIO $ TransportError SendFailed "Endpoint closed"
1282−
1283− selfClose :: IORef Bool -> ConnectionId -> IO ()
1284− selfClose connAlive connId =
1285− withMVar ourState $ \st -> case st of
1286− LocalEndPointValid _ -> do
1287− alive <- readIORef connAlive
1288− when alive $ do
1289− writeChan ourChan (ConnectionClosed connId)
1290− writeIORef connAlive False
1291− LocalEndPointClosed ->
1292− return ()
1293−
1294− ourChan = localChannel ourEndPoint
1295− ourState = localState ourEndPoint
1296− connectFailed = TransportError ConnectFailed . show
1297−
1298−-- | Resolve an endpoint currently in 'Init' state
1299−resolveInit :: EndPointPair -> RemoteState -> IO ()
1300−resolveInit (ourEndPoint, theirEndPoint) newState =
1301− modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
1302− RemoteEndPointInit resolved _ -> do
1303− putMVar resolved ()
1304− case newState of
1305− RemoteEndPointClosed ->
1306− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1307− _ ->
1308− return ()
1309− return newState
1310− RemoteEndPointFailed ex ->
1311− throwIO ex
1312− _ ->
1313− relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
1314−
1315−-- | Get the next connection ID
1316−--
1317−-- Throws an IO exception when the endpoint is closed.
1318−getNextConnectionId :: LocalEndPoint -> IO ConnectionId
1319−getNextConnectionId ourEndpoint =
1320− modifyMVar (localState ourEndpoint) $ \st -> case st of
1321− LocalEndPointValid vst -> do
1322− let connId = vst ^. nextConnectionId
1323− return ( LocalEndPointValid
1324− . (nextConnectionId ^= connId + 1)
1325− $ vst
1326− , connId)
1327− LocalEndPointClosed ->
1328− throwIO $ userError "Local endpoint closed"
1329−
1330−-- | Create a new local endpoint
1331−--
1332−-- May throw a TransportError NewEndPointErrorCode exception if the transport
1333−-- is closed.
1334−createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
1335−createLocalEndPoint transport = do
1336− chan <- newChan
1337− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
1338− { _nextConnectionId = firstNonReservedConnectionId
1339− , _localConnections = Map.empty
1340− , _nextRemoteId = 0
1341− }
1342− modifyMVar (transportState transport) $ \st -> case st of
1343− TransportValid vst -> do
1344− let ix = vst ^. nextEndPointId
1345− let addr = encodeEndPointAddress (transportHost transport)
1346− (transportPort transport)
1347− ix
1348− let localEndPoint = LocalEndPoint { localAddress = addr
1349− , localChannel = chan
1350− , localState = state
1351− }
1352− return ( TransportValid
1353− . (localEndPointAt addr ^= Just localEndPoint)
1354− . (nextEndPointId ^= ix + 1)
1355− $ vst
1356− , localEndPoint
1357− )
1358− TransportClosed ->
1359− throwIO (TransportError NewEndPointFailed "Transport closed")
1360−
1361−
1362−-- | Remove reference to a remote endpoint from a local endpoint
1363−--
1364−-- If the local endpoint is closed, do nothing
1365−removeRemoteEndPoint :: EndPointPair -> IO ()
1366−removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
1367− modifyMVar_ ourState $ \st -> case st of
1368− LocalEndPointValid vst ->
1369− case vst ^. localConnectionTo theirAddress of
1370− Nothing ->
1371− return st
1372− Just remoteEndPoint' ->
1373− if remoteId remoteEndPoint' == remoteId theirEndPoint
1374− then return
1375− ( LocalEndPointValid
1376− . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
1377− $ vst
1378− )
1379− else return st
1380− LocalEndPointClosed ->
1381− return LocalEndPointClosed
1382− where
1383− ourState = localState ourEndPoint
1384− theirAddress = remoteAddress theirEndPoint
1385−
1386−-- | Remove reference to a local endpoint from the transport state
1387−--
1388−-- Does nothing if the transport is closed
1389−removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
1390−removeLocalEndPoint transport ourEndPoint =
1391− modifyMVar_ (transportState transport) $ \st -> case st of
1392− TransportValid vst ->
1393− return ( TransportValid
1394− . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
1395− $ vst
1396− )
1397− TransportClosed ->
1398− return TransportClosed
1399−
1400−-- | Find a remote endpoint. If the remote endpoint does not yet exist we
1401−-- create it in Init state. Returns if the endpoint was new.
1402−findRemoteEndPoint
1403− :: LocalEndPoint
1404− -> EndPointAddress
1405− -> RequestedBy
1406− -> IO (RemoteEndPoint, Bool)
1407−findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
1408− where
1409− go = do
1410− (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of
1411− LocalEndPointValid vst -> case vst ^. localConnectionTo theirAddress of
1412− Just theirEndPoint ->
1413− return (st, (theirEndPoint, False))
1414− Nothing -> do
1415− resolved <- newEmptyMVar
1416− theirState <- newMVar (RemoteEndPointInit resolved findOrigin)
1417− let theirEndPoint = RemoteEndPoint
1418− { remoteAddress = theirAddress
1419− , remoteState = theirState
1420− , remoteId = vst ^. nextRemoteId
1421− }
1422− return ( LocalEndPointValid
1423− . (localConnectionTo theirAddress ^= Just theirEndPoint)
1424− . (nextRemoteId ^: (+ 1))
1425− $ vst
1426− , (theirEndPoint, True)
1427− )
1428− LocalEndPointClosed ->
1429− throwIO $ userError "Local endpoint closed"
1430−
1431− if isNew
1432− then
1433− return (theirEndPoint, True)
1434− else do
1435− let theirState = remoteState theirEndPoint
1436− snapshot <- modifyMVar theirState $ \st -> case st of
1437− RemoteEndPointValid vst ->
1438− case findOrigin of
1439− RequestedByUs -> do
1440− let st' = RemoteEndPointValid
1441− . (remoteOutgoing ^: (+ 1))
1442− $ vst
1443− return (st', st')
1444− RequestedByThem ->
1445− return (st, st)
1446− _ ->
1447− return (st, st)
1448− -- The snapshot may no longer be up to date at this point, but if we
1449− -- increased the refcount then it can only either be Valid or Failed
1450− -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
1451− case snapshot of
1452− RemoteEndPointInvalid err ->
1453− throwIO err
1454− RemoteEndPointInit resolved initOrigin ->
1455− case (findOrigin, initOrigin) of
1456− (RequestedByUs, RequestedByUs) ->
1457− readMVar resolved >> go
1458− (RequestedByUs, RequestedByThem) ->
1459− readMVar resolved >> go
1460− (RequestedByThem, RequestedByUs) ->
1461− if ourAddress > theirAddress
1462− then
1463− -- Wait for the Crossed message
1464− readMVar resolved >> go
1465− else
1466− return (theirEndPoint, False)
1467− (RequestedByThem, RequestedByThem) ->
1468− throwIO $ userError "Already connected"
1469− RemoteEndPointValid _ ->
1470− -- We assume that the request crossed if we find the endpoint in
1471− -- Valid state. It is possible that this is really an invalid
1472− -- request, but only in the case of a broken client (we don't
1473− -- maintain enough history to be able to tell the difference).
1474− return (theirEndPoint, False)
1475− RemoteEndPointClosing resolved _ ->
1476− readMVar resolved >> go
1477− RemoteEndPointClosed ->
1478− go
1479− RemoteEndPointFailed err ->
1480− throwIO err
1481−
1482− ourState = localState ourEndPoint
1483− ourAddress = localAddress ourEndPoint
1484−
1485−--------------------------------------------------------------------------------
1486−-- "Stateless" (MVar free) functions --
1487−--------------------------------------------------------------------------------
1488−
1489−-- | Establish a connection to a remote endpoint
1490−--
1491−-- Maybe throw a TransportError
1492−socketToEndPoint :: EndPointAddress -- ^ Our address
1493− -> EndPointAddress -- ^ Their address
1494− -> Bool -- ^ Use SO_REUSEADDR?
1495− -> Maybe Int -- ^ Timeout for connect
1496− -> IO (Either (TransportError ConnectErrorCode)
1497− (N.Socket, ConnectionRequestResponse))
1498−socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1499− try $ do
1500− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
1501− Nothing -> throwIO (failed . userError $ "Could not parse")
1502− Just dec -> return dec
1503− addr:_ <- mapIOException invalidAddress $
1504− N.getAddrInfo Nothing (Just host) (Just port)
1505− bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
1506− when reuseAddr $
1507− mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
1508− mapIOException invalidAddress $
1509− timeoutMaybe timeout timeoutError $
1510− N.connect sock (N.addrAddress addr)
1511− response <- mapIOException failed $ do
1512− sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
1513− recvInt32 sock
1514− case tryToEnum response of
1515− Nothing -> throwIO (failed . userError $ "Unexpected response")
1516− Just r -> return (sock, r)
1517− where
1518− createSocket :: N.AddrInfo -> IO N.Socket
1519− createSocket addr = mapIOException insufficientResources $
1520− N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
1521−
1522− invalidAddress = TransportError ConnectNotFound . show
1523− insufficientResources = TransportError ConnectInsufficientResources . show
1524− failed = TransportError ConnectFailed . show
1525− timeoutError = TransportError ConnectTimeout "Timed out"
1526−
1527−-- | Encode end point address
1528−encodeEndPointAddress :: N.HostName
1529− -> N.ServiceName
1530− -> EndPointId
1531− -> EndPointAddress
1532−encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
1533− host ++ ":" ++ port ++ ":" ++ show ix
1534−
1535−-- | Decode end point address
1536−decodeEndPointAddress :: EndPointAddress
1537− -> Maybe (N.HostName, N.ServiceName, EndPointId)
1538−decodeEndPointAddress (EndPointAddress bs) =
1539− case splitMaxFromEnd (== ':') 2 $ BSC.unpack bs of
1540− [host, port, endPointIdStr] ->
1541− case reads endPointIdStr of
1542− [(endPointId, "")] -> Just (host, port, endPointId)
1543− _ -> Nothing
1544− _ ->
1545− Nothing
1546−
1547−-- | @spltiMaxFromEnd p n xs@ splits list @xs@ at elements matching @p@,
1548−-- returning at most @p@ segments -- counting from the /end/
1549−--
1550−-- > splitMaxFromEnd (== ':') 2 "ab:cd:ef:gh" == ["ab:cd", "ef", "gh"]
1551−splitMaxFromEnd :: (a -> Bool) -> Int -> [a] -> [[a]]
1552−splitMaxFromEnd p = \n -> go [[]] n . reverse
1553− where
1554− -- go :: [[a]] -> Int -> [a] -> [[a]]
1555− go accs _ [] = accs
1556− go ([] : accs) 0 xs = reverse xs : accs
1557− go (acc : accs) n (x:xs) =
1558− if p x then go ([] : acc : accs) (n - 1) xs
1559− else go ((x : acc) : accs) n xs
1560− go _ _ _ = error "Bug in splitMaxFromEnd"
1561−
1562−--------------------------------------------------------------------------------
1563−-- Functions from TransportInternals --
1564−--------------------------------------------------------------------------------
1565−
1566−-- Find a socket between two endpoints
1567−--
1568−-- Throws an IO exception if the socket could not be found.
1569−internalSocketBetween :: TCPTransport -- ^ Transport
1570− -> EndPointAddress -- ^ Local endpoint
1571− -> EndPointAddress -- ^ Remote endpoint
1572− -> IO N.Socket
1573−internalSocketBetween transport ourAddress theirAddress = do
1574− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
1575− TransportClosed ->
1576− throwIO $ userError "Transport closed"
1577− TransportValid vst ->
1578− case vst ^. localEndPointAt ourAddress of
1579− Nothing -> throwIO $ userError "Local endpoint not found"
1580− Just ep -> return ep
1581− theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1582− LocalEndPointClosed ->
1583− throwIO $ userError "Local endpoint closed"
1584− LocalEndPointValid vst ->
1585− case vst ^. localConnectionTo theirAddress of
1586− Nothing -> throwIO $ userError "Remote endpoint not found"
1587− Just ep -> return ep
1588− withMVar (remoteState theirEndPoint) $ \st -> case st of
1589− RemoteEndPointInit _ _ ->
1590− throwIO $ userError "Remote endpoint not yet initialized"
1591− RemoteEndPointValid vst ->
1592− return $ remoteSocket vst
1593− RemoteEndPointClosing _ vst ->
1594− return $ remoteSocket vst
1595− RemoteEndPointClosed ->
1596− throwIO $ userError "Remote endpoint closed"
1597− RemoteEndPointInvalid err ->
1598− throwIO err
1599− RemoteEndPointFailed err ->
1600− throwIO err
1601−
1602−--------------------------------------------------------------------------------
1603−-- Constants --
1604−--------------------------------------------------------------------------------
1605−
1606−-- | We reserve a bunch of connection IDs for control messages
1607−firstNonReservedConnectionId :: ConnectionId
1608−firstNonReservedConnectionId = 1024
1609−
1610−--------------------------------------------------------------------------------
1611−-- Accessor definitions --
1612−--------------------------------------------------------------------------------
1613−
1614−localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
1615−localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es })
1616−
1617−nextEndPointId :: Accessor ValidTransportState EndPointId
1618−nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid })
1619−
1620−nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
1621−nextConnectionId = accessor _nextConnectionId (\cix st -> st { _nextConnectionId = cix })
1622−
1623−localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
1624−localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
1625−
1626−nextRemoteId :: Accessor ValidLocalEndPointState Int
1627−nextRemoteId = accessor _nextRemoteId (\rid st -> st { _nextRemoteId = rid })
1628−
1629−remoteOutgoing :: Accessor ValidRemoteEndPointState Int
1630−remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs })
1631−
1632−remoteIncoming :: Accessor ValidRemoteEndPointState IntSet
1633−remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs })
1634−
1635−pendingCtrlRequests :: Accessor ValidRemoteEndPointState (IntMap (MVar (Either IOException [ByteString])))
1636−pendingCtrlRequests = accessor _pendingCtrlRequests (\rep st -> st { _pendingCtrlRequests = rep })
1637−
1638−nextCtrlRequestId :: Accessor ValidRemoteEndPointState ControlRequestId
1639−nextCtrlRequestId = accessor _nextCtrlRequestId (\cid st -> st { _nextCtrlRequestId = cid })
1640−
1641−localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1642−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1643−
1644−pendingCtrlRequestsAt :: ControlRequestId -> Accessor ValidRemoteEndPointState (Maybe (MVar (Either IOException [ByteString])))
1645−pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral ix)
1646−
1647−localConnectionTo :: EndPointAddress
1648− -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1649−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1650−
1651−-------------------------------------------------------------------------------
1652−-- Debugging --
1653−-------------------------------------------------------------------------------
1654−
1655−relyViolation :: EndPointPair -> String -> IO a
1656−relyViolation (ourEndPoint, theirEndPoint) str = do
1657− elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1658− fail (str ++ " RELY violation")
1659−
1660−elog :: EndPointPair -> String -> IO ()
1661−elog (ourEndPoint, theirEndPoint) msg = do
1662− tid <- myThreadId
1663− putStrLn $ show (localAddress ourEndPoint)
1664− ++ "/" ++ show (remoteAddress theirEndPoint)
1665− ++ "(" ++ show (remoteId theirEndPoint) ++ ")"
1666− ++ "/" ++ show tid
1667− ++ ": " ++ msg
network-transport-tcp/src/Network/Transport/TCP/Internal.hsdeleted−119
@@ -1,119 +0,0 @@
1−-- | Utility functions for TCP sockets
2−module Network.Transport.TCP.Internal ( forkServer
3− , recvWithLength
4− , recvExact
5− , recvInt32
6− , tryCloseSocket
7− ) where
8−
9−#if ! MIN_VERSION_base(4,6,0)
10−import Prelude hiding (catch)
11−#endif
12−
13−import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)
14−import qualified Network.Socket as N ( HostName
15− , ServiceName
16− , Socket
17− , SocketType(Stream)
18− , SocketOption(ReuseAddr)
19− , getAddrInfo
20− , defaultHints
21− , socket
22− , bindSocket
23− , listen
24− , addrFamily
25− , addrAddress
26− , defaultProtocol
27− , setSocketOption
28− , accept
29− , sClose
30− )
31−import qualified Network.Socket.ByteString as NBS (recv)
32−import Control.Concurrent (ThreadId)
33−import Control.Monad (forever, when)
34−import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_)
35−import Control.Applicative ((<$>))
36−import Data.ByteString (ByteString)
37−import qualified Data.ByteString as BS (length, concat, null)
38−import Data.Int (Int32)
39−
40−-- | Start a server at the specified address.
41−--
42−-- This sets up a server socket for the specified host and port. Exceptions
43−-- thrown during setup are not caught.
44−--
45−-- Once the socket is created we spawn a new thread which repeatedly accepts
46−-- incoming connections and executes the given request handler. If any
47−-- exception occurs the thread terminates and calls the terminationHandler.
48−-- This exception may occur because of a call to 'N.accept', because the thread
49−-- was explicitly killed, or because of a synchronous exception thrown by the
50−-- request handler. Typically, you should avoid the last case by catching any
51−-- relevant exceptions in the request handler.
52−--
53−-- The request handler should spawn threads to handle each individual request
54−-- or the server will block. Once a thread has been spawned it will be the
55−-- responsibility of the new thread to close the socket when an exception
56−-- occurs.
57−forkServer :: N.HostName -- ^ Host
58− -> N.ServiceName -- ^ Port
59− -> Int -- ^ Backlog (maximum number of queued connections)
60− -> Bool -- ^ Set ReuseAddr option?
61− -> (SomeException -> IO ()) -- ^ Termination handler
62− -> (N.Socket -> IO ()) -- ^ Request handler
63− -> IO ThreadId
64−forkServer host port backlog reuseAddr terminationHandler requestHandler = do
65− -- Resolve the specified address. By specification, getAddrInfo will never
66− -- return an empty list (but will throw an exception instead) and will return
67− -- the "best" address first, whatever that means
68− addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
69− bracketOnError (N.socket (N.addrFamily addr) N.Stream N.defaultProtocol)
70− tryCloseSocket $ \sock -> do
71− when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1
72− N.bindSocket sock (N.addrAddress addr)
73− N.listen sock backlog
74− -- We start listening for incoming requests in a separate thread. When
75− -- that thread is killed, we close the server socket and the termination
76− -- handler. We have to make sure that the exception handler is installed
77− -- /before/ any asynchronous exception occurs. So we mask_, then fork
78− -- (the child thread inherits the masked state from the parent), then
79− -- unmask only inside the catch.
80− mask_ $ forkIOWithUnmask $ \unmask ->
81− catch (unmask (forever $ acceptRequest sock)) $ \ex -> do
82− tryCloseSocket sock
83− terminationHandler ex
84− where
85− acceptRequest :: N.Socket -> IO ()
86− acceptRequest sock = bracketOnError (N.accept sock)
87− (tryCloseSocket . fst)
88− (requestHandler . fst)
89−
90−-- | Read a length and then a payload of that length
91−recvWithLength :: N.Socket -> IO [ByteString]
92−recvWithLength sock = recvInt32 sock >>= recvExact sock
93−
94−-- | Receive a 32-bit integer
95−recvInt32 :: Num a => N.Socket -> IO a
96−recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
97−
98−-- | Close a socket, ignoring I/O exceptions
99−tryCloseSocket :: N.Socket -> IO ()
100−tryCloseSocket sock = void . tryIO $
101− N.sClose sock
102−
103−-- | Read an exact number of bytes from a socket
104−--
105−-- Throws an I/O exception if the socket closes before the specified
106−-- number of bytes could be read
107−recvExact :: N.Socket -- ^ Socket to read from
108− -> Int32 -- ^ Number of bytes to read
109− -> IO [ByteString]
110−recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")
111−recvExact sock len = go [] len
112− where
113− go :: [ByteString] -> Int32 -> IO [ByteString]
114− go acc 0 = return (reverse acc)
115− go acc l = do
116− bs <- NBS.recv sock (fromIntegral l `min` 4096)
117− if BS.null bs
118− then throwIO (userError "recvExact: Socket closed")
119− else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport-tcp/tests/TestTCP.hsdeleted−794

This diff is too big to show here.

network-transport-tests/LICENSEdeleted−30

This diff is too big to show here.

network-transport-tests/Setup.hsdeleted−2

This diff is too big to show here.

network-transport-tests/network-transport-tests.cabaldeleted−35

This diff is too big to show here.

network-transport-tests/src/Network/Transport/Tests.hsdeleted−964

This diff is too big to show here.

network-transport-tests/src/Network/Transport/Tests/Auxiliary.hsdeleted−112

This diff is too big to show here.

network-transport-tests/src/Network/Transport/Tests/Traced.hsdeleted−200

This diff is too big to show here.

network-transport/ChangeLogdeleted−16

This diff is too big to show here.

network-transport/LICENSEdeleted−31

This diff is too big to show here.

network-transport/Setup.hsdeleted−2

This diff is too big to show here.

network-transport/network-transport.cabaldeleted−81

This diff is too big to show here.

network-transport/src/Network/Transport.hsdeleted−264

This diff is too big to show here.

network-transport/src/Network/Transport/Internal.hsdeleted−153

This diff is too big to show here.

network-transport/src/Network/Transport/Util.hsdeleted−24

This diff is too big to show here.

network-transport/tests/chat/ChatClient.hsdeleted−107

This diff is too big to show here.

network-transport/tests/chat/ChatServer.hsdeleted−28

This diff is too big to show here.

network-transport/tests/sumeuler/SumEulerMaster.hsdeleted−44

This diff is too big to show here.

network-transport/tests/sumeuler/SumEulerWorker.hsdeleted−52

This diff is too big to show here.

network-transport/tests/sumeuler/sumeuler.shdeleted−20

This diff is too big to show here.

rank1dynamic/LICENSEdeleted−30

This diff is too big to show here.

rank1dynamic/Setup.hsdeleted−2

This diff is too big to show here.

rank1dynamic/rank1dynamic.cabaldeleted−28

This diff is too big to show here.

rank1dynamic/src/Data/Rank1Dynamic.hsdeleted−120

This diff is too big to show here.

rank1dynamic/src/Data/Rank1Typeable.hsdeleted−362

This diff is too big to show here.

distributed-process/src/Control/Distributed/Process.hs → src/Control/Distributed/Process.hsrenamed+209−171

This diff is too big to show here.

distributed-process/src/Control/Distributed/Process/Closure.hs → src/Control/Distributed/Process/Closure.hsrenamed+65−39

This diff is too big to show here.

src/Control/Distributed/Process/Debug.hsnew file+288

This diff is too big to show here.

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

This diff is too big to show here.

src/Control/Distributed/Process/Internal/CQueue.hsnew file+300

This diff is too big to show here.

distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs → src/Control/Distributed/Process/Internal/Closure/BuiltIn.hsrenamed+121−39

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Closure/Explicit.hsnew file+147

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Closure/TH.hsnew file+330

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Messaging.hsnew file+207

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Primitives.hsnew file+1363

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Spawn.hsnew file+165

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictContainerAccessors.hsnew file+21

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictList.hsnew file+27

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictMVar.hsnew file+93

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Types.hsnew file+887

This diff is too big to show here.

src/Control/Distributed/Process/Internal/WeakTQueue.hsnew file+107

This diff is too big to show here.

src/Control/Distributed/Process/Management.hsnew file+509

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Agent.hsnew file+157

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Bus.hsnew file+21

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hsnew file+179

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Remote.hsnew file+61

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hsnew file+354

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Types.hsnew file+159

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Types.hsnew file+141

This diff is too big to show here.

src/Control/Distributed/Process/Node.hsnew file+1304

This diff is too big to show here.

distributed-process/src/Control/Distributed/Process/Serializable.hs → src/Control/Distributed/Process/Serializable.hsrenamed+26−16

This diff is too big to show here.

src/Control/Distributed/Process/UnsafePrimitives.hsnew file+200

This diff is too big to show here.

stack-ghc-7.10.3.yamlnew file+21

This diff is too big to show here.

stack-ghc-8.0.2.yamlnew file+23

This diff is too big to show here.

stack-ghc-8.2.2.yamlnew file+21

This diff is too big to show here.

stack-ghc-8.4.4.yamlnew file+20

This diff is too big to show here.

stack-nightly.yamlnew file+26

This diff is too big to show here.

stack.yamlnew file+22

This diff is too big to show here.