git.iko.soy/distributed-process
on master help sign in
swap
660d554866 ahead, 0 behind
166 files changed+14344−15681
since splitsnapshots
unifiedsplit
.gitignore+3−11 .travis.yml+43 CONTRIBUTING.md+1 ChangeLog+236 distributed-process/LICENSE → LICENSE+1 README.md+10−108 distributed-process-simplelocalnet/Setup.hs → Setup.hs benchmarks/.gitignore−3 benchmarks/Channels.hs+43 benchmarks/Headers.gnuplot−16 benchmarks/Indirection.gnuplot−16 benchmarks/JustPingC.c−150 benchmarks/JustPingCacheHeader.hs−134 benchmarks/JustPingHaskell.hs−105 benchmarks/JustPingOneRecv.hs−131 benchmarks/JustPingThroughChan.hs−127 benchmarks/JustPingThroughMVar.hs−127 benchmarks/JustPingTransport.hs−95 benchmarks/JustPingTwoSocketPairs.hs−151 benchmarks/JustPingWithHeader.hs−131 benchmarks/Latency.hs+39 benchmarks/Makefile−72 benchmarks/Makefile.JustPing−52 benchmarks/NewTransport.gnuplot−8 benchmarks/PingPipes.hs−112 benchmarks/PingTCP.hs−133 benchmarks/PingTCPTransport.hs−128 benchmarks/ProcessRing.hs+117 benchmarks/SendTCP.hs−109 benchmarks/SendTransport.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/pingtest.c−183 benchmarks/remote/Latency.hs+32 benchmarks/remote/Throughput.hs+39 benchmarks/results_notes.md−111 distributed-process-simplelocalnet/ChangeLog−7 distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal−63 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs−291 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-simplelocalnet/LICENSE → distributed-process-tests/LICENSE distributed-process-tests/README.md+14 distributed-process/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−7 distributed-process/distributed-process.cabal−135 distributed-process/src/Control/Distributed/Process.hs−336 distributed-process/src/Control/Distributed/Process/Closure.hs−163 distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs−105 distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs−245 distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hs−20 distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs−34 distributed-process/src/Control/Distributed/Process/Internal/Closure/Static.hs−153 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs−204 distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hs−81 distributed-process/src/Control/Distributed/Process/Internal/MessageT.hs−130 distributed-process/src/Control/Distributed/Process/Internal/Node.hs−16 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−517 distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hs−21 distributed-process/src/Control/Distributed/Process/Internal/Types.hs−611 distributed-process/src/Control/Distributed/Process/Node.hs−701 distributed-process/tests/TestAuxiliary.hs−71 distributed-process/tests/TestCH.hs−600 distributed-process/tests/TestClosure.hs−296 doc/InternalsTransportMulticast.txt−181 doc/InternalsTransportTCP.txt−81 doc/NetworkTCP.png doc/NetworkTCP.svg−657 doc/reconnect/reconnect.tex−409 doc/semantics/CloudHaskellSemantics.tex+706 doc/semantics/Makefile+11 doc/semantics/references.bib+72 doc/tutorial/tutorial-client.hs−20 doc/tutorial/tutorial-server.hs−52 examples/.gitignore−1 examples/DemoProcess.hs−36 examples/DemoTCP.hs−113 examples/DemoTransport.hs−192 examples/Makefile−20 install_all.sh−18 network-transport-inmemory/LICENSE−31 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-pipes/LICENSE−31 network-transport-pipes/network-transport-pipes.cabal−33 network-transport-pipes/src/Network/Transport/Pipes.hs−264 network-transport-tcp/ChangeLog−3 network-transport-tcp/LICENSE−31 network-transport-tcp/Setup.hs−2 network-transport-tcp/network-transport-tcp.cabal−54 network-transport-tcp/src/Network/Transport/TCP.hs−1649 network-transport-tcp/src/Network/Transport/TCP/Internal.hs−116 network-transport-tcp/tests/TestAuxiliary.hs−108 network-transport-tcp/tests/TestTCP.hs−786 network-transport-tcp/tests/TestTransport.hs−956 network-transport-tcp/tests/Traced.hs−191 network-transport/ChangeLog−3 network-transport/LICENSE−31 network-transport/Setup.hs−2 network-transport/network-transport.cabal−80 network-transport/src/Network/Transport.hs−226 network-transport/src/Network/Transport/Internal.hs−150 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 src/Control/Distributed/Process.hs+447 src/Control/Distributed/Process/Closure.hs+244 src/Control/Distributed/Process/Debug.hs+288 src/Control/Distributed/Process/Internal/BiMultiMap.hs+135 src/Control/Distributed/Process/Internal/CQueue.hs+300 src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+320 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+32−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−11
@@ -1,12 +1,4 @@
1−tags
2−TAGS
31dist/
4−\#*#
5−*~
6−*.aux
7−*.hp
8−*.hi
9−*.o
10−*.prof
11−*.ps
12−*.swp
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.
distributed-process/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+10−108
@@ -1,114 +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] based on the work
5−of Jeff Epstein, Andrew Black, and Simon Peyton-Jones.
5+This repository is part of Cloud Haskell.
66
7−At present, this repository hosts two packages:
7+See http://haskell-distributed.github.com for documentation, user guides,
8+tutorials and assistance.
89
9−* distributed-process
10−* network-transport
10+## Getting Help / Raising Issues
1111
12−For more detailed information about the interfaces provided by these packages,
13−please refer to the [distributed-process repository wiki][2].
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.
1413
15−Examples
16−--------
14+## License
1715
18−Examples of the transport layer at work can be found in the `/examples` folder.
19−
20−### DemoTransport.hs
21−
22−The `DemoTransport.hs` file contains a number of different functions named
23−`demo#`. These functions demonstrate the use of the `Network.Transport` module.
24−
25−To try them out, launch `ghci`, including the appropriate sources:
26−
27− ghci -idistributed-process/src -inetwork-transport/src examples/DemoTransport.hs
28−
29−The first demo, `demo0` yields the following output when run with the TCP transport:
30−
31− *DemoTransport> tcp >>= demo0
32− logServer: [Chunk "hello 1" Empty]
33− logServer: [Chunk "hello 2" Empty]
34− logServer: [Chunk "hello 3" Empty]
35− logServer: [Chunk "hello 4" Empty]
36− logServer: [Chunk "hello 5" Empty]
37− logServer: [Chunk "hello 6" Empty]
38− logServer: [Chunk "hello 7" Empty]
39− logServer: [Chunk "hello 8" Empty]
40− logServer: [Chunk "hello 9" Empty]
41− logServer: [Chunk "hello 10" Empty]
42−
43−See the source code for more details.
44−
45−### DemoProcess.hs
46−
47−The `DemoProcess.hs` file shows a very basic example of how to use the
48−`Control.Distributed.Process` module in conjunction with `Network.Transport.TCP`.
49−This is demonstrated using the `demo1` function:
50−
51− ghci -idistributed-process/src -inetwork-transport/src examples/DemoProcess.hs
52−
53−The output of the example is as follows:
54−
55− *DemoProcess> demo1
56− "Starting node"
57− "Starting process"
58− 1: jim1 says: hi there
59− 2: bob1 says: hi there
60− 3: jim1 says: bye
61− 4: bob1 says: bye
62−
63−### DemoTCP.hs
64−
65−The `DemoTCP.hs` file demonstrates how a master can be connected to slaves
66−using the transport layer over TCP.
67−This example should be compiled in the usual fashion:
68−
69− ghc --make -idistributed-process/src -inetwork-transport/src examples/DemoTCP.hs
70−
71−After compiling, the following will initialize a new master that waits
72−for two clients to connect on the local machine:
73−
74− ./examples/DemoTCP 127.0.0.1 8080 sourceAddrFile 2
75−
76−Following this, two slaves should be created that will connect to the master:
77−
78− ./examples/DemoTCP 127.0.0.1 8081 sourceAddrFile
79− ./examples/DemoTCP 127.0.0.1 8082 sourceAddrFile
80−
81−Once the connection is established, the slaves will provide the master
82−with their `SourceAddr`. The master then decodes this, and sends a message
83−back. After processing this message, the slaves respond to the master,
84−which then outputs some data.
85−
86−Benchmarks
87−----------
88−
89−The `Transport.TCP` backend uses `Network.ByteString.Lazy` as its underlying
90−protocol, so we produce a benchmark that compares it directly with this.
91−Furthermore, the `Data.Binary` package is used for converting values
92−to `ByteStrings` for transmission.
93−
94−The benchmarking is performed on the client side using criterion:
95−the server must be set up before benching is performed.
96−
97−### Ping
98−
99−This benchmark measures how quickly a sequence of ping/pong messages
100−are sent between a server and client. Full details can be found in:
101−
102− ./benchmarks/PingTCP.hs
103− ./benchmarks/PingTransport.hs
104−
105−### Send
106−
107−This benchmark measures how quickly a number of bytes can be sent from
108−a client to a server. Full details can be found in the following files:
109−
110− ./benchmarks/SendTCP.hs
111− ./benchmarks/SendTransport.hs
112−
113−[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
114−[2]: https://github.com/haskell-distributed/distributed-process/wiki
16+This package is made available under a 3-clause BSD-style license.
distributed-process-simplelocalnet/Setup.hs → Setup.hsrenamed

The content is the same.

benchmarks/.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−*.swp
2−*.exe
3−*.data
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/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"
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"
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;
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(int 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−}
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))
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
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))
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))
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))
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"
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))
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))
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/Makefiledeleted−72
@@ -1,72 +0,0 @@
1−
2−# Run 100K ping-pongs, for one trial:
3−size = 100000
4−trials = 1
5−# You can run "make run1 size=1000 trials=100" for example.
6−
7−
8−# Disable this to test installed packages only:
9−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src
10−
11−# Enable for profiling
12−# PROFILING=-prof -fprof-auto
13−
14−ifeq ($(GHC),)
15− GHC=ghc
16−endif
17−
18−BENCHS= PingTCP.exe PingTCPTransport.exe PingPipes.exe SendTransport.exe
19−
20−all: $(BENCHS)
21−$(BENCHS): %.exe: %.hs
22− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $(PROFILING) $< -o $@
23−
24−#-------------------------------------------------------------------------------
25−# Shorthands for running benchmarks:
26−
27−run: run1 run2 run3 run4
28−
29−run1: runBaseline
30−runBaseline:
31− ./PingTCP.exe server 8080 &
32− sleep 1
33− time ./PingTCP.exe client 0.0.0.0 8080 $(size) $(trials)
34− # Kill the server:
35− killall PingTCP.exe
36−
37−run2: runTCP
38−runTCP:
39− ./PingTCPTransport.exe server 0.0.0.0 8080 sourceAddr &
40− sleep 1
41− # Run 100K ping-pongs, for one trial:
42− time ./PingTCPTransport.exe client 0.0.0.0 8081 sourceAddr $(size) $(trials)
43− # Kill the server:
44− killall PingTCPTransport.exe
45−
46−run3: runPipes
47−runPipes:
48− ./PingPipes.exe server sourceAddr &
49− sleep 1
50− time ./PingPipes.exe client sourceAddr $(size) $(trials)
51− # Kill the server:
52− killall PingPipes.exe
53−
54−# This benchmark measures throughput rather than latency
55−# Here 'size' means message size rather than number of pings:
56−run4: runTPT
57−runTPT:
58− ./SendTransport.exe server 0.0.0.0 8080 sourceAddr &
59− sleep 1
60− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr $(size)
61− killall SendTransport.exe
62−
63−# Run multiple sizes:
64−runTPTs:
65− $(MAKE) runTPT size=1000
66− $(MAKE) runTPT size=5000
67− $(MAKE) runTPT size=10000
68− $(MAKE) runTPT size=50000
69− $(MAKE) runTPT size=100000
70−
71−clean:
72− rm -f *.hi *.o *.exe
benchmarks/Makefile.JustPingdeleted−52
@@ -1,52 +0,0 @@
1−# The "Just Ping" tests measure ping latency with as little overhead as possible
2−
3−NUMPINGS=100000
4−INCLUDES=-i../network-transport/src -i../network-transport-pipes/src
5−
6−# Enable for profiling
7−# PROF_GHC=-prof -fprof-auto
8−# PROF_EXE=+RTS -pa -RTS
9−
10−GCC=gcc -std=c99
11−GHC=ghc -rtsopts -XRankNTypes -XScopedTypeVariables -XDeriveDataTypeable
12−
13−NewTransport.ps: JustPingHaskell.data \
14− JustPingTransport.data
15− gnuplot ./NewTransport.gnuplot
16−
17−Indirection.ps: JustPingWithHeader.data \
18− JustPingThroughChan.data \
19− JustPingThroughMVar.data \
20− JustPingTwoSocketPairs.data \
21− JustPingTwoSocketPairsND.data \
22− JustPingTransport.data
23− gnuplot ./Indirection.gnuplot
24−
25−Headers.ps: JustPingC.data \
26− JustPingHaskellNT.data \
27− JustPingHaskell.data \
28− JustPingWithHeader.data \
29− JustPingOneRecv.data \
30− JustPingCacheHeader.data
31− gnuplot ./Headers.gnuplot
32−
33−JustPingC.exe: JustPingC.c
34− $(GCC) -O2 -o JustPingC.exe JustPingC.c
35−
36−JustPingHaskellNT.exe: JustPingHaskell.hs
37− $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs
38−
39−JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe
40− time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@
41−
42−%.data : %.exe
43− time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@
44−
45−%.exe :: %.hs
46− $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES)
47−
48−.PHONY: clean
49−clean:
50− rm -f *.data *.ps *.pdf *.o *.hi *.exe
51−
52−# vi:set noexpandtab:
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"
benchmarks/PingPipes.hsdeleted−112
@@ -1,112 +0,0 @@
1−module Main where
2−
3−-- TODO: Merge with PingTCPTransport and factor differences.
4−
5−import Network.Transport (newConnection, receive, connect, send,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.Pipes (mkTransport)
8−
9−import Control.Monad (forever, replicateM_)
10−import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
11−import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
12−-- import Data.Binary (encode,decode)
13−import Data.Serialize (encode,decode)
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−
18−-- import qualified Data.ByteString.Lazy.Char8 as LBS
19−import qualified Data.ByteString.Char8 as BS
20−
21−-- | This performs a ping benchmark on the TCP transport. This can be
22−-- compiled using:
23−--
24−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
25−--
26−-- To use the compiled binary, first set up a server:
27−--
28−-- ./benchmarks/PingPipes server sourceAddr
29−--
30−-- Once this is established, launch a client to perform the benchmark. The
31−-- following command sends 1000 pings per mark.
32−--
33−-- ./benchmarks/PingPipes client sourceAddr 1000
34−--
35−-- The server must be restarted between benchmarks.
36−main :: IO ()
37−main = do
38− args <- getArgs
39− case args of
40− "server" : sourceAddrFilePath : [] -> do
41− -- establish transport
42− transport <- mkTransport
43−
44− -- create ping end
45− putStrLn "server: creating ping end"
46− (sourceAddrPing, targetEndPing) <- newConnection transport
47− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
48−
49− -- create pong end
50− putStrLn "server: creating pong end"
51− [sourceAddrPongBS] <- receive targetEndPing
52− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
53−
54− -- always respond to a ping with a pong
55− putStrLn "server: awaiting pings"
56− forever $ pong targetEndPing sourceEndPong
57−
58−
59− "client" : sourceAddrFilePath : pingsStr : reps : args' -> do
60− let pings = read pingsStr
61− -- establish transport
62− transport <- mkTransport
63−
64− -- create ping end
65− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
66− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
67−
68− -- create pong end
69− (sourceAddrPong, targetEndPong) <- newConnection transport
70− send sourceEndPing [serialize sourceAddrPong]
71−
72− -- benchmark the pings
73− case (read reps) :: Int of
74− 0 -> error "What would zero reps mean?"
75− 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
76− replicateM_ pings (ping sourceEndPing targetEndPong)
77− n -> withArgs args' $ defaultMainWith
78− (defaultConfig{ cfgSamples = ljust n })
79− (return ()) -- Init action.
80− [ benchPing sourceEndPing targetEndPong (fromIntegral pings) ]
81− putStrLn "Done with all ping/pongs."
82−
83−
84−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
85−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
86−-- in reply down the `SourceEnd`, repeating whatever was sent.
87−pong :: TargetEnd -> SourceEnd -> IO ()
88−pong targetEndPing sourceEndPong = do
89− bs <- receive targetEndPing
90− send sourceEndPong bs
91−
92−-- | The effect of `ping sourceEndPing targetEndPong n` is to send the number
93−-- `n` using `sourceEndPing`, and to then receive the a number from
94−-- `targetEndPong`, which is then returned.
95−ping :: SourceEnd -> TargetEnd -> IO Int64
96−ping sourceEndPing targetEndPong = do
97− -- send sourceEndPing [BS.empty]
98− send sourceEndPing [encode (42 :: Int64)]
99−
100− [bs] <- receive targetEndPong
101−-- return $ decode bs
102− case decode bs of
103− Left err -> error$ "decode failure: " ++ err
104− Right x -> return x
105−
106−-- | The effect of `benchPing sourceEndPing targetEndPong n` is to send
107−-- `n` pings down `sourceEndPing` using the `ping` function. The time
108−-- taken is benchmarked.
109−benchPing :: SourceEnd -> TargetEnd -> Int64 -> Benchmark
110−benchPing sourceEndPing targetEndPong n = bench "PingTransport" $
111− nfIO (replicateM_ (fromIntegral n) (ping sourceEndPing targetEndPong))
112−
benchmarks/PingTCP.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
18−import System.IO (withFile, IOMode(..), hPutStrLn, Handle)
19−import Control.Concurrent (forkIO)
20−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
21−
22−import qualified Network.Socket as N
23−
24−import Debug.Trace
25−
26−#ifndef LAZY
27−import Data.ByteString (ByteString)
28−import Data.ByteString.Char8 (pack)
29−import qualified Data.ByteString as BS
30−import qualified Network.Socket.ByteString as NBS
31−encode = Ser.encode
32−decode = Ser.decode
33−#else
34−import Data.ByteString.Lazy (ByteString, pack)
35−import qualified Network.Socket.ByteString.Lazy as NBS
36−encode = Ser.encodeLazy
37−decode = Ser.decodeLazy
38−#endif
39−{-# INLINE encode #-}
40−{-# INLINE decode #-}
41−encode :: Ser.Serialize a => a -> ByteString
42−decode :: Ser.Serialize a => ByteString -> Either String a
43−
44−-- | This performs a ping benchmark on a TCP connection created by
45−-- Network.Socket. To compile this file, you might use:
46−--
47−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTCP.hs
48−--
49−-- To use the compiled binary, first set up the server on the current machine:
50−--
51−-- ./benchmarks/PingTCP server 8080
52−--
53−-- Next, perform the benchmark on a client using the server address, where
54−-- each mark is 1000 pings:
55−--
56−-- ./benchmarks/PingTCP client 0.0.0.0 8080 1000
57−--
58−-- The server must be restarted between benchmarks.
59−main :: IO ()
60−main = do
61− [pingsStr] <- getArgs
62− serverReady <- newEmptyMVar
63−
64− -- Start the server
65− forkIO $ do
66− putStrLn "server: creating TCP connection"
67− serverAddrs <- getAddrInfo
68− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
69− Nothing
70− (Just "8080")
71− let serverAddr = head serverAddrs
72− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
73− setSocketOption sock ReuseAddr 1
74− bindSocket sock (addrAddress serverAddr)
75−
76− putStrLn "server: awaiting client connection"
77− putMVar serverReady ()
78− listen sock 1
79− (clientSock, clientAddr) <- accept sock
80−
81− putStrLn "server: listening for pings"
82− pong clientSock
83−
84− -- Client
85− takeMVar serverReady
86− let pings = read pingsStr
87− serverAddrs <- getAddrInfo
88− Nothing
89− (Just "127.0.0.1")
90− (Just "8080")
91− let serverAddr = head serverAddrs
92− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
93−
94− N.connect sock (addrAddress serverAddr)
95−
96− ping sock pings
97−
98−pingMessage :: ByteString
99−pingMessage = pack "ping123"
100−
101−ping :: Socket -> Int -> IO ()
102−ping sock pings = go [] pings
103− where
104− go :: [Double] -> Int -> IO ()
105− go rtl 0 = do
106− withFile "round-trip-latency-tcp.data" WriteMode (writeData rtl)
107− putStrLn $ "client did " ++ show pings ++ " pings"
108− go rtl !i = do
109− before <- getCurrentTime
110− send sock pingMessage
111− bs <- recv sock 8
112− after <- getCurrentTime
113− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
114− latency `seq` go (latency : rtl) (i - 1)
115− writeData :: [Double] -> Handle -> IO ()
116− writeData rtl h = forM_ (zip [0..] rtl) (writeDataLine h)
117− writeDataLine :: Handle -> (Int, Double) -> IO ()
118− writeDataLine h (i, latency) = hPutStrLn h $ (show i) ++ " " ++ (show latency)
119−
120−pong :: Socket -> IO ()
121−pong sock = do
122− bs <- recv sock 8
123− when (BS.length bs > 0) $ do
124− send sock bs
125− pong sock
126−
127−-- | Wrapper around NBS.recv (for profiling)
128−recv :: Socket -> Int -> IO ByteString
129−recv = NBS.recv
130−
131−-- | Wrapper around NBS.send (for profiling)
132−send :: Socket -> ByteString -> IO Int
133−send = NBS.send
benchmarks/PingTCPTransport.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Network.Transport (newConnection, receive, connect, send, defaultHints,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Monad (forever, replicateM_, forM_)
10−
11−import qualified Data.Serialize as Ser
12−import Data.Maybe (fromJust)
13−import Data.Int
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−
20−#ifndef LAZY
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import qualified Data.ByteString.Lazy.Char8 as BS
27−import qualified Network.Socket.ByteString.Lazy as NBS
28−encode = Ser.encodeLazy
29−decode = Ser.decodeLazy
30−#endif
31−{-# INLINE encode #-}
32−{-# INLINE decode #-}
33−encode :: Ser.Serialize a => a -> BS.ByteString
34−decode :: Ser.Serialize a => BS.ByteString -> Either String a
35−
36−
37−
38−-- | This performs a ping benchmark on the TCP transport. This can be
39−-- compiled using:
40−--
41−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
42−--
43−-- To use the compiled binary, first set up a server:
44−--
45−-- ./benchmarks/PingTransport server 0.0.0.0 8080 sourceAddr
46−--
47−-- Once this is established, launch a client to perform the benchmark. The
48−-- following command sends 1000 pings per mark.
49−--
50−-- ./benchmarks/PingTransport client 0.0.0.0 8081 sourceAddr 1000
51−--
52−-- The server must be restarted between benchmarks.
53−main :: IO ()
54−main = do
55− [pingsStr] <- getArgs
56− serverAddr <- newEmptyMVar
57− clientAddr <- newEmptyMVar
58−
59− -- Start the server
60− forkIO $ do
61− -- establish transport
62− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
63−
64− -- create ping end
65− putStrLn "server: creating ping end"
66− (sourceAddrPing, targetEndPing) <- newConnection transport
67− putMVar serverAddr sourceAddrPing
68−
69− -- create pong end
70− putStrLn "server: creating pong end"
71− sourceAddrPong <- takeMVar clientAddr
72− sourceEndPong <- connect sourceAddrPong
73−
74− -- always respond to a ping with a pong
75− putStrLn "server: awaiting pings"
76− pong targetEndPing sourceEndPong
77−
78− -- Client
79− sourceAddr <- takeMVar serverAddr
80− let pings = read pingsStr
81− -- establish transport
82− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
83−
84− -- create ping end
85− sourceEndPing <- connect sourceAddr
86−
87− -- create pong end
88− (sourceAddrPong, targetEndPong) <- newConnection transport
89− putMVar clientAddr sourceAddrPong
90−
91− ping sourceEndPing targetEndPong pings
92− putStrLn "Done with all ping/pongs."
93−
94−-- | The message we use to ping (CAF so that we don't keep encoding it)
95−pingMessage :: BS.ByteString
96−pingMessage = BS.pack "ping123"
97−
98−-- | Keep replying to pings (send pongs)
99−pong :: TargetEnd -> SourceEnd -> IO ()
100−pong targetEndPing sourceEndPong = do
101− [bs] <- receive targetEndPing
102− -- putStrLn $ "server got " ++ BS.unpack bs
103− send sourceEndPong [bs]
104− pong targetEndPing sourceEndPong
105−
106−-- | Send a number of pings
107−ping :: SourceEnd -> TargetEnd -> Int -> IO ()
108−ping sourceEndPing targetEndPong pings = go [] pings
109− where
110− go :: [Double] -> Int -> IO ()
111− go rtl 0 = do
112− outputData rtl
113− putStrLn $ "client did " ++ show pings ++ " pings"
114− go rtl !i = do
115− before <- getCurrentTime
116− send sourceEndPing [pingMessage]
117− [bs] <- receive targetEndPong
118− -- putStrLn $ "client got " ++ BS.unpack bs
119− after <- getCurrentTime
120− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
121− latency `seq` go (latency : rtl) (i - 1)
122−
123−-- | Output latencies to a file to be plotted
124−outputData :: [Double] -> IO ()
125−outputData rtl = do
126− withFile "round-trip-latency-tcp-transport.data" WriteMode $ \h ->
127− forM_ (zip [0..] rtl) $ \(i, latency) ->
128− hPutStrLn h $ (show i) ++ " " ++ (show latency)
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/SendTCP.hsdeleted−109
@@ -1,109 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Main where
4−
5−import Control.Monad
6−import Criterion.Main (Benchmark, bench, defaultMain, nfIO, bgroup)
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−
18−import qualified Network.Socket as N
19−
20−#ifdef LAZY
21−import Data.ByteString (ByteString)
22−import qualified Data.ByteString as BS
23−import qualified Network.Socket.ByteString as NBS
24−encode = Ser.encode
25−decode = Ser.decode
26−#else
27−import Data.ByteString.Lazy (ByteString)
28−import qualified Data.ByteString.Lazy as BS
29−import qualified Network.Socket.ByteString.Lazy as NBS
30−encode = Ser.encodeLazy
31−decode = Ser.decodeLazy
32−#endif
33−{-# INLINE encode #-}
34−{-# INLINE decode #-}
35−encode :: Ser.Serialize a => a -> ByteString
36−decode :: Ser.Serialize a => ByteString -> Either String a
37−
38−-- | This performs a benchmark on a TCP connection to measure how long it takes
39−-- to transfer a number of bytes.
40−-- To compile this file, you might use:
41−--
42−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTCP.hs
43−--
44−-- To use the compiled binary, first set up the server on the current machine,
45−-- such that it expects 1000 bytes:
46−--
47−-- ./benchmarks/SendTCP server 8080 1000
48−--
49−-- Next, perform the benchmark on a client using the server address, where
50−-- each mark is 1000 bytes:
51−--
52−-- ./benchmarks/SendTCP client 0.0.0.0 8080 1000
53−--
54−-- The server must be restarted between benchmarks.
55−main :: IO ()
56−main = do
57− args <- getArgs
58− case args of
59− "server" : service : sizeStr : [] -> withSocketsDo $ do
60− let size = read sizeStr
61− putStrLn "server: creating TCP connection"
62− serverAddrs <- getAddrInfo
63− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
64− Nothing
65− (Just service)
66− let serverAddr = head serverAddrs
67− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− setSocketOption sock ReuseAddr 1
69− bindSocket sock (addrAddress serverAddr)
70−
71− putStrLn "server: awaiting client connection"
72− listen sock 1
73− (clientSock, clientAddr) <- accept sock
74−
75− putStrLn "server: listening for data"
76−
77− forever $ pong clientSock size
78−
79− "client": host : service : sizeStr : args' -> withSocketsDo $ do
80− let size = read sizeStr
81− serverAddrs <- getAddrInfo
82− Nothing
83− (Just host)
84− (Just service)
85− let serverAddr = head serverAddrs
86− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
87−
88− N.connect sock (addrAddress serverAddr)
89−
90− -- benchmark the data
91− let bs = BS.replicate size 0
92− withArgs args' $ defaultMain [ benchSend sock bs ]
93−
94−-- | Each `ping` sends a `ByteString` and expects a byte in return.
95−ping :: Socket -> ByteString -> IO Word8
96−ping sock bs = do
97− NBS.send sock bs
98− bs' <- NBS.recv sock 1
99− either error return $ decode bs
100−
101−-- pong :: Socket -> Int64 -> IO ()
102−pong sock size = do
103− bs <- NBS.recv sock size
104− NBS.sendAll sock (encode (0 :: Word8))
105− return ()
106−
107−benchSend :: Socket -> ByteString -> Benchmark
108−benchSend sock bs = bench "SendTCP" $
109− nfIO (ping sock bs)
benchmarks/SendTransport.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoMonomorphismRestriction #-}
3−
4−module Main where
5−
6−import Network.Transport (newConnection, receive, connect, send, defaultHints,
7− serialize, deserialize, SourceEnd, TargetEnd)
8−import Network.Transport.TCP (mkTransport, TCPConfig (..))
9−
10−import Control.Applicative
11−import Control.Monad (forever, replicateM, replicateM_)
12−import Criterion.Main (Benchmark, bench, defaultMain, nfIO)
13−import qualified Data.Serialize as Ser
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−import System.Random
18−
19−#ifndef LAZY
20−import Data.ByteString (ByteString)
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import Data.ByteString.Lazy (ByteString)
27−import qualified Data.ByteString.Lazy.Char8 as BS
28−import qualified Network.Socket.ByteString.Lazy as NBS
29−encode = Ser.encodeLazy
30−decode = Ser.decodeLazy
31−#endif
32−{-# INLINE encode #-}
33−{-# INLINE decode #-}
34−encode :: Ser.Serialize a => a -> ByteString
35−decode :: Ser.Serialize a => ByteString -> Either String a
36−
37−-- | This performs a benchmark on the TCP transport to measure how long
38−-- it takes to transfer a number of bytes. This can be compiled using:
39−--
40−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTransport.hs
41−--
42−-- To use the compiled binary, first set up a server:
43−--
44−-- ./benchmarks/SendTransport server 0.0.0.0 8080 sourceAddr
45−--
46−-- Once this is established, launch a client to perform the benchmark. The
47−-- following command sends 1000 bytes per mark.
48−--
49−-- ./benchmarks/SendTransport client 0.0.0.0 8081 sourceAddr 1000
50−--
51−-- The server must be restarted between benchmarks.
52−main :: IO ()
53−main = do
54− args <- getArgs
55− case args of
56− "server" : host : service : sourceAddrFilePath : [] -> do
57−
58− -- establish transport
59− transport <- mkTransport $ TCPConfig defaultHints host service
60−
61− -- create ping end
62− putStrLn "server: creating ping end"
63− (sourceAddrPing, targetEndPing) <- newConnection transport
64− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
65−
66− -- create pong end
67− putStrLn "server: creating pong end"
68− [sourceAddrPongBS] <- receive targetEndPing
69− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
70−
71− -- always respond to a ping with a pong
72− putStrLn "server: awaiting pings"
73− forever $ pong targetEndPing sourceEndPong
74−
75−
76− "client" : host : service : sourceAddrFilePath : sizeStr : args' -> do
77− let size = read sizeStr
78−
79− -- establish transport
80− transport <- mkTransport $ TCPConfig defaultHints host service
81−
82− -- create ping end
83− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
84− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
85−
86− -- create pong end
87− (sourceAddrPong, targetEndPong) <- newConnection transport
88− send sourceEndPing [serialize sourceAddrPong]
89−
90− -- benchmark the data
91− bs <- BS.pack <$> replicateM size randomIO
92− withArgs args' $ defaultMain [ benchSend sourceEndPing targetEndPong bs ]
93−
94−-- | The effect of `ping sourceEndPing targetEndPong bs` is to send the
95−-- `ByteString` `bs` using `sourceEndPing`, and to then receive
96−-- that string back. Returns the length of the received message.
97−ping :: SourceEnd -> TargetEnd -> ByteString -> IO Int
98−ping sourceEndPing targetEndPong bs = do
99− send sourceEndPing [bs]
100− cs <- receive targetEndPong
101− return . fromIntegral $! sum (map BS.length cs)
102−
103−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
104−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
105−-- in reply down the `SourceEnd`, repeating whatever was sent.
106−pong :: TargetEnd -> SourceEnd -> IO ()
107−pong targetEndPing sourceEndPong = do
108− bs <- receive targetEndPing
109− send sourceEndPong bs
110−
111−-- | The effect of `benchSend sourceEndPing targetEndPong bs` is to send
112−-- `bs` pings down `sourceEndPing` using the `ping` function. The time
113−-- taken is benchmarked.
114−benchSend :: SourceEnd -> TargetEnd -> ByteString -> Benchmark
115−benchSend sourceEndPing targetEndPong bs = bench "SendTransport" $
116− nfIO (ping sourceEndPing targetEndPong bs)
117−
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/pingtest.cdeleted−183
@@ -1,183 +0,0 @@
1−/**
2− * Compute baseline average and standard deviancy ping latency
3− *
4− * Compile using
5− *
6− * gcc -o pingtest -O2 -std=c99 pingtest.c
7− *
8− * Then start server
9− *
10− * ./pingtest server &
11− *
12− * And finally start the client
13− *
14− * ./pingtest client <number of pings; for instance, 10000>
15− *
16− * The server will terminate when the client does.
17− *
18− * Edsko de Vries <edsko@well-typed.com>
19− */
20−
21−#include <stdio.h>
22−#include <stdlib.h>
23−#include <sys/types.h>
24−#include <sys/socket.h>
25−#include <netdb.h>
26−#include <string.h>
27−#include <unistd.h>
28−#include <signal.h>
29−#include <errno.h>
30−#include <time.h>
31−#include <sys/time.h>
32−#include <math.h>
33−
34−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
35−double timestamp() {
36− struct timeval tp;
37− gettimeofday(&tp, NULL);
38− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
39−}
40−
41−int server() {
42− printf("starting server\n");
43−
44− struct addrinfo hints, *res;
45− int error, server_socket;
46−
47− memset(&hints, 0, sizeof(hints));
48− hints.ai_family = PF_INET;
49− hints.ai_socktype = SOCK_STREAM;
50− hints.ai_flags = AI_PASSIVE;
51−
52− error = getaddrinfo(NULL, "8080", &hints, &res);
53− if(error) {
54− printf("server error: %s\n", gai_strerror(error));
55− return -1;
56− }
57−
58− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
59− if(server_socket < 0) {
60− printf("server error: could not create socket\n");
61− return -1;
62− }
63−
64− int yes = 1;
65− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
66− printf("server error: could not set socket options\n");
67− return -1;
68− }
69−
70− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
71− printf("server error: could not bind to socket\n");
72− return -1;
73− }
74−
75− listen(server_socket, 5);
76−
77− int client_socket;
78− struct sockaddr_storage client_addr;
79− socklen_t addr_size;
80− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
81−
82− for(;;) {
83− char buf[8];
84− ssize_t read = recv(client_socket, &buf, 8, 0);
85− // printf("server received '%s'\n", buf);
86− send(client_socket, buf, 8, 0);
87− }
88−
89− freeaddrinfo(res);
90− return 0;
91−}
92−
93−int client(int pings) {
94− printf("starting client\n");
95−
96− struct addrinfo hints, *res;
97− int error, client_socket;
98−
99− memset(&hints, 0, sizeof(hints));
100− hints.ai_family = PF_INET;
101− hints.ai_socktype = SOCK_STREAM;
102−
103− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
104− if(error) {
105− printf("client error: %s\n", gai_strerror(error));
106− return -1;
107− }
108−
109− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
110− if(client_socket < 0) {
111− printf("client error: could not create socket\n");
112− return -1;
113− }
114−
115− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
116− printf("client error: could not connect: %s\n", strerror(errno));
117− return -1;
118− }
119−
120− double* round_trip_latency = (double*) calloc(pings, sizeof(double));
121−
122− for(int i = 0; i < pings; i++) {
123− double timestamp_before = timestamp();
124−
125− send(client_socket, "ping123", 8, 0);
126−
127− char buf[8];
128− ssize_t read = recv(client_socket, &buf, 8, 0);
129− // printf("client received '%s'\n", buf);
130−
131− double timestamp_after = timestamp();
132− round_trip_latency[i] = timestamp_after - timestamp_before;
133− }
134−
135− printf("client did %d pings\n", pings);
136−
137− // Write data to a file for plotting
138− FILE* data = fopen("round-trip-latency-c.data", "wt");
139− for(int i = 0; i < pings; i++) {
140− fprintf(data, "%i %lf\n", i, round_trip_latency[i]);
141− }
142− fclose(data);
143−
144− // compute average
145− double round_trip_latency_average = 0;
146− for(int i = 0; i < pings; i++) {
147− round_trip_latency_average += round_trip_latency[i];
148− };
149− round_trip_latency_average /= (double) pings;
150−
151−
152− // compute standard deviation
153− double round_trip_latency_stddev = 0;
154− for(int i = 0; i < pings; i++) {
155− round_trip_latency_stddev += pow(round_trip_latency[i] - round_trip_latency_average, 2);
156− }
157− round_trip_latency_stddev = sqrt(round_trip_latency_stddev / (double) (pings - 1));
158−
159− printf("average round-trip latency: %lf us (standard devitation %lf us)\n", round_trip_latency_average, round_trip_latency_stddev);
160−
161− freeaddrinfo(res);
162− return 0;
163−}
164−
165−int usage(int argc, char** argv) {
166− printf("usage: %s <number of pings>\n", argv[0]);
167− return -1;
168−}
169−
170−int main(int argc, char** argv) {
171− if(argc != 2) {
172− return usage(argc, argv);
173− }
174−
175− if(fork() == 0) {
176− // TODO: we should wait until we know the server is ready
177− int pings = 0;
178− sscanf(argv[1], "%d", &pings);
179− return client(pings);
180− } else {
181− return server();
182− }
183−}
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
benchmarks/results_notes.mddeleted−111
@@ -1,111 +0,0 @@
1−
2−
3−[2012.02.22] {File for notes on results}
4−============================================================
5−
6−Here's a run of the PingTCP benchmark on a 3.1 ghz Intel Westmere running RHEL 6.2:
7−
8− ./PingTCP.exe server 8080 &
9− sleep 1
10− server: creating TCP connection
11− server: awaiting client connection
12− ./PingTCP.exe client 0.0.0.0 8080 1000
13− server: listening for pings
14− warming up
15− estimating clock resolution...
16− mean is 1.963031 us (320001 iterations)
17− found 38180 outliers among 319999 samples (11.9%)
18− 32741 (10.2%) low severe
19− 5439 (1.7%) high severe
20− estimating cost of a clock call...
21− mean is 43.17696 ns (15 iterations)
22− found 2 outliers among 15 samples (13.3%)
23− 1 (6.7%) high mild
24− 1 (6.7%) high severe
25−
26− benchmarking PingTCP
27− collecting 100 samples, 1 iterations each, in estimated 8.073997 s
28− mean: 77.01177 ms, lb 76.92822 ms, ub 77.14009 ms, ci 0.950
29− std dev: 526.1251 us, lb 366.2692 us, ub 803.1751 us, ci 0.950
30−
31−(That was without -O2)
32−
33− -----
34−
35−Running a C benchmark on the same machine it takes 5.6 seconds to do
36−200K ping pongs.
37−
38− => 28 us avg latency for C
39−
40−I got 72 us avg latency using PingTCP. The named pipes backend took
41−19.8s and was using 100% CPU. That's a 99 us latency.
42−
43−Pipes with unix-bytestring take 11.0 seconds, but still use 100% CPU.
44−
45− => 55 us latency for Pipes with unix-bytestring
46−
47−
48−
49−[2012.02.24] {After Adam's strictness refactoring.}
50−============================================================
51−
52−100K ping/pongs, 1 trial:
53−
54− PingTCP: 7.34s >80%CPU
55− PingTCPTransport: 19s ~60%CPU
56− PingPipes: 6.36s >=100%CPU
57−
58−Timing instead using 100 trials of 1000 pingpongs via criterion gives
59−results consistent with the above. Here are the mean latencies:
60−
61− PingTCP: 72 us
62− PingTCPTransport: 191 us
63− PingPipes: 65 us
64−
65−And here is my first attempt at running the SendTransport benchmark (TCP backend):
66−
67− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 1000
68− mean: 38.10901 ms, lb 35.92353 ms, ub 39.30006 ms, ci 0.950
69− std dev: 8.305210 ms, lb 4.935312 ms, ub 11.97144 ms, ci 0.950
70− found 5 outliers among 100 samples (5.0%)
71− 5 (5.0%) low severe
72− variance introduced by outliers: 94.703%
73− variance is severely inflated by outliers
74−
75− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 5000
76− mean: 32.87646 ms, lb 29.69947 ms, ub 35.62485 ms, ci 0.950
77− std dev: 15.21419 ms, lb 12.39949 ms, ub 17.39441 ms, ci 0.950
78− found 18 outliers among 100 samples (18.0%)
79− 18 (18.0%) low severe
80− variance introduced by outliers: 98.928%
81− variance is severely inflated by outliers
82−
83− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 10000
84− mean: 32.87737 ms, lb 29.34305 ms, ub 35.62680 ms, ci 0.950
85− std dev: 15.22060 ms, lb 12.40398 ms, ub 17.57401 ms, ci 0.950
86− found 18 outliers among 100 samples (18.0%)
87− 18 (18.0%) low severe
88− variance introduced by outliers: 98.929%
89− variance is severely inflated by outliers
90−
91− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 50000
92− mean: 1.351308 ms, lb 1.249680 ms, ub 1.548209 ms, ci 0.950
93− std dev: 696.6768 us, lb 448.3538 us, ub 1.314057 ms, ci 0.950
94− found 24 outliers among 100 samples (24.0%)
95− 3 (3.0%) high mild
96− 21 (21.0%) high severe
97− variance introduced by outliers: 98.942%
98− variance is severely inflated by outliers
99−
100− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 100000
101− mean: 2.184967 ms, lb 2.030858 ms, ub 2.641543 ms, ci 0.950
102− std dev: 1.235358 ms, lb 518.3995 us, ub 2.666540 ms, ci 0.950
103− found 15 outliers among 100 samples (15.0%)
104− 4 (4.0%) low severe
105− 9 (9.0%) high severe
106− variance introduced by outliers: 98.952%
107− variance is severely inflated by outliers
108−
109−This is quite odd. so in addition to the high variance it would seem
110−that messages of size 50K or 100K are much FASTER to send than smaller
111−massages?
distributed-process-simplelocalnet/ChangeLogdeleted−7
@@ -1,7 +0,0 @@
1−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
2−
3−* Bugfix: Documentation referred to old module name
4−
5−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
6−
7−* Initial release.
distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabaldeleted−63
@@ -1,63 +0,0 @@
1−Name: distributed-process-simplelocalnet
2−Version: 0.2.0.1
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.10,
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.5,
34− transformers >= 0.2 && < 0.4,
35− network-transport >= 0.2 && < 0.3,
36− network-transport-tcp >= 0.2 && < 0.3,
37− distributed-process >= 0.2 && < 0.3
38− Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet,
39− Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast
40− Extensions: RankNTypes,
41− DeriveDataTypeable
42− ghc-options: -Wall
43− HS-Source-Dirs: src
44−
45−-- Not a proper test, but we want to use cabal to compile it
46−Test-Suite TestSimpleLocalnet
47− Type: exitcode-stdio-1.0
48− Main-Is: TestSimpleLocalnet.hs
49− Build-Depends: base >= 4.4 && < 5,
50− bytestring >= 0.9 && < 0.10,
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.5,
56− transformers >= 0.2 && < 0.4,
57− network-transport >= 0.2 && < 0.3,
58− network-transport-tcp >= 0.2 && < 0.3,
59− distributed-process >= 0.2 && < 0.3
60− Extensions: RankNTypes,
61− DeriveDataTypeable
62− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
63− HS-Source-Dirs: tests src
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hsdeleted−291
@@ -1,291 +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−{-# OPTIONS_GHC -fno-warn-orphans #-}
37−module Control.Distributed.Process.Backend.SimpleLocalnet
38− ( -- * Initialization
39− Backend(..)
40− , initializeBackend
41− -- * Slave nodes
42− , startSlave
43− , terminateSlave
44− , findSlaves
45− , terminateAllSlaves
46− -- * Master nodes
47− , startMaster
48− ) where
49−
50−import System.IO (fixIO)
51−import Data.Maybe (catMaybes)
52−import Data.Binary (Binary(get, put), getWord8, putWord8)
53−import Data.Accessor (Accessor, accessor, (^:), (^.))
54−import Data.Set (Set)
55−import qualified Data.Set as Set (insert, empty, toList)
56−import Data.Foldable (forM_)
57−import Data.Typeable (Typeable)
58−import Control.Applicative ((<$>))
59−import Control.Exception (throw)
60−import Control.Monad (forever, forM)
61−import Control.Monad.IO.Class (liftIO)
62−import Control.Concurrent (forkIO, threadDelay, ThreadId)
63−import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
64−import Control.Distributed.Process
65− ( RemoteTable
66− , NodeId
67− , Process
68− , WhereIsReply(..)
69− , whereis
70− , whereisRemoteAsync
71− , registerRemote
72− , getSelfPid
73− , register
74− , expect
75− , nsendRemote
76− , receiveWait
77− , matchIf
78− , processNodeId
79− )
80−import qualified Control.Distributed.Process.Node as Node
81− ( LocalNode
82− , newLocalNode
83− , localNodeId
84− , runProcess
85− )
86−import qualified Network.Transport.TCP as NT
87− ( createTransport
88− , defaultTCPParameters
89− )
90−import qualified Network.Transport as NT (Transport)
91−import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
92−import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)
93−
94−-- | Local backend
95−data Backend = Backend {
96− -- | Create a new local node
97− newLocalNode :: IO Node.LocalNode
98− -- | @findPeers t@ sends out a /who's there?/ request, waits 't' msec,
99− -- and then collects and returns the answers
100− , findPeers :: Int -> IO [NodeId]
101− -- | Make sure that all log messages are printed by the logger on the
102− -- current node
103− , redirectLogsHere :: Process ()
104− }
105−
106−data BackendState = BackendState {
107− _localNodes :: [Node.LocalNode]
108− , _peers :: Set NodeId
109− , discoveryDaemon :: ThreadId
110− }
111−
112−-- | Initialize the backend
113−initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend
114−initializeBackend host port rtable = do
115− mTransport <- NT.createTransport host port NT.defaultTCPParameters
116− (recv, send) <- initMulticast "224.0.0.99" 9999 1024
117− (_, backendState) <- fixIO $ \ ~(tid, _) -> do
118− backendState <- newMVar BackendState
119− { _localNodes = []
120− , _peers = Set.empty
121− , discoveryDaemon = tid
122− }
123− tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
124− return (tid', backendState)
125− case mTransport of
126− Left err -> throw err
127− Right transport ->
128− let backend = Backend {
129− newLocalNode = apiNewLocalNode transport rtable backendState
130− , findPeers = apiFindPeers send backendState
131− , redirectLogsHere = apiRedirectLogsHere backend
132− }
133− in return backend
134−
135−-- | Create a new local node
136−apiNewLocalNode :: NT.Transport
137− -> RemoteTable
138− -> MVar BackendState
139− -> IO Node.LocalNode
140−apiNewLocalNode transport rtable backendState = do
141− localNode <- Node.newLocalNode transport rtable
142− modifyMVar_ backendState $ return . (localNodes ^: (localNode :))
143− return localNode
144−
145−-- | Peer discovery
146−apiFindPeers :: (PeerDiscoveryMsg -> IO ())
147− -> MVar BackendState
148− -> Int
149− -> IO [NodeId]
150−apiFindPeers send backendState delay = do
151− send PeerDiscoveryRequest
152− threadDelay delay
153− Set.toList . (^. peers) <$> readMVar backendState
154−
155−data PeerDiscoveryMsg =
156− PeerDiscoveryRequest
157− | PeerDiscoveryReply NodeId
158−
159−instance Binary PeerDiscoveryMsg where
160− put PeerDiscoveryRequest = putWord8 0
161− put (PeerDiscoveryReply nid) = putWord8 1 >> put nid
162− get = do
163− header <- getWord8
164− case header of
165− 0 -> return PeerDiscoveryRequest
166− 1 -> PeerDiscoveryReply <$> get
167− _ -> fail "PeerDiscoveryMsg.get: invalid"
168−
169−-- | Respond to peer discovery requests sent by other nodes
170−peerDiscoveryDaemon :: MVar BackendState
171− -> IO (PeerDiscoveryMsg, N.SockAddr)
172− -> (PeerDiscoveryMsg -> IO ())
173− -> IO ()
174−peerDiscoveryDaemon backendState recv send = forever go
175− where
176− go = do
177− (msg, _) <- recv
178− case msg of
179− PeerDiscoveryRequest -> do
180− nodes <- (^. localNodes) <$> readMVar backendState
181− forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
182− PeerDiscoveryReply nid ->
183− modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
184−
185−--------------------------------------------------------------------------------
186−-- Back-end specific primitives --
187−--------------------------------------------------------------------------------
188−
189−-- | Make sure that all log messages are printed by the logger on this node
190−apiRedirectLogsHere :: Backend -> Process ()
191−apiRedirectLogsHere backend = do
192− mLogger <- whereis "logger"
193− forM_ mLogger $ \logger -> do
194− nids <- liftIO $ findPeers backend 1000000
195− forM_ nids $ \nid -> registerRemote nid "logger" logger
196−
197−--------------------------------------------------------------------------------
198−-- Slaves --
199−--------------------------------------------------------------------------------
200−
201−-- | Messages to slave nodes
202−--
203−-- This datatype is not exposed; instead, we expose primitives for dealing
204−-- with slaves.
205−data SlaveControllerMsg =
206− SlaveTerminate
207− deriving (Typeable, Show)
208−
209−instance Binary SlaveControllerMsg where
210− put SlaveTerminate = putWord8 0
211− get = do
212− header <- getWord8
213− case header of
214− 0 -> return SlaveTerminate
215− _ -> fail "SlaveControllerMsg.get: invalid"
216−
217−-- | Calling 'slave' sets up a new local node and then waits. You start
218−-- processes on the slave by calling 'spawn' from other nodes.
219−--
220−-- This function does not return. The only way to exit the slave is to CTRL-C
221−-- the process or call terminateSlave from another node.
222−startSlave :: Backend -> IO ()
223−startSlave backend = do
224− node <- newLocalNode backend
225− Node.runProcess node slaveController
226−
227−-- | The slave controller interprets 'SlaveControllerMsg's
228−slaveController :: Process ()
229−slaveController = do
230− pid <- getSelfPid
231− register "slaveController" pid
232− go
233− where
234− go = do
235− msg <- expect
236− case msg of
237− SlaveTerminate -> return ()
238−
239−-- | Terminate the slave at the given node ID
240−terminateSlave :: NodeId -> Process ()
241−terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate
242−
243−-- | Find slave nodes
244−findSlaves :: Backend -> Process [NodeId]
245−findSlaves backend = do
246− nodes <- liftIO $ findPeers backend 1000000
247− -- Fire of asynchronous requests for the slave controller
248− forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController"
249− -- Wait for the replies
250− catMaybes <$> forM nodes (\_ ->
251− receiveWait
252− [ matchIf (\(WhereIsReply label _) -> label == "slaveController")
253− (\(WhereIsReply _ mPid) -> return (processNodeId <$> mPid))
254− ])
255−
256−-- | Terminate all slaves
257−terminateAllSlaves :: Backend -> Process ()
258−terminateAllSlaves backend = do
259− slaves <- findSlaves backend
260− forM_ slaves terminateSlave
261− liftIO $ threadDelay 1000000
262−
263−--------------------------------------------------------------------------------
264−-- Master nodes
265−--------------------------------------------------------------------------------
266−
267−-- | 'startMaster' finds all slaves currently available on the local network
268−-- (which should therefore be started first), redirects all log messages to
269−-- itself, and then calls the specified process, passing the list of slaves
270−-- nodes.
271−--
272−-- Terminates when the specified process terminates. If you want to terminate
273−-- the slaves when the master terminates, you should manually call
274−-- 'terminateAllSlaves'.
275−startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()
276−startMaster backend proc = do
277− node <- newLocalNode backend
278− Node.runProcess node $ do
279− slaves <- findSlaves backend
280− redirectLogsHere backend
281− proc slaves
282−
283−--------------------------------------------------------------------------------
284−-- Accessors --
285−--------------------------------------------------------------------------------
286−
287−localNodes :: Accessor BackendState [Node.LocalNode]
288−localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })
289−
290−peers :: Accessor BackendState (Set NodeId)
291−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-simplelocalnet/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/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−7
@@ -1,7 +0,0 @@
1−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
2−
3−* Bugfix: Continue processing messages when a connection breaks.
4−
5−2012-07-07 Edsko de Vries <edsko@well-typed.com>
6−
7−* Initial release.
distributed-process/distributed-process.cabaldeleted−135
@@ -1,135 +0,0 @@
1−Name: distributed-process
2−Version: 0.2.0.1
3−Cabal-Version: >=1.8
4−Build-Type: Simple
5−License: BSD3
6−License-File: LICENSE
7−Copyright: Well-Typed LLP
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10−Stability: experimental
11−Homepage: http://github.com/haskell-distributed/distributed-process
12−Bug-Reports: mailto:edsko@well-typed.com
13−Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell
14−Description: This is an implementation of Cloud Haskell, as described in
15− /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,
16− and Simon Peyton Jones
17− (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
18− although some of the details are different. The precise message
19− passing semantics are based on /A unified semantics for future Erlang/
20− by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.
21−
22− You will probably also want to install a Cloud Haskell backend such
23− as distributed-process-simplelocalnet.
24−Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
25−Category: Control
26−
27−Source-Repository head
28− Type: git
29− Location: https://github.com/haskell-distributed/distributed-process
30− SubDir: distributed-process
31−
32−Library
33− Build-Depends: base >= 4.4 && < 5,
34− binary >= 0.5 && < 0.6,
35− network-transport >= 0.2 && < 0.3,
36− stm >= 2.3 && < 2.5,
37− transformers >= 0.2 && < 0.4,
38− mtl >= 2.0 && < 2.2,
39− data-accessor >= 0.2 && < 0.3,
40− bytestring >= 0.9 && < 0.10,
41− containers >= 0.4 && < 0.5,
42− old-locale >= 1.0 && < 1.1,
43− time >= 1.2 && < 1.3,
44− template-haskell >= 2.6 && < 2.8,
45− random >= 1.0 && < 1.1,
46− ghc-prim >= 0.2 && < 0.3
47− Exposed-modules: Control.Distributed.Process,
48− Control.Distributed.Process.Serializable,
49− Control.Distributed.Process.Closure,
50− Control.Distributed.Process.Node,
51− Control.Distributed.Process.Internal.Primitives,
52− Control.Distributed.Process.Internal.CQueue,
53− Control.Distributed.Process.Internal.Dynamic,
54− Control.Distributed.Process.Internal.TypeRep,
55− Control.Distributed.Process.Internal.MessageT,
56− Control.Distributed.Process.Internal.Types,
57− Control.Distributed.Process.Internal.Closure.Static,
58− Control.Distributed.Process.Internal.Closure.MkClosure,
59− Control.Distributed.Process.Internal.Closure.CP,
60− Control.Distributed.Process.Internal.Closure.TH,
61− Control.Distributed.Process.Internal.Closure.Resolution,
62− Control.Distributed.Process.Internal.Node
63− Extensions: RankNTypes,
64− ScopedTypeVariables,
65− FlexibleInstances,
66− UndecidableInstances,
67− ExistentialQuantification,
68− GADTs,
69− GeneralizedNewtypeDeriving,
70− DeriveDataTypeable,
71− TemplateHaskell
72− ghc-options: -Wall
73− HS-Source-Dirs: src
74−
75−Test-Suite TestCH
76− Type: exitcode-stdio-1.0
77− Main-Is: TestCH.hs
78− Build-Depends: base >= 4.4 && < 5,
79− binary >= 0.5 && < 0.6,
80− network-transport >= 0.2 && < 0.3,
81− network-transport-tcp >= 0.2 && < 0.3,
82− stm >= 2.3 && < 2.5,
83− transformers >= 0.2 && < 0.4,
84− mtl >= 2.0 && < 2.2,
85− data-accessor >= 0.2 && < 0.3,
86− bytestring >= 0.9 && < 0.10,
87− containers >= 0.4 && < 0.5,
88− old-locale >= 1.0 && < 1.1,
89− time >= 1.2 && < 1.3,
90− template-haskell >= 2.6 && < 2.8,
91− random >= 1.0 && < 1.1,
92− ghc-prim >= 0.2 && < 0.3,
93− ansi-terminal >= 0.5 && < 0.6
94− Extensions: RankNTypes,
95− ScopedTypeVariables,
96− FlexibleInstances,
97− UndecidableInstances,
98− ExistentialQuantification,
99− GADTs,
100− GeneralizedNewtypeDeriving,
101− DeriveDataTypeable,
102− TemplateHaskell
103− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
104− HS-Source-Dirs: tests src
105−
106−Test-Suite TestClosure
107− Type: exitcode-stdio-1.0
108− Main-Is: TestClosure.hs
109− Build-Depends: base >= 4.4 && < 5,
110− binary >= 0.5 && < 0.6,
111− network-transport >= 0.2 && < 0.3,
112− network-transport-tcp >= 0.2 && < 0.3,
113− stm >= 2.3 && < 2.5,
114− transformers >= 0.2 && < 0.4,
115− mtl >= 2.0 && < 2.2,
116− data-accessor >= 0.2 && < 0.3,
117− bytestring >= 0.9 && < 0.10,
118− containers >= 0.4 && < 0.5,
119− old-locale >= 1.0 && < 1.1,
120− time >= 1.2 && < 1.3,
121− template-haskell >= 2.6 && < 2.8,
122− random >= 1.0 && < 1.1,
123− ghc-prim >= 0.2 && < 0.3,
124− ansi-terminal >= 0.5 && < 0.6
125− Extensions: RankNTypes,
126− ScopedTypeVariables,
127− FlexibleInstances,
128− UndecidableInstances,
129− ExistentialQuantification,
130− GADTs,
131− GeneralizedNewtypeDeriving,
132− DeriveDataTypeable,
133− TemplateHaskell
134− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
135− HS-Source-Dirs: tests src
distributed-process/src/Control/Distributed/Process.hsdeleted−336
@@ -1,336 +0,0 @@
1−-- | [Cloud Haskell]
2−--
3−-- This is an implementation of Cloud Haskell, as described in
4−-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon
5−-- Peyton Jones
6−-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
7−-- although some of the details are different. The precise message passing
8−-- semantics are based on /A unified semantics for future Erlang/ by Hans
9−-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.
10−{-# LANGUAGE TemplateHaskell #-}
11−module Control.Distributed.Process
12− ( -- * Basic types
13− ProcessId
14− , NodeId
15− , Process
16− , SendPortId
17− , processNodeId
18− , sendPortProcessId
19− , liftIO -- Reexported for convenience
20− -- * Basic messaging
21− , send
22− , expect
23− -- * Channels
24− , ReceivePort
25− , SendPort
26− , sendPortId
27− , newChan
28− , sendChan
29− , receiveChan
30− , mergePortsBiased
31− , mergePortsRR
32− -- * Advanced messaging
33− , Match
34− , receiveWait
35− , receiveTimeout
36− , match
37− , matchIf
38− , matchUnknown
39− -- * Process management
40− , spawn
41− , call
42− , terminate
43− , ProcessTerminationException(..)
44− , SpawnRef
45− , getSelfPid
46− , getSelfNode
47− -- * Monitoring and linking
48− , link
49− , linkNode
50− , linkPort
51− , unlink
52− , unlinkNode
53− , unlinkPort
54− , monitor
55− , monitorNode
56− , monitorPort
57− , unmonitor
58− , ProcessLinkException(..)
59− , NodeLinkException(..)
60− , PortLinkException(..)
61− , MonitorRef -- opaque
62− , ProcessMonitorNotification(..)
63− , NodeMonitorNotification(..)
64− , PortMonitorNotification(..)
65− , DiedReason(..)
66− -- * Closures
67− , Closure
68− , Static
69− , unClosure
70− , RemoteTable
71− -- * Logging
72− , say
73− -- * Registry
74− , register
75− , unregister
76− , whereis
77− , nsend
78− , registerRemote
79− , unregisterRemote
80− , whereisRemote
81− , whereisRemoteAsync
82− , nsendRemote
83− , WhereIsReply(..)
84− -- * Auxiliary API
85− , catch
86− , expectTimeout
87− , spawnAsync
88− , spawnSupervised
89− , spawnLink
90− , spawnMonitor
91− , DidSpawn(..)
92− ) where
93−
94−import Prelude hiding (catch)
95−import Control.Monad.IO.Class (liftIO)
96−import Control.Distributed.Process.Internal.Types
97− ( RemoteTable
98− , NodeId(..)
99− , ProcessId(..)
100− , Process(..)
101− , Closure(..)
102− , Static(..)
103− , MonitorRef(..)
104− , ProcessMonitorNotification(..)
105− , NodeMonitorNotification(..)
106− , PortMonitorNotification(..)
107− , ProcessLinkException(..)
108− , NodeLinkException(..)
109− , PortLinkException(..)
110− , DiedReason(..)
111− , SpawnRef(..)
112− , DidSpawn(..)
113− , Closure(..)
114− , SendPort(..)
115− , ReceivePort(..)
116− , SerializableDict(..)
117− , SendPortId(..)
118− , WhereIsReply(..)
119− )
120−import Control.Distributed.Process.Internal.Closure.CP
121− ( cpSeq
122− , cpBind
123− , cpSend
124− , cpExpect
125− , cpLink
126− , cpUnlink
127− )
128−import Control.Distributed.Process.Internal.Closure.Static
129− ( sdictUnit
130− , sdictUnit__static
131− )
132−import Control.Distributed.Process.Internal.Primitives
133− ( -- Basic messaging
134− send
135− , expect
136− -- Channels
137− , newChan
138− , sendChan
139− , receiveChan
140− , mergePortsBiased
141− , mergePortsRR
142− -- Advanced messaging
143− , Match
144− , receiveWait
145− , receiveTimeout
146− , match
147− , matchIf
148− , matchUnknown
149− -- Process management
150− , terminate
151− , ProcessTerminationException(..)
152− , getSelfPid
153− , getSelfNode
154− -- Monitoring and linking
155− , link
156− , linkNode
157− , linkPort
158− , unlink
159− , unlinkNode
160− , unlinkPort
161− , monitor
162− , monitorNode
163− , monitorPort
164− , unmonitor
165− -- Logging
166− , say
167− -- Registry
168− , register
169− , unregister
170− , whereis
171− , nsend
172− , registerRemote
173− , unregisterRemote
174− , whereisRemote
175− , whereisRemoteAsync
176− , nsendRemote
177− -- Closures
178− , unClosure
179− -- Auxiliary API
180− , catch
181− , expectTimeout
182− , spawnAsync
183− )
184−import Control.Distributed.Process.Serializable (Serializable)
185−import Control.Distributed.Process.Internal.Closure.TH (mkStatic)
186−
187−-- INTERNAL NOTES
188−--
189−-- 1. 'send' never fails. If you want to know that the remote process received
190−-- your message, you will need to send an explicit acknowledgement. If you
191−-- want to know when the remote process failed, you will need to monitor
192−-- that remote process.
193−--
194−-- 2. 'send' may block (when the system TCP buffers are full, while we are
195−-- trying to establish a connection to the remote endpoint, etc.) but its
196−-- return does not imply that the remote process received the message (much
197−-- less processed it)
198−--
199−-- 3. Message delivery is reliable and ordered. That means that if process A
200−-- sends messages m1, m2, m3 to process B, B will either arrive all three
201−-- messages in order (m1, m2, m3) or a prefix thereof; messages will not be
202−-- 'missing' (m1, m3) or reordered (m1, m3, m2)
203−--
204−-- In order to guarantee (3), we stipulate that
205−--
206−-- 3a. We do not garbage collect connections because Network.Transport provides
207−-- ordering guarantees only *per connection*.
208−--
209−-- 3b. Once a connection breaks, we have no way of knowing which messages
210−-- arrived and which did not; hence, once a connection fails, we assume the
211−-- remote process to be forever unreachable. Otherwise we might sent m1 and
212−-- m2, get notified of the broken connection, reconnect, send m3, but only
213−-- m1 and m3 arrive.
214−--
215−-- 3c. As a consequence of (3b) we should not reuse PIDs. If a process dies,
216−-- we consider it forever unreachable. Hence, new processes should get new
217−-- IDs or they too would be considered unreachable.
218−--
219−-- Main reference for Cloud Haskell is
220−--
221−-- [1] "Towards Haskell in the Cloud", Jeff Epstein, Andrew Black and Simon
222−-- Peyton-Jones.
223−-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
224−--
225−-- The precise semantics for message passing is based on
226−--
227−-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund
228−-- and Clara Benac Earle (not freely available online, unfortunately)
229−--
230−-- Some pointers to related documentation about Erlang, for comparison and
231−-- inspiration:
232−--
233−-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",
234−-- Hans Svensson and Lars-Ake Fredlund
235−-- http://man.lupaworld.com/content/develop/p37-svensson.pdf
236−-- [4] The Erlang manual, sections "Message Sending" and "Send"
237−-- http://www.erlang.org/doc/reference_manual/processes.html#id82409
238−-- http://www.erlang.org/doc/reference_manual/expressions.html#send
239−-- [5] Questions "Is the order of message reception guaranteed?" and
240−-- "If I send a message, is it guaranteed to reach the receiver?" of
241−-- the Erlang FAQ
242−-- http://www.erlang.org/faq/academic.html
243−-- [6] "Delivery of Messages", post on erlang-questions
244−-- http://erlang.org/pipermail/erlang-questions/2012-February/064767.html
245−
246−--------------------------------------------------------------------------------
247−-- Primitives are defined in a separate module; here we only define derived --
248−-- constructs --
249−--------------------------------------------------------------------------------
250−
251−-- | Spawn a process
252−spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
253−spawn nid proc = do
254− us <- getSelfPid
255− -- Since we throw an exception when the remote node dies, we could use
256− -- linkNode instead. However, we don't have a way of "scoped" linking so if
257− -- we call linkNode here, and unlinkNode after, then we might remove a link
258− -- that was already set up
259− mRef <- monitorNode nid
260− sRef <- spawnAsync nid $ cpLink us
261− `cpSeq` cpExpect $(mkStatic 'sdictUnit)
262− `cpSeq` cpUnlink us
263− `cpSeq` proc
264− mPid <- receiveWait
265− [ matchIf (\(DidSpawn ref _) -> ref == sRef)
266− (\(DidSpawn _ pid) -> return $ Just pid)
267− , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)
268− (\_ -> return Nothing)
269− ]
270− unmonitor mRef
271− case mPid of
272− Nothing -> fail "spawn: remote node failed"
273− Just pid -> send pid () >> return pid
274−
275−-- | Spawn a process and link to it
276−--
277−-- Note that this is just the sequential composition of 'spawn' and 'link'.
278−-- (The "Unified" semantics that underlies Cloud Haskell does not even support
279−-- a synchronous link operation)
280−spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
281−spawnLink nid proc = do
282− pid <- spawn nid proc
283− link pid
284− return pid
285−
286−-- | Like 'spawnLink', but monitor the spawned process
287−spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
288−spawnMonitor nid proc = do
289− pid <- spawn nid proc
290− ref <- monitor pid
291− return (pid, ref)
292−
293−-- | Run a process remotely and wait for it to reply
294−--
295−-- We monitor the remote process; if it dies before it can send a reply, we die
296−-- too
297−call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
298−call dict nid proc = do
299− us <- getSelfPid
300− (_, mRef) <- spawnMonitor nid (proc `cpBind` cpSend dict us)
301− -- We are guaranteed to receive the reply before the monitor notification
302− -- (if a reply is sent at all)
303− -- NOTE: This might not be true if we switch to unreliable delivery.
304− mResult <- receiveWait
305− [ match (return . Right)
306− , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
307− (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))
308− ]
309− case mResult of
310− Right a -> unmonitor mRef >> return a
311− Left err -> fail $ "call: remote process died: " ++ show err
312−
313−-- | Spawn a child process, have the child link to the parent and the parent
314−-- monitor the child
315−spawnSupervised :: NodeId
316− -> Closure (Process ())
317− -> Process (ProcessId, MonitorRef)
318−spawnSupervised nid proc = do
319− us <- getSelfPid
320− them <- spawn nid (cpLink us `cpSeq` proc)
321− ref <- monitor them
322− return (them, ref)
323−
324−{-
325−spawnChannel :: forall a. Typeable a
326− => NodeId
327− -> Closure (ReceivePort a -> Process ())
328− -> Process (SendPort a)
329−spawnChannel nid proc = do
330− us <- getSelfPid
331− undefined
332− where
333− rproc :: ProcessId -> Closure (Process ((), ReceivePort a))
334− rproc pid = newChanClosure
335− `cpBind` cpFirst (sendClosure undefined pid)
336−-}
distributed-process/src/Control/Distributed/Process/Closure.hsdeleted−163
@@ -1,163 +0,0 @@
1−-- | Implementation of 'Closure' that works around the absence of 'static'.
2−--
3−-- [User-defined monomorphic closures]
4−--
5−-- Suppose we have a monomorphic function
6−--
7−-- > addInt :: Int -> Int -> Int
8−-- > addInt x y = x + y
9−--
10−-- Then the Template Haskell splice
11−--
12−-- > remotable ['addInt]
13−--
14−-- creates a function
15−--
16−-- > $(mkClosure 'addInt) :: Int -> Closure (Int -> Int)
17−--
18−-- which can be used to partially apply 'addInt' and turn it into a 'Closure',
19−-- which can be sent across the network. Closures can be deserialized with
20−--
21−-- > unClosure :: Typeable a => Closure a -> Process a
22−--
23−-- In general, given a monomorphic function @f :: T1 -> T2@ the corresponding
24−-- function @$(mkClosure 'f)@ will have type @T1 -> Closure T2@.
25−--
26−-- The call to 'remotable' will also generate a function
27−--
28−-- > __remoteTable :: RemoteTable -> RemoteTable
29−--
30−-- which can be used to construct the 'RemoteTable' used to initialize
31−-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,
32−-- and compose all created functions when initializing Cloud Haskell:
33−--
34−-- > let rtable = M1.__remoteTable
35−-- > . M2.__remoteTable
36−-- > . ...
37−-- > . Mn.__remoteTable
38−-- > $ initRemoteTable
39−--
40−-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.
41−--
42−-- [User-defined polymorphic closures]
43−--
44−-- Suppose we have a polymorphic function
45−--
46−-- > first :: forall a b. (a, b) -> a
47−-- > first (x, _) = x
48−--
49−-- Then the Template Haskell splice
50−--
51−-- > remotable ['first]
52−--
53−-- creates a function
54−--
55−-- > $(mkClosure 'first) :: forall a b. (Typeable a, Typeable b)
56−-- > => Closure (a -> b -> a)
57−--
58−-- In general, given a polymorphic function @f :: forall a1 .. an. T@ the
59−-- corresponding function @$(mkClosure 'f)@ will have type
60−-- @forall a1 .. an. (Typeable a1, .., Typeable an) => Closure T@.
61−--
62−-- [Built-in closures]
63−--
64−-- We offer a number of standard commonly useful closures.
65−--
66−-- [Closure combinators]
67−--
68−-- Closures combinators allow to create closures from other closures. For
69−-- example, 'spawnSupervised' is defined as follows:
70−--
71−-- > spawnSupervised :: NodeId
72−-- > -> Closure (Process ())
73−-- > -> Process (ProcessId, MonitorRef)
74−-- > spawnSupervised nid proc = do
75−-- > us <- getSelfPid
76−-- > them <- spawn nid (linkClosure us `cpSeq` proc)
77−-- > ref <- monitor them
78−-- > return (them, ref)
79−--
80−-- [Serializable Dictionaries]
81−--
82−-- Some functions (such as 'sendClosure' or 'returnClosure') require an
83−-- explicit (reified) serializable dictionary. To create such a dictionary do
84−--
85−-- > sdictInt :: SerializableDict Int
86−-- > sdictInt = SerializableDict
87−--
88−-- and then pass @'sdictInt@ to 'remotable'. This will fail if the
89−-- type is not serializable.
90−module Control.Distributed.Process.Closure
91− ( -- * User-defined closures
92− remotable
93− , mkStatic
94− , mkClosure
95− , functionSDict
96− -- * Static functionals
97− , staticConst
98− , staticCompose
99− , staticFirst
100− , staticSecond
101− , staticSplit
102− -- * Creating closures
103− , staticDecode
104− , staticClosure
105− , toClosure
106− -- * Closure versions of CH primitives
107− , cpLink
108− , cpUnlink
109− , cpSend
110− , cpExpect
111− , cpNewChan
112− -- * @Closure (Process a)@ as a not-quite-monad
113− , cpReturn
114− , cpBind
115− , cpSeq
116− -- * Serialization dictionaries (and their static versions)
117− , SerializableDict(..)
118− , staticApply
119− , sdictUnit
120− , sdictUnit__static
121− , sdictProcessId
122− , sdictProcessId__static
123− ) where
124−
125−import Control.Distributed.Process.Internal.Types
126− ( SerializableDict(..)
127− , staticApply
128− )
129−import Control.Distributed.Process.Internal.Closure.TH
130− ( remotable
131− , mkStatic
132− , functionSDict
133− )
134−import Control.Distributed.Process.Internal.Closure.Static
135− ( -- Static functionals
136− staticConst
137− , staticCompose
138− , staticFirst
139− , staticSecond
140− , staticSplit
141− -- Creating closures
142− , staticDecode
143− , staticClosure
144− , toClosure
145− -- Serialization dictionaries (and their static versions)
146− , sdictUnit
147− , sdictUnit__static
148− , sdictProcessId
149− , sdictProcessId__static
150− )
151−import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
152−import Control.Distributed.Process.Internal.Closure.CP
153− ( -- Closure versions of CH primitives
154− cpLink
155− , cpUnlink
156− , cpSend
157− , cpExpect
158− , cpNewChan
159− -- @Closure (Process a)@ as a not-quite-monad
160− , cpReturn
161− , cpBind
162− , cpSeq
163− )
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/CP.hsdeleted−245
@@ -1,245 +0,0 @@
1−-- | Combinator for process closures
2−{-# LANGUAGE MagicHash #-}
3−module Control.Distributed.Process.Internal.Closure.CP
4− ( -- * Closure versions of CH primitives
5− cpLink
6− , cpUnlink
7− , cpSend
8− , cpExpect
9− , cpNewChan
10− -- * @Closure (Process a)@ as a not-quite-monad
11− , cpReturn
12− , cpBind
13− , cpSeq
14− -- * Runtime support
15− , __remoteTable
16− ) where
17−
18−import Data.Binary (encode)
19−import Data.ByteString.Lazy (ByteString)
20−import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
21−import Control.Applicative ((<$>))
22−import Control.Monad (join)
23−import Control.Distributed.Process.Serializable (Serializable)
24−import Control.Distributed.Process.Internal.Types
25− ( Closure(Closure)
26− , SerializableDict(SerializableDict)
27− , Static(Static)
28− , Process
29− , staticApply
30− , staticDuplicate
31− , staticTypeOf
32− , typeOfStaticLabel
33− , ProcessId
34− , LocalNode(remoteTable)
35− , procMsg
36− , SendPort
37− , ReceivePort
38− )
39−import Control.Distributed.Process.Internal.Primitives
40− ( link
41− , unlink
42− , send
43− , expect
44− , newChan
45− )
46−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
47−import Control.Distributed.Process.Internal.MessageT (getLocalNode)
48−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
49−import Control.Distributed.Process.Internal.Closure.Static
50− ( staticCompose
51− , staticDecode
52− , staticClosure
53− , staticSplit
54− , staticConst
55− , staticUnit
56− , sdictProcessId
57− , sdictProcessId__static
58− )
59−import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
60−import Control.Distributed.Process.Internal.Dynamic
61− ( Dynamic(Dynamic)
62− , dynBind
63− , unsafeCoerce#
64− , dynTypeRep
65− )
66−
67−--------------------------------------------------------------------------------
68−-- Setup: A number of functions that we will pass to 'remotable' --
69−--------------------------------------------------------------------------------
70−
71−---- Type specializations of monadic operations on Processes -------------------
72−
73−returnProcess :: a -> Process a
74−returnProcess = return
75−
76−bindProcess :: Process a -> (a -> Process b) -> Process b
77−bindProcess = (>>=)
78−
79−joinProcess :: Process (Process a) -> Process a
80−joinProcess = join
81−
82−---- Variations on standard or CH functions with an explicit dictionary arg ----
83−
84−sendDict :: SerializableDict a -> ProcessId -> a -> Process ()
85−sendDict SerializableDict = send
86−
87−expectDict :: SerializableDict a -> Process a
88−expectDict SerializableDict = expect
89−
90−newChanDict :: SerializableDict a -> Process (SendPort a, ReceivePort a)
91−newChanDict SerializableDict = newChan
92−
93−---- Serialization dictionaries ------------------------------------------------
94−
95−-- | Specialized serialization dictionary required in 'cpBind'
96−sdictBind :: SerializableDict (ByteString, ByteString)
97−sdictBind = SerializableDict
98−
99−---- Some specialised processes necessary to implement the combinators ---------
100−
101−-- | Resolve a closure
102−unClosure :: Static a -> ByteString -> Process Dynamic
103−unClosure (Static label) env = do
104− rtable <- remoteTable <$> procMsg getLocalNode
105− case resolveClosure rtable label env of
106− Nothing -> fail "Derived.unClosure: resolveClosure failed"
107− Just dyn -> return dyn
108−
109−-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the
110−-- type of the first static argument (the value of that argument is not used)
111−unDynamic :: Static a -> Process Dynamic -> Process a
112−unDynamic (Static label) pdyn = do
113− Dynamic typ val <- pdyn
114− if typ == typeOfStaticLabel label
115− then return (unsafeCoerce# val)
116− else fail $ "unDynamic: cannot match "
117− ++ show typ
118− ++ " against expected type "
119− ++ show (typeOfStaticLabel label)
120−
121−-- | Dynamic bind
122−--
123−-- The first argument stops remotable from trying to generate a SerializableDict
124−-- for (Process Dynamic, Process Dynamic)
125−bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
126−bindDyn () (px, pf) = do
127− x <- px
128− f <- pf
129− case dynBind tyConProcess bindProcess x f of
130− Just dyn -> return dyn
131− Nothing -> fail $ "bindDyn: could not bind "
132− ++ show (dynTypeRep x)
133− ++ " to "
134− ++ show (dynTypeRep f)
135− where
136− tyConProcess :: TyCon
137− tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))
138−
139−---- Finally, the call to remotable --------------------------------------------
140−
141−remotable [ -- Monadic operations
142− 'returnProcess
143− , 'bindProcess
144− , 'joinProcess
145− -- CH primitives
146− , 'link
147− , 'unlink
148− -- Explicit dictionaries
149− , 'sendDict
150− , 'expectDict
151− , 'newChanDict
152− -- Serialization dictionaries
153− , 'sdictBind
154− -- Specialized processes
155− , 'unClosure
156− , 'unDynamic
157− , 'bindDyn
158− ]
159−
160−--------------------------------------------------------------------------------
161−-- Closure versions of CH primitives --
162−--------------------------------------------------------------------------------
163−
164−-- | Closure version of 'link'
165−cpLink :: ProcessId -> Closure (Process ())
166−cpLink = $(mkClosure 'link)
167−
168−-- | Closure version of 'unlink'
169−cpUnlink :: ProcessId -> Closure (Process ())
170−cpUnlink = $(mkClosure 'unlink)
171−
172−-- | Closure version of 'send'
173−cpSend :: forall a. Typeable a
174− => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())
175−cpSend dict pid = Closure decoder (encode pid)
176− where
177− decoder :: Static (ByteString -> a -> Process ())
178− decoder = ($(mkStatic 'sendDict) `staticApply` dict)
179− `staticCompose`
180− staticDecode $(mkStatic 'sdictProcessId)
181−
182−-- | Closure version of 'expect'
183−cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
184−cpExpect dict = staticClosure ($(mkStatic 'expectDict) `staticApply` dict)
185−
186−-- | Closure version of 'newChan'
187−cpNewChan :: Typeable a
188− => Static (SerializableDict a)
189− -> Closure (Process (SendPort a, ReceivePort a))
190−cpNewChan dict = staticClosure ($(mkStatic 'newChanDict) `staticApply` dict)
191−
192−--------------------------------------------------------------------------------
193−-- (Closure . Process) as a not-quite-monad --
194−--------------------------------------------------------------------------------
195−
196−-- | Not-quite-monadic 'return'
197−cpReturn :: forall a. Serializable a
198− => Static (SerializableDict a) -> a -> Closure (Process a)
199−cpReturn dict x = Closure decoder (encode x)
200− where
201− decoder :: Static (ByteString -> Process a)
202− decoder = $(mkStatic 'returnProcess)
203− `staticCompose`
204− staticDecode dict
205−
206−
207−staticUnclosure :: Typeable a
208− => Static a -> Static (ByteString -> Process Dynamic)
209−staticUnclosure s =
210− $(mkStatic 'unClosure) `staticApply` staticDuplicate s
211−
212−staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)
213−staticUndynamic =
214− $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))
215−
216−staticBindDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
217−staticBindDyn = $(mkStatic 'bindDyn) `staticApply` staticUnit
218−
219−-- | Not-quite-monadic bind ('>>=')
220−cpBind :: forall a b. (Typeable a, Typeable b)
221− => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
222−cpBind (Closure xstatic xenv) (Closure fstatic fenv) =
223− Closure decoder (encode (xenv, fenv))
224− where
225− decoder :: Static (ByteString -> Process b)
226− decoder = $(mkStatic 'joinProcess)
227− `staticCompose`
228− staticUndynamic
229− `staticCompose`
230− staticBindDyn
231− `staticCompose`
232− (staticUnclosure xstatic `staticSplit` staticUnclosure fstatic)
233− `staticCompose`
234− staticDecode $(mkStatic 'sdictBind)
235−
236−cpIntro :: forall a b. (Typeable a, Typeable b)
237− => Closure (Process b) -> Closure (a -> Process b)
238−cpIntro (Closure static env) = Closure decoder env
239− where
240− decoder :: Static (ByteString -> a -> Process b)
241− decoder = staticConst `staticCompose` static
242−
243−-- | Monadic sequencing ('>>')
244−cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())
245−cpSeq p q = p `cpBind` cpIntro q
distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure) where
3−
4−import Data.Binary (encode)
5−import Language.Haskell.TH (Q, Exp, Name)
6−import Control.Distributed.Process.Internal.Types (Closure(Closure))
7−import Control.Distributed.Process.Internal.Closure.TH
8− ( mkStatic
9− , functionSDict
10− )
11−import Control.Distributed.Process.Internal.Closure.Static
12− ( staticCompose
13− , staticDecode
14− )
15−
16−mkClosure :: Name -> Q Exp
17−mkClosure n =
18− [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
19− . encode
20− |]
distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hsdeleted−34
@@ -1,34 +0,0 @@
1−{-# LANGUAGE MagicHash #-}
2−module Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure) where
3−
4−import Data.Accessor ((^.))
5−import Data.ByteString.Lazy (ByteString)
6−import Control.Distributed.Process.Internal.Types
7− ( RemoteTable
8− , remoteTableLabel
9− , Static(Static)
10− , StaticLabel(..)
11− )
12−import Control.Distributed.Process.Internal.Dynamic
13− ( Dynamic(Dynamic)
14− , toDyn
15− , dynApply
16− , unsafeCoerce#
17− )
18−import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
19−
20−resolveStatic :: RemoteTable -> StaticLabel -> Maybe Dynamic
21−resolveStatic rtable (StaticLabel string typ) = do
22− Dynamic _ val <- rtable ^. remoteTableLabel string
23− return (Dynamic typ val)
24−resolveStatic rtable (StaticApply static1 static2) = do
25− f <- resolveStatic rtable static1
26− x <- resolveStatic rtable static2
27− f `dynApply` x
28−resolveStatic _rtable (StaticDuplicate static typ) =
29− return $ Dynamic typ (unsafeCoerce# (Static static))
30−
31−resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
32−resolveClosure rtable static env = do
33− decoder <- resolveStatic rtable static
34− decoder `dynApply` toDyn env
distributed-process/src/Control/Distributed/Process/Internal/Closure/Static.hsdeleted−153
@@ -1,153 +0,0 @@
1−-- | Combinators on static values
2−{-# LANGUAGE MagicHash #-}
3−module Control.Distributed.Process.Internal.Closure.Static
4− ( -- * Static functionals
5− staticConst
6− , staticCompose
7− , staticFirst
8− , staticSecond
9− , staticSplit
10− -- * Static constants
11− , staticUnit
12− -- * Creating closures
13− , staticDecode
14− , staticClosure
15− , toClosure
16− -- * Serialization dictionaries (and their static versions)
17− , sdictUnit
18− , sdictUnit__static
19− , sdictProcessId
20− , sdictProcessId__static
21− -- * Runtime support
22− , __remoteTable
23− ) where
24−
25−import Data.Binary (encode, decode)
26−import Data.ByteString.Lazy (ByteString, empty)
27−import Data.Typeable (Typeable)
28−import Control.Distributed.Process.Serializable (Serializable)
29−import Control.Distributed.Process.Internal.Types
30− ( Closure(Closure)
31− , SerializableDict(SerializableDict)
32− , Static
33− , staticApply
34− , ProcessId
35− )
36−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
37−import qualified Control.Arrow as Arrow (first, second, (***))
38−
39−--------------------------------------------------------------------------------
40−-- Setup: A number of functions that we will pass to 'remotable' --
41−--------------------------------------------------------------------------------
42−
43−---- Functionals ---------------------------------------------------------------
44−
45−compose :: (b -> c) -> (a -> b) -> a -> c
46−compose = (.)
47−
48−first :: (a -> b) -> (a, c) -> (b, c)
49−first = Arrow.first
50−
51−second :: (a -> b) -> (c, a) -> (c, b)
52−second = Arrow.second
53−
54−split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
55−split = (Arrow.***)
56−
57−---- Constants -----------------------------------------------------------------
58−
59−unit :: ()
60−unit = ()
61−
62−---- Variations on standard or CH functions with an explicit dictionary arg ----
63−
64−decodeDict :: SerializableDict a -> ByteString -> a
65−decodeDict SerializableDict = decode
66−
67−---- Serialization dictionaries ------------------------------------------------
68−
69−-- | Serialization dictionary for '()'
70−--
71−-- Use @$(mkStatic sdictUnit)@ (instead of 'sdictUnit__static')
72−-- to refer to the static dictionary.
73−sdictUnit :: SerializableDict ()
74−sdictUnit = SerializableDict
75−
76−-- | Serialization dictionary for 'ProcessId'
77−--
78−-- Use @$(mkStatic sdictProcessId)@ (instead of 'sdictProcessId__static')
79−-- to refer to the static dictionary.
80−sdictProcessId :: SerializableDict ProcessId
81−sdictProcessId = SerializableDict
82−
83−---- Finally, the call to remotable --------------------------------------------
84−
85−remotable [ -- Functionals (predefined)
86− 'const
87− -- Functionals (defined above)
88− , 'compose
89− , 'first
90− , 'second
91− , 'split
92− -- Constants
93− , 'unit
94− -- Explicit dictionaries
95− , 'decodeDict
96− -- Serialization dictionaries
97− , 'sdictUnit
98− , 'sdictProcessId
99− ]
100−
101−--------------------------------------------------------------------------------
102−-- Static versions of the functionals --
103−-- (We give these explicit names because they are useful outside this module) --
104−--------------------------------------------------------------------------------
105−
106−-- | Static version of 'const'
107−staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)
108−staticConst = $(mkStatic 'const)
109−
110−-- | Static version of ('Prelude..')
111−staticCompose :: (Typeable a, Typeable b, Typeable c)
112− => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
113−staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x
114−
115−-- | Static version of 'Control.Arrow.first'
116−staticFirst :: (Typeable a, Typeable b, Typeable c)
117− => Static ((a -> b) -> (a, c) -> (b, c))
118−staticFirst = $(mkStatic 'first)
119−
120−-- | Static version of 'Control.Arrow.second'
121−staticSecond :: (Typeable a, Typeable b, Typeable c)
122− => Static ((a -> b) -> (c, a) -> (c, b))
123−staticSecond = $(mkStatic 'second)
124−
125−-- | Static version of ('Control.Arrow.***')
126−staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
127− => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))
128−staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g
129−
130−--------------------------------------------------------------------------------
131−-- Constants --
132−--------------------------------------------------------------------------------
133−
134−-- | Static version of '()'
135−staticUnit :: Static ()
136−staticUnit = $(mkStatic 'unit)
137−
138−--------------------------------------------------------------------------------
139−-- Creating closures --
140−--------------------------------------------------------------------------------
141−
142−staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
143−staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
144−
145−staticClosure :: forall a. Typeable a => Static a -> Closure a
146−staticClosure static = Closure decoder empty
147− where
148− decoder :: Static (ByteString -> a)
149− decoder = staticConst `staticApply` static
150−
151−toClosure :: forall a. Serializable a
152− => Static (SerializableDict a) -> a -> Closure a
153−toClosure dict x = Closure (staticDecode dict) (encode x)
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hsdeleted−204
@@ -1,204 +0,0 @@
1−-- | Template Haskell support
2−--
3−-- (In a separate file for convenience)
4−{-# LANGUAGE MagicHash #-}
5−module Control.Distributed.Process.Internal.Closure.TH
6− ( -- * User-level API
7− remotable
8− , mkStatic
9− , functionSDict
10− ) where
11−
12−import Prelude hiding (lookup)
13−import Data.Accessor ((^=))
14−import Data.Typeable (typeOf)
15−import Control.Applicative ((<$>))
16−import Language.Haskell.TH
17− ( -- Q monad and operations
18− Q
19− , reify
20− -- Names
21− , Name
22− , mkName
23− , nameBase
24− -- Algebraic data types
25− , Dec
26− , Exp
27− , Type(AppT, ForallT, VarT, ArrowT)
28− , Info(VarI)
29− , TyVarBndr(PlainTV, KindedTV)
30− , Pred(ClassP)
31− -- Lifted constructors
32− -- .. Literals
33− , stringL
34− -- .. Patterns
35− , normalB
36− , clause
37− -- .. Expressions
38− , varE
39− , litE
40− -- .. Top-level declarations
41− , funD
42− , sigD
43− )
44−import Control.Distributed.Process.Internal.Types
45− ( RemoteTable
46− , Static(Static)
47− , StaticLabel(StaticLabel)
48− , remoteTableLabel
49− , SerializableDict(SerializableDict)
50− )
51−import Control.Distributed.Process.Internal.Dynamic
52− ( Dynamic(..)
53− , unsafeCoerce#
54− , toDyn
55− )
56−
57−--------------------------------------------------------------------------------
58−-- User-level API --
59−--------------------------------------------------------------------------------
60−
61−-- | Create the closure, decoder, and metadata definitions for the given list
62−-- of functions
63−remotable :: [Name] -> Q [Dec]
64−remotable ns = do
65− (closures, inserts) <- unzip <$> mapM generateDefs ns
66− rtable <- createMetaData (concat inserts)
67− return $ concat closures ++ rtable
68−
69−-- | Construct a static value
70−mkStatic :: Name -> Q Exp
71−mkStatic = varE . staticName
72−
73−-- | Serialization dictionary for a function argument (see module header)
74−functionSDict :: Name -> Q Exp
75−functionSDict = varE . sdictName
76−
77−{-
78−-- | Create a closure
79−--
80−-- See module documentation header for "Control.Distributed.Process.Closure"
81−-- for a detailed explanation and examples.
82−mkClosure :: Name -> Q Exp
83−mkClosure = varE . closureName
84−-}
85−
86−--------------------------------------------------------------------------------
87−-- Internal (Template Haskell) --
88−--------------------------------------------------------------------------------
89−
90−-- | Generate the code to add the metadata to the CH runtime
91−createMetaData :: [Q Exp] -> Q [Dec]
92−createMetaData is =
93− [d| __remoteTable :: RemoteTable -> RemoteTable ;
94− __remoteTable = $(compose is)
95− |]
96−
97−generateDefs :: Name -> Q ([Dec], [Q Exp])
98−generateDefs n = do
99− mType <- getType n
100− case mType of
101− Just (origName, typ) -> do
102− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
103− _ -> ([], typ)
104− (static, register) <- do
105− static <- generateStatic origName typVars typ'
106− let dyn = case typVars of
107− [] -> [| toDyn $(varE origName) |]
108− _ -> [| Dynamic (error "Polymorphic value")
109− (unsafeCoerce# $(varE origName))
110− |]
111− return ( static
112− , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
113− )
114−
115− (sdict, registerSDict) <- case (typVars, typ') of
116− ([], ArrowT `AppT` arg `AppT` _res) -> do
117− -- TODO: we should check if arg is an instance of Serializable, but we cannot
118− -- http://hackage.haskell.org/trac/ghc/ticket/7066
119− sdict <- generateSDict origName arg
120− let dyn' = [| toDyn (SerializableDict
121− :: SerializableDict $(return arg)
122− )
123− |]
124− return ( sdict
125− , [ [| registerStatic $(stringE (show (sdictName origName)))
126− $dyn'
127− |] ]
128− )
129− _ ->
130− return ([], [])
131−
132− return ( static ++ sdict
133− , register ++ registerSDict
134− )
135− _ ->
136− fail $ "remotable: " ++ show n ++ " not found"
137−
138−registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
139−registerStatic label dyn = remoteTableLabel label ^= Just dyn
140−
141−-- | Generate a static value
142−generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
143−generateStatic n xs typ = do
144− staticTyp <- [t| Static |]
145− sequence
146− [ sigD (staticName n) $
147− return (ForallT xs
148− (map typeable xs)
149− (staticTyp `AppT` typ)
150− )
151− , sfnD (staticName n)
152− [| Static $ StaticLabel
153− $(stringE (show n))
154− (typeOf (undefined :: $(return typ)))
155− |]
156− ]
157− where
158− typeable :: TyVarBndr -> Pred
159− typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
160− typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
161−
162−-- | Generate a function serialization dictionary
163−generateSDict :: Name -> Type -> Q [Dec]
164−generateSDict n typ = do
165− sequence
166− [ sigD (sdictName n) $ [t| Static (SerializableDict $(return typ)) |]
167− , sfnD (sdictName n)
168− [| Static $ StaticLabel
169− $(stringE (show (sdictName n)))
170− (typeOf (undefined :: SerializableDict $(return typ)))
171− |]
172− ]
173−
174−staticName :: Name -> Name
175−staticName n = mkName $ nameBase n ++ "__static"
176−
177−sdictName :: Name -> Name
178−sdictName n = mkName $ nameBase n ++ "__sdict"
179−
180−--------------------------------------------------------------------------------
181−-- Generic Template Haskell auxiliary functions --
182−--------------------------------------------------------------------------------
183−
184−-- | Compose a set of expressions
185−compose :: [Q Exp] -> Q Exp
186−compose [] = [| id |]
187−compose [e] = e
188−compose (e:es) = [| $e . $(compose es) |]
189−
190−-- | Literal string as an expression
191−stringE :: String -> Q Exp
192−stringE = litE . stringL
193−
194−-- | Look up the "original name" (module:name) and type of a top-level function
195−getType :: Name -> Q (Maybe (Name, Type))
196−getType name = do
197− info <- reify name
198− case info of
199− VarI origName typ _ _ -> return $ Just (origName, typ)
200− _ -> return Nothing
201−
202−-- | Variation on 'funD' which takes a single expression to define the function
203−sfnD :: Name -> Q Exp -> Q Dec
204−sfnD n e = funD n [clause [] (normalB e) []]
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hsdeleted−81
@@ -1,81 +0,0 @@
1−-- | Reimplementation of Dynamic that supports dynBind
2−--
3−-- We don't have access to the internal representation of Dynamic, otherwise
4−-- we would not have to redefine it completely. Note that we use this only
5−-- internally, so the incompatibility with "our" Dynamic from the standard
6−-- Dynamic is not important.
7−{-# LANGUAGE MagicHash #-}
8−module Control.Distributed.Process.Internal.Dynamic
9− ( Dynamic(..)
10− , toDyn
11− , fromDyn
12− , fromDynamic
13− , dynTypeRep
14− , dynApply
15− , dynApp
16− , dynBind
17− , dynBind'
18− , GHC.unsafeCoerce#
19− ) where
20−
21−import Data.Typeable
22− ( Typeable
23− , TypeRep
24− , typeOf
25− , funResultTy
26− , TyCon
27− , splitTyConApp
28− )
29−import qualified GHC.Prim as GHC (Any, unsafeCoerce#)
30−import Data.Maybe (fromMaybe)
31−
32−data Dynamic = Dynamic TypeRep GHC.Any
33− deriving Typeable
34−
35−toDyn :: Typeable a => a -> Dynamic
36−toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)
37−
38−fromDyn :: Typeable a => Dynamic -> a -> a
39−fromDyn (Dynamic rep val) a =
40− if rep == typeOf a
41− then GHC.unsafeCoerce# val
42− else a
43−
44−fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a
45−fromDynamic (Dynamic rep val) =
46− if rep == typeOf (undefined :: a)
47− then Just (GHC.unsafeCoerce# val)
48− else Nothing
49−
50−dynTypeRep :: Dynamic -> TypeRep
51−dynTypeRep (Dynamic t _) = t
52−
53−instance Show Dynamic where
54− show = show . dynTypeRep
55−
56−dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
57−dynApply (Dynamic t1 f) (Dynamic t2 x) =
58− case funResultTy t1 t2 of
59− Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))
60− Nothing -> Nothing
61−
62−dynApp :: Dynamic -> Dynamic -> Dynamic
63−dynApp f x = fromMaybe (error typeError) (dynApply f x)
64− where
65− typeError = "Type error in dynamic application.\n"
66− ++ "Can't apply function " ++ show f
67− ++ " to argument " ++ show x
68−
69−dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic
70−dynBind m bind (Dynamic t1 x) (Dynamic t2 f) =
71− case splitTyConApp t1 of
72− (m', [a]) | m' == m ->
73− case funResultTy t2 a of
74− Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))
75− _ -> Nothing
76− _ -> Nothing
77−
78−dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic
79−dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)
80− where
81− typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f
distributed-process/src/Control/Distributed/Process/Internal/MessageT.hsdeleted−130
@@ -1,130 +0,0 @@
1−-- | Add message sending capability to a monad
2−--
3−-- NOTE: Not thread-safe (you should not do concurrent sends within the same
4−-- monad).
5−module Control.Distributed.Process.Internal.MessageT
6− ( MessageT
7− , runMessageT
8− , getLocalNode
9− , sendPayload
10− , sendBinary
11− , sendMessage
12− , payloadToMessage
13− , createMessage
14− ) where
15−
16−import Data.Binary (Binary, encode)
17−import qualified Data.ByteString as BSS (ByteString)
18−import qualified Data.ByteString.Lazy as BSL (toChunks)
19−import Data.Map (Map)
20−import qualified Data.Map as Map (empty)
21−import Data.Accessor (Accessor, accessor, (^=), (^.))
22−import qualified Data.Accessor.Container as DAC (mapMaybe)
23−import Control.Category ((>>>))
24−import Control.Monad (unless, liftM)
25−import Control.Monad.State (gets, modify, evalStateT)
26−import Control.Monad.IO.Class (MonadIO, liftIO)
27−import Control.Concurrent.Chan (writeChan)
28−import Control.Distributed.Process.Internal.Types
29− ( Identifier(..)
30− , nodeOf
31− , NodeId(nodeAddress)
32− , LocalNode(localCtrlChan, localEndPoint)
33− , NCMsg(NCMsg, ctrlMsgSender, ctrlMsgSignal)
34− , DiedReason(DiedDisconnect)
35− , ProcessSignal(Died)
36− , MessageT(..)
37− , MessageState(..)
38− , createMessage
39− , messageToPayload
40− , payloadToMessage
41− )
42−import Control.Distributed.Process.Serializable (Serializable)
43−import qualified Network.Transport as NT
44− ( EndPoint
45− , Connection
46− , connect
47− , send
48− , Reliability(ReliableOrdered)
49− , defaultConnectHints
50− )
51−
52−--------------------------------------------------------------------------------
53−-- API --
54−--------------------------------------------------------------------------------
55−
56−runMessageT :: Monad m => LocalNode -> MessageT m a -> m a
57−runMessageT localNode m =
58− evalStateT (unMessageT m) $ initMessageState localNode
59−
60−getLocalNode :: Monad m => MessageT m LocalNode
61−getLocalNode = gets messageLocalNode
62−
63−sendPayload :: MonadIO m => Identifier -> [BSS.ByteString] -> MessageT m ()
64−sendPayload them payload = do
65− mConn <- connTo them
66− didSend <- case mConn of
67− Just conn -> do
68− didSend <- liftIO $ NT.send conn payload
69− case didSend of
70− Left _ -> return False
71− Right _ -> return True
72− Nothing -> return False
73− unless didSend $ do
74− node <- getLocalNode
75− liftIO . writeChan (localCtrlChan node) $ NCMsg
76− { ctrlMsgSender = them
77− , ctrlMsgSignal = Died them DiedDisconnect
78− }
79−
80−sendBinary :: (MonadIO m, Binary a) => Identifier -> a -> MessageT m ()
81−sendBinary them = sendPayload them . BSL.toChunks . encode
82−
83−sendMessage :: (MonadIO m, Serializable a) => Identifier -> a -> MessageT m ()
84−sendMessage them = sendPayload them . messageToPayload . createMessage
85−
86−--------------------------------------------------------------------------------
87−-- Internal --
88−--------------------------------------------------------------------------------
89−
90−initMessageState :: LocalNode -> MessageState
91−initMessageState localNode = MessageState {
92− messageLocalNode = localNode
93− , _messageConnections = Map.empty
94− }
95−
96−setupConnTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
97−setupConnTo them = do
98− endPoint <- localEndPoint `liftM` getLocalNode
99− mConn <- liftIO $ NT.connect endPoint
100− (nodeAddress . nodeOf $ them)
101− NT.ReliableOrdered
102− NT.defaultConnectHints
103− case mConn of
104− Right conn -> do
105− didSend <- liftIO $ NT.send conn (BSL.toChunks . encode $ them)
106− case didSend of
107− Left _ ->
108− return Nothing
109− Right () -> do
110− modify $ messageConnectionTo them ^= Just conn
111− return $ Just conn
112− Left _ ->
113− return Nothing
114−
115−connTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
116−connTo them = do
117− mConn <- gets (^. messageConnectionTo them)
118− case mConn of
119− Just conn -> return $ Just conn
120− Nothing -> setupConnTo them
121−
122−--------------------------------------------------------------------------------
123−-- Accessors --
124−--------------------------------------------------------------------------------
125−
126−messageConnections :: Accessor MessageState (Map Identifier NT.Connection)
127−messageConnections = accessor _messageConnections (\conns st -> st { _messageConnections = conns })
128−
129−messageConnectionTo :: Identifier -> Accessor MessageState (Maybe NT.Connection)
130−messageConnectionTo them = messageConnections >>> DAC.mapMaybe them
distributed-process/src/Control/Distributed/Process/Internal/Node.hsdeleted−16
@@ -1,16 +0,0 @@
1−module Control.Distributed.Process.Internal.Node
2− ( runLocalProcess
3− ) where
4−
5−import Control.Monad.Reader (runReaderT)
6−import Control.Distributed.Process.Internal.Types
7− ( LocalNode
8− , LocalProcess
9− , Process(unProcess)
10− )
11−import Control.Distributed.Process.Internal.MessageT (runMessageT)
12−
13−-- | Deconstructor for 'Process' (not exported to the public API)
14−runLocalProcess :: LocalNode -> Process a -> LocalProcess -> IO a
15−runLocalProcess node proc = runMessageT node . runReaderT (unProcess proc)
16−
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hsdeleted−517
@@ -1,517 +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− , whereisRemote
42− , whereisRemoteAsync
43− , nsendRemote
44− -- * Closures
45− , unClosure
46− -- * Auxiliary API
47− , catch
48− , expectTimeout
49− , spawnAsync
50− , linkNode
51− , linkPort
52− , unlinkNode
53− , unlinkPort
54− , monitorNode
55− , monitorPort
56− ) where
57−
58−import Prelude hiding (catch)
59−import Data.Binary (decode)
60−import Data.Typeable (Typeable, typeOf)
61−import Data.Time.Clock (getCurrentTime)
62−import Data.Time.Format (formatTime)
63−import System.Locale (defaultTimeLocale)
64−import Control.Monad.Reader (ask)
65−import Control.Monad.IO.Class (MonadIO, liftIO)
66−import Control.Applicative ((<$>))
67−import Control.Exception (Exception, throw)
68−import qualified Control.Exception as Exception (catch)
69−import Control.Concurrent.MVar (modifyMVar)
70−import Control.Concurrent.Chan (writeChan)
71−import Control.Concurrent.STM
72− ( STM
73− , atomically
74− , orElse
75− , newTChan
76− , readTChan
77− , newTVar
78− , readTVar
79− , writeTVar
80− )
81−import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..))
82−import Control.Distributed.Process.Serializable (Serializable, fingerprint)
83−import Data.Accessor ((^.), (^:), (^=))
84−import Control.Distributed.Process.Internal.Types
85− ( NodeId(..)
86− , ProcessId(..)
87− , LocalNode(..)
88− , LocalProcess(..)
89− , Process(..)
90− , Closure(..)
91− , Message(..)
92− , MonitorRef(..)
93− , SpawnRef(..)
94− , NCMsg(..)
95− , ProcessSignal(..)
96− , monitorCounter
97− , spawnCounter
98− , Closure(..)
99− , SendPort(..)
100− , ReceivePort(..)
101− , channelCounter
102− , typedChannelWithId
103− , TypedChannel(..)
104− , SendPortId(..)
105− , Identifier(..)
106− , procMsg
107− , DidUnmonitor(..)
108− , DidUnlinkProcess(..)
109− , DidUnlinkNode(..)
110− , DidUnlinkPort(..)
111− , WhereIsReply(..)
112− , createMessage
113− , Static(..)
114− )
115−import Control.Distributed.Process.Internal.MessageT
116− ( sendMessage
117− , sendBinary
118− , getLocalNode
119− )
120−import Control.Distributed.Process.Internal.Node (runLocalProcess)
121−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
122−import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
123−
124−--------------------------------------------------------------------------------
125−-- Basic messaging --
126−--------------------------------------------------------------------------------
127−
128−-- | Send a message
129−send :: Serializable a => ProcessId -> a -> Process ()
130−-- This requires a lookup on every send. If we want to avoid that we need to
131−-- modify serializable to allow for stateful (IO) deserialization
132−send them msg = procMsg $ sendMessage (ProcessIdentifier them) msg
133−
134−-- | Wait for a message of a specific type
135−expect :: forall a. Serializable a => Process a
136−expect = receiveWait [match return]
137−
138−--------------------------------------------------------------------------------
139−-- Channels --
140−--------------------------------------------------------------------------------
141−
142−-- | Create a new typed channel
143−newChan :: Serializable a => Process (SendPort a, ReceivePort a)
144−newChan = do
145− proc <- ask
146− liftIO . modifyMVar (processState proc) $ \st -> do
147− chan <- liftIO . atomically $ newTChan
148− let lcid = st ^. channelCounter
149− cid = SendPortId { sendPortProcessId = processId proc
150− , sendPortLocalId = lcid
151− }
152− sport = SendPort cid
153− rport = ReceivePortSingle chan
154− tch = TypedChannel chan
155− return ( (channelCounter ^: (+ 1))
156− . (typedChannelWithId lcid ^= Just tch)
157− $ st
158− , (sport, rport)
159− )
160−
161−-- | Send a message on a typed channel
162−sendChan :: Serializable a => SendPort a -> a -> Process ()
163−sendChan (SendPort cid) msg = procMsg $ sendBinary (SendPortIdentifier cid) msg
164−
165−-- | Wait for a message on a typed channel
166−receiveChan :: Serializable a => ReceivePort a -> Process a
167−receiveChan = liftIO . atomically . receiveSTM
168− where
169− receiveSTM :: ReceivePort a -> STM a
170− receiveSTM (ReceivePortSingle c) =
171− readTChan c
172− receiveSTM (ReceivePortBiased ps) =
173− foldr1 orElse (map receiveSTM ps)
174− receiveSTM (ReceivePortRR psVar) = do
175− ps <- readTVar psVar
176− a <- foldr1 orElse (map receiveSTM ps)
177− writeTVar psVar (rotate ps)
178− return a
179−
180− rotate :: [a] -> [a]
181− rotate [] = []
182− rotate (x:xs) = xs ++ [x]
183−
184−-- | Merge a list of typed channels.
185−--
186−-- The result port is left-biased: if there are messages available on more
187−-- than one port, the first available message is returned.
188−mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
189−mergePortsBiased = return . ReceivePortBiased
190−
191−-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than
192−-- left-biased)
193−mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
194−mergePortsRR ps = liftIO . atomically $ ReceivePortRR <$> newTVar ps
195−
196−--------------------------------------------------------------------------------
197−-- Advanced messaging --
198−--------------------------------------------------------------------------------
199−
200−-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
201−newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }
202−
203−-- | Test the matches in order against each message in the queue
204−receiveWait :: [Match b] -> Process b
205−receiveWait ms = do
206− queue <- processQueue <$> ask
207− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
208− proc
209−
210−-- | Like 'receiveWait' but with a timeout.
211−--
212−-- If the timeout is zero do a non-blocking check for matching messages. A
213−-- non-zero timeout is applied only when waiting for incoming messages (that is,
214−-- /after/ we have checked the messages that are already in the mailbox).
215−receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
216−receiveTimeout t ms = do
217− queue <- processQueue <$> ask
218− let blockSpec = if t == 0 then NonBlocking else Timeout t
219− mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)
220− case mProc of
221− Nothing -> return Nothing
222− Just proc -> Just <$> proc
223−
224−-- | Match against any message of the right type
225−match :: forall a b. Serializable a => (a -> Process b) -> Match b
226−match = matchIf (const True)
227−
228−-- | Match against any message of the right type that satisfies a predicate
229−matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
230−matchIf c p = Match $ \msg ->
231− let decoded :: a
232− decoded = decode . messageEncoding $ msg in
233− if messageFingerprint msg == fingerprint (undefined :: a) && c decoded
234− then Just $ p decoded
235− else Nothing
236−
237−-- | Remove any message from the queue
238−matchUnknown :: Process b -> Match b
239−matchUnknown = Match . const . Just
240−
241−--------------------------------------------------------------------------------
242−-- Process management --
243−--------------------------------------------------------------------------------
244−
245−-- | Thrown by 'terminate'
246−data ProcessTerminationException = ProcessTerminationException
247− deriving (Show, Typeable)
248−
249−instance Exception ProcessTerminationException
250−
251−-- | Terminate (throws a ProcessTerminationException)
252−terminate :: Process a
253−terminate = liftIO $ throw ProcessTerminationException
254−
255−-- | Our own process ID
256−getSelfPid :: Process ProcessId
257−getSelfPid = processId <$> ask
258−
259−-- | Get the node ID of our local node
260−getSelfNode :: Process NodeId
261−getSelfNode = localNodeId <$> procMsg getLocalNode
262−
263−--------------------------------------------------------------------------------
264−-- Monitoring and linking --
265−--------------------------------------------------------------------------------
266−
267−-- | Link to a remote process (asynchronous)
268−--
269−-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').
270−-- Linking makes no distinction between normal and abnormal termination of
271−-- the remote process.
272−link :: ProcessId -> Process ()
273−link = sendCtrlMsg Nothing . Link . ProcessIdentifier
274−
275−-- | Monitor another process (asynchronous)
276−monitor :: ProcessId -> Process MonitorRef
277−monitor = monitor' . ProcessIdentifier
278−
279−-- | Remove a link (synchronous)
280−unlink :: ProcessId -> Process ()
281−unlink pid = do
282− unlinkAsync pid
283− receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
284− (\_ -> return ())
285− ]
286−
287−-- | Remove a node link (synchronous)
288−unlinkNode :: NodeId -> Process ()
289−unlinkNode nid = do
290− unlinkNodeAsync nid
291− receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)
292− (\_ -> return ())
293− ]
294−
295−-- | Remove a channel (send port) link (synchronous)
296−unlinkPort :: SendPort a -> Process ()
297−unlinkPort sport = do
298− unlinkPortAsync sport
299− receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)
300− (\_ -> return ())
301− ]
302−
303−-- | Remove a monitor (synchronous)
304−unmonitor :: MonitorRef -> Process ()
305−unmonitor ref = do
306− unmonitorAsync ref
307− receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)
308− (\_ -> return ())
309− ]
310−
311−--------------------------------------------------------------------------------
312−-- Auxiliary API --
313−--------------------------------------------------------------------------------
314−
315−-- | Catch exceptions within a process
316−catch :: Exception e => Process a -> (e -> Process a) -> Process a
317−catch p h = do
318− node <- procMsg getLocalNode
319− lproc <- ask
320− let run :: Process a -> IO a
321− run proc = runLocalProcess node proc lproc
322− liftIO $ Exception.catch (run p) (run . h)
323−
324−-- | Like 'expect' but with a timeout
325−expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
326−expectTimeout timeout = receiveTimeout timeout [match return]
327−
328−-- | Asynchronous version of 'spawn'
329−--
330−-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
331−spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
332−spawnAsync nid proc = do
333− spawnRef <- getSpawnRef
334− sendCtrlMsg (Just nid) $ Spawn proc spawnRef
335− return spawnRef
336−
337−-- | Monitor a node
338−monitorNode :: NodeId -> Process MonitorRef
339−monitorNode =
340− monitor' . NodeIdentifier
341−
342−-- | Monitor a typed channel
343−monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
344−monitorPort (SendPort cid) =
345− monitor' (SendPortIdentifier cid)
346−
347−-- | Remove a monitor (asynchronous)
348−unmonitorAsync :: MonitorRef -> Process ()
349−unmonitorAsync =
350− sendCtrlMsg Nothing . Unmonitor
351−
352−-- | Link to a node
353−linkNode :: NodeId -> Process ()
354−linkNode = link' . NodeIdentifier
355−
356−-- | Link to a channel (send port)
357−linkPort :: SendPort a -> Process ()
358−linkPort (SendPort cid) =
359− link' (SendPortIdentifier cid)
360−
361−-- | Remove a process link (asynchronous)
362−unlinkAsync :: ProcessId -> Process ()
363−unlinkAsync =
364− sendCtrlMsg Nothing . Unlink . ProcessIdentifier
365−
366−-- | Remove a node link (asynchronous)
367−unlinkNodeAsync :: NodeId -> Process ()
368−unlinkNodeAsync =
369− sendCtrlMsg Nothing . Unlink . NodeIdentifier
370−
371−-- | Remove a channel (send port) link (asynchronous)
372−unlinkPortAsync :: SendPort a -> Process ()
373−unlinkPortAsync (SendPort cid) =
374− sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
375−
376−--------------------------------------------------------------------------------
377−-- Logging --
378−--------------------------------------------------------------------------------
379−
380−-- | Log a string
381−--
382−-- @say message@ sends a message (time, pid of the current process, message)
383−-- to the process registered as 'logger'. By default, this process simply
384−-- sends the string to 'stderr'. Individual Cloud Haskell backends might
385−-- replace this with a different logger process, however.
386−say :: String -> Process ()
387−say string = do
388− now <- liftIO getCurrentTime
389− us <- getSelfPid
390− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)
391−
392−--------------------------------------------------------------------------------
393−-- Registry --
394−--------------------------------------------------------------------------------
395−
396−-- | Register a process with the local registry (asynchronous).
397−--
398−-- The process to be registered does not have to be local itself.
399−register :: String -> ProcessId -> Process ()
400−register label pid =
401− sendCtrlMsg Nothing (Register label (Just pid))
402−
403−-- | Register a process with a remote registry (asynchronous).
404−--
405−-- The process to be registered does not have to live on the same remote node.
406−registerRemote :: NodeId -> String -> ProcessId -> Process ()
407−registerRemote nid label pid =
408− sendCtrlMsg (Just nid) (Register label (Just pid))
409−
410−-- | Remove a process from the local registry (asynchronous).
411−unregister :: String -> Process ()
412−unregister label =
413− sendCtrlMsg Nothing (Register label Nothing)
414−
415−-- | Remove a process from a remote registry (asynchronous).
416−unregisterRemote :: NodeId -> String -> Process ()
417−unregisterRemote nid label =
418− sendCtrlMsg (Just nid) (Register label Nothing)
419−
420−-- | Query the local process registry (synchronous).
421−whereis :: String -> Process (Maybe ProcessId)
422−whereis label = do
423− sendCtrlMsg Nothing (WhereIs label)
424− receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
425− (\(WhereIsReply _ mPid) -> return mPid)
426− ]
427−
428−-- | Query a remote process registry (synchronous)
429−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
430−whereisRemote nid label = do
431− whereisRemoteAsync nid label
432− receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
433− (\(WhereIsReply _ mPid) -> return mPid)
434− ]
435−
436−-- | Query a remote process registry (asynchronous)
437−--
438−-- Reply will come in the form of a 'WhereIsReply' message
439−whereisRemoteAsync :: NodeId -> String -> Process ()
440−whereisRemoteAsync nid label =
441− sendCtrlMsg (Just nid) (WhereIs label)
442−
443−-- | Named send to a process in the local registry (asynchronous)
444−nsend :: Serializable a => String -> a -> Process ()
445−nsend label msg =
446− sendCtrlMsg Nothing (NamedSend label (createMessage msg))
447−
448−-- | Named send to a process in a remote registry (asynchronous)
449−nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
450−nsendRemote nid label msg =
451− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
452−
453−--------------------------------------------------------------------------------
454−-- Closures --
455−--------------------------------------------------------------------------------
456−
457−-- | Deserialize a closure
458−unClosure :: forall a. Typeable a => Closure a -> Process a
459−unClosure (Closure (Static label) env) = do
460− rtable <- remoteTable <$> procMsg getLocalNode
461− case resolveClosure rtable label env of
462− Nothing -> throw . userError $ "Unregistered closure " ++ show label
463− Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
464− where
465− typeError dyn = userError $ "lookupStatic type error: "
466− ++ "cannot match " ++ show (dynTypeRep dyn)
467− ++ " against " ++ show (typeOf (undefined :: a))
468−
469−--------------------------------------------------------------------------------
470−-- Auxiliary functions --
471−--------------------------------------------------------------------------------
472−
473−getMonitorRefFor :: Identifier -> Process MonitorRef
474−getMonitorRefFor ident = do
475− proc <- ask
476− liftIO $ modifyMVar (processState proc) $ \st -> do
477− let counter = st ^. monitorCounter
478− return ( monitorCounter ^: (+ 1) $ st
479− , MonitorRef ident counter
480− )
481−
482−getSpawnRef :: Process SpawnRef
483−getSpawnRef = do
484− proc <- ask
485− liftIO $ modifyMVar (processState proc) $ \st -> do
486− let counter = st ^. spawnCounter
487− return ( spawnCounter ^: (+ 1) $ st
488− , SpawnRef counter
489− )
490−
491−-- | Monitor a process/node/channel
492−monitor' :: Identifier -> Process MonitorRef
493−monitor' ident = do
494− monitorRef <- getMonitorRefFor ident
495− sendCtrlMsg Nothing $ Monitor monitorRef
496− return monitorRef
497−
498−-- | Link to a process/node/channel
499−link' :: Identifier -> Process ()
500−link' = sendCtrlMsg Nothing . Link
501−
502−-- Send a control message
503−sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
504− -> ProcessSignal -- ^ Message to send
505− -> Process ()
506−sendCtrlMsg mNid signal = do
507− us <- getSelfPid
508− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier us
509− , ctrlMsgSignal = signal
510− }
511− case mNid of
512− Nothing -> do
513− ctrlChan <- localCtrlChan <$> procMsg getLocalNode
514− liftIO $ writeChan ctrlChan msg
515− Just nid ->
516− procMsg $ sendBinary (NodeIdentifier nid) msg
517−
distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hsdeleted−21
@@ -1,21 +0,0 @@
1−-- | 'Binary' instances for 'TypeRep'
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Internal.TypeRep () where
4−
5−import Control.Applicative ((<$>), (<*>))
6−import Data.Binary (Binary(get, put))
7−import Data.Typeable.Internal (TypeRep(..), TyCon(..))
8−import GHC.Fingerprint.Type (Fingerprint(..))
9−
10−instance Binary Fingerprint where
11− put (Fingerprint hi lo) = put hi >> put lo
12− get = Fingerprint <$> get <*> get
13−
14−instance Binary TypeRep where
15− put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts
16− get = TypeRep <$> get <*> get <*> get
17−
18−instance Binary TyCon where
19− put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name
20− get = TyCon <$> get <*> get <*> get <*> get
21−
distributed-process/src/Control/Distributed/Process/Internal/Types.hsdeleted−611
@@ -1,611 +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−{-# LANGUAGE MagicHash #-}
7−module Control.Distributed.Process.Internal.Types
8− ( -- * Node and process identifiers
9− NodeId(..)
10− , LocalProcessId(..)
11− , ProcessId(..)
12− , Identifier(..)
13− , nodeOf
14− -- * Local nodes and processes
15− , LocalNode(..)
16− , LocalNodeState(..)
17− , LocalProcess(..)
18− , LocalProcessState(..)
19− , Process(..)
20− , procMsg
21− -- * Typed channels
22− , LocalSendPortId
23− , SendPortId(..)
24− , TypedChannel(..)
25− , SendPort(..)
26− , ReceivePort(..)
27− -- * Closures
28− , StaticLabel(..)
29− , Static(..)
30− , staticApply
31− , staticDuplicate
32− , staticTypeOf
33− , typeOfStaticLabel
34− , Closure(..)
35− , RemoteTable(..)
36− , SerializableDict(..)
37− -- * Messages
38− , Message(..)
39− , createMessage
40− , messageToPayload
41− , payloadToMessage
42− -- * Node controller user-visible data types
43− , MonitorRef(..)
44− , ProcessMonitorNotification(..)
45− , NodeMonitorNotification(..)
46− , PortMonitorNotification(..)
47− , ProcessLinkException(..)
48− , NodeLinkException(..)
49− , PortLinkException(..)
50− , DiedReason(..)
51− , DidUnmonitor(..)
52− , DidUnlinkProcess(..)
53− , DidUnlinkNode(..)
54− , DidUnlinkPort(..)
55− , SpawnRef(..)
56− , DidSpawn(..)
57− , WhereIsReply(..)
58− -- * Node controller internal data types
59− , NCMsg(..)
60− , ProcessSignal(..)
61− -- * MessageT monad
62− , MessageT(..)
63− , MessageState(..)
64− -- * Accessors
65− , localProcesses
66− , localPidCounter
67− , localPidUnique
68− , localProcessWithId
69− , monitorCounter
70− , spawnCounter
71− , channelCounter
72− , typedChannels
73− , typedChannelWithId
74− , remoteTableLabels
75− , remoteTableLabel
76− ) where
77−
78−import Data.Map (Map)
79−import Data.Int (Int32)
80−import Data.Maybe (fromJust)
81−import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)
82−import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
83−import qualified Data.ByteString as BSS (ByteString, concat)
84−import qualified Data.ByteString.Lazy as BSL
85− ( ByteString
86− , toChunks
87− , splitAt
88− , fromChunks
89− )
90−import Data.Accessor (Accessor, accessor)
91−import qualified Data.Accessor.Container as DAC (mapMaybe)
92−import Control.Category ((>>>))
93−import Control.Exception (Exception)
94−import Control.Concurrent (ThreadId)
95−import Control.Concurrent.MVar (MVar)
96−import Control.Concurrent.Chan (Chan)
97−import Control.Concurrent.STM (TChan, TVar)
98−import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
99−import Control.Applicative (Applicative, (<$>), (<*>))
100−import Control.Monad.Reader (MonadReader(..), ReaderT)
101−import Control.Monad.IO.Class (MonadIO)
102−import Control.Monad.State (MonadState, StateT)
103−import qualified Control.Monad.Trans.Class as Trans (lift)
104−import Control.Distributed.Process.Serializable
105− ( Fingerprint
106− , Serializable
107− , fingerprint
108− , encodeFingerprint
109− , sizeOfFingerprint
110− , decodeFingerprint
111− , showFingerprint
112− )
113−import Control.Distributed.Process.Internal.CQueue (CQueue)
114−import Control.Distributed.Process.Internal.Dynamic (Dynamic)
115−import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
116−
117−--------------------------------------------------------------------------------
118−-- Node and process identifiers --
119−--------------------------------------------------------------------------------
120−
121−-- | Node identifier
122−newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
123− deriving (Eq, Ord, Binary)
124−
125−instance Show NodeId where
126− show (NodeId addr) = "nid://" ++ show addr
127−
128−-- | A local process ID consists of a seed which distinguishes processes from
129−-- different instances of the same local node and a counter
130−data LocalProcessId = LocalProcessId
131− { lpidUnique :: Int32
132− , lpidCounter :: Int32
133− }
134− deriving (Eq, Ord, Typeable)
135−
136−instance Show LocalProcessId where
137− show = show . lpidCounter
138−
139−-- | Process identifier
140−data ProcessId = ProcessId
141− { -- | The ID of the node the process is running on
142− processNodeId :: NodeId
143− -- | Node-local identifier for the process
144− , processLocalId :: LocalProcessId
145− }
146− deriving (Eq, Ord, Typeable)
147−
148−instance Show ProcessId where
149− show (ProcessId (NodeId addr) (LocalProcessId _ lid))
150− = "pid://" ++ show addr ++ ":" ++ show lid
151−
152−-- | Union of all kinds of identifiers
153−data Identifier =
154− NodeIdentifier NodeId
155− | ProcessIdentifier ProcessId
156− | SendPortIdentifier SendPortId
157− deriving (Eq, Ord)
158−
159−instance Show Identifier where
160− show (NodeIdentifier nid) = show nid
161− show (ProcessIdentifier pid) = show pid
162− show (SendPortIdentifier cid) = show cid
163−
164−nodeOf :: Identifier -> NodeId
165−nodeOf (NodeIdentifier nid) = nid
166−nodeOf (ProcessIdentifier pid) = processNodeId pid
167−nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)
168−
169−--------------------------------------------------------------------------------
170−-- Local nodes and processes --
171−--------------------------------------------------------------------------------
172−
173−-- | Local nodes
174−data LocalNode = LocalNode
175− { -- | 'NodeId' of the node
176− localNodeId :: NodeId
177− -- | The network endpoint associated with this node
178− , localEndPoint :: NT.EndPoint
179− -- | Local node state
180− , localState :: MVar LocalNodeState
181− -- | Channel for the node controller
182− , localCtrlChan :: Chan NCMsg
183− -- | Runtime lookup table for supporting closures
184− -- TODO: this should be part of the CH state, not the local endpoint state
185− , remoteTable :: RemoteTable
186− }
187−
188−-- | Local node state
189−data LocalNodeState = LocalNodeState
190− { _localProcesses :: Map LocalProcessId LocalProcess
191− , _localPidCounter :: Int32
192− , _localPidUnique :: Int32
193− }
194−
195−-- | Processes running on our local node
196−data LocalProcess = LocalProcess
197− { processQueue :: CQueue Message
198− , processId :: ProcessId
199− , processState :: MVar LocalProcessState
200− , processThread :: ThreadId
201− }
202−
203−-- | Local process state
204−data LocalProcessState = LocalProcessState
205− { _monitorCounter :: Int32
206− , _spawnCounter :: Int32
207− , _channelCounter :: Int32
208− , _typedChannels :: Map LocalSendPortId TypedChannel
209− }
210−
211−-- | The Cloud Haskell 'Process' type
212−newtype Process a = Process {
213− unProcess :: ReaderT LocalProcess (MessageT IO) a
214− }
215− deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
216−
217−procMsg :: MessageT IO a -> Process a
218−procMsg = Process . Trans.lift
219−
220−--------------------------------------------------------------------------------
221−-- Typed channels --
222−--------------------------------------------------------------------------------
223−
224−type LocalSendPortId = Int32
225−
226−-- | A send port is identified by a SendPortId.
227−--
228−-- You cannot send directly to a SendPortId; instead, use 'newChan'
229−-- to create a SendPort.
230−data SendPortId = SendPortId {
231− -- | The ID of the process that will receive messages sent on this port
232− sendPortProcessId :: ProcessId
233− -- | Process-local ID of the channel
234− , sendPortLocalId :: LocalSendPortId
235− }
236− deriving (Eq, Ord)
237−
238−instance Show SendPortId where
239− show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
240− = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
241−
242−data TypedChannel = forall a. Serializable a => TypedChannel (TChan a)
243−
244−-- | The send send of a typed channel (serializable)
245−newtype SendPort a = SendPort {
246− -- | The (unique) ID of this send port
247− sendPortId :: SendPortId
248− }
249− deriving (Typeable, Binary, Show, Eq, Ord)
250−
251−-- | The receive end of a typed channel (not serializable)
252−data ReceivePort a =
253− -- | A single receive port
254− ReceivePortSingle (TChan a)
255− -- | A left-biased combination of receive ports
256− | ReceivePortBiased [ReceivePort a]
257− -- | A round-robin combination of receive ports
258− | ReceivePortRR (TVar [ReceivePort a])
259− deriving Typeable
260−
261−--------------------------------------------------------------------------------
262−-- Closures --
263−--------------------------------------------------------------------------------
264−
265−data StaticLabel =
266− StaticLabel String TypeRep
267− | StaticApply StaticLabel StaticLabel
268− | StaticDuplicate StaticLabel TypeRep
269− deriving (Typeable, Show)
270−
271−-- | A static value is top-level bound or the application of two static values
272−newtype Static a = Static StaticLabel
273− deriving (Typeable, Show)
274−
275−-- | Apply two static values
276−staticApply :: Static (a -> b) -> Static a -> Static b
277−staticApply (Static f) (Static x) = Static (StaticApply f x)
278−
279−-- | Co-monadic 'duplicate' for static values
280−staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)
281−staticDuplicate (Static x) =
282− Static (StaticDuplicate x (typeOf (undefined :: Static a)))
283−
284−staticTypeOf :: forall a. Typeable a => a -> Static a
285−staticTypeOf _ = Static (StaticLabel "undefined" (typeOf (undefined :: a)))
286−
287−typeOfStaticLabel :: StaticLabel -> TypeRep
288−typeOfStaticLabel (StaticLabel _ typ)
289− = typ
290−typeOfStaticLabel (StaticApply f x)
291− = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)
292−typeOfStaticLabel (StaticDuplicate _ typ)
293− = typ
294−
295−-- | A closure is a static value and an encoded environment
296−data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString
297− deriving (Typeable, Show)
298−
299−-- | Runtime dictionary for 'unstatic' lookups
300−data RemoteTable = RemoteTable {
301− _remoteTableLabels :: Map String Dynamic
302− }
303−
304−-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")
305−data SerializableDict a where
306− SerializableDict :: Serializable a => SerializableDict a
307− deriving (Typeable)
308−
309−--------------------------------------------------------------------------------
310−-- Messages --
311−--------------------------------------------------------------------------------
312−
313−-- | Messages consist of their typeRep fingerprint and their encoding
314−data Message = Message
315− { messageFingerprint :: Fingerprint
316− , messageEncoding :: BSL.ByteString
317− }
318−
319−instance Show Message where
320− show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
321−
322−-- | Turn any serialiable term into a message
323−createMessage :: Serializable a => a -> Message
324−createMessage a = Message (fingerprint a) (encode a)
325−
326−-- | Serialize a message
327−messageToPayload :: Message -> [BSS.ByteString]
328−messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc
329−
330−-- | Deserialize a message
331−payloadToMessage :: [BSS.ByteString] -> Message
332−payloadToMessage payload = Message fp msg
333− where
334− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
335− $ BSL.fromChunks payload
336− fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
337−
338−--------------------------------------------------------------------------------
339−-- Node controller user-visible data types --
340−--------------------------------------------------------------------------------
341−
342−-- | MonitorRef is opaque for regular Cloud Haskell processes
343−data MonitorRef = MonitorRef
344− { -- | ID of the entity to be monitored
345− monitorRefIdent :: Identifier
346− -- | Unique to distinguish multiple monitor requests by the same process
347− , monitorRefCounter :: Int32
348− }
349− deriving (Eq, Ord, Show)
350−
351−-- | Message sent by process monitors
352−data ProcessMonitorNotification =
353− ProcessMonitorNotification MonitorRef ProcessId DiedReason
354− deriving (Typeable, Show)
355−
356−-- | Message sent by node monitors
357−data NodeMonitorNotification =
358− NodeMonitorNotification MonitorRef NodeId DiedReason
359− deriving (Typeable, Show)
360−
361−-- | Message sent by channel (port) monitors
362−data PortMonitorNotification =
363− PortMonitorNotification MonitorRef SendPortId DiedReason
364− deriving (Typeable, Show)
365−
366−-- | Exceptions thrown when a linked process dies
367−data ProcessLinkException =
368− ProcessLinkException ProcessId DiedReason
369− deriving (Typeable, Show)
370−
371−-- | Exception thrown when a linked node dies
372−data NodeLinkException =
373− NodeLinkException NodeId DiedReason
374− deriving (Typeable, Show)
375−
376−-- | Exception thrown when a linked channel (port) dies
377−data PortLinkException =
378− PortLinkException SendPortId DiedReason
379− deriving (Typeable, Show)
380−
381−instance Exception ProcessLinkException
382−instance Exception NodeLinkException
383−instance Exception PortLinkException
384−
385−-- | Why did a process die?
386−data DiedReason =
387− -- | Normal termination
388− DiedNormal
389− -- | The process exited with an exception
390− -- (provided as 'String' because 'Exception' does not implement 'Binary')
391− | DiedException String
392− -- | We got disconnected from the process node
393− | DiedDisconnect
394− -- | The process node died
395− | DiedNodeDown
396− -- | Invalid (process/node/channel) identifier
397− | DiedUnknownId
398− deriving (Show, Eq)
399−
400−-- | (Asynchronous) reply from unmonitor
401−newtype DidUnmonitor = DidUnmonitor MonitorRef
402− deriving (Typeable, Binary)
403−
404−-- | (Asynchronous) reply from unlink
405−newtype DidUnlinkProcess = DidUnlinkProcess ProcessId
406− deriving (Typeable, Binary)
407−
408−-- | (Asynchronous) reply from unlinkNode
409−newtype DidUnlinkNode = DidUnlinkNode NodeId
410− deriving (Typeable, Binary)
411−
412−-- | (Asynchronous) reply from unlinkPort
413−newtype DidUnlinkPort = DidUnlinkPort SendPortId
414− deriving (Typeable, Binary)
415−
416−-- | 'SpawnRef' are used to return pids of spawned processes
417−newtype SpawnRef = SpawnRef Int32
418− deriving (Show, Binary, Typeable, Eq)
419−
420−-- | (Asynchronius) reply from 'spawn'
421−data DidSpawn = DidSpawn SpawnRef ProcessId
422− deriving (Show, Typeable)
423−
424−-- | (Asynchronous) reply from 'whereis'
425−data WhereIsReply = WhereIsReply String (Maybe ProcessId)
426− deriving (Show, Typeable)
427−
428−--------------------------------------------------------------------------------
429−-- Node controller internal data types --
430−--------------------------------------------------------------------------------
431−
432−-- | Messages to the node controller
433−data NCMsg = NCMsg
434− { ctrlMsgSender :: Identifier
435− , ctrlMsgSignal :: ProcessSignal
436− }
437− deriving Show
438−
439−-- | Signals to the node controller (see 'NCMsg')
440−data ProcessSignal =
441− Link Identifier
442− | Unlink Identifier
443− | Monitor MonitorRef
444− | Unmonitor MonitorRef
445− | Died Identifier DiedReason
446− | Spawn (Closure (Process ())) SpawnRef
447− | WhereIs String
448− | Register String (Maybe ProcessId) -- Nothing to unregister
449− | NamedSend String Message
450− deriving Show
451−
452−--------------------------------------------------------------------------------
453−-- Binary instances --
454−--------------------------------------------------------------------------------
455−
456−instance Binary LocalProcessId where
457− put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
458− get = LocalProcessId <$> get <*> get
459−
460−instance Binary ProcessId where
461− put pid = put (processNodeId pid) >> put (processLocalId pid)
462− get = ProcessId <$> get <*> get
463−
464−instance Binary ProcessMonitorNotification where
465− put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
466− get = ProcessMonitorNotification <$> get <*> get <*> get
467−
468−instance Binary NodeMonitorNotification where
469− put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason
470− get = NodeMonitorNotification <$> get <*> get <*> get
471−
472−instance Binary PortMonitorNotification where
473− put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason
474− get = PortMonitorNotification <$> get <*> get <*> get
475−
476−instance Binary NCMsg where
477− put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)
478− get = NCMsg <$> get <*> get
479−
480−instance Binary MonitorRef where
481− put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)
482− get = MonitorRef <$> get <*> get
483−
484−instance Binary ProcessSignal where
485− put (Link pid) = putWord8 0 >> put pid
486− put (Unlink pid) = putWord8 1 >> put pid
487− put (Monitor ref) = putWord8 2 >> put ref
488− put (Unmonitor ref) = putWord8 3 >> put ref
489− put (Died who reason) = putWord8 4 >> put who >> put reason
490− put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
491− put (WhereIs label) = putWord8 6 >> put label
492− put (Register label pid) = putWord8 7 >> put label >> put pid
493− put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
494− get = do
495− header <- getWord8
496− case header of
497− 0 -> Link <$> get
498− 1 -> Unlink <$> get
499− 2 -> Monitor <$> get
500− 3 -> Unmonitor <$> get
501− 4 -> Died <$> get <*> get
502− 5 -> Spawn <$> get <*> get
503− 6 -> WhereIs <$> get
504− 7 -> Register <$> get <*> get
505− 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
506− _ -> fail "ProcessSignal.get: invalid"
507−
508−instance Binary DiedReason where
509− put DiedNormal = putWord8 0
510− put (DiedException e) = putWord8 1 >> put e
511− put DiedDisconnect = putWord8 2
512− put DiedNodeDown = putWord8 3
513− put DiedUnknownId = putWord8 4
514− get = do
515− header <- getWord8
516− case header of
517− 0 -> return DiedNormal
518− 1 -> DiedException <$> get
519− 2 -> return DiedDisconnect
520− 3 -> return DiedNodeDown
521− 4 -> return DiedUnknownId
522− _ -> fail "DiedReason.get: invalid"
523−
524−instance Binary (Closure a) where
525− put (Closure (Static label) env) = put label >> put env
526− get = Closure <$> (Static <$> get) <*> get
527−
528−instance Binary DidSpawn where
529− put (DidSpawn ref pid) = put ref >> put pid
530− get = DidSpawn <$> get <*> get
531−
532−instance Binary SendPortId where
533− put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
534− get = SendPortId <$> get <*> get
535−
536−instance Binary Identifier where
537− put (ProcessIdentifier pid) = putWord8 0 >> put pid
538− put (NodeIdentifier nid) = putWord8 1 >> put nid
539− put (SendPortIdentifier cid) = putWord8 2 >> put cid
540− get = do
541− header <- getWord8
542− case header of
543− 0 -> ProcessIdentifier <$> get
544− 1 -> NodeIdentifier <$> get
545− 2 -> SendPortIdentifier <$> get
546− _ -> fail "Identifier.get: invalid"
547−
548−instance Binary StaticLabel where
549− put (StaticLabel string typ) = putWord8 0 >> put string >> put typ
550− put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2
551− put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ
552− get = do
553− header <- getWord8
554− case header of
555− 0 -> StaticLabel <$> get <*> get
556− 1 -> StaticApply <$> get <*> get
557− 2 -> StaticDuplicate <$> get <*> get
558− _ -> fail "StaticLabel.get: invalid"
559−
560−instance Binary WhereIsReply where
561− put (WhereIsReply label mPid) = put label >> put mPid
562− get = WhereIsReply <$> get <*> get
563−
564−--------------------------------------------------------------------------------
565−-- Accessors --
566−--------------------------------------------------------------------------------
567−
568−localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)
569−localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })
570−
571−localPidCounter :: Accessor LocalNodeState Int32
572−localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })
573−
574−localPidUnique :: Accessor LocalNodeState Int32
575−localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
576−
577−localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
578−localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
579−
580−monitorCounter :: Accessor LocalProcessState Int32
581−monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
582−
583−spawnCounter :: Accessor LocalProcessState Int32
584−spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })
585−
586−channelCounter :: Accessor LocalProcessState LocalSendPortId
587−channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })
588−
589−typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)
590−typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })
591−
592−typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)
593−typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid
594−
595−remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)
596−remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })
597−
598−remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
599−remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label
600−
601−--------------------------------------------------------------------------------
602−-- MessageT monad --
603−--------------------------------------------------------------------------------
604−
605−newtype MessageT m a = MessageT { unMessageT :: StateT MessageState m a }
606− deriving (Functor, Monad, MonadIO, MonadState MessageState, Applicative)
607−
608−data MessageState = MessageState {
609− messageLocalNode :: LocalNode
610− , _messageConnections :: Map Identifier NT.Connection
611− }
distributed-process/src/Control/Distributed/Process/Node.hsdeleted−701
@@ -1,701 +0,0 @@
1−-- | Local nodes
2−module Control.Distributed.Process.Node
3− ( LocalNode
4− , newLocalNode
5− , closeLocalNode
6− , forkProcess
7− , runProcess
8− , initRemoteTable
9− , localNodeId
10− ) where
11−
12−import Prelude hiding (catch)
13−import System.IO (fixIO, hPutStrLn, stderr)
14−import qualified Data.ByteString.Lazy as BSL (fromChunks)
15−import Data.Binary (decode)
16−import Data.Map (Map)
17−import qualified Data.Map as Map
18− ( empty
19− , lookup
20− , insert
21− , delete
22− , toList
23− , partitionWithKey
24− , filterWithKey
25− )
26−import qualified Data.List as List (delete, (\\))
27−import Data.Set (Set)
28−import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)
29−import Data.Foldable (forM_)
30−import Data.Maybe (isJust, fromMaybe)
31−import Data.Typeable (Typeable)
32−import Control.Category ((>>>))
33−import Control.Applicative ((<$>))
34−import Control.Monad (void, when, forever)
35−import Control.Monad.IO.Class (MonadIO, liftIO)
36−import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
37−import qualified Control.Monad.Trans.Class as Trans (lift)
38−import Control.Exception (throwIO, SomeException, Exception, throwTo)
39−import qualified Control.Exception as Exception (catch)
40−import Control.Concurrent (forkIO)
41−import Control.Concurrent.MVar
42− ( newMVar
43− , withMVar
44− , modifyMVar
45− , modifyMVar_
46− , newEmptyMVar
47− , putMVar
48− , takeMVar
49− )
50−import Control.Concurrent.Chan (newChan, writeChan, readChan)
51−import Control.Concurrent.STM (atomically, writeTChan)
52−import Control.Distributed.Process.Internal.CQueue (enqueue, newCQueue)
53−import qualified Network.Transport as NT
54− ( Transport
55− , EndPoint
56− , newEndPoint
57− , receive
58− , Event(..)
59− , EventErrorCode(..)
60− , TransportError(..)
61− , address
62− , closeEndPoint
63− , ConnectionId
64− )
65−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
66−import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)
67−import System.Random (randomIO)
68−import Control.Distributed.Process.Internal.Types
69− ( RemoteTable
70− , NodeId(..)
71− , LocalProcessId(..)
72− , ProcessId(..)
73− , LocalNode(..)
74− , LocalNodeState(..)
75− , LocalProcess(..)
76− , LocalProcessState(..)
77− , Process(..)
78− , DiedReason(..)
79− , NCMsg(..)
80− , ProcessSignal(..)
81− , localPidCounter
82− , localPidUnique
83− , localProcessWithId
84− , MonitorRef(..)
85− , ProcessMonitorNotification(..)
86− , NodeMonitorNotification(..)
87− , PortMonitorNotification(..)
88− , ProcessLinkException(..)
89− , NodeLinkException(..)
90− , PortLinkException(..)
91− , DidUnmonitor(..)
92− , DidUnlinkProcess(..)
93− , DidUnlinkNode(..)
94− , DidUnlinkPort(..)
95− , SpawnRef
96− , DidSpawn(..)
97− , Closure(..)
98− , Static(..)
99− , Message
100− , MessageT
101− , TypedChannel(..)
102− , Identifier(..)
103− , nodeOf
104− , SendPortId(..)
105− , typedChannelWithId
106− , WhereIsReply(..)
107− , messageToPayload
108− , RemoteTable(..)
109− )
110−import Control.Distributed.Process.Serializable (Serializable)
111−import Control.Distributed.Process.Internal.MessageT
112− ( sendBinary
113− , sendMessage
114− , sendPayload
115− , getLocalNode
116− , runMessageT
117− , payloadToMessage
118− , createMessage
119− )
120−import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
121−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
122−import Control.Distributed.Process.Internal.Node (runLocalProcess)
123−import Control.Distributed.Process.Internal.Primitives (expect, register)
124−import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
125−import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
126−
127−--------------------------------------------------------------------------------
128−-- Initialization --
129−--------------------------------------------------------------------------------
130−
131−initRemoteTable :: RemoteTable
132−initRemoteTable = Static.__remoteTable
133− . CP.__remoteTable
134− $ RemoteTable Map.empty
135−
136−-- | Initialize a new local node.
137−--
138−-- Note that proper Cloud Haskell initialization and configuration is still
139−-- to do.
140−newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode
141−newLocalNode transport rtable = do
142− mEndPoint <- NT.newEndPoint transport
143− case mEndPoint of
144− Left ex -> throwIO ex
145− Right endPoint -> do
146− localNode <- createBareLocalNode endPoint rtable
147− startServiceProcesses localNode
148− return localNode
149−
150−-- | Create a new local node (without any service processes running)
151−createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
152−createBareLocalNode endPoint rtable = do
153− unq <- randomIO
154− state <- newMVar LocalNodeState
155− { _localProcesses = Map.empty
156− , _localPidCounter = 0
157− , _localPidUnique = unq
158− }
159− ctrlChan <- newChan
160− let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
161− , localEndPoint = endPoint
162− , localState = state
163− , localCtrlChan = ctrlChan
164− , remoteTable = rtable
165− }
166− void . forkIO $ runNodeController node
167− void . forkIO $ handleIncomingMessages node
168− return node
169−
170−-- | Start and register the service processes on a node
171−-- (for now, this is only the logger)
172−startServiceProcesses :: LocalNode -> IO ()
173−startServiceProcesses node = do
174− logger <- forkProcess node . forever $ do
175− (time, pid, string) <- expect :: Process (String, ProcessId, String)
176− liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
177− runProcess node $ register "logger" logger
178−
179−-- | Force-close a local node
180−--
181−-- TODO: for now we just close the associated endpoint
182−closeLocalNode :: LocalNode -> IO ()
183−closeLocalNode node =
184− NT.closeEndPoint (localEndPoint node)
185−
186−-- | Run a process on a local node and wait for it to finish
187−runProcess :: LocalNode -> Process () -> IO ()
188−runProcess node proc = do
189− done <- newEmptyMVar
190− void $ forkProcess node (proc >> liftIO (putMVar done ()))
191− takeMVar done
192−
193−-- | Spawn a new process on a local node
194−forkProcess :: LocalNode -> Process () -> IO ProcessId
195−forkProcess node proc = modifyMVar (localState node) $ \st -> do
196− let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter
197− , lpidUnique = st ^. localPidUnique
198− }
199− let pid = ProcessId { processNodeId = localNodeId node
200− , processLocalId = lpid
201− }
202− pst <- newMVar LocalProcessState { _monitorCounter = 0
203− , _spawnCounter = 0
204− , _channelCounter = 0
205− , _typedChannels = Map.empty
206− }
207− queue <- newCQueue
208− (_, lproc) <- fixIO $ \ ~(tid, _) -> do
209− let lproc = LocalProcess { processQueue = queue
210− , processId = pid
211− , processState = pst
212− , processThread = tid
213− }
214− tid' <- forkIO $ do
215− reason <- Exception.catch
216− (runLocalProcess node proc lproc >> return DiedNormal)
217− (return . DiedException . (show :: SomeException -> String))
218− -- [Unified: Table 4, rules termination and exiting]
219− modifyMVar_ (localState node) $
220− return . (localProcessWithId lpid ^= Nothing)
221− writeChan (localCtrlChan node) NCMsg
222− { ctrlMsgSender = ProcessIdentifier pid
223− , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
224− }
225− return (tid', lproc)
226−
227− if lpidCounter lpid == maxBound
228− then do
229− newUnique <- randomIO
230− return ( (localProcessWithId lpid ^= Just lproc)
231− . (localPidCounter ^= 0)
232− . (localPidUnique ^= newUnique)
233− $ st
234− , pid
235− )
236− else
237− return ( (localProcessWithId lpid ^= Just lproc)
238− . (localPidCounter ^: (+ 1))
239− $ st
240− , pid
241− )
242−
243−handleIncomingMessages :: LocalNode -> IO ()
244−handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
245− where
246− go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know
247− -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes
248− -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels
249− -> Set NT.ConnectionId -- ^ Connections to our controller
250− -> IO ()
251− go uninitConns procs chans ctrls = do
252− event <- NT.receive endpoint
253− case event of
254− NT.ConnectionOpened cid _rel _theirAddr ->
255− -- TODO: Check if _rel is ReliableOrdered, and if not, treat as
256− -- (**) below.
257− go (cid : uninitConns) procs chans ctrls
258− NT.Received cid payload ->
259− case ( Map.lookup cid procs
260− , Map.lookup cid chans
261− , cid `Set.member` ctrls
262− , cid `elem` uninitConns
263− ) of
264− (Just proc, _, _, _) -> do
265− let msg = payloadToMessage payload
266− enqueue (processQueue proc) msg
267− go uninitConns procs chans ctrls
268− (_, Just (TypedChannel chan), _, _) -> do
269− atomically $ writeTChan chan . decode . BSL.fromChunks $ payload
270− go uninitConns procs chans ctrls
271− (_, _, True, _) -> do
272− let ctrlMsg = decode . BSL.fromChunks $ payload
273− writeChan ctrlChan ctrlMsg
274− go uninitConns procs chans ctrls
275− (_, _, _, True) ->
276− case decode (BSL.fromChunks payload) of
277− ProcessIdentifier pid -> do
278− let lpid = processLocalId pid
279− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
280− case mProc of
281− Just proc ->
282− go (List.delete cid uninitConns)
283− (Map.insert cid proc procs)
284− chans
285− ctrls
286− Nothing ->
287− -- Request for an unknown process.
288− --
289− -- TODO: We should treat this as a fatal error on the
290− -- part of the remote node. That is, we should report the
291− -- remote node as having died, and we should close
292− -- incoming connections (this requires a Transport layer
293− -- extension). (**)
294− go (List.delete cid uninitConns) procs chans ctrls
295− SendPortIdentifier chId -> do
296− let lcid = sendPortLocalId chId
297− lpid = processLocalId (sendPortProcessId chId)
298− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
299− case mProc of
300− Just proc -> do
301− mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
302− case mChannel of
303− Just channel ->
304− go (List.delete cid uninitConns)
305− procs
306− (Map.insert cid channel chans)
307− ctrls
308− Nothing ->
309− -- Unknown typed channel
310− -- TODO (**) above
311− go (List.delete cid uninitConns) procs chans ctrls
312− Nothing ->
313− -- Unknown process
314− -- TODO (**) above
315− go (List.delete cid uninitConns) procs chans ctrls
316− NodeIdentifier _ ->
317− go (List.delete cid uninitConns)
318− procs
319− chans
320− (Set.insert cid ctrls)
321− _ ->
322− -- Unexpected message
323− -- TODO (**) above
324− go uninitConns procs chans ctrls
325− NT.ConnectionClosed cid ->
326− go (List.delete cid uninitConns)
327− (Map.delete cid procs)
328− (Map.delete cid chans)
329− (Set.delete cid ctrls)
330− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost (Just theirAddr) cids) _) -> do
331− -- [Unified table 9, rule node_disconnect]
332− let nid = NodeIdentifier $ NodeId theirAddr
333− writeChan ctrlChan NCMsg
334− { ctrlMsgSender = nid
335− , ctrlMsgSignal = Died nid DiedDisconnect
336− }
337− go (uninitConns List.\\ cids)
338− (Map.filterWithKey (\k _ -> k `notElem` cids) procs)
339− (Map.filterWithKey (\k _ -> k `notElem` cids) chans)
340− (ctrls Set.\\ Set.fromList cids)
341− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->
342− -- TODO: We should treat an asymetrical connection loss (incoming
343− -- connection broken, but outgoing connection still potentially ok)
344− -- as a fatal error on the part of the remote node (like (**), above)
345− fail "handleIncomingMessages: TODO"
346− NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
347− fail $ "Cloud Haskell fatal error: end point failed: " ++ str
348− NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
349− fail $ "Cloud Haskell fatal error: transport failed: " ++ str
350− NT.EndPointClosed ->
351− return ()
352− NT.ReceivedMulticast _ _ ->
353− -- If we received a multicast message, something went horribly wrong
354− -- and we just give up
355− fail "Cloud Haskell fatal error: received unexpected multicast"
356−
357− state = localState node
358− endpoint = localEndPoint node
359− ctrlChan = localCtrlChan node
360−
361−--------------------------------------------------------------------------------
362−-- Top-level access to the node controller --
363−--------------------------------------------------------------------------------
364−
365−runNodeController :: LocalNode -> IO ()
366−runNodeController node =
367− runMessageT node (evalStateT (unNC nodeController) initNCState)
368−
369−--------------------------------------------------------------------------------
370−-- Internal data types --
371−--------------------------------------------------------------------------------
372−
373−data NCState = NCState
374− { -- Mapping from remote processes to linked local processes
375− _links :: Map Identifier (Set ProcessId)
376− -- Mapping from remote processes to monitoring local processes
377− , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))
378− -- Process registry
379− , _registry :: Map String ProcessId
380− }
381−
382−newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }
383− deriving (Functor, Monad, MonadIO, MonadState NCState)
384−
385−ncMsg :: MessageT IO a -> NC a
386−ncMsg = NC . Trans.lift
387−
388−initNCState :: NCState
389−initNCState = NCState { _links = Map.empty
390− , _monitors = Map.empty
391− , _registry = Map.empty
392− }
393−
394−--------------------------------------------------------------------------------
395−-- Core functionality --
396−--------------------------------------------------------------------------------
397−
398−-- [Unified: Table 7]
399−nodeController :: NC ()
400−nodeController = do
401− node <- ncMsg getLocalNode
402− forever $ do
403− msg <- liftIO $ readChan (localCtrlChan node)
404−
405− -- [Unified: Table 7, rule nc_forward]
406− case destNid (ctrlMsgSignal msg) of
407− Just nid' | nid' /= localNodeId node ->
408− ncMsg $ sendBinary (NodeIdentifier nid') msg
409− _ ->
410− return ()
411−
412− case msg of
413− NCMsg (ProcessIdentifier from) (Link them) ->
414− ncEffectMonitor from them Nothing
415− NCMsg (ProcessIdentifier from) (Monitor ref) ->
416− ncEffectMonitor from (monitorRefIdent ref) (Just ref)
417− NCMsg (ProcessIdentifier from) (Unlink them) ->
418− ncEffectUnlink from them
419− NCMsg (ProcessIdentifier from) (Unmonitor ref) ->
420− ncEffectUnmonitor from ref
421− NCMsg _from (Died ident reason) ->
422− ncEffectDied ident reason
423− NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
424− ncEffectSpawn from proc ref
425− NCMsg _from (Register label pid) ->
426− ncEffectRegister label pid
427− NCMsg (ProcessIdentifier from) (WhereIs label) ->
428− ncEffectWhereIs from label
429− NCMsg from (NamedSend label msg') ->
430− ncEffectNamedSend from label msg'
431− unexpected ->
432− error $ "nodeController: unexpected message " ++ show unexpected
433−
434−-- [Unified: Table 10]
435−ncEffectMonitor :: ProcessId -- ^ Who's watching?
436− -> Identifier -- ^ Who's being watched?
437− -> Maybe MonitorRef -- ^ 'Nothing' to link
438− -> NC ()
439−ncEffectMonitor from them mRef = do
440− node <- ncMsg getLocalNode
441− shouldLink <-
442− if not (isLocal node them)
443− then return True
444− else isValidLocalIdentifier them
445− case (shouldLink, isLocal node (ProcessIdentifier from)) of
446− (True, _) -> -- [Unified: first rule]
447− case mRef of
448− Just ref -> modify $ monitorsFor them ^: Set.insert (from, ref)
449− Nothing -> modify $ linksFor them ^: Set.insert from
450− (False, True) -> -- [Unified: second rule]
451− notifyDied from them DiedUnknownId mRef
452− (False, False) -> -- [Unified: third rule]
453− ncMsg $ sendBinary (NodeIdentifier $ processNodeId from) NCMsg
454− { ctrlMsgSender = NodeIdentifier (localNodeId node)
455− , ctrlMsgSignal = Died them DiedUnknownId
456− }
457−
458−-- [Unified: Table 11]
459−ncEffectUnlink :: ProcessId -> Identifier -> NC ()
460−ncEffectUnlink from them = do
461− node <- ncMsg getLocalNode
462− when (isLocal node (ProcessIdentifier from)) $
463− case them of
464− ProcessIdentifier pid ->
465− postAsMessage from $ DidUnlinkProcess pid
466− NodeIdentifier nid ->
467− postAsMessage from $ DidUnlinkNode nid
468− SendPortIdentifier cid ->
469− postAsMessage from $ DidUnlinkPort cid
470− modify $ linksFor them ^: Set.delete from
471−
472−-- [Unified: Table 11]
473−ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
474−ncEffectUnmonitor from ref = do
475− node <- ncMsg getLocalNode
476− when (isLocal node (ProcessIdentifier from)) $
477− postAsMessage from $ DidUnmonitor ref
478− modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
479−
480−-- [Unified: Table 12]
481−ncEffectDied :: Identifier -> DiedReason -> NC ()
482−ncEffectDied ident reason = do
483− node <- ncMsg getLocalNode
484− (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
485− (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
486−
487− let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False
488−
489− forM_ (Map.toList affectedLinks) $ \(them, uss) ->
490− forM_ uss $ \us ->
491− when (localOnly <= isLocal node (ProcessIdentifier us)) $
492− notifyDied us them reason Nothing
493−
494− forM_ (Map.toList affectedMons) $ \(them, refs) ->
495− forM_ refs $ \(us, ref) ->
496− when (localOnly <= isLocal node (ProcessIdentifier us)) $
497− notifyDied us them reason (Just ref)
498−
499− modify $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)
500−
501−-- [Unified: Table 13]
502−ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
503−ncEffectSpawn pid cProc ref = do
504− mProc <- unClosure cProc
505− -- If the closure does not exist, we spawn a process that throws an exception
506− -- This allows the remote node to find out what's happening
507− let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
508− node <- ncMsg getLocalNode
509− pid' <- liftIO $ forkProcess node proc
510− ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
511−
512−-- Unified semantics does not explicitly describe how to implement 'register',
513−-- but mentions it's "very similar to nsend" (Table 14)
514−ncEffectRegister :: String -> Maybe ProcessId -> NC ()
515−ncEffectRegister label mPid =
516− modify $ registryFor label ^= mPid
517− -- An acknowledgement is not necessary. If we want a synchronous register,
518− -- it suffices to send a whereis requiry immediately after the register
519− -- (that may not suffice if we do decide for unreliable messaging instead)
520−
521−-- Unified semantics does not explicitly describe 'whereis'
522−ncEffectWhereIs :: ProcessId -> String -> NC ()
523−ncEffectWhereIs from label = do
524− mPid <- gets (^. registryFor label)
525− ncMsg $ sendMessage (ProcessIdentifier from) (WhereIsReply label mPid)
526−
527−-- [Unified: Table 14]
528−ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
529−ncEffectNamedSend _from label msg = do
530− mPid <- gets (^. registryFor label)
531− -- If mPid is Nothing, we just ignore the named send (as per Table 14)
532− -- TODO: messages don't carry a "from", but if they do, we should set it
533− -- to be the 'from' of the original named send, not this node controller
534− forM_ mPid $ \pid ->
535− ncMsg $ sendPayload (ProcessIdentifier pid) (messageToPayload msg)
536−
537−--------------------------------------------------------------------------------
538−-- Auxiliary --
539−--------------------------------------------------------------------------------
540−
541−notifyDied :: ProcessId -- ^ Who to notify?
542− -> Identifier -- ^ Who died?
543− -> DiedReason -- ^ How did they die?
544− -> Maybe MonitorRef -- ^ 'Nothing' for linking
545− -> NC ()
546−notifyDied dest src reason mRef = do
547− node <- ncMsg getLocalNode
548− case (isLocal node (ProcessIdentifier dest), mRef, src) of
549− (True, Just ref, ProcessIdentifier pid) ->
550− postAsMessage dest $ ProcessMonitorNotification ref pid reason
551− (True, Just ref, NodeIdentifier nid) ->
552− postAsMessage dest $ NodeMonitorNotification ref nid reason
553− (True, Just ref, SendPortIdentifier cid) ->
554− postAsMessage dest $ PortMonitorNotification ref cid reason
555− (True, Nothing, ProcessIdentifier pid) ->
556− throwException dest $ ProcessLinkException pid reason
557− (True, Nothing, NodeIdentifier pid) ->
558− throwException dest $ NodeLinkException pid reason
559− (True, Nothing, SendPortIdentifier pid) ->
560− throwException dest $ PortLinkException pid reason
561− (False, _, _) ->
562− -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
563− -- (see [Unified: Table 10]
564− ncMsg $ sendBinary (NodeIdentifier $ processNodeId dest) NCMsg
565− { ctrlMsgSender = NodeIdentifier (localNodeId node)
566− , ctrlMsgSignal = Died src reason
567− }
568−
569−-- | [Unified: Table 8]
570−destNid :: ProcessSignal -> Maybe NodeId
571−destNid (Link ident) = Just $ nodeOf ident
572−destNid (Unlink ident) = Just $ nodeOf ident
573−destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
574−destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
575−destNid (Spawn _ _) = Nothing
576−destNid (Register _ _) = Nothing
577−destNid (WhereIs _) = Nothing
578−destNid (NamedSend _ _) = Nothing
579−-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
580−-- then when a local process dies the monitoring/linking machinery will take
581−-- care of notifying remote nodes
582−destNid (Died _ _) = Nothing
583−
584−-- | Check if a process is local to our own node
585−isLocal :: LocalNode -> Identifier -> Bool
586−isLocal nid ident = nodeOf ident == localNodeId nid
587−
588−-- | Lookup a local closure
589−unClosure :: Typeable a => Closure a -> NC (Maybe a)
590−unClosure (Closure (Static label) env) = do
591− rtable <- remoteTable <$> ncMsg getLocalNode
592− return (resolveClosure rtable label env >>= fromDynamic)
593−
594−-- | Check if an identifier refers to a valid local object
595−isValidLocalIdentifier :: Identifier -> NC Bool
596−isValidLocalIdentifier ident = do
597− node <- ncMsg getLocalNode
598− liftIO . withMVar (localState node) $ \nSt ->
599− case ident of
600− NodeIdentifier nid ->
601− return $ nid == localNodeId node
602− ProcessIdentifier pid -> do
603− let mProc = nSt ^. localProcessWithId (processLocalId pid)
604− return $ isJust mProc
605− SendPortIdentifier cid -> do
606− let pid = sendPortProcessId cid
607− mProc = nSt ^. localProcessWithId (processLocalId pid)
608− case mProc of
609− Nothing -> return False
610− Just proc -> withMVar (processState proc) $ \pSt -> do
611− let mCh = pSt ^. typedChannelWithId (sendPortLocalId cid)
612− return $ isJust mCh
613−
614−--------------------------------------------------------------------------------
615−-- Messages to local processes --
616−--------------------------------------------------------------------------------
617−
618−postAsMessage :: Serializable a => ProcessId -> a -> NC ()
619−postAsMessage pid = postMessage pid . createMessage
620−
621−postMessage :: ProcessId -> Message -> NC ()
622−postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
623−
624−throwException :: Exception e => ProcessId -> e -> NC ()
625−throwException pid e = withLocalProc pid $ \p ->
626− throwTo (processThread p) e
627−
628−withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
629−withLocalProc pid p = do
630− node <- ncMsg getLocalNode
631− liftIO $ do
632− -- By [Unified: table 6, rule missing_process] messages to dead processes
633− -- can silently be dropped
634− let lpid = processLocalId pid
635− mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
636− forM_ mProc p
637−
638−--------------------------------------------------------------------------------
639−-- Accessors --
640−--------------------------------------------------------------------------------
641−
642−links :: Accessor NCState (Map Identifier (Set ProcessId))
643−links = accessor _links (\ls st -> st { _links = ls })
644−
645−monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))
646−monitors = accessor _monitors (\ms st -> st { _monitors = ms })
647−
648−registry :: Accessor NCState (Map String ProcessId)
649−registry = accessor _registry (\ry st -> st { _registry = ry })
650−
651−linksFor :: Identifier -> Accessor NCState (Set ProcessId)
652−linksFor ident = links >>> DAC.mapDefault Set.empty ident
653−
654−monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))
655−monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident
656−
657−registryFor :: String -> Accessor NCState (Maybe ProcessId)
658−registryFor ident = registry >>> DAC.mapMaybe ident
659−
660−-- | @splitNotif ident@ splits a notifications map into those
661−-- notifications that should trigger when 'ident' fails and those links that
662−-- should not.
663−--
664−-- There is a hierarchy between identifiers: failure of a node implies failure
665−-- of all processes on that node, and failure of a process implies failure of
666−-- all typed channels to that process. In other words, if 'ident' refers to a
667−-- node, then the /should trigger/ set will include
668−--
669−-- * the notifications for the node specifically
670−-- * the notifications for processes on that node, and
671−-- * the notifications for typed channels to processes on that node.
672−--
673−-- Similarly, if 'ident' refers to a process, the /should trigger/ set will
674−-- include
675−--
676−-- * the notifications for that process specifically and
677−-- * the notifications for typed channels to that process.
678−splitNotif :: Identifier
679− -> Map Identifier a
680− -> (Map Identifier a, Map Identifier a)
681−splitNotif ident = Map.partitionWithKey (const . impliesDeathOf ident)
682−
683−-- | Does the death of one entity (node, project, channel) imply the death
684−-- of another?
685−impliesDeathOf :: Identifier -- ^ Who died
686− -> Identifier -- ^ Who's being watched
687− -> Bool -- ^ Does this death implies the death of the watchee?
688−NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
689− nid' == nid
690−NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
691− processNodeId pid == nid
692−NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =
693− processNodeId (sendPortProcessId cid) == nid
694−ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =
695− pid' == pid
696−ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =
697− sendPortProcessId cid == pid
698−SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =
699− cid' == cid
700−_ `impliesDeathOf` _ =
701− False
distributed-process/tests/TestAuxiliary.hsdeleted−71
@@ -1,71 +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.Monad (liftM2, unless)
14−import Control.Exception (SomeException, try, catch)
15−import System.Timeout (timeout)
16−import System.IO (stdout, hFlush)
17−import System.Console.ANSI ( SGR(SetColor, Reset)
18− , Color(Red, Green)
19− , ConsoleLayer(Foreground)
20− , ColorIntensity(Vivid)
21− , setSGR
22− )
23−import System.Random (randomIO)
24−
25−-- | Like fork, but throw exceptions in the child thread to the parent
26−forkTry :: IO () -> IO ThreadId
27−forkTry p = do
28− tid <- myThreadId
29− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
30−
31−-- | Like try, but specialized to SomeException
32−trySome :: IO a -> IO (Either SomeException a)
33−trySome = try
34−
35−-- | Run the given test, catching timeouts and exceptions
36−runTest :: String -> IO () -> IO Bool
37−runTest description test = do
38− putStr $ "Running " ++ show description ++ ": "
39− hFlush stdout
40− done <- try . timeout 60000000 $ test -- 60 seconds
41− case done of
42− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
43− Right Nothing -> failed "(timeout)"
44− Right (Just ()) -> ok
45− where
46− failed :: String -> IO Bool
47− failed err = do
48− setSGR [SetColor Foreground Vivid Red]
49− putStr "failed "
50− setSGR [Reset]
51− putStrLn err
52− return False
53−
54− ok :: IO Bool
55− ok = do
56− setSGR [SetColor Foreground Vivid Green]
57− putStrLn "ok"
58− setSGR [Reset]
59− return True
60−
61−-- | Run a bunch of tests and throw an exception if any fails
62−runTests :: [(String, IO ())] -> IO ()
63−runTests tests = do
64− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests
65− unless success $ fail "Some tests failed"
66−
67−-- | Random thread delay between 0 and the specified max
68−randomThreadDelay :: Int -> IO ()
69−randomThreadDelay maxDelay = do
70− delay <- randomIO :: IO Int
71− threadDelay (delay `mod` maxDelay)
distributed-process/tests/TestCH.hsdeleted−600
@@ -1,600 +0,0 @@
1−module Main where
2−
3−import Prelude hiding (catch)
4−import Data.Binary (Binary(..))
5−import Data.Typeable (Typeable)
6−import Data.Foldable (forM_)
7−import Control.Concurrent (forkIO, threadDelay)
8−import Control.Concurrent.MVar
9− ( MVar
10− , newEmptyMVar
11− , putMVar
12− , takeMVar
13− , readMVar
14− )
15−import Control.Monad (replicateM_, replicateM)
16−import Control.Exception (throwIO)
17−import Control.Applicative ((<$>), (<*>))
18−import qualified Network.Transport as NT (Transport, closeEndPoint)
19−import Network.Transport.TCP (createTransport, defaultTCPParameters)
20−import Control.Distributed.Process
21−import Control.Distributed.Process.Internal.Types (LocalNode(localEndPoint))
22−import Control.Distributed.Process.Node
23−import Control.Distributed.Process.Serializable (Serializable)
24−import TestAuxiliary
25−
26−newtype Ping = Ping ProcessId
27− deriving (Typeable, Binary, Show)
28−
29−newtype Pong = Pong ProcessId
30− deriving (Typeable, Binary, Show)
31−
32−-- | The ping server from the paper
33−ping :: Process ()
34−ping = do
35− Pong partner <- expect
36− self <- getSelfPid
37− send partner (Ping self)
38− ping
39−
40−-- | Basic ping test
41−testPing :: NT.Transport -> IO ()
42−testPing transport = do
43− serverAddr <- newEmptyMVar
44− clientDone <- newEmptyMVar
45−
46− -- Server
47− forkIO $ do
48− localNode <- newLocalNode transport initRemoteTable
49− addr <- forkProcess localNode ping
50− putMVar serverAddr addr
51−
52− -- Client
53− forkIO $ do
54− localNode <- newLocalNode transport initRemoteTable
55− pingServer <- readMVar serverAddr
56−
57− let numPings = 10000
58−
59− runProcess localNode $ do
60− pid <- getSelfPid
61− replicateM_ numPings $ do
62− send pingServer (Pong pid)
63− Ping _ <- expect
64− return ()
65−
66− putMVar clientDone ()
67−
68− takeMVar clientDone
69−
70−-- | Monitor or link to a remote node
71−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
72− -> ProcessId -- Process to monitor/link to
73− -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
74− -> Process (Maybe MonitorRef)
75−monitorOrLink mOrL pid mSignal = do
76− result <- if mOrL then Just <$> monitor pid
77− else link pid >> return Nothing
78− -- Monitor is asynchronous, which usually does not matter but if we want a
79− -- *specific* signal then it does. Therefore we wait an arbitrary delay and
80− -- hope that this means the monitor has been set up
81− forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
82− return result
83−
84−monitorTestProcess :: ProcessId -- Process to monitor/link to
85− -> Bool -- 'True' for monitor, 'False' for link
86− -> Bool -- Should we unmonitor?
87− -> DiedReason -- Expected cause of death
88− -> Maybe (MVar ()) -- Signal for 'monitor set up'
89− -> MVar () -- Signal for successful termination
90− -> Process ()
91−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
92− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
93− case (un, mRef) of
94− (True, Nothing) -> do
95− unlink theirAddr
96− liftIO $ putMVar done ()
97− (True, Just ref) -> do
98− unmonitor ref
99− liftIO $ putMVar done ()
100− (False, ref) -> do
101− ProcessMonitorNotification ref' pid reason' <- expect
102− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
103− liftIO $ putMVar done ()
104− )
105− (\(ProcessLinkException pid reason') -> do
106− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
107− liftIO $ putMVar done ()
108− )
109−
110−
111−-- | Monitor a process on an unreachable node
112−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
113−testMonitorUnreachable transport mOrL un = do
114− deadProcess <- newEmptyMVar
115− done <- newEmptyMVar
116−
117− forkIO $ do
118− localNode <- newLocalNode transport initRemoteTable
119− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
120− closeLocalNode localNode
121− putMVar deadProcess addr
122−
123− forkIO $ do
124− localNode <- newLocalNode transport initRemoteTable
125− theirAddr <- readMVar deadProcess
126− runProcess localNode $
127− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
128−
129− takeMVar done
130−
131−-- | Monitor a process which terminates normally
132−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
133−testMonitorNormalTermination transport mOrL un = do
134− monitorSetup <- newEmptyMVar
135− monitoredProcess <- newEmptyMVar
136− done <- newEmptyMVar
137−
138− forkIO $ do
139− localNode <- newLocalNode transport initRemoteTable
140− addr <- forkProcess localNode $
141− liftIO $ readMVar monitorSetup
142− putMVar monitoredProcess addr
143−
144− forkIO $ do
145− localNode <- newLocalNode transport initRemoteTable
146− theirAddr <- readMVar monitoredProcess
147− runProcess localNode $
148− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
149−
150− takeMVar done
151−
152−-- | Monitor a process which terminates abnormally
153−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
154−testMonitorAbnormalTermination transport mOrL un = do
155− monitorSetup <- newEmptyMVar
156− monitoredProcess <- newEmptyMVar
157− done <- newEmptyMVar
158−
159− let err = userError "Abnormal termination"
160−
161− forkIO $ do
162− localNode <- newLocalNode transport initRemoteTable
163− addr <- forkProcess localNode . liftIO $ do
164− readMVar monitorSetup
165− throwIO err
166− putMVar monitoredProcess addr
167−
168− forkIO $ do
169− localNode <- newLocalNode transport initRemoteTable
170− theirAddr <- readMVar monitoredProcess
171− runProcess localNode $
172− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
173−
174− takeMVar done
175−
176−-- | Monitor a local process that is already dead
177−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
178−testMonitorLocalDeadProcess transport mOrL un = do
179− processDead <- newEmptyMVar
180− processAddr <- newEmptyMVar
181− localNode <- newLocalNode transport initRemoteTable
182− done <- newEmptyMVar
183−
184− forkIO $ do
185− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
186− putMVar processAddr addr
187−
188− forkIO $ do
189− theirAddr <- readMVar processAddr
190− readMVar processDead
191− runProcess localNode $ do
192− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
193−
194− takeMVar done
195−
196−-- | Monitor a remote process that is already dead
197−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
198−testMonitorRemoteDeadProcess transport mOrL un = do
199− processDead <- newEmptyMVar
200− processAddr <- newEmptyMVar
201− done <- newEmptyMVar
202−
203− forkIO $ do
204− localNode <- newLocalNode transport initRemoteTable
205− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
206− putMVar processAddr addr
207−
208− forkIO $ do
209− localNode <- newLocalNode transport initRemoteTable
210− theirAddr <- readMVar processAddr
211− readMVar processDead
212− runProcess localNode $ do
213− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
214−
215− takeMVar done
216−
217−-- | Monitor a process that becomes disconnected
218−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
219−testMonitorDisconnect transport mOrL un = do
220− processAddr <- newEmptyMVar
221− monitorSetup <- newEmptyMVar
222− done <- newEmptyMVar
223−
224− forkIO $ do
225− localNode <- newLocalNode transport initRemoteTable
226− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
227− putMVar processAddr addr
228− readMVar monitorSetup
229− NT.closeEndPoint (localEndPoint localNode)
230−
231− forkIO $ do
232− localNode <- newLocalNode transport initRemoteTable
233− theirAddr <- readMVar processAddr
234− runProcess localNode $ do
235− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
236−
237− takeMVar done
238−
239−data Add = Add ProcessId Double Double deriving (Typeable)
240−data Divide = Divide ProcessId Double Double deriving (Typeable)
241−data DivByZero = DivByZero deriving (Typeable)
242−
243−instance Binary Add where
244− put (Add pid x y) = put pid >> put x >> put y
245− get = Add <$> get <*> get <*> get
246−
247−instance Binary Divide where
248− put (Divide pid x y) = put pid >> put x >> put y
249− get = Divide <$> get <*> get <*> get
250−
251−instance Binary DivByZero where
252− put DivByZero = return ()
253− get = return DivByZero
254−
255−math :: Process ()
256−math = do
257− receiveWait
258− [ match (\(Add pid x y) -> send pid (x + y))
259− , matchIf (\(Divide _ _ y) -> y /= 0)
260− (\(Divide pid x y) -> send pid (x / y))
261− , match (\(Divide pid _ _) -> send pid DivByZero)
262− ]
263− math
264−
265−-- | Test the math server (i.e., receiveWait)
266−testMath :: NT.Transport -> IO ()
267−testMath transport = do
268− serverAddr <- newEmptyMVar
269− clientDone <- newEmptyMVar
270−
271− -- Server
272− forkIO $ do
273− localNode <- newLocalNode transport initRemoteTable
274− addr <- forkProcess localNode math
275− putMVar serverAddr addr
276−
277− -- Client
278− forkIO $ do
279− localNode <- newLocalNode transport initRemoteTable
280− mathServer <- readMVar serverAddr
281−
282− runProcess localNode $ do
283− pid <- getSelfPid
284− send mathServer (Add pid 1 2)
285− 3 <- expect :: Process Double
286− send mathServer (Divide pid 8 2)
287− 4 <- expect :: Process Double
288− send mathServer (Divide pid 8 0)
289− DivByZero <- expect
290− liftIO $ putMVar clientDone ()
291−
292− takeMVar clientDone
293−
294−-- | Send first message (i.e. connect) to an already terminated process
295−-- (without monitoring); then send another message to a second process on
296−-- the same remote node (we're checking that the remote node did not die)
297−testSendToTerminated :: NT.Transport -> IO ()
298−testSendToTerminated transport = do
299− serverAddr1 <- newEmptyMVar
300− serverAddr2 <- newEmptyMVar
301− clientDone <- newEmptyMVar
302−
303− forkIO $ do
304− terminated <- newEmptyMVar
305− localNode <- newLocalNode transport initRemoteTable
306− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
307− addr2 <- forkProcess localNode $ ping
308− readMVar terminated
309− putMVar serverAddr1 addr1
310− putMVar serverAddr2 addr2
311−
312− forkIO $ do
313− localNode <- newLocalNode transport initRemoteTable
314− server1 <- readMVar serverAddr1
315− server2 <- readMVar serverAddr2
316− runProcess localNode $ do
317− pid <- getSelfPid
318− send server1 "Hi"
319− send server2 (Pong pid)
320− Ping pid' <- expect
321− True <- return $ pid' == server2
322− liftIO $ putMVar clientDone ()
323−
324− takeMVar clientDone
325−
326−-- | Test (non-zero) timeout
327−testTimeout :: NT.Transport -> IO ()
328−testTimeout transport = do
329− localNode <- newLocalNode transport initRemoteTable
330− runProcess localNode $ do
331− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
332− return ()
333−
334−-- | Test zero timeout
335−testTimeout0 :: NT.Transport -> IO ()
336−testTimeout0 transport = do
337− serverAddr <- newEmptyMVar
338− clientDone <- newEmptyMVar
339− messagesSent <- newEmptyMVar
340−
341− forkIO $ do
342− localNode <- newLocalNode transport initRemoteTable
343− addr <- forkProcess localNode $ do
344− liftIO $ readMVar messagesSent >> threadDelay 1000000
345− -- Variation on the venerable ping server which uses a zero timeout
346− -- Since we wait for all messages to be sent before doing this receive,
347− -- we should nevertheless find the right message immediately
348− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
349− self <- getSelfPid
350− send partner (Ping self)
351− putMVar serverAddr addr
352−
353− forkIO $ do
354− localNode <- newLocalNode transport initRemoteTable
355− server <- readMVar serverAddr
356− runProcess localNode $ do
357− pid <- getSelfPid
358− -- Send a bunch of messages. A large number of messages that the server
359− -- is not interested in, and then a single message that it wants
360− replicateM_ 10000 $ send server "Irrelevant message"
361− send server (Pong pid)
362− liftIO $ putMVar messagesSent ()
363− Ping _ <- expect
364− liftIO $ putMVar clientDone ()
365−
366− takeMVar clientDone
367−
368−-- | Test typed channels
369−testTypedChannels :: NT.Transport -> IO ()
370−testTypedChannels transport = do
371− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
372− clientDone <- newEmptyMVar
373−
374− forkIO $ do
375− localNode <- newLocalNode transport initRemoteTable
376− forkProcess localNode $ do
377− (serverSendPort, rport) <- newChan
378− liftIO $ putMVar serverChannel serverSendPort
379− (clientSendPort, i) <- receiveChan rport
380− sendChan clientSendPort (even i)
381− return ()
382−
383− forkIO $ do
384− localNode <- newLocalNode transport initRemoteTable
385− serverSendPort <- readMVar serverChannel
386− runProcess localNode $ do
387− (clientSendPort, rport) <- newChan
388− sendChan serverSendPort (clientSendPort, 5)
389− False <- receiveChan rport
390− liftIO $ putMVar clientDone ()
391−
392− takeMVar clientDone
393−
394−-- | Test merging receive ports
395−testMergeChannels :: NT.Transport -> IO ()
396−testMergeChannels transport = do
397− localNode <- newLocalNode transport initRemoteTable
398− testFlat localNode True "aaabbbccc"
399− testFlat localNode False "abcabcabc"
400− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
401− testNested localNode True False "adgadgadgbehbehbehcficficfi"
402− testNested localNode False True "abcabcabcdefdefdefghighighi"
403− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
404− testBlocked localNode True
405− testBlocked localNode False
406− where
407− -- Single layer of merging
408− testFlat :: LocalNode -> Bool -> String -> IO ()
409− testFlat localNode biased expected =
410− runProcess localNode $ do
411− rs <- mapM charChannel "abc"
412− m <- mergePorts biased rs
413− xs <- replicateM 9 $ receiveChan m
414− True <- return $ xs == expected
415− return ()
416−
417− -- Two layers of merging
418− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
419− testNested localNode biasedInner biasedOuter expected =
420− runProcess localNode $ do
421− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
422− ms <- mapM (mergePorts biasedInner) rss
423− m <- mergePorts biasedOuter ms
424− xs <- replicateM (9 * 3) $ receiveChan m
425− True <- return $ xs == expected
426− return ()
427−
428− -- Test that if no messages are (immediately) available, the scheduler makes no difference
429− testBlocked :: LocalNode -> Bool -> IO ()
430− testBlocked localNode biased = do
431− vs <- replicateM 3 newEmptyMVar
432−
433− forkProcess localNode $ do
434− [sa, sb, sc] <- liftIO $ mapM readMVar vs
435− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
436− [ -- a, b, c
437− (sa, 'a')
438− , (sb, 'b')
439− , (sc, 'c')
440− -- a, c, b
441− , (sa, 'a')
442− , (sc, 'c')
443− , (sb, 'b')
444− -- b, a, c
445− , (sb, 'b')
446− , (sa, 'a')
447− , (sc, 'c')
448− -- b, c, a
449− , (sb, 'b')
450− , (sc, 'c')
451− , (sa, 'a')
452− -- c, a, b
453− , (sc, 'c')
454− , (sa, 'a')
455− , (sb, 'b')
456− -- c, b, a
457− , (sc, 'c')
458− , (sb, 'b')
459− , (sa, 'a')
460− ]
461−
462− runProcess localNode $ do
463− (ss, rs) <- unzip <$> replicateM 3 newChan
464− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
465− m <- mergePorts biased rs
466− xs <- replicateM (6 * 3) $ receiveChan m
467− True <- return $ xs == "abcacbbacbcacabcba"
468− return ()
469−
470− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
471− mergePorts True = mergePortsBiased
472− mergePorts False = mergePortsRR
473−
474− charChannel :: Char -> Process (ReceivePort Char)
475− charChannel c = do
476− (sport, rport) <- newChan
477− replicateM_ 3 $ sendChan sport c
478− liftIO $ threadDelay 10000 -- Make sure messages have been sent
479− return rport
480−
481−testTerminate :: NT.Transport -> IO ()
482−testTerminate transport = do
483− localNode <- newLocalNode transport initRemoteTable
484−
485− pid <- forkProcess localNode $ do
486− liftIO $ threadDelay 100000
487− terminate
488−
489− runProcess localNode $ do
490− ref <- monitor pid
491− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
492− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
493− return ()
494−
495−testMonitorNode :: NT.Transport -> IO ()
496−testMonitorNode transport = do
497− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
498−
499− closeLocalNode node1
500−
501− runProcess node2 $ do
502− ref <- monitorNode (localNodeId node1)
503− NodeMonitorNotification ref' nid DiedDisconnect <- expect
504− True <- return $ ref == ref' && nid == localNodeId node1
505− return ()
506−
507−testMonitorChannel :: NT.Transport -> IO ()
508−testMonitorChannel transport = do
509− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
510− gotNotification <- newEmptyMVar
511−
512− pid <- forkProcess node1 $ do
513− sport <- expect :: Process (SendPort ())
514− ref <- monitorPort sport
515− PortMonitorNotification ref' port' DiedNormal <- expect
516− return $ ref' == ref && port' == sendPortId sport
517− liftIO $ putMVar gotNotification ()
518−
519− runProcess node2 $ do
520− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
521− send pid sport
522− liftIO $ threadDelay 100000
523−
524− takeMVar gotNotification
525−
526−testRegistry :: NT.Transport -> IO ()
527−testRegistry transport = do
528− node <- newLocalNode transport initRemoteTable
529−
530− pingServer <- forkProcess node ping
531−
532− runProcess node $ do
533− register "ping" pingServer
534− Just pid <- whereis "ping"
535− True <- return $ pingServer == pid
536− us <- getSelfPid
537− nsend "ping" (Pong us)
538− Ping pid' <- expect
539− True <- return $ pingServer == pid'
540− return ()
541−
542−testRemoteRegistry :: NT.Transport -> IO ()
543−testRemoteRegistry transport = do
544− node1 <- newLocalNode transport initRemoteTable
545− node2 <- newLocalNode transport initRemoteTable
546−
547− pingServer <- forkProcess node1 ping
548−
549− runProcess node2 $ do
550− let nid1 = localNodeId node1
551− registerRemote nid1 "ping" pingServer
552− Just pid <- whereisRemote nid1 "ping"
553− True <- return $ pingServer == pid
554− us <- getSelfPid
555− nsendRemote nid1 "ping" (Pong us)
556− Ping pid' <- expect
557− True <- return $ pingServer == pid'
558− return ()
559−
560−main :: IO ()
561−main = do
562− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
563− runTests
564− [ ("Ping", testPing transport)
565− , ("Math", testMath transport)
566− , ("Timeout", testTimeout transport)
567− , ("Timeout0", testTimeout0 transport)
568− , ("SendToTerminated", testSendToTerminated transport)
569− , ("TypedChannnels", testTypedChannels transport)
570− , ("MergeChannels", testMergeChannels transport)
571− , ("Terminate", testTerminate transport)
572− , ("Registry", testRegistry transport)
573− , ("RemoteRegistry", testRemoteRegistry transport)
574− -- Monitoring processes
575− --
576− -- The "missing" combinations in the list below don't make much sense, as
577− -- we cannot guarantee that the monitor reply or link exception will not
578− -- happen before the unmonitor or unlink
579− , ("MonitorUnreachable", testMonitorUnreachable transport True False)
580− , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
581− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
582− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
583− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
584− , ("MonitorDisconnect", testMonitorDisconnect transport True False)
585− , ("LinkUnreachable", testMonitorUnreachable transport False False)
586− , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
587− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
588− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
589− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
590− , ("LinkDisconnect", testMonitorDisconnect transport False False)
591− , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
592− , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
593− , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
594− , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
595− , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
596− , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
597− -- Monitoring nodes and channels
598− , ("MonitorNode", testMonitorNode transport)
599− , ("MonitorChannel", testMonitorChannel transport)
600− ]
distributed-process/tests/TestClosure.hsdeleted−296
@@ -1,296 +0,0 @@
1−module Main where
2−
3−import Data.ByteString.Lazy (empty)
4−import Data.Typeable (Typeable, typeOf)
5−import Control.Monad (join, replicateM)
6−import Control.Exception (IOException, throw)
7−import Control.Concurrent (forkIO, threadDelay)
8−import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, takeMVar, putMVar)
9−import Control.Applicative ((<$>))
10−import Network.Transport (Transport)
11−import Network.Transport.TCP (createTransport, defaultTCPParameters)
12−import Control.Distributed.Process
13−import Control.Distributed.Process.Closure
14−import Control.Distributed.Process.Node
15−import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))
16−import TestAuxiliary
17−
18−sdictInt :: SerializableDict Int
19−sdictInt = SerializableDict
20−
21−factorial :: Int -> Process Int
22−factorial 0 = return 1
23−factorial n = (n *) <$> factorial (n - 1)
24−
25−addInt :: Int -> Int -> Int
26−addInt x y = x + y
27−
28−putInt :: Int -> MVar Int -> IO ()
29−putInt = flip putMVar
30−
31−sendPid :: ProcessId -> Process ()
32−sendPid toPid = do
33− fromPid <- getSelfPid
34− send toPid fromPid
35−
36−wait :: Int -> Process ()
37−wait = liftIO . threadDelay
38−
39−remotable [ 'factorial
40− , 'addInt
41− , 'putInt
42− , 'sendPid
43− , 'sdictInt
44− , 'wait
45− ]
46−
47−factorialClosure :: Int -> Closure (Process Int)
48−factorialClosure = $(mkClosure 'factorial)
49−
50−addIntClosure :: Int -> Closure (Int -> Int)
51−addIntClosure = $(mkClosure 'addInt)
52−
53−putIntClosure :: Int -> Closure (MVar Int -> IO ())
54−putIntClosure = $(mkClosure 'putInt)
55−
56−sendPidClosure :: ProcessId -> Closure (Process ())
57−sendPidClosure = $(mkClosure 'sendPid)
58−
59−sendFac :: Int -> ProcessId -> Closure (Process ())
60−sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid
61−
62−factorialOf :: Closure (Int -> Process Int)
63−factorialOf = staticClosure $(mkStatic 'factorial)
64−
65−factorial' :: Int -> Closure (Process Int)
66−factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf
67−
68−waitClosure :: Int -> Closure (Process ())
69−waitClosure = $(mkClosure 'wait)
70−
71−testUnclosure :: Transport -> RemoteTable -> IO ()
72−testUnclosure transport rtable = do
73− node <- newLocalNode transport rtable
74− runProcess node $ do
75− 120 <- join . unClosure $ factorialClosure 5
76− return ()
77−
78−testBind :: Transport -> RemoteTable -> IO ()
79−testBind transport rtable = do
80− node <- newLocalNode transport rtable
81− runProcess node $ do
82− us <- getSelfPid
83− join . unClosure $ sendFac 6 us
84− (720 :: Int) <- expect
85− return ()
86−
87−testSendPureClosure :: Transport -> RemoteTable -> IO ()
88−testSendPureClosure transport rtable = do
89− serverAddr <- newEmptyMVar
90− serverDone <- newEmptyMVar
91−
92− forkIO $ do
93− node <- newLocalNode transport rtable
94− addr <- forkProcess node $ do
95− cl <- expect
96− fn <- unClosure cl :: Process (Int -> Int)
97− 13 <- return $ fn 6
98− liftIO $ putMVar serverDone ()
99− putMVar serverAddr addr
100−
101− forkIO $ do
102− node <- newLocalNode transport rtable
103− theirAddr <- readMVar serverAddr
104− runProcess node $ send theirAddr (addIntClosure 7)
105−
106− takeMVar serverDone
107−
108−testSendIOClosure :: Transport -> RemoteTable -> IO ()
109−testSendIOClosure transport rtable = do
110− serverAddr <- newEmptyMVar
111− serverDone <- newEmptyMVar
112−
113− forkIO $ do
114− node <- newLocalNode transport rtable
115− addr <- forkProcess node $ do
116− cl <- expect
117− io <- unClosure cl :: Process (MVar Int -> IO ())
118− liftIO $ do
119− someMVar <- newEmptyMVar
120− io someMVar
121− 5 <- readMVar someMVar
122− putMVar serverDone ()
123− putMVar serverAddr addr
124−
125− forkIO $ do
126− node <- newLocalNode transport rtable
127− theirAddr <- readMVar serverAddr
128− runProcess node $ send theirAddr (putIntClosure 5)
129−
130− takeMVar serverDone
131−
132−testSendProcClosure :: Transport -> RemoteTable -> IO ()
133−testSendProcClosure transport rtable = do
134− serverAddr <- newEmptyMVar
135− clientDone <- newEmptyMVar
136−
137− forkIO $ do
138− node <- newLocalNode transport rtable
139− addr <- forkProcess node $ do
140− cl <- expect
141− pr <- unClosure cl :: Process (Int -> Process ())
142− pr 5
143− putMVar serverAddr addr
144−
145− forkIO $ do
146− node <- newLocalNode transport rtable
147− theirAddr <- readMVar serverAddr
148− runProcess node $ do
149− pid <- getSelfPid
150− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
151− 5 <- expect :: Process Int
152− liftIO $ putMVar clientDone ()
153−
154− takeMVar clientDone
155−
156−testSpawn :: Transport -> RemoteTable -> IO ()
157−testSpawn transport rtable = do
158− serverNodeAddr <- newEmptyMVar
159− clientDone <- newEmptyMVar
160−
161− forkIO $ do
162− node <- newLocalNode transport rtable
163− putMVar serverNodeAddr (localNodeId node)
164−
165− forkIO $ do
166− node <- newLocalNode transport rtable
167− nid <- readMVar serverNodeAddr
168− runProcess node $ do
169− pid <- getSelfPid
170− pid' <- spawn nid (sendPidClosure pid)
171− pid'' <- expect
172− True <- return $ pid' == pid''
173− liftIO $ putMVar clientDone ()
174−
175− takeMVar clientDone
176−
177−testCall :: Transport -> RemoteTable -> IO ()
178−testCall transport rtable = do
179− serverNodeAddr <- newEmptyMVar
180− clientDone <- newEmptyMVar
181−
182− forkIO $ do
183− node <- newLocalNode transport rtable
184− putMVar serverNodeAddr (localNodeId node)
185−
186− forkIO $ do
187− node <- newLocalNode transport rtable
188− nid <- readMVar serverNodeAddr
189− runProcess node $ do
190− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
191− liftIO $ putMVar clientDone ()
192−
193− takeMVar clientDone
194−
195−testCallBind :: Transport -> RemoteTable -> IO ()
196−testCallBind transport rtable = do
197− serverNodeAddr <- newEmptyMVar
198− clientDone <- newEmptyMVar
199−
200− forkIO $ do
201− node <- newLocalNode transport rtable
202− putMVar serverNodeAddr (localNodeId node)
203−
204− forkIO $ do
205− node <- newLocalNode transport rtable
206− nid <- readMVar serverNodeAddr
207− runProcess node $ do
208− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
209− liftIO $ putMVar clientDone ()
210−
211− takeMVar clientDone
212−
213−testSeq :: Transport -> RemoteTable -> IO ()
214−testSeq transport rtable = do
215− node <- newLocalNode transport rtable
216− runProcess node $ do
217− us <- getSelfPid
218− join . unClosure $ sendFac 5 us `cpSeq` sendFac 6 us
219− 120 :: Int <- expect
220− 720 :: Int <- expect
221− return ()
222−
223−-- Test 'spawnSupervised'
224−--
225−-- Set up a supervisor, spawn a child, then have a third process monitor the
226−-- child. The supervisor then throws an exception, the child dies because it
227−-- was linked to the supervisor, and the third process notices that the child
228−-- dies.
229−testSpawnSupervised :: Transport -> RemoteTable -> IO ()
230−testSpawnSupervised transport rtable = do
231− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
232− [superPid, childPid] <- replicateM 2 $ newEmptyMVar
233− thirdProcessDone <- newEmptyMVar
234−
235− forkProcess node1 $ do
236− us <- getSelfPid
237− liftIO $ putMVar superPid us
238− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
239− liftIO $ do
240− putMVar childPid child
241− threadDelay 500000 -- Give the child a chance to link to us
242− throw supervisorDeath
243−
244− forkProcess node2 $ do
245− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
246− ref <- monitor child
247− ProcessMonitorNotification ref' pid' (DiedException e) <- expect
248− True <- return $ ref' == ref
249− && pid' == child
250− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
251− liftIO $ putMVar thirdProcessDone ()
252−
253− takeMVar thirdProcessDone
254− where
255− supervisorDeath :: IOException
256− supervisorDeath = userError "Supervisor died"
257−
258−testSpawnInvalid :: Transport -> RemoteTable -> IO ()
259−testSpawnInvalid transport rtable = do
260− node <- newLocalNode transport rtable
261− runProcess node $ do
262− (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (StaticLabel "ThisDoesNotExist" (typeOf ()))) empty)
263− ProcessMonitorNotification ref' pid' _reason <- expect
264− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
265− True <- return $ ref' == ref && pid == pid'
266− return ()
267−
268−testClosureExpect :: Transport -> RemoteTable -> IO ()
269−testClosureExpect transport rtable = do
270− node <- newLocalNode transport rtable
271− runProcess node $ do
272− nodeId <- getSelfNode
273− us <- getSelfPid
274− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `cpBind` cpSend $(mkStatic 'sdictInt) us
275− send them (1234 :: Int)
276− (1234 :: Int) <- expect
277− return ()
278−
279−main :: IO ()
280−main = do
281− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
282− let rtable = __remoteTable initRemoteTable
283− runTests
284− [ ("Unclosure", testUnclosure transport rtable)
285− , ("Bind", testBind transport rtable)
286− , ("SendPureClosure", testSendPureClosure transport rtable)
287− , ("SendIOClosure", testSendIOClosure transport rtable)
288− , ("SendProcClosure", testSendProcClosure transport rtable)
289− , ("Spawn", testSpawn transport rtable)
290− , ("Call", testCall transport rtable)
291− , ("CallBind", testCallBind transport rtable)
292− , ("Seq", testSeq transport rtable)
293− , ("SpawnSupervised", testSpawnSupervised transport rtable)
294− , ("SpawnInvalid", testSpawnInvalid transport rtable)
295− , ("ClosureExpect", testClosureExpect transport rtable)
296− ]
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/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−20
@@ -1,20 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport)
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
11− Right endpoint <- newEndPoint transport
12−
13− let addr = EndPointAddress (pack serverAddr)
14− Right conn <- connect endpoint addr ReliableOrdered
15− send conn [pack "Hello world"]
16− close conn
17−
18− replicateM_ 3 $ receive endpoint >>= print
19−
20− closeTransport transport
doc/tutorial/tutorial-server.hsdeleted−52
@@ -1,52 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport)
3−import Control.Concurrent
4−import Data.Map
5−import Control.Exception
6−import System.Environment
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− connMVar <- newEmptyMVar
18− forkIO $ do
19− Right conn <- connect endpoint addr rel
20− putMVar connMVar conn
21− go (insert cid connMVar cs)
22− Received cid payload -> do
23− forkIO $ do
24− conn <- readMVar (cs ! cid)
25− send conn payload
26− return ()
27− go cs
28− ConnectionClosed cid -> do
29− forkIO $ do
30− conn <- readMVar (cs ! cid)
31− close conn
32− go (delete cid cs)
33− EndPointClosed -> do
34− putStrLn "Echo server exiting"
35− putMVar serverDone ()
36−
37−onCtrlC :: IO a -> IO () -> IO a
38−p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
39− where
40− isUserInterrupt :: AsyncException -> Maybe ()
41− isUserInterrupt UserInterrupt = Just ()
42− isUserInterrupt _ = Nothing
43−
44−main :: IO ()
45−main = do
46− [host, port] <- getArgs
47− serverDone <- newEmptyMVar
48− Right transport <- createTransport host port
49− Right endpoint <- newEndPoint transport
50− forkIO $ echoServer endpoint serverDone
51− putStrLn $ "Echo server started at " ++ show (address endpoint)
52− readMVar serverDone `onCtrlC` closeTransport transport
examples/.gitignoredeleted−1
@@ -1 +0,0 @@
1−*.exe
examples/DemoProcess.hsdeleted−36
@@ -1,36 +0,0 @@
1−module Main where
2−
3−import Control.Distributed.Process
4−import Control.Concurrent (threadDelay)
5−
6−import Network.Transport (closeTransport)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Debug.Trace
10−
11−demo1 = do
12− trans <- mkTransport $ TCPConfig undefined "127.0.0.1" "8080"
13− node <- newLocalNode trans
14− print "Starting node"
15− runProcess node $ do
16− liftIO $ print "Starting process"
17− lpid1 <- spawnLocal (logger 1)
18− spawnLocal (chatty "jim1" lpid1)
19− spawnLocal (chatty "bob1" lpid1)
20− return ()
21− threadDelay 600000
22− closeTransport trans
23−
24−chatty :: String -> ProcessId -> Process ()
25−chatty name target = do
26− send target (name ++ " says: hi there")
27− liftIO $ threadDelay 500000
28− send target (name ++ " says: bye")
29−
30−logger :: Int -> Process ()
31−logger n = do
32− str <- expect
33− liftIO . putStrLn $ show n ++ ": " ++ str
34− logger (n+1)
35−
36−main = demo1
examples/DemoTCP.hsdeleted−113
@@ -1,113 +0,0 @@
1−module Main where
2−
3−import Network.Transport
4−import Network.Transport.TCP
5−
6−import Control.Monad
7−import Data.Char
8−import Data.String
9−import Network.Socket (HostName, ServiceName)
10−import System.Environment
11−
12−import qualified Data.ByteString.Char8 as BS
13−
14−import Debug.Trace
15−
16−type ChanId = Int
17−
18−-- | This example demonstrates how a master can be connected to slaves using
19−-- the transport layer. After compiling, the following will initialize a new
20−-- master that waits for two clients to connect on the local machine:
21−--
22−-- ./DemoTCP 127.0.0.1 8080 sourceAddrFile 2
23−--
24−-- Following this, two slaves should be created that will connect to the master:
25−--
26−-- ./DemoTCP 127.0.0.1 8081 sourceAddrFile
27−-- ./DemoTCP 127.0.0.1 8082 sourceAddrFile
28−--
29−-- Once the connection is established, the slaves will provide the master
30−-- with their SourceAddr. The master then decodes this, and sends a message
31−-- back. After processing this message, the slaves respond to the master,
32−-- which then outputs some data.
33−main :: IO ()
34−main = do
35− args <- getArgs
36− case args of
37− -- Master:
38− -- The master only provides the host, service, and slaves to expect.
39− [host, service, sourceAddrFilePath, number] -> do
40− let numSlaves = read number
41− transport <- mkTransport $ TCPConfig defaultHints host service
42− (clientSourceEnds, masterTargetEnd) <- demoMaster transport sourceAddrFilePath numSlaves
43− zipWithM_
44− (\clientSourceEnd clientId ->
45− send clientSourceEnd [BS.pack . show $ clientId])
46− clientSourceEnds [0 .. numSlaves-1]
47− replicateM_ numSlaves $ do
48− [clientMessage] <- receive masterTargetEnd
49− print clientMessage
50−
51− closeTargetEnd masterTargetEnd
52− putStrLn "master: close connections"
53−
54− -- Slave:
55− -- Each slave provides its own host and service, as well as details of
56− -- the master it wishes to connect to.
57− [host, service, sourceAddrFilePath] -> do
58− transport <- mkTransport $ TCPConfig defaultHints host service
59− (masterSourceEnd, slaveTargetEnd) <- demoSlave transport sourceAddrFilePath
60− [clientId] <- receive slaveTargetEnd
61− putStrLn $ "slave: received clientId: " ++ show clientId
62− let message = "Connected to slave: " ++ (BS.unpack clientId)
63−
64− send masterSourceEnd [BS.pack message]
65− putStrLn "slave: sent message to master"
66−
67− closeSourceEnd masterSourceEnd
68− putStrLn "slave: close connection"
69−
70− _ -> error "Unexpected arguments"
71−
72−demoMaster :: Transport -- ^ Transport
73− -> FilePath -- ^ File to write SourceAddr
74− -> Int -- ^ Number of slaves to expect
75− -> IO ([SourceEnd], TargetEnd)
76−demoMaster transport sourceAddrFilePath numSlaves = do
77− -- Establish an initial transport
78− (sourceAddr, targetEnd) <- newConnection transport
79−
80− -- Write a file containing the sourceAddr
81− putStrLn $ "master: writing sourceAddr file:" ++ (show . serialize $ sourceAddr)
82− BS.writeFile sourceAddrFilePath $ serialize sourceAddr
83−
84− -- Deserialize each of the sourceEnds received by the slaves
85− sourceEnds <- replicateM numSlaves $ do
86− [bytes] <- receive targetEnd
87− putStrLn "master: received connection."
88− case deserialize transport bytes of
89− Nothing -> fail "Garbage message from slave!"
90− Just sourceAddr -> connect sourceAddr
91− return (sourceEnds, targetEnd)
92−
93−demoSlave :: Transport -- ^ Transport
94− -> FilePath -- ^ File to read SourceAddr
95− -> IO (SourceEnd, TargetEnd)
96−demoSlave transport masterSourceAddrFilePath = do
97− -- Create a new connection on the transport
98− (sourceAddr, targetEnd) <- newConnection transport
99−
100− -- Establish connection with the master
101− bytes <- BS.readFile masterSourceAddrFilePath
102− case deserialize transport bytes of
103− Just masterSourceAddr -> do
104− putStrLn $ "slave: connecting to sourceAddr: " ++ (show . serialize $ masterSourceAddr)
105− masterSourceEnd <- connect masterSourceAddr
106−
107− -- Source the serialized address of this slave
108− send masterSourceEnd [serialize sourceAddr]
109− putStrLn "slave: sent sourceAddr"
110− return (masterSourceEnd, targetEnd)
111−
112− Nothing -> error "slave: Unable to deserialize master SourceAddr!"
113−
examples/DemoTransport.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE CPP, NamedFieldPuns #-}
2−module Main where
3−
4−import Network.Transport
5−import qualified Network.Transport.MVar
6−import qualified Network.Transport.Pipes
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Concurrent
10−import Control.Monad
11−
12−#ifndef LAZY
13−import qualified Data.ByteString.Char8 as BS
14−#else
15−import qualified Data.ByteString.Lazy.Char8 as BS
16−#endif
17−
18−import Data.IORef
19−import Debug.Trace
20−
21−-------------------------------------------
22−
23−{- Run a demo above with one of these tranpsort shorthands like this:
24− tcp >>= demo0
25− -}
26−tcp = mkTCPOff 8080
27−mvar = return Network.Transport.MVar.mkTransport
28−pipes = return Network.Transport.Pipes.mkTransport
29−
30−tcp :: IO (IO Transport)
31−mvar :: IO (IO Transport)
32−pipes :: IO (IO Transport)
33−
34−-------------------------------------------
35−-- Example programs using backend directly
36−
37−
38−-- | Check if multiple messages can be sent on the same connection.
39−demo0 :: IO Transport -> IO ()
40−demo0 mktrans = do
41− trans <- mktrans
42−
43− (sourceAddr, targetEnd) <- newConnection trans
44−
45− forkIO $ logServer "logServer" targetEnd
46− threadDelay 100000
47−
48− sourceEnd <- connect sourceAddr
49−
50− mapM_ (\n -> send sourceEnd [BS.pack ("hello " ++ show n)]) [1 .. 10]
51− threadDelay 100000
52−
53− closeTransport trans
54−
55−
56−-- | Check endpoint serialization and deserialization.
57−demo1 :: IO Transport -> IO ()
58−demo1 mktrans = do
59− trans <- mktrans
60−
61− (sourceAddr, targetEnd) <- newConnection trans
62−
63− forkIO $ logServer "logServer" targetEnd
64− threadDelay 100000
65−
66− sourceEnd <- connect sourceAddr
67−
68− -- This use of Just is slightly naughty
69− let Just sourceAddr' = deserialize trans (serialize sourceAddr)
70− sourceEnd' <- connect sourceAddr'
71−
72− send sourceEnd [BS.pack "hello 1"]
73− send sourceEnd' [BS.pack "hello 2"]
74− threadDelay 100000
75− closeTransport trans
76−
77−
78−-- | Check that messages can be sent before receive is set up.
79−demo2 :: IO Transport -> IO ()
80−demo2 mktrans = do
81− trans <- mktrans
82−
83− (sourceAddr, targetEnd) <- newConnection trans
84− sourceEnd <- connect sourceAddr
85−
86− forkIO $ send sourceEnd [BS.pack "hello 1"]
87− threadDelay 100000
88−
89− forkIO $ logServer "logServer" targetEnd
90− threadDelay 100000
91− closeTransport trans
92−
93−
94−-- | Check that two different transports can be created.
95−demo3 :: IO Transport -> IO ()
96−demo3 mktrans = do
97− trans1 <- mktrans
98− trans2 <- mktrans
99−
100− (sourceAddr1, targetEnd1) <- newConnection trans1
101− (sourceAddr2, targetEnd2) <- newConnection trans2
102−
103− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
104− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
105−
106− sourceEnd1 <- connect sourceAddr1
107− sourceEnd2 <- connect sourceAddr2
108−
109− send sourceEnd1 [BS.pack "hello1"]
110− send sourceEnd2 [BS.pack "hello2"]
111−
112− threadDelay 100000
113− putStrLn "demo3: Time, up, killing threads & closing transports.."
114− killThread threadId1
115− killThread threadId2
116− putStrLn "demo3: Threads killed."
117− closeTransport trans1
118− closeTransport trans2
119− putStrLn "demo3: Done."
120−
121−
122−-- | Check that two different connections on the same transport can be created.
123−demo4 :: IO Transport -> IO ()
124−demo4 mktrans = do
125− trans <- mktrans
126−
127− (sourceAddr1, targetEnd1) <- newConnection trans
128− (sourceAddr2, targetEnd2) <- newConnection trans
129−
130− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
131− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
132−
133− sourceEnd1 <- connect sourceAddr1
134− sourceEnd2 <- connect sourceAddr2
135−
136− threadId3 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd1 [BS.pack ("A" ++ show i)]
137− threadId4 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd2 [BS.pack ("B" ++ show i)]
138−
139− threadDelay 1000000
140−
141− putStrLn "demo4: Time, up, killing threads & closing transports.."
142− killThread threadId1
143− killThread threadId2
144− killThread threadId3
145− killThread threadId4
146− putStrLn "demo4: Threads killed."
147− closeTransport trans
148− putStrLn "demo4: Done."
149−
150−
151−
152−--------------------------------------------------------------------------------
153−
154−logServer :: String -> TargetEnd -> IO ()
155−logServer name targetEnd = forever $ do
156− x <- receive targetEnd
157− trace (name ++ " rcvd: " ++ show x) $ return ()
158−
159−mkTCPOff off = do
160− cntr <- newIORef 0
161− return$ do cnt <- readIORef cntr
162− writeIORef cntr (cnt+1)
163− mkTransport (TCPConfig undefined "127.0.0.1" (show (off + cnt)))
164−
165−--------------------------------------------------------------------------------
166−
167−runWAllTranports :: (IO Transport -> IO ()) -> Int -> IO ()
168−runWAllTranports demo offset = do
169− putStrLn "------------------------------------------------------------"
170− putStrLn " MVAR transport:"
171− mvar >>= demo
172− putStrLn "\n TCP transport:"
173− tcp >>= demo
174− putStrLn "\n PIPES transport:"
175− pipes >>= demo
176− putStrLn "\n"
177−
178−
179−main = do
180− putStrLn "Demo0:"
181− runWAllTranports demo0 0
182− putStrLn "Demo1:"
183− runWAllTranports demo1 10
184− putStrLn "Demo2:"
185− runWAllTranports demo2 20
186− putStrLn "Demo3:"
187− runWAllTranports demo3 30
188− putStrLn "Demo4:"
189− runWAllTranports demo4 40
190−
191− threadDelay (300 * 1000)
192− putStrLn "Done with all demos!"
examples/Makefiledeleted−20
@@ -1,20 +0,0 @@
1−
2−
3−ifeq ($(GHC),)
4− GHC=ghc
5−endif
6−
7−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src -i../distributed-process/src
8−
9−EXMPLS= DemoTransport.exe DemoProcess.exe
10−
11−all: $(EXMPLS)
12−
13−$(EXMPLS): %.exe: %.hs
14− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $< -o $@
15−
16−# transport:
17−# $(GHC) -threaded --make -i../network-transport/src DemoTransport.hs -o DemoTransport.exe -fforce-recomp
18−
19−clean:
20− rm -f *.hi *.o $(EXMPLS)
install_all.shdeleted−18
@@ -1,18 +0,0 @@
1−#!/bin/bash
2−
3−set -e
4−
5−if [ "$GHC" == "" ]; then
6− GHC=ghc
7−fi
8−
9−cd network-transport/
10−cabal.par install --with-ghc=$GHC $*
11−
12−echo;echo
13−cd ../network-transport-pipes/
14−cabal.par install --with-ghc=$GHC $*
15−
16−echo;echo
17−cd ../distributed-process/
18−cabal.par install --with-ghc=$GHC $*
network-transport-inmemory/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-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-pipes/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Ryan Newton, 2011
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-pipes/network-transport-pipes.cabaldeleted−33
@@ -1,33 +0,0 @@
1−Name: network-transport-pipes
2−Version: 0.0.1.2
3−-- Version History:
4−-- 0.0.1.1 - Initial
5−
6−Description: Named Pipes backend for network-transport interface.
7−License: BSD3
8−License-file: LICENSE
9−Author: Ryan Newton
10−Maintainer: rrnewton@gmail.com
11−Homepage: http://github.com/haskell-distributed/
12−Build-Type: Simple
13−Cabal-Version: >=1.2
14−
15−Library
16− Build-Depends: base >= 3 && < 5,
17−-- binary >= 0.5,
18− cereal,
19− bytestring >= 0.9,
20− network-transport >= 0.0.1.1,
21−-- containers >= 0.4,
22− containers >= 0.3,
23−-- network >= 2.3,
24−-- safe >= 0.3,
25− unix >= 2.4,
26− random,
27− directory,
28− unix-bytestring >= 0.3.5.3,
29− time
30− Exposed-modules: Network.Transport.Pipes
31−-- Extensions: BangPatterns
32− ghc-options: -Wall
33− HS-Source-Dirs: src
network-transport-pipes/src/Network/Transport/Pipes.hsdeleted−264
@@ -1,264 +0,0 @@
1−{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, PackageImports #-}
2−
3−----------------------------------------------------------------------------------------------------
4−
5−-- WARNING -- This transport is not yet completed. TODO:
6−
7−-- * Add support for messages greater than 4096 bytes.
8−-- * debug ODD problem with CEREAL below
9−
10−----------------------------------------------------------------------------------------------------
11−
12−module Network.Transport.Pipes
13− ( mkTransport
14− ) where
15−
16−import Control.Monad (when, unless)
17−import Control.Exception (evaluate, throw, handle, fromException,
18− SomeException, IOException)
19−import Control.Concurrent.MVar
20−import Control.Concurrent (threadDelay, forkOS)
21−import Data.IntMap (IntMap)
22−-- import Data.ByteString.Char8 (ByteString)
23−import Data.Word
24−import Data.Int
25−import Data.IORef
26−import qualified Data.IntMap as IntMap
27−import qualified Data.ByteString.Char8 as BS
28−import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) -- Not in 6.10
29−
30−-- For some STRANGE reason this is not working with Data.Binary [2012.02.20]:
31−#define CEREAL
32−#ifdef CEREAL
33−import Data.Serialize (encode,decode) -- Uses strict BS
34−#else
35−import Data.Binary (encode,decode) -- Uses lazy BS
36−#endif
37−
38−import Data.List (foldl')
39−import Network.Transport
40−import System.Random (randomIO)
41−import System.IO (IOMode(ReadMode,AppendMode,WriteMode,ReadWriteMode),
42− openFile, hClose, hPutStrLn, hPutStr, stderr, stdout, hFlush)
43−import System.IO.Error (ioeGetHandle)
44−import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
45−import System.Posix.Types (Fd, ByteCount)
46−import System.Directory (doesFileExist, removeFile)
47−import System.Mem (performGC)
48−
49−#define USE_UNIX_BYTESTRING
50−#ifdef USE_UNIX_BYTESTRING
51−import qualified "unix-bytestring" System.Posix.IO.ByteString as PIO
52−-- import qualified "unix-bytestring" System.Posix.IO.ByteString.Lazy as PIO
53−import System.Posix.IO as PIO (openFd, closeFd, -- append, exclusive, noctty, nonBlock, trunc,
54− OpenFileFlags(..), OpenMode(ReadOnly, WriteOnly))
55−-- (fromS,toS) = (BS.pack, BS.unpack)
56−(fromS,toS) = (BS.pack, BS.unpack)
57−fromBS = id
58−readit fd n = PIO.fdRead fd n
59−#else
60−import qualified System.Posix.IO as PIO
61−(toS,fromS) = (id,id)
62−fromBS = BS.unpack
63−readit fd n = do (s,_) <- PIO.fdRead fd n
64− return (BS.pack s)
65−#endif
66−-- readit :: Fd -> Int -> IO BS.ByteString
67−readit :: Fd -> ByteCount -> IO BS.ByteString
68−
69−----------------------------------------------------------------------------------------------------
70−
71−-- The msg header consists of just a length field represented as a Word32
72−sizeof_header = 4
73−
74−fileFlags =
75− PIO.OpenFileFlags {
76− PIO.append = False,
77− PIO.exclusive = False,
78− PIO.noctty = False,
79− PIO.nonBlock = True,
80− -- In nonblocking mode opening for read will always succeed and
81− -- opening for write must happen second.
82− PIO.trunc = False
83− }
84−-- NOTE:
85−-- "The only open file status flags that can be meaningfully applied
86−-- to a pipe or FIFO are O_NONBLOCK and O_ASYNC. "
87−
88−
89−mkTransport :: IO Transport
90−mkTransport = do
91−-- uid <- randomIO :: IO Word64
92− -- For backwards compatibility we shouldn't assume a Random instance for Word64:
93− uid <- randomIO :: IO Int
94−
95− lock <- newMVar ()
96− let filename = "/tmp/pipe_"++show (abs uid)
97− createNamedPipe filename $ unionFileModes ownerReadMode ownerWriteMode
98−
99− return Transport
100− { newConnectionWith = \ _ -> do
101− -- Here we protect from blocking other threads by running on a separate (OS) thread:
102− -- Opening the file on the reader side should always succeed:
103− mv <- onOSThread$ tryUntilNoIOErr "open pipe for read" $
104−-- spinTillThere filename
105− PIO.openFd filename PIO.ReadOnly Nothing fileFlags
106−
107− return (mkSourceAddr filename,
108− mkTargetEnd mv lock)
109− , newMulticastWith = error "Pipes.hs: newMulticastWith not implemented yet"
110− , deserialize = \bs -> return$ mkSourceAddr (BS.unpack bs)
111− , closeTransport = removeFile filename
112− }
113− where
114− mkSourceAddr :: String -> SourceAddr
115− mkSourceAddr filename = SourceAddr
116− { connectWith = \_ -> mkSourceEnd filename
117− , serialize = BS.pack filename
118− }
119−
120− mkSourceEnd :: String -> IO SourceEnd
121− mkSourceEnd filename = do
122− -- Initiate but do not block on file opening:
123− mv <- onOSThread$ tryUntilNoIOErr "open pipe for write" $
124− -- The reader must connect first, the writer here spins with backoff.
125− PIO.openFd filename PIO.WriteOnly Nothing fileFlags
126−
127− return $
128− -- Write to the named pipe. If the message is less than
129− -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
130− -- we have to do something more sophisticated.
131− SourceEnd
132− { send = \bsls -> do
133− -- ThreadSafe: This may happen on multiple processes/threads:
134− -- We don't need to lock because the write is atomic (for <4096):
135− let msgsize :: Word32 = fromIntegral$ foldl' (\n s -> n + BS.length s) 0 bsls
136− when (msgsize > 4096)$ -- TODO, look up PIPE_BUF in foreign code
137− error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
138− -- Otherwise it's just a simple write:
139− -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
140−
141− let hdrbss :: BS.ByteString
142−#ifdef CEREAL
143− hdrbss = encode msgsize
144−#else
145−-- hdrbss = BS.fromChunks[encode msgsize]
146− [hdrbss] = BS.toChunks (encode msgsize)
147−#endif
148−
149−-- let finalmsg = BS.concat (encode msgsize : bss)
150− let finalmsg = BS.concat (hdrbss : bsls)
151−
152− fd <- readMVar mv -- Synchronize with file opening.
153− ----------------------------------------
154− cnt <- PIO.fdWrite fd (fromBS finalmsg) -- inefficient to use String here!
155− unless (fromIntegral cnt == BS.length finalmsg) $
156− error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
157− ----------------------------------------
158− return ()
159− , closeSourceEnd = do
160− fd <- readMVar mv
161− PIO.closeFd fd
162− }
163−
164− mkTargetEnd :: MVar Fd -> MVar () -> TargetEnd
165− mkTargetEnd mv lock = TargetEnd
166− { receive = do
167− fd <- readMVar mv -- Make sure Fd is there before
168−
169− -- This should only happen on a *single* process. But it may
170− -- happen on multiple threads so we grab a lock.
171−
172− -- If we don't lock, we cannot atomically read the length
173− -- and THEN read the payload. (A single read could be
174− -- atomic, but not two reads.)
175− takeMVar lock
176−
177− let spinread :: Int -> IO BS.ByteString
178− spinread desired = do
179−
180− bs <- tryUntilNoIOErr "read pipe file descriptor"$
181− readit fd (fromIntegral desired)
182−
183− case BS.length bs of
184− n | n == desired -> return bs
185− -- Because we're in non-blocking mode we deal with failed reads thusly:
186−-- 0 -> do threadDelay (10*1000)
187−-- spinread desired
188− 0 -> error$ "receive: read zero bytes from pipe. Even in non-blocking mode should have had an EAGAIN error instead."
189− l -> error$ "Inclomplete read expected either 0 bytes or complete msg ("++
190− show desired ++" bytes) got "++ show l ++ " bytes"
191−
192− hdr <- spinread sizeof_header
193− let
194−#ifdef CEREAL
195− decoded = decode hdr
196−#else
197− decoded = decode (BS.fromChunks [hdr])
198−#endif
199− payload <- case decoded of
200− Left err -> error$ "ERROR: "++ err
201− Right size -> spinread (fromIntegral (size::Word32))
202−
203− putMVar lock ()
204− return [payload] -- How terribly listy.
205− , closeTargetEnd = do
206− fd <- readMVar mv
207− PIO.closeFd fd
208− }
209−
210−-- | Wait untila file is present, with backoff.
211−spinTillThere :: String -> IO ()
212−spinTillThere filename = mkBackoff >>= loop
213− where
214− loop bkoff = do b <- doesFileExist filename
215− unless b $ do bkoff; loop bkoff
216−
217−-- | Create a backoff action that waits successively longer between attempts.
218−mkBackoff :: IO (IO ())
219−mkBackoff =
220− do tref <- newIORef 1
221− return$ do t <- readIORef tref
222− writeIORef tref (min maxwait (2 * t))
223− threadDelay t
224− where
225− maxwait = 50 * 1000
226−
227−-- | Try an IO action repeatedly (with backoff) until it succeeds without exception.
228−tryUntilNoIOErr :: String -> IO a -> IO a
229−tryUntilNoIOErr msg action =
230− do startTime <- getCurrentTime
231− bkoff <- mkBackoff
232− loop startTime startTime bkoff
233− where
234− loop start lastWarned bkoff =
235− handle (\ (e :: IOException) ->
236− do lw <- maybeWarn start lastWarned
237− bkoff
238−-- BSS.hPutStr stderr$ BSS.pack$ " got IO err: " ++ show e
239− -- case ioeGetHandle e of
240− -- Nothing -> BSS.hPutStrLn stderr$ BSS.pack$ " no hndl io err."
241− -- Just x -> BSS.hPutStrLn stderr$ BSS.pack$ " HNDL on io err!" ++ show x
242− loop start lw bkoff) $
243− action
244− -- After how many milleseconds should we start warning?
245− warn_lvl = 3000
246− maybeWarn :: UTCTime -> UTCTime -> IO UTCTime
247− maybeWarn start lastWarned = do
248− now <- getCurrentTime
249− let seconds :: Double = fromRational $ toRational $ diffUTCTime now start
250− sinceWarned :: Double = fromRational $ toRational $ diffUTCTime now lastWarned
251− if (seconds * 1000 >= warn_lvl &&
252− sinceWarned >= 1.0 ) then do
253− BS.hPutStrLn stderr$ BS.pack$ "WARNING: have been trying an IO action ("++msg++
254− ") for "++show seconds++ " seconds without success"
255− return now
256− else
257− return lastWarned
258−
259−-- Execute an action on its own OS thread. Return an MVar to synchronize on.
260−onOSThread :: IO a -> IO (MVar a)
261−onOSThread action = do
262− mv <- newEmptyMVar
263− forkOS (action >>= putMVar mv )
264− return mv
network-transport-tcp/ChangeLogdeleted−3
@@ -1,3 +0,0 @@
1−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
2−
3−* 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/network-transport-tcp.cabaldeleted−54
@@ -1,54 +0,0 @@
1−Name: network-transport-tcp
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: TCP instantation of Network.Transport
14−Description: TCP 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−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.2 && < 0.3,
26− data-accessor >= 0.2 && < 0.3,
27− containers >= 0.4 && < 0.5,
28− bytestring >= 0.9 && < 0.10,
29− network >= 2.3 && < 2.4
30− Exposed-modules: Network.Transport.TCP,
31− Network.Transport.TCP.Internal
32− ghc-options: -Wall -fno-warn-unused-do-bind
33− HS-Source-Dirs: src
34−
35−Test-Suite TestTCP
36− Type: exitcode-stdio-1.0
37− Main-Is: TestTCP.hs
38− Build-Depends: base >= 4.3 && < 5,
39− network-transport >= 0.2 && < 0.3,
40− data-accessor >= 0.2 && < 0.3,
41− containers >= 0.4 && < 0.5,
42− bytestring >= 0.9 && < 0.10,
43− network >= 2.3 && < 2.4,
44− random >= 1.0 && < 1.1,
45− ansi-terminal >= 0.5 && < 0.6,
46− mtl >= 2.0 && < 2.2
47− ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
48− Extensions: ExistentialQuantification,
49− FlexibleInstances,
50− DeriveDataTypeable,
51− RankNTypes,
52− OverlappingInstances,
53− OverloadedStrings
54− HS-Source-Dirs: tests src
network-transport-tcp/src/Network/Transport/TCP.hsdeleted−1649
@@ -1,1649 +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 (catch, mapM_)
32−import Network.Transport
33−import Network.Transport.TCP.Internal ( forkServer
34− , recvWithLength
35− , recvInt32
36− , tryCloseSocket
37− )
38−import Network.Transport.Internal ( encodeInt32
39− , decodeInt32
40− , prependLength
41− , mapIOException
42− , tryIO
43− , tryToEnum
44− , void
45− , timeoutMaybe
46− , asyncWhenCancelled
47− )
48−import qualified Network.Socket as N ( HostName
49− , ServiceName
50− , Socket
51− , getAddrInfo
52− , socket
53− , addrFamily
54− , addrAddress
55− , SocketType(Stream)
56− , defaultProtocol
57− , setSocketOption
58− , SocketOption(ReuseAddr)
59− , connect
60− , sOMAXCONN
61− , AddrInfo
62− )
63−import Network.Socket.ByteString (sendMany)
64−import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
65−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
66−import Control.Concurrent.MVar ( MVar
67− , newMVar
68− , modifyMVar
69− , modifyMVar_
70− , readMVar
71− , takeMVar
72− , putMVar
73− , newEmptyMVar
74− , withMVar
75− )
76−import Control.Category ((>>>))
77−import Control.Applicative ((<$>))
78−import Control.Monad (when, unless)
79−import Control.Exception ( IOException
80− , SomeException
81− , AsyncException
82− , handle
83− , throw
84− , throwIO
85− , try
86− , bracketOnError
87− , mask
88− , onException
89− , fromException
90− )
91−import Data.IORef (IORef, newIORef, writeIORef, readIORef)
92−import Data.ByteString (ByteString)
93−import qualified Data.ByteString as BS (concat)
94−import qualified Data.ByteString.Char8 as BSC (pack, unpack, split)
95−import Data.Int (Int32)
96−import Data.IntMap (IntMap)
97−import qualified Data.IntMap as IntMap (empty)
98−import Data.IntSet (IntSet)
99−import qualified Data.IntSet as IntSet ( empty
100− , insert
101− , elems
102− , singleton
103− , null
104− , delete
105− , member
106− )
107−import Data.Map (Map)
108−import qualified Data.Map as Map (empty)
109−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
110−import qualified Data.Accessor.Container as DAC (mapMaybe, intMapMaybe)
111−import Data.Foldable (forM_, mapM_)
112−
113−-- $design
114−--
115−-- [Goals]
116−--
117−-- The TCP transport maps multiple logical connections between /A/ and /B/ (in
118−-- either direction) to a single TCP connection:
119−--
120−-- > +-------+ +-------+
121−-- > | A |==========================| B |
122−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
123−-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q |
124−-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
125−-- > | |==========================| |
126−-- > +-------+ +-------+
127−--
128−-- Ignoring the complications detailed below, the TCP connection is set up is
129−-- when the first lightweight connection is created (in either direction), and
130−-- torn down when the last lightweight connection (in either direction) is
131−-- closed.
132−--
133−-- [Connecting]
134−--
135−-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to
136−-- connect to /B/, it locally records that it is trying to connect to /B/ and
137−-- sends a request to /B/. As part of the request /A/ sends its own endpoint
138−-- address to /B/ (so that /B/ can reuse the connection in the other direction).
139−--
140−-- When /B/ receives the connection request it first checks if it did not
141−-- already initiate a connection request to /A/. If not it will acknowledge the
142−-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record
143−-- that it has a TCP connection to /A/.
144−--
145−-- The tricky case arises when /A/ sends a connection request to /B/ and /B/
146−-- finds that it had already sent a connection request to /A/. In this case /B/
147−-- will accept the connection request from /A/ if /A/s endpoint address is
148−-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects
149−-- it, it sends a 'ConnectionRequestCrossed' message to /A/. (The
150−-- lexicographical ordering is an arbitrary but convenient way to break the
151−-- tie.)
152−--
153−-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that
154−-- initiated the request just needs to wait until the /A/ thread that is dealing
155−-- with /B/'s connection request completes.
156−--
157−-- [Disconnecting]
158−--
159−-- The TCP connection is created as soon as the first logical connection from
160−-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
161−-- spawned that listens for incoming connections from /B/:
162−--
163−-- > +-------+ +-------+
164−-- > | A |==========================| B |
165−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
166−-- > | | | Q |
167−-- > | #| | |
168−-- > | |==========================| |
169−-- > +-------+ +-------+
170−--
171−-- The question is when the TCP connection can be closed again. Conceptually,
172−-- we want to do reference counting: when there are no logical connections left
173−-- between /A/ and /B/ we want to close the socket (possibly after some
174−-- timeout).
175−--
176−-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
177−-- might happen that /B/ sends a connection request over the existing socket at
178−-- the same time that /A/ closes its logical connection to /B/ and closes the
179−-- socket. This will cause a failure in /B/ (which will have to retry) which is
180−-- not caused by a network failure, which is unfortunate. (Note that the
181−-- connection request from /B/ might succeed even if /A/ closes the socket.)
182−--
183−-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
184−-- request to /B/ and records that its connection to /B/ is closing. If /A/
185−-- receives a new connection request from /B/ after having sent the
186−-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
187−-- and increments the reference count of the connection again.
188−--
189−-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
190−-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
191−-- and then actually close the socket. /A/ meanwhile will not send any more
192−-- requests to /B/ after having sent a 'CloseSocket' request, and will actually
193−-- close its end of the socket only when receiving the 'CloseSocket' message
194−-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
195−-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
196−-- reciprocal 'CloseSocket' message.)
197−--
198−-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
199−-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
200−-- whether to reuse the old socket (if /B/ sends a new connection request
201−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
202−
203−--------------------------------------------------------------------------------
204−-- Internal datatypes --
205−--------------------------------------------------------------------------------
206−
207−-- We use underscores for fields that we might update (using accessors)
208−--
209−-- All data types follow the same structure:
210−--
211−-- * A top-level data type describing static properties (TCPTransport,
212−-- LocalEndPoint, RemoteEndPoint)
213−-- * The 'static' properties include an MVar containing a data structure for
214−-- the dynamic properties (TransportState, LocalEndPointState,
215−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
216−-- * For the case of "valid" we use third data structure to give more details
217−-- about the state (ValidTransportState, ValidLocalEndPointState,
218−-- ValidRemoteEndPointState).
219−
220−data TCPTransport = TCPTransport
221− { transportHost :: N.HostName
222− , transportPort :: N.ServiceName
223− , transportState :: MVar TransportState
224− , transportParams :: TCPParameters
225− }
226−
227−data TransportState =
228− TransportValid ValidTransportState
229− | TransportClosed
230−
231−data ValidTransportState = ValidTransportState
232− { _localEndPoints :: Map EndPointAddress LocalEndPoint
233− , _nextEndPointId :: EndPointId
234− }
235−
236−data LocalEndPoint = LocalEndPoint
237− { localAddress :: EndPointAddress
238− , localChannel :: Chan Event
239− , localState :: MVar LocalEndPointState
240− }
241−
242−data LocalEndPointState =
243− LocalEndPointValid ValidLocalEndPointState
244− | LocalEndPointClosed
245−
246−data ValidLocalEndPointState = ValidLocalEndPointState
247− { _nextConnectionId :: !ConnectionId
248− , _localConnections :: Map EndPointAddress RemoteEndPoint
249− , _nextRemoteId :: !Int
250− }
251−
252−-- REMOTE ENDPOINTS
253−--
254−-- Remote endpoints (basically, TCP connections) have the following lifecycle:
255−--
256−-- Init ---+---> Invalid
257−-- |
258−-- +-------------------------------\
259−-- | |
260−-- | /----------\ |
261−-- | | | |
262−-- | v | v
263−-- +---> Valid ---> Closing ---> Closed
264−-- | | | |
265−-- | | | v
266−-- \-------+----------+--------> Failed
267−--
268−-- Init: There are two places where we create new remote endpoints: in
269−-- requestConnectionTo (in response to an API 'connect' call) and in
270−-- handleConnectionRequest (when a remote node tries to connect to us).
271−-- 'Init' carries an MVar () 'resolved' which concurrent threads can use to
272−-- wait for the remote endpoint to finish initialization. We record who
273−-- requested the connection (the local endpoint or the remote endpoint).
274−--
275−-- Invalid: We put the remote endpoint in invalid state only during
276−-- requestConnectionTo when we fail to connect.
277−--
278−-- Valid: This is the "normal" state for a working remote endpoint.
279−--
280−-- Closing: When we detect that a remote endpoint is no longer used, we send a
281−-- CloseSocket request across the connection and put the remote endpoint in
282−-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which
283−-- concurrent threads can use to wait for the remote endpoint to either be
284−-- closed fully (if the communication parnet responds with another
285−-- CloseSocket) or be put back in 'Valid' state if the remote endpoint denies
286−-- the request.
287−--
288−-- We also put the endpoint in Closed state, directly from Init, if we our
289−-- outbound connection request crossed an inbound connection request and we
290−-- decide to keep the inbound (i.e., the remote endpoint sent us a
291−-- ConnectionRequestCrossed message).
292−--
293−-- Closed: The endpoint is put in Closed state after a successful garbage
294−-- collection.
295−--
296−-- Failed: If the connection to the remote endpoint is lost, or the local
297−-- endpoint (or the whole transport) is closed manually, the remote endpoint is
298−-- put in Failed state, and we record the reason.
299−--
300−-- Invariants for dealing with remote endpoints:
301−--
302−-- INV-SEND: Whenever we send data the remote endpoint must be locked (to avoid
303−-- interleaving bits of payload).
304−--
305−-- INV-CLOSE: Local endpoints should never point to remote endpoint in closed
306−-- state. Whenever we put an endpoint in Closed state we remove that
307−-- endpoint from localConnections first, so that if a concurrent thread reads
308−-- the MVar, finds RemoteEndPointClosed, and then looks up the endpoint in
309−-- localConnections it is guaranteed to either find a different remote
310−-- endpoint, or else none at all (if we don't insist in this order some
311−-- threads might start spinning).
312−--
313−-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is
314−-- locked, and the remote endpoint must be in Valid or Closed state once
315−-- unlocked. This guarantees that there will not be two threads attempting to
316−-- both signal on 'resolved'.
317−--
318−-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we
319−-- first put the remote endpoint in Closed state, and then send a
320−-- EventConnectionLost event. This guarantees that we only send this event
321−-- once.
322−--
323−-- INV-CLOSING: An endpoint in closing state is for all intents and purposes
324−-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
325−-- acceptable, of course -- as we are waiting for the remote endpoint to
326−-- confirm or deny the request).
327−--
328−-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints.
329−-- In other words: it is okay to call modifyMVar on a local endpoint inside a
330−-- modifyMVar on a remote endpoint, but not the other way around. In
331−-- particular, it is okay to call removeRemoteEndPoint inside
332−-- modifyRemoteState.
333−
334−data RemoteEndPoint = RemoteEndPoint
335− { remoteAddress :: EndPointAddress
336− , remoteState :: MVar RemoteState
337− , remoteId :: Int
338− }
339−
340−data RequestedBy = RequestedByUs | RequestedByThem
341− deriving (Eq, Show)
342−
343−data RemoteState =
344− -- | Invalid remote endpoint (for example, invalid address)
345− RemoteEndPointInvalid (TransportError ConnectErrorCode)
346− -- | The remote endpoint is being initialized
347− | RemoteEndPointInit (MVar ()) RequestedBy
348− -- | "Normal" working endpoint
349− | RemoteEndPointValid ValidRemoteEndPointState
350− -- | The remote endpoint is being closed (garbage collected)
351− | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
352− -- | The remote endpoint has been closed (garbage collected)
353− | RemoteEndPointClosed
354− -- | The remote endpoint has failed, or has been forcefully shutdown
355− -- using a closeTransport or closeEndPoint API call
356− | RemoteEndPointFailed IOException
357−
358−data ValidRemoteEndPointState = ValidRemoteEndPointState
359− { _remoteOutgoing :: !Int
360− , _remoteIncoming :: IntSet
361− , remoteSocket :: N.Socket
362− , sendOn :: [ByteString] -> IO ()
363− , _pendingCtrlRequests :: IntMap (MVar (Either IOException [ByteString]))
364− , _nextCtrlRequestId :: !ControlRequestId
365− }
366−
367−-- | Local identifier for an endpoint within this transport
368−type EndPointId = Int32
369−
370−-- | Control request ID
371−--
372−-- Control requests are asynchronous; the request ID makes it possible to match
373−-- requests and replies
374−type ControlRequestId = Int32
375−
376−-- | Pair of local and a remote endpoint (for conciseness in signatures)
377−type EndPointPair = (LocalEndPoint, RemoteEndPoint)
378−
379−-- | Control headers
380−data ControlHeader =
381− -- | Request a new connection ID from the remote endpoint
382− RequestConnectionId
383− -- | Tell the remote endpoint we will no longer be using a connection
384− | CloseConnection
385− -- | Respond to a control request /from/ the remote endpoint
386− | ControlResponse
387− -- | Request to close the connection (see module description)
388− | CloseSocket
389− deriving (Enum, Bounded, Show)
390−
391−-- | Response sent by /B/ to /A/ when /A/ tries to connect
392−data ConnectionRequestResponse =
393− -- | /B/ accepts the connection
394− ConnectionRequestAccepted
395− -- | /A/ requested an invalid endpoint
396− | ConnectionRequestInvalid
397− -- | /A/s request crossed with a request from /B/ (see protocols)
398− | ConnectionRequestCrossed
399− deriving (Enum, Bounded, Show)
400−
401−-- | Parameters for setting up the TCP transport
402−data TCPParameters = TCPParameters {
403− -- | Backlog for 'listen'.
404− -- Defaults to SOMAXCONN.
405− tcpBacklog :: Int
406− -- | Should we set SO_REUSEADDR on the server socket?
407− -- Defaults to True.
408− , tcpReuseServerAddr :: Bool
409− -- | Should we set SO_REUSEADDR on client sockets?
410− -- Defaults to True.
411− , tcpReuseClientAddr :: Bool
412− }
413−
414−-- | Internal functionality we expose for unit testing
415−data TransportInternals = TransportInternals
416− { -- | The ID of the thread that listens for new incoming connections
417− transportThread :: ThreadId
418− -- | Find the socket between a local and a remote endpoint
419− , socketBetween :: EndPointAddress
420− -> EndPointAddress
421− -> IO N.Socket
422− }
423−
424−--------------------------------------------------------------------------------
425−-- Top-level functionality --
426−--------------------------------------------------------------------------------
427−
428−-- | Create a TCP transport
429−createTransport :: N.HostName
430− -> N.ServiceName
431− -> TCPParameters
432− -> IO (Either IOException Transport)
433−createTransport host port params =
434− either Left (Right . fst) <$> createTransportExposeInternals host port params
435−
436−-- | You should probably not use this function (used for unit testing only)
437−createTransportExposeInternals
438− :: N.HostName
439− -> N.ServiceName
440− -> TCPParameters
441− -> IO (Either IOException (Transport, TransportInternals))
442−createTransportExposeInternals host port params = do
443− state <- newMVar . TransportValid $ ValidTransportState
444− { _localEndPoints = Map.empty
445− , _nextEndPointId = 0
446− }
447− let transport = TCPTransport { transportState = state
448− , transportHost = host
449− , transportPort = port
450− , transportParams = params
451− }
452− tryIO $ bracketOnError (forkServer
453− host
454− port
455− (tcpBacklog params)
456− (tcpReuseServerAddr params)
457− (terminationHandler transport)
458− (handleConnectionRequest transport))
459− killThread
460− (mkTransport transport)
461− where
462− mkTransport :: TCPTransport
463− -> ThreadId
464− -> IO (Transport, TransportInternals)
465− mkTransport transport tid = return
466− ( Transport
467− { newEndPoint = apiNewEndPoint transport
468− , closeTransport = let evs = [ EndPointClosed
469− , throw $ userError "Transport closed"
470− ] in
471− apiCloseTransport transport (Just tid) evs
472− }
473− , TransportInternals
474− { transportThread = tid
475− , socketBetween = internalSocketBetween transport
476− }
477− )
478−
479− terminationHandler :: TCPTransport -> SomeException -> IO ()
480− terminationHandler transport ex = do
481− let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))
482− , throw $ userError "Transport closed"
483− ]
484− apiCloseTransport transport Nothing evs
485−
486−-- | Default TCP parameters
487−defaultTCPParameters :: TCPParameters
488−defaultTCPParameters = TCPParameters {
489− tcpBacklog = N.sOMAXCONN
490− , tcpReuseServerAddr = True
491− , tcpReuseClientAddr = True
492− }
493−
494−--------------------------------------------------------------------------------
495−-- API functions --
496−--------------------------------------------------------------------------------
497−
498−-- | Close the transport
499−apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()
500−apiCloseTransport transport mTransportThread evs =
501− asyncWhenCancelled return $ do
502− mTSt <- modifyMVar (transportState transport) $ \st -> case st of
503− TransportValid vst -> return (TransportClosed, Just vst)
504− TransportClosed -> return (TransportClosed, Nothing)
505− forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
506− -- This will invoke the termination handler, which in turn will call
507− -- apiCloseTransport again, but then the transport will already be closed
508− -- and we won't be passed a transport thread, so we terminate immmediate
509− forM_ mTransportThread killThread
510−
511−-- | Create a new endpoint
512−apiNewEndPoint :: TCPTransport
513− -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
514−apiNewEndPoint transport =
515− try . asyncWhenCancelled closeEndPoint $ do
516− ourEndPoint <- createLocalEndPoint transport
517− return EndPoint
518− { receive = readChan (localChannel ourEndPoint)
519− , address = localAddress ourEndPoint
520− , connect = apiConnect (transportParams transport) ourEndPoint
521− , closeEndPoint = let evs = [ EndPointClosed
522− , throw $ userError "Endpoint closed"
523− ] in
524− apiCloseEndPoint transport evs ourEndPoint
525− , newMulticastGroup = return . Left $ newMulticastGroupError
526− , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
527− }
528− where
529− newMulticastGroupError =
530− TransportError NewMulticastGroupUnsupported "Multicast not supported"
531− resolveMulticastGroupError =
532− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
533−
534−-- | Connnect to an endpoint
535−apiConnect :: TCPParameters -- ^ Parameters
536− -> LocalEndPoint -- ^ Local end point
537− -> EndPointAddress -- ^ Remote address
538− -> Reliability -- ^ Reliability (ignored)
539− -> ConnectHints -- ^ Hints
540− -> IO (Either (TransportError ConnectErrorCode) Connection)
541−apiConnect params ourEndPoint theirAddress _reliability hints =
542− try . asyncWhenCancelled close $
543− if localAddress ourEndPoint == theirAddress
544− then connectToSelf ourEndPoint
545− else do
546− resetIfBroken ourEndPoint theirAddress
547− (theirEndPoint, connId) <-
548− requestConnectionTo params ourEndPoint theirAddress hints
549− -- connAlive can be an IORef rather than an MVar because it is protected
550− -- by the remoteState MVar. We don't need the overhead of locking twice.
551− connAlive <- newIORef True
552− return Connection
553− { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
554− , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
555− }
556−
557−-- | Close a connection
558−apiClose :: EndPointPair -> ConnectionId -> IORef Bool -> IO ()
559−apiClose (ourEndPoint, theirEndPoint) connId connAlive =
560− void . tryIO . asyncWhenCancelled return $ do
561− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
562− { caseValid = \vst -> do
563− alive <- readIORef connAlive
564− if alive
565− then do
566− writeIORef connAlive False
567− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
568− return ( RemoteEndPointValid
569− . (remoteOutgoing ^: (\x -> x - 1))
570− $ vst
571− )
572− else
573− return (RemoteEndPointValid vst)
574− }
575− closeIfUnused (ourEndPoint, theirEndPoint)
576−
577−-- | Send data across a connection
578−apiSend :: EndPointPair -- ^ Local and remote endpoint
579− -> ConnectionId -- ^ Connection ID (supplied by remote endpoint)
580− -> IORef Bool -- ^ Is the connection still alive?
581− -> [ByteString] -- ^ Payload
582− -> IO (Either (TransportError SendErrorCode) ())
583−apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
584− -- We don't need the overhead of asyncWhenCancelled here
585− try . mapIOException sendFailed $
586− withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
587− { caseInvalid = \_ ->
588− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
589− , caseInit = \_ _ ->
590− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
591− , caseValid = \vst -> do
592− alive <- readIORef connAlive
593− if alive
594− then sendOn vst (encodeInt32 connId : prependLength payload)
595− else throwIO $ TransportError SendClosed "Connection closed"
596− , caseClosing = \_ _ -> do
597− alive <- readIORef connAlive
598− if alive
599− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
600− else throwIO $ TransportError SendClosed "Connection closed"
601− , caseClosed = do
602− alive <- readIORef connAlive
603− if alive
604− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
605− else throwIO $ TransportError SendClosed "Connection closed"
606− , caseFailed = \err -> do
607− alive <- readIORef connAlive
608− if alive
609− then throwIO $ TransportError SendFailed (show err)
610− else throwIO $ TransportError SendClosed "Connection closed"
611− }
612− where
613− sendFailed = TransportError SendFailed . show
614−
615−-- | Force-close the endpoint
616−apiCloseEndPoint :: TCPTransport -- ^ Transport
617− -> [Event] -- ^ Events used to report closure
618− -> LocalEndPoint -- ^ Local endpoint
619− -> IO ()
620−apiCloseEndPoint transport evs ourEndPoint =
621− asyncWhenCancelled return $ do
622− -- Remove the reference from the transport state
623− removeLocalEndPoint transport ourEndPoint
624− -- Close the local endpoint
625− mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
626− case st of
627− LocalEndPointValid vst ->
628− return (LocalEndPointClosed, Just vst)
629− LocalEndPointClosed ->
630− return (LocalEndPointClosed, Nothing)
631− forM_ mOurState $ \vst -> do
632− forM_ (vst ^. localConnections) tryCloseRemoteSocket
633− forM_ evs $ writeChan (localChannel ourEndPoint)
634− where
635− -- Close the remote socket and return the set of all incoming connections
636− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
637− tryCloseRemoteSocket theirEndPoint = do
638− -- We make an attempt to close the connection nicely
639− -- (by sending a CloseSocket first)
640− let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"
641− modifyMVar_ (remoteState theirEndPoint) $ \st ->
642− case st of
643− RemoteEndPointInvalid _ ->
644− return st
645− RemoteEndPointInit resolved _ -> do
646− putMVar resolved ()
647− return closed
648− RemoteEndPointValid conn -> do
649− tryIO $ sendOn conn [encodeInt32 CloseSocket]
650− tryCloseSocket (remoteSocket conn)
651− return closed
652− RemoteEndPointClosing resolved conn -> do
653− putMVar resolved ()
654− tryCloseSocket (remoteSocket conn)
655− return closed
656− RemoteEndPointClosed ->
657− return st
658− RemoteEndPointFailed err ->
659− return $ RemoteEndPointFailed err
660−
661−--------------------------------------------------------------------------------
662−-- As soon as a remote connection fails, we want to put notify our endpoint --
663−-- and put it into a closed state. Since this may happen in many places, we --
664−-- provide some abstractions. --
665−--------------------------------------------------------------------------------
666−
667−data RemoteStatePatternMatch a = RemoteStatePatternMatch
668− { caseInvalid :: TransportError ConnectErrorCode -> IO a
669− , caseInit :: MVar () -> RequestedBy -> IO a
670− , caseValid :: ValidRemoteEndPointState -> IO a
671− , caseClosing :: MVar () -> ValidRemoteEndPointState -> IO a
672− , caseClosed :: IO a
673− , caseFailed :: IOException -> IO a
674− }
675−
676−remoteStateIdentity :: RemoteStatePatternMatch RemoteState
677−remoteStateIdentity =
678− RemoteStatePatternMatch
679− { caseInvalid = return . RemoteEndPointInvalid
680− , caseInit = (return .) . RemoteEndPointInit
681− , caseValid = return . RemoteEndPointValid
682− , caseClosing = (return .) . RemoteEndPointClosing
683− , caseClosed = return RemoteEndPointClosed
684− , caseFailed = return . RemoteEndPointFailed
685− }
686−
687−-- | Like modifyMVar, but if an I/O exception occurs don't restore the remote
688−-- endpoint to its original value but close it instead
689−modifyRemoteState :: EndPointPair
690− -> RemoteStatePatternMatch (RemoteState, a)
691− -> IO a
692−modifyRemoteState (ourEndPoint, theirEndPoint) match =
693− mask $ \restore -> do
694− st <- takeMVar theirState
695− case st of
696− RemoteEndPointValid vst -> do
697− mResult <- try $ restore (caseValid match vst)
698− case mResult of
699− Right (st', a) -> do
700− putMVar theirState st'
701− return a
702− Left ex -> do
703− case fromException ex of
704− Just ioEx -> handleIOException ioEx vst
705− Nothing -> putMVar theirState st
706− throwIO ex
707− -- The other cases are less interesting, because unless the endpoint is
708− -- in Valid state we're not supposed to do any IO on it
709− RemoteEndPointInit resolved origin -> do
710− (st', a) <- onException (restore $ caseInit match resolved origin)
711− (putMVar theirState st)
712− putMVar theirState st'
713− return a
714− RemoteEndPointClosing resolved vst -> do
715− (st', a) <- onException (restore $ caseClosing match resolved vst)
716− (putMVar theirState st)
717− putMVar theirState st'
718− return a
719− RemoteEndPointInvalid err -> do
720− (st', a) <- onException (restore $ caseInvalid match err)
721− (putMVar theirState st)
722− putMVar theirState st'
723− return a
724− RemoteEndPointClosed -> do
725− (st', a) <- onException (restore $ caseClosed match)
726− (putMVar theirState st)
727− putMVar theirState st'
728− return a
729− RemoteEndPointFailed err -> do
730− (st', a) <- onException (restore $ caseFailed match err)
731− (putMVar theirState st)
732− putMVar theirState st'
733− return a
734− where
735− theirState :: MVar RemoteState
736− theirState = remoteState theirEndPoint
737−
738− handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()
739− handleIOException ex vst = do
740− tryCloseSocket (remoteSocket vst)
741− putMVar theirState (RemoteEndPointFailed ex)
742− let incoming = IntSet.elems $ vst ^. remoteIncoming
743− code = EventConnectionLost (Just $ remoteAddress theirEndPoint) incoming
744− err = TransportError code (show ex)
745− writeChan (localChannel ourEndPoint) $ ErrorEvent err
746−
747−-- | Like 'modifyRemoteState' but without a return value
748−modifyRemoteState_ :: EndPointPair
749− -> RemoteStatePatternMatch RemoteState
750− -> IO ()
751−modifyRemoteState_ (ourEndPoint, theirEndPoint) match =
752− modifyRemoteState (ourEndPoint, theirEndPoint)
753− RemoteStatePatternMatch
754− { caseInvalid = u . caseInvalid match
755− , caseInit = \resolved origin -> u $ caseInit match resolved origin
756− , caseValid = u . caseValid match
757− , caseClosing = \resolved vst -> u $ caseClosing match resolved vst
758− , caseClosed = u $ caseClosed match
759− , caseFailed = u . caseFailed match
760− }
761− where
762− u :: IO a -> IO (a, ())
763− u p = p >>= \a -> return (a, ())
764−
765−-- | Like 'modifyRemoteState' but without the ability to change the state
766−withRemoteState :: EndPointPair
767− -> RemoteStatePatternMatch a
768− -> IO a
769−withRemoteState (ourEndPoint, theirEndPoint) match =
770− modifyRemoteState (ourEndPoint, theirEndPoint)
771− RemoteStatePatternMatch
772− { caseInvalid = \err -> do
773− a <- caseInvalid match err
774− return (RemoteEndPointInvalid err, a)
775− , caseInit = \resolved origin -> do
776− a <- caseInit match resolved origin
777− return (RemoteEndPointInit resolved origin, a)
778− , caseValid = \vst -> do
779− a <- caseValid match vst
780− return (RemoteEndPointValid vst, a)
781− , caseClosing = \resolved vst -> do
782− a <- caseClosing match resolved vst
783− return (RemoteEndPointClosing resolved vst, a)
784− , caseClosed = do
785− a <- caseClosed match
786− return (RemoteEndPointClosed, a)
787− , caseFailed = \err -> do
788− a <- caseFailed match err
789− return (RemoteEndPointFailed err, a)
790− }
791−
792−--------------------------------------------------------------------------------
793−-- Incoming requests --
794−--------------------------------------------------------------------------------
795−
796−-- | Handle a connection request (that is, a remote endpoint that is trying to
797−-- establish a TCP connection with us)
798−--
799−-- 'handleConnectionRequest' runs in the context of the transport thread, which
800−-- can be killed asynchronously by 'closeTransport'. We fork a separate thread
801−-- as soon as we have located the lcoal endpoint that the remote endpoint is
802−-- interested in. We cannot fork any sooner because then we have no way of
803−-- storing the thread ID and hence no way of killing the thread when we take
804−-- the transport down. We must be careful to close the socket when a (possibly
805−-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
806−-- handleConnectionRequest the transport will be shut down.)
807−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
808−handleConnectionRequest transport sock = handle handleException $ do
809− ourEndPointId <- recvInt32 sock
810− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
811− let ourAddress = encodeEndPointAddress (transportHost transport)
812− (transportPort transport)
813− ourEndPointId
814− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
815− TransportValid vst ->
816− case vst ^. localEndPointAt ourAddress of
817− Nothing -> do
818− sendMany sock [encodeInt32 ConnectionRequestInvalid]
819− throwIO $ userError "handleConnectionRequest: Invalid endpoint"
820− Just ourEndPoint ->
821− return ourEndPoint
822− TransportClosed ->
823− throwIO $ userError "Transport closed"
824− void . forkIO $ go ourEndPoint theirAddress
825− where
826− go :: LocalEndPoint -> EndPointAddress -> IO ()
827− go ourEndPoint theirAddress = do
828− -- This runs in a thread that will never be killed
829− mEndPoint <- handle ((>> return Nothing) . handleException) $ do
830− resetIfBroken ourEndPoint theirAddress
831− (theirEndPoint, isNew) <-
832− findRemoteEndPoint ourEndPoint theirAddress RequestedByThem
833−
834− if not isNew
835− then do
836− tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
837− tryCloseSocket sock
838− return Nothing
839− else do
840− let vst = ValidRemoteEndPointState
841− { remoteSocket = sock
842− , _remoteOutgoing = 0
843− , _remoteIncoming = IntSet.empty
844− , sendOn = sendMany sock
845− , _pendingCtrlRequests = IntMap.empty
846− , _nextCtrlRequestId = 0
847− }
848− sendMany sock [encodeInt32 ConnectionRequestAccepted]
849− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
850− return (Just theirEndPoint)
851− -- If we left the scope of the exception handler with a return value of
852− -- Nothing then the socket is already closed; otherwise, the socket has
853− -- been recorded as part of the remote endpoint. Either way, we no longer
854− -- have to worry about closing the socket on receiving an asynchronous
855− -- exception from this point forward.
856− forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
857−
858− handleException :: SomeException -> IO ()
859− handleException ex = do
860− tryCloseSocket sock
861− rethrowIfAsync (fromException ex)
862−
863− rethrowIfAsync :: Maybe AsyncException -> IO ()
864− rethrowIfAsync = mapM_ throwIO
865−
866−-- | Handle requests from a remote endpoint.
867−--
868−-- Returns only if the remote party closes the socket or if an error occurs.
869−-- This runs in a thread that will never be killed.
870−handleIncomingMessages :: EndPointPair -> IO ()
871−handleIncomingMessages (ourEndPoint, theirEndPoint) = do
872− mSock <- withMVar theirState $ \st ->
873− case st of
874− RemoteEndPointInvalid _ ->
875− relyViolation (ourEndPoint, theirEndPoint)
876− "handleIncomingMessages (invalid)"
877− RemoteEndPointInit _ _ ->
878− relyViolation (ourEndPoint, theirEndPoint)
879− "handleIncomingMessages (init)"
880− RemoteEndPointValid ep ->
881− return . Just $ remoteSocket ep
882− RemoteEndPointClosing _ ep ->
883− return . Just $ remoteSocket ep
884− RemoteEndPointClosed ->
885− return Nothing
886− RemoteEndPointFailed _ ->
887− return Nothing
888−
889− forM_ mSock $ \sock ->
890− tryIO (go sock) >>= either (prematureExit sock) return
891− where
892− -- Dispatch
893− --
894− -- If a recv throws an exception this will be caught top-level and
895− -- 'prematureExit' will be invoked. The same will happen if the remote
896− -- endpoint is put into a Closed (or Closing) state by a concurrent thread
897− -- (because a 'send' failed) -- the individual handlers below will throw a
898− -- user exception which is then caught and handled the same way as an
899− -- exception thrown by 'recv'.
900− go :: N.Socket -> IO ()
901− go sock = do
902− connId <- recvInt32 sock
903− if connId >= firstNonReservedConnectionId
904− then do
905− readMessage sock connId
906− go sock
907− else
908− case tryToEnum (fromIntegral connId) of
909− Just RequestConnectionId -> do
910− recvInt32 sock >>= createNewConnection
911− go sock
912− Just ControlResponse -> do
913− recvInt32 sock >>= readControlResponse sock
914− go sock
915− Just CloseConnection -> do
916− recvInt32 sock >>= closeConnection
917− go sock
918− Just CloseSocket -> do
919− didClose <- closeSocket sock
920− unless didClose $ go sock
921− Nothing ->
922− throwIO $ userError "Invalid control request"
923−
924− -- Create a new connection
925− createNewConnection :: ControlRequestId -> IO ()
926− createNewConnection reqId = do
927− newId <- getNextConnectionId ourEndPoint
928− modifyMVar_ theirState $ \st -> do
929− vst <- case st of
930− RemoteEndPointInvalid _ ->
931− relyViolation (ourEndPoint, theirEndPoint)
932− "handleIncomingMessages:createNewConnection (invalid)"
933− RemoteEndPointInit _ _ ->
934− relyViolation (ourEndPoint, theirEndPoint)
935− "handleIncomingMessages:createNewConnection (init)"
936− RemoteEndPointValid vst ->
937− return (remoteIncoming ^: IntSet.insert newId $ vst)
938− RemoteEndPointClosing resolved vst -> do
939− -- If the endpoint is in closing state that means we send a
940− -- CloseSocket request to the remote endpoint. If the remote
941− -- endpoint replies with the request to create a new connection, it
942− -- either ignored our request or it sent the request before it got
943− -- ours. Either way, at this point we simply restore the endpoint
944− -- to RemoteEndPointValid
945− putMVar resolved ()
946− return (remoteIncoming ^= IntSet.singleton newId $ vst)
947− RemoteEndPointFailed err ->
948− throwIO err
949− RemoteEndPointClosed ->
950− relyViolation (ourEndPoint, theirEndPoint)
951− "createNewConnection (closed)"
952− sendOn vst ( encodeInt32 ControlResponse
953− : encodeInt32 reqId
954− : prependLength [encodeInt32 newId]
955− )
956− return (RemoteEndPointValid vst)
957− writeChan ourChannel (ConnectionOpened newId ReliableOrdered theirAddr)
958−
959− -- Read a control response
960− readControlResponse :: N.Socket -> ControlRequestId -> IO ()
961− readControlResponse sock reqId = do
962− response <- recvWithLength sock
963− mmvar <- modifyMVar theirState $ \st -> case st of
964− RemoteEndPointInvalid _ ->
965− relyViolation (ourEndPoint, theirEndPoint)
966− "readControlResponse (invalid)"
967− RemoteEndPointInit _ _ ->
968− relyViolation (ourEndPoint, theirEndPoint)
969− "readControlResponse (init)"
970− RemoteEndPointValid vst ->
971− return ( RemoteEndPointValid
972− . (pendingCtrlRequestsAt reqId ^= Nothing)
973− $ vst
974− , vst ^. pendingCtrlRequestsAt reqId
975− )
976− RemoteEndPointClosing _ _ ->
977− throwIO $ userError "Invalid control response"
978− RemoteEndPointFailed err ->
979− throwIO err
980− RemoteEndPointClosed ->
981− relyViolation (ourEndPoint, theirEndPoint)
982− "readControlResponse (closed)"
983− case mmvar of
984− Nothing ->
985− throwIO $ userError "Invalid request ID"
986− Just mvar ->
987− putMVar mvar (Right response)
988−
989− -- Close a connection
990− -- It is important that we verify that the connection is in fact open,
991− -- because otherwise we should not decrement the reference count
992− closeConnection :: ConnectionId -> IO ()
993− closeConnection cid = do
994− modifyMVar_ theirState $ \st -> case st of
995− RemoteEndPointInvalid _ ->
996− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"
997− RemoteEndPointInit _ _ ->
998− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"
999− RemoteEndPointValid vst -> do
1000− unless (IntSet.member cid (vst ^. remoteIncoming)) $
1001− throwIO $ userError "Invalid CloseConnection"
1002− return ( RemoteEndPointValid
1003− . (remoteIncoming ^: IntSet.delete cid)
1004− $ vst
1005− )
1006− RemoteEndPointClosing _ _ ->
1007− -- If the remote endpoint is in Closing state, that means that are as
1008− -- far as we are concerned there are no incoming connections. This
1009− -- means that a CloseConnection request at this point is invalid.
1010− throwIO $ userError "Invalid CloseConnection request"
1011− RemoteEndPointFailed err ->
1012− throwIO err
1013− RemoteEndPointClosed ->
1014− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (closed)"
1015− writeChan ourChannel (ConnectionClosed cid)
1016− closeIfUnused (ourEndPoint, theirEndPoint)
1017−
1018− -- Close the socket (if we don't have any outgoing connections)
1019− closeSocket :: N.Socket -> IO Bool
1020− closeSocket sock =
1021− modifyMVar theirState $ \st ->
1022− case st of
1023− RemoteEndPointInvalid _ ->
1024− relyViolation (ourEndPoint, theirEndPoint)
1025− "handleIncomingMessages:closeSocket (invalid)"
1026− RemoteEndPointInit _ _ ->
1027− relyViolation (ourEndPoint, theirEndPoint)
1028− "handleIncomingMessages:closeSocket (init)"
1029− RemoteEndPointValid vst -> do
1030− -- We regard a CloseSocket message as an (optimized) way for the
1031− -- remote endpoint to indicate that all its connections to us are
1032− -- now properly closed
1033− forM_ (IntSet.elems $ vst ^. remoteIncoming) $
1034− writeChan ourChannel . ConnectionClosed
1035− let vst' = remoteIncoming ^= IntSet.empty $ vst
1036− -- Check if we agree that the connection should be closed
1037− if vst' ^. remoteOutgoing == 0
1038− then do
1039− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1040− -- Attempt to reply (but don't insist)
1041− tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1042− tryCloseSocket sock
1043− return (RemoteEndPointClosed, True)
1044− else
1045− return (RemoteEndPointValid vst', False)
1046− RemoteEndPointClosing resolved _ -> do
1047− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1048− tryCloseSocket sock
1049− putMVar resolved ()
1050− return (RemoteEndPointClosed, True)
1051− RemoteEndPointFailed err ->
1052− throwIO err
1053− RemoteEndPointClosed ->
1054− relyViolation (ourEndPoint, theirEndPoint)
1055− "handleIncomingMessages:closeSocket (closed)"
1056−
1057− -- Read a message and output it on the endPoint's channel. By rights we
1058− -- should verify that the connection ID is valid, but this is unnecessary
1059− -- overhead
1060− readMessage :: N.Socket -> ConnectionId -> IO ()
1061− readMessage sock connId =
1062− recvWithLength sock >>= writeChan ourChannel . Received connId
1063−
1064− -- Arguments
1065− ourChannel = localChannel ourEndPoint
1066− theirState = remoteState theirEndPoint
1067− theirAddr = remoteAddress theirEndPoint
1068−
1069− -- Deal with a premature exit
1070− prematureExit :: N.Socket -> IOException -> IO ()
1071− prematureExit sock err = do
1072− tryCloseSocket sock
1073− modifyMVar_ theirState $ \st ->
1074− case st of
1075− RemoteEndPointInvalid _ ->
1076− relyViolation (ourEndPoint, theirEndPoint)
1077− "handleIncomingMessages:prematureExit"
1078− RemoteEndPointInit _ _ ->
1079− relyViolation (ourEndPoint, theirEndPoint)
1080− "handleIncomingMessages:prematureExit"
1081− RemoteEndPointValid vst -> do
1082− let code = EventConnectionLost
1083− (Just $ remoteAddress theirEndPoint)
1084− (IntSet.elems $ vst ^. remoteIncoming)
1085− writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1086− forM_ (vst ^. pendingCtrlRequests) $ flip putMVar (Left err)
1087− return (RemoteEndPointFailed err)
1088− RemoteEndPointClosing resolved _ -> do
1089− putMVar resolved ()
1090− return (RemoteEndPointFailed err)
1091− RemoteEndPointClosed ->
1092− relyViolation (ourEndPoint, theirEndPoint)
1093− "handleIncomingMessages:prematureExit"
1094− RemoteEndPointFailed err' ->
1095− return (RemoteEndPointFailed err')
1096−
1097−--------------------------------------------------------------------------------
1098−-- Uninterruptable auxiliary functions --
1099−-- --
1100−-- All these functions assume they are running in a thread which will never --
1101−-- be killed.
1102−--------------------------------------------------------------------------------
1103−
1104−-- | Request a connection to a remote endpoint
1105−--
1106−-- This will block until we get a connection ID from the remote endpoint; if
1107−-- the remote endpoint was in 'RemoteEndPointClosing' state then we will
1108−-- additionally block until that is resolved.
1109−--
1110−-- May throw a TransportError ConnectErrorCode exception.
1111−requestConnectionTo :: TCPParameters
1112− -> LocalEndPoint
1113− -> EndPointAddress
1114− -> ConnectHints
1115− -> IO (RemoteEndPoint, ConnectionId)
1116−requestConnectionTo params ourEndPoint theirAddress hints = go
1117− where
1118− go = do
1119− (theirEndPoint, isNew) <- mapIOException connectFailed $
1120− findRemoteEndPoint ourEndPoint theirAddress RequestedByUs
1121−
1122− if isNew
1123− then do
1124− forkIO . handle absorbAllExceptions $
1125− setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
1126− go
1127− else do
1128− reply <- mapIOException connectFailed $
1129− doRemoteRequest (ourEndPoint, theirEndPoint) RequestConnectionId
1130− return (theirEndPoint, decodeInt32 . BS.concat $ reply)
1131−
1132− connectFailed :: IOException -> TransportError ConnectErrorCode
1133− connectFailed = TransportError ConnectFailed . show
1134−
1135− absorbAllExceptions :: SomeException -> IO ()
1136− absorbAllExceptions _ex =
1137− return ()
1138−
1139−-- | Set up a remote endpoint
1140−setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
1141−setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
1142− result <- socketToEndPoint ourAddress
1143− theirAddress
1144− (tcpReuseClientAddr params)
1145− (connectTimeout hints)
1146− didAccept <- case result of
1147− Right (sock, ConnectionRequestAccepted) -> do
1148− let vst = ValidRemoteEndPointState
1149− { remoteSocket = sock
1150− , _remoteOutgoing = 0
1151− , _remoteIncoming = IntSet.empty
1152− , sendOn = sendMany sock
1153− , _pendingCtrlRequests = IntMap.empty
1154− , _nextCtrlRequestId = 0
1155− }
1156− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
1157− return True
1158− Right (sock, ConnectionRequestInvalid) -> do
1159− let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"
1160− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1161− tryCloseSocket sock
1162− return False
1163− Right (sock, ConnectionRequestCrossed) -> do
1164− resolveInit (ourEndPoint, theirEndPoint) RemoteEndPointClosed
1165− tryCloseSocket sock
1166− return False
1167− Left err -> do
1168− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1169− return False
1170−
1171− when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
1172− where
1173− ourAddress = localAddress ourEndPoint
1174− theirAddress = remoteAddress theirEndPoint
1175− invalidAddress = TransportError ConnectNotFound
1176−
1177−-- | Do a (blocking) remote request
1178−--
1179−-- May throw IO (user) exception if the local or the remote endpoint is closed,
1180−-- if the send fails, or if the remote endpoint fails before it replies.
1181−doRemoteRequest :: EndPointPair -> ControlHeader -> IO [ByteString]
1182−doRemoteRequest (ourEndPoint, theirEndPoint) header = do
1183− replyMVar <- newEmptyMVar
1184− modifyRemoteState_ (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
1185− { caseValid = \vst -> do
1186− let reqId = vst ^. nextCtrlRequestId
1187− sendOn vst [encodeInt32 header, encodeInt32 reqId]
1188− return ( RemoteEndPointValid
1189− . (nextCtrlRequestId ^: (+ 1))
1190− . (pendingCtrlRequestsAt reqId ^= Just replyMVar)
1191− $ vst
1192− )
1193− -- Error cases
1194− , caseInvalid =
1195− throwIO
1196− , caseInit = \_ _ ->
1197− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (init)"
1198− , caseClosing = \_ _ ->
1199− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closing)"
1200− , caseClosed =
1201− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closed)"
1202− , caseFailed =
1203− throwIO
1204− }
1205− mReply <- takeMVar replyMVar
1206− case mReply of
1207− Left err -> throwIO err
1208− Right reply -> return reply
1209−
1210−-- | Send a CloseSocket request if the remote endpoint is unused
1211−closeIfUnused :: EndPointPair -> IO ()
1212−closeIfUnused (ourEndPoint, theirEndPoint) =
1213− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
1214− { caseValid = \vst ->
1215− if vst ^. remoteOutgoing == 0 && IntSet.null (vst ^. remoteIncoming)
1216− then do
1217− sendOn vst [encodeInt32 CloseSocket]
1218− resolved <- newEmptyMVar
1219− return $ RemoteEndPointClosing resolved vst
1220− else
1221− return $ RemoteEndPointValid vst
1222− }
1223−
1224−-- | Reset a remote endpoint if it is in Invalid mode
1225−--
1226−-- If the remote endpoint is currently in broken state, and
1227−--
1228−-- - a user calls the API function 'connect', or and the remote endpoint is
1229−-- - an inbound connection request comes in from this remote address
1230−--
1231−-- we remove the remote endpoint first.
1232−--
1233−-- Throws a TransportError ConnectFailed exception if the local endpoint is
1234−-- closed.
1235−resetIfBroken :: LocalEndPoint -> EndPointAddress -> IO ()
1236−resetIfBroken ourEndPoint theirAddress = do
1237− mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1238− LocalEndPointValid vst ->
1239− return (vst ^. localConnectionTo theirAddress)
1240− LocalEndPointClosed ->
1241− throwIO $ TransportError ConnectFailed "Endpoint closed"
1242− forM_ mTheirEndPoint $ \theirEndPoint ->
1243− withMVar (remoteState theirEndPoint) $ \st -> case st of
1244− RemoteEndPointInvalid _ ->
1245− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1246− RemoteEndPointFailed _ ->
1247− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1248− _ ->
1249− return ()
1250−
1251−-- | Special case of 'apiConnect': connect an endpoint to itself
1252−--
1253−-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)
1254−connectToSelf :: LocalEndPoint
1255− -> IO Connection
1256−connectToSelf ourEndPoint = do
1257− connAlive <- newIORef True -- Protected by the local endpoint lock
1258− connId <- mapIOException connectFailed $ getNextConnectionId ourEndPoint
1259− writeChan ourChan $
1260− ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)
1261− return Connection
1262− { send = selfSend connAlive connId
1263− , close = selfClose connAlive connId
1264− }
1265− where
1266− selfSend :: IORef Bool
1267− -> ConnectionId
1268− -> [ByteString]
1269− -> IO (Either (TransportError SendErrorCode) ())
1270− selfSend connAlive connId msg =
1271− try . withMVar ourState $ \st -> case st of
1272− LocalEndPointValid _ -> do
1273− alive <- readIORef connAlive
1274− if alive
1275− then writeChan ourChan (Received connId msg)
1276− else throwIO $ TransportError SendClosed "Connection closed"
1277− LocalEndPointClosed ->
1278− throwIO $ TransportError SendFailed "Endpoint closed"
1279−
1280− selfClose :: IORef Bool -> ConnectionId -> IO ()
1281− selfClose connAlive connId =
1282− withMVar ourState $ \st -> case st of
1283− LocalEndPointValid _ -> do
1284− alive <- readIORef connAlive
1285− when alive $ do
1286− writeChan ourChan (ConnectionClosed connId)
1287− writeIORef connAlive False
1288− LocalEndPointClosed ->
1289− return ()
1290−
1291− ourChan = localChannel ourEndPoint
1292− ourState = localState ourEndPoint
1293− connectFailed = TransportError ConnectFailed . show
1294−
1295−-- | Resolve an endpoint currently in 'Init' state
1296−resolveInit :: EndPointPair -> RemoteState -> IO ()
1297−resolveInit (ourEndPoint, theirEndPoint) newState =
1298− modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
1299− RemoteEndPointInit resolved _ -> do
1300− putMVar resolved ()
1301− case newState of
1302− RemoteEndPointClosed ->
1303− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1304− _ ->
1305− return ()
1306− return newState
1307− RemoteEndPointFailed ex ->
1308− throwIO ex
1309− _ ->
1310− relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
1311−
1312−-- | Get the next connection ID
1313−--
1314−-- Throws an IO exception when the endpoint is closed.
1315−getNextConnectionId :: LocalEndPoint -> IO ConnectionId
1316−getNextConnectionId ourEndpoint =
1317− modifyMVar (localState ourEndpoint) $ \st -> case st of
1318− LocalEndPointValid vst -> do
1319− let connId = vst ^. nextConnectionId
1320− return ( LocalEndPointValid
1321− . (nextConnectionId ^= connId + 1)
1322− $ vst
1323− , connId)
1324− LocalEndPointClosed ->
1325− throwIO $ userError "Local endpoint closed"
1326−
1327−-- | Create a new local endpoint
1328−--
1329−-- May throw a TransportError NewEndPointErrorCode exception if the transport
1330−-- is closed.
1331−createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
1332−createLocalEndPoint transport = do
1333− chan <- newChan
1334− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
1335− { _nextConnectionId = firstNonReservedConnectionId
1336− , _localConnections = Map.empty
1337− , _nextRemoteId = 0
1338− }
1339− modifyMVar (transportState transport) $ \st -> case st of
1340− TransportValid vst -> do
1341− let ix = vst ^. nextEndPointId
1342− let addr = encodeEndPointAddress (transportHost transport)
1343− (transportPort transport)
1344− ix
1345− let localEndPoint = LocalEndPoint { localAddress = addr
1346− , localChannel = chan
1347− , localState = state
1348− }
1349− return ( TransportValid
1350− . (localEndPointAt addr ^= Just localEndPoint)
1351− . (nextEndPointId ^= ix + 1)
1352− $ vst
1353− , localEndPoint
1354− )
1355− TransportClosed ->
1356− throwIO (TransportError NewEndPointFailed "Transport closed")
1357−
1358−
1359−-- | Remove reference to a remote endpoint from a local endpoint
1360−--
1361−-- If the local endpoint is closed, do nothing
1362−removeRemoteEndPoint :: EndPointPair -> IO ()
1363−removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
1364− modifyMVar_ ourState $ \st -> case st of
1365− LocalEndPointValid vst ->
1366− case vst ^. localConnectionTo theirAddress of
1367− Nothing ->
1368− return st
1369− Just remoteEndPoint' ->
1370− if remoteId remoteEndPoint' == remoteId theirEndPoint
1371− then return
1372− ( LocalEndPointValid
1373− . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
1374− $ vst
1375− )
1376− else return st
1377− LocalEndPointClosed ->
1378− return LocalEndPointClosed
1379− where
1380− ourState = localState ourEndPoint
1381− theirAddress = remoteAddress theirEndPoint
1382−
1383−-- | Remove reference to a local endpoint from the transport state
1384−--
1385−-- Does nothing if the transport is closed
1386−removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
1387−removeLocalEndPoint transport ourEndPoint =
1388− modifyMVar_ (transportState transport) $ \st -> case st of
1389− TransportValid vst ->
1390− return ( TransportValid
1391− . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
1392− $ vst
1393− )
1394− TransportClosed ->
1395− return TransportClosed
1396−
1397−-- | Find a remote endpoint. If the remote endpoint does not yet exist we
1398−-- create it in Init state. Returns if the endpoint was new.
1399−findRemoteEndPoint
1400− :: LocalEndPoint
1401− -> EndPointAddress
1402− -> RequestedBy
1403− -> IO (RemoteEndPoint, Bool)
1404−findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
1405− where
1406− go = do
1407− (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of
1408− LocalEndPointValid vst -> case vst ^. localConnectionTo theirAddress of
1409− Just theirEndPoint ->
1410− return (st, (theirEndPoint, False))
1411− Nothing -> do
1412− resolved <- newEmptyMVar
1413− theirState <- newMVar (RemoteEndPointInit resolved findOrigin)
1414− let theirEndPoint = RemoteEndPoint
1415− { remoteAddress = theirAddress
1416− , remoteState = theirState
1417− , remoteId = vst ^. nextRemoteId
1418− }
1419− return ( LocalEndPointValid
1420− . (localConnectionTo theirAddress ^= Just theirEndPoint)
1421− . (nextRemoteId ^: (+ 1))
1422− $ vst
1423− , (theirEndPoint, True)
1424− )
1425− LocalEndPointClosed ->
1426− throwIO $ userError "Local endpoint closed"
1427−
1428− if isNew
1429− then
1430− return (theirEndPoint, True)
1431− else do
1432− let theirState = remoteState theirEndPoint
1433− snapshot <- modifyMVar theirState $ \st -> case st of
1434− RemoteEndPointValid vst ->
1435− case findOrigin of
1436− RequestedByUs -> do
1437− let st' = RemoteEndPointValid
1438− . (remoteOutgoing ^: (+ 1))
1439− $ vst
1440− return (st', st')
1441− RequestedByThem ->
1442− return (st, st)
1443− _ ->
1444− return (st, st)
1445− -- The snapshot may no longer be up to date at this point, but if we
1446− -- increased the refcount then it can only either be Valid or Failed
1447− -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
1448− case snapshot of
1449− RemoteEndPointInvalid err ->
1450− throwIO err
1451− RemoteEndPointInit resolved initOrigin ->
1452− case (findOrigin, initOrigin) of
1453− (RequestedByUs, RequestedByUs) ->
1454− readMVar resolved >> go
1455− (RequestedByUs, RequestedByThem) ->
1456− readMVar resolved >> go
1457− (RequestedByThem, RequestedByUs) ->
1458− if ourAddress > theirAddress
1459− then
1460− -- Wait for the Crossed message
1461− readMVar resolved >> go
1462− else
1463− return (theirEndPoint, False)
1464− (RequestedByThem, RequestedByThem) ->
1465− throwIO $ userError "Already connected"
1466− RemoteEndPointValid _ ->
1467− -- We assume that the request crossed if we find the endpoint in
1468− -- Valid state. It is possible that this is really an invalid
1469− -- request, but only in the case of a broken client (we don't
1470− -- maintain enough history to be able to tell the difference).
1471− return (theirEndPoint, False)
1472− RemoteEndPointClosing resolved _ ->
1473− readMVar resolved >> go
1474− RemoteEndPointClosed ->
1475− go
1476− RemoteEndPointFailed err ->
1477− throwIO err
1478−
1479− ourState = localState ourEndPoint
1480− ourAddress = localAddress ourEndPoint
1481−
1482−--------------------------------------------------------------------------------
1483−-- "Stateless" (MVar free) functions --
1484−--------------------------------------------------------------------------------
1485−
1486−-- | Establish a connection to a remote endpoint
1487−--
1488−-- Maybe throw a TransportError
1489−socketToEndPoint :: EndPointAddress -- ^ Our address
1490− -> EndPointAddress -- ^ Their address
1491− -> Bool -- ^ Use SO_REUSEADDR?
1492− -> Maybe Int -- ^ Timeout for connect
1493− -> IO (Either (TransportError ConnectErrorCode)
1494− (N.Socket, ConnectionRequestResponse))
1495−socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1496− try $ do
1497− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
1498− Nothing -> throwIO (failed . userError $ "Could not parse")
1499− Just dec -> return dec
1500− addr:_ <- mapIOException invalidAddress $
1501− N.getAddrInfo Nothing (Just host) (Just port)
1502− bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
1503− when reuseAddr $
1504− mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
1505− mapIOException invalidAddress $
1506− timeoutMaybe timeout timeoutError $
1507− N.connect sock (N.addrAddress addr)
1508− response <- mapIOException failed $ do
1509− sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
1510− recvInt32 sock
1511− case tryToEnum response of
1512− Nothing -> throwIO (failed . userError $ "Unexpected response")
1513− Just r -> return (sock, r)
1514− where
1515− createSocket :: N.AddrInfo -> IO N.Socket
1516− createSocket addr = mapIOException insufficientResources $
1517− N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
1518−
1519− invalidAddress = TransportError ConnectNotFound . show
1520− insufficientResources = TransportError ConnectInsufficientResources . show
1521− failed = TransportError ConnectFailed . show
1522− timeoutError = TransportError ConnectTimeout "Timed out"
1523−
1524−-- | Encode end point address
1525−encodeEndPointAddress :: N.HostName
1526− -> N.ServiceName
1527− -> EndPointId
1528− -> EndPointAddress
1529−encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
1530− host ++ ":" ++ port ++ ":" ++ show ix
1531−
1532−-- | Decode end point address
1533−decodeEndPointAddress :: EndPointAddress
1534− -> Maybe (N.HostName, N.ServiceName, EndPointId)
1535−decodeEndPointAddress (EndPointAddress bs) =
1536− case map BSC.unpack $ BSC.split ':' bs of
1537− [host, port, endPointIdStr] ->
1538− case reads endPointIdStr of
1539− [(endPointId, "")] -> Just (host, port, endPointId)
1540− _ -> Nothing
1541− _ ->
1542− Nothing
1543−
1544−--------------------------------------------------------------------------------
1545−-- Functions from TransportInternals --
1546−--------------------------------------------------------------------------------
1547−
1548−-- Find a socket between two endpoints
1549−--
1550−-- Throws an IO exception if the socket could not be found.
1551−internalSocketBetween :: TCPTransport -- ^ Transport
1552− -> EndPointAddress -- ^ Local endpoint
1553− -> EndPointAddress -- ^ Remote endpoint
1554− -> IO N.Socket
1555−internalSocketBetween transport ourAddress theirAddress = do
1556− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
1557− TransportClosed ->
1558− throwIO $ userError "Transport closed"
1559− TransportValid vst ->
1560− case vst ^. localEndPointAt ourAddress of
1561− Nothing -> throwIO $ userError "Local endpoint not found"
1562− Just ep -> return ep
1563− theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1564− LocalEndPointClosed ->
1565− throwIO $ userError "Local endpoint closed"
1566− LocalEndPointValid vst ->
1567− case vst ^. localConnectionTo theirAddress of
1568− Nothing -> throwIO $ userError "Remote endpoint not found"
1569− Just ep -> return ep
1570− withMVar (remoteState theirEndPoint) $ \st -> case st of
1571− RemoteEndPointInit _ _ ->
1572− throwIO $ userError "Remote endpoint not yet initialized"
1573− RemoteEndPointValid vst ->
1574− return $ remoteSocket vst
1575− RemoteEndPointClosing _ vst ->
1576− return $ remoteSocket vst
1577− RemoteEndPointClosed ->
1578− throwIO $ userError "Remote endpoint closed"
1579− RemoteEndPointInvalid err ->
1580− throwIO err
1581− RemoteEndPointFailed err ->
1582− throwIO err
1583−
1584−--------------------------------------------------------------------------------
1585−-- Constants --
1586−--------------------------------------------------------------------------------
1587−
1588−-- | We reserve a bunch of connection IDs for control messages
1589−firstNonReservedConnectionId :: ConnectionId
1590−firstNonReservedConnectionId = 1024
1591−
1592−--------------------------------------------------------------------------------
1593−-- Accessor definitions --
1594−--------------------------------------------------------------------------------
1595−
1596−localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
1597−localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es })
1598−
1599−nextEndPointId :: Accessor ValidTransportState EndPointId
1600−nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid })
1601−
1602−nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
1603−nextConnectionId = accessor _nextConnectionId (\cix st -> st { _nextConnectionId = cix })
1604−
1605−localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
1606−localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
1607−
1608−nextRemoteId :: Accessor ValidLocalEndPointState Int
1609−nextRemoteId = accessor _nextRemoteId (\rid st -> st { _nextRemoteId = rid })
1610−
1611−remoteOutgoing :: Accessor ValidRemoteEndPointState Int
1612−remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs })
1613−
1614−remoteIncoming :: Accessor ValidRemoteEndPointState IntSet
1615−remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs })
1616−
1617−pendingCtrlRequests :: Accessor ValidRemoteEndPointState (IntMap (MVar (Either IOException [ByteString])))
1618−pendingCtrlRequests = accessor _pendingCtrlRequests (\rep st -> st { _pendingCtrlRequests = rep })
1619−
1620−nextCtrlRequestId :: Accessor ValidRemoteEndPointState ControlRequestId
1621−nextCtrlRequestId = accessor _nextCtrlRequestId (\cid st -> st { _nextCtrlRequestId = cid })
1622−
1623−localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1624−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1625−
1626−pendingCtrlRequestsAt :: ControlRequestId -> Accessor ValidRemoteEndPointState (Maybe (MVar (Either IOException [ByteString])))
1627−pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral ix)
1628−
1629−localConnectionTo :: EndPointAddress
1630− -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1631−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1632−
1633−-------------------------------------------------------------------------------
1634−-- Debugging --
1635−-------------------------------------------------------------------------------
1636−
1637−relyViolation :: EndPointPair -> String -> IO a
1638−relyViolation (ourEndPoint, theirEndPoint) str = do
1639− elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1640− fail (str ++ " RELY violation")
1641−
1642−elog :: EndPointPair -> String -> IO ()
1643−elog (ourEndPoint, theirEndPoint) msg = do
1644− tid <- myThreadId
1645− putStrLn $ show (localAddress ourEndPoint)
1646− ++ "/" ++ show (remoteAddress theirEndPoint)
1647− ++ "(" ++ show (remoteId theirEndPoint) ++ ")"
1648− ++ "/" ++ show tid
1649− ++ ": " ++ msg
network-transport-tcp/src/Network/Transport/TCP/Internal.hsdeleted−116
@@ -1,116 +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−import Prelude hiding (catch)
10−import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)
11−import qualified Network.Socket as N ( HostName
12− , ServiceName
13− , Socket
14− , SocketType(Stream)
15− , SocketOption(ReuseAddr)
16− , getAddrInfo
17− , defaultHints
18− , socket
19− , bindSocket
20− , listen
21− , addrFamily
22− , addrAddress
23− , defaultProtocol
24− , setSocketOption
25− , accept
26− , sClose
27− )
28−import qualified Network.Socket.ByteString as NBS (recv)
29−import Control.Concurrent (ThreadId)
30−import Control.Monad (forever, when)
31−import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_)
32−import Control.Applicative ((<$>))
33−import Data.ByteString (ByteString)
34−import qualified Data.ByteString as BS (length, concat, null)
35−import Data.Int (Int32)
36−
37−-- | Start a server at the specified address.
38−--
39−-- This sets up a server socket for the specified host and port. Exceptions
40−-- thrown during setup are not caught.
41−--
42−-- Once the socket is created we spawn a new thread which repeatedly accepts
43−-- incoming connections and executes the given request handler. If any
44−-- exception occurs the thread terminates and calls the terminationHandler.
45−-- This exception may occur because of a call to 'N.accept', because the thread
46−-- was explicitly killed, or because of a synchronous exception thrown by the
47−-- request handler. Typically, you should avoid the last case by catching any
48−-- relevant exceptions in the request handler.
49−--
50−-- The request handler should spawn threads to handle each individual request
51−-- or the server will block. Once a thread has been spawned it will be the
52−-- responsibility of the new thread to close the socket when an exception
53−-- occurs.
54−forkServer :: N.HostName -- ^ Host
55− -> N.ServiceName -- ^ Port
56− -> Int -- ^ Backlog (maximum number of queued connections)
57− -> Bool -- ^ Set ReuseAddr option?
58− -> (SomeException -> IO ()) -- ^ Termination handler
59− -> (N.Socket -> IO ()) -- ^ Request handler
60− -> IO ThreadId
61−forkServer host port backlog reuseAddr terminationHandler requestHandler = do
62− -- Resolve the specified address. By specification, getAddrInfo will never
63− -- return an empty list (but will throw an exception instead) and will return
64− -- the "best" address first, whatever that means
65− addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
66− bracketOnError (N.socket (N.addrFamily addr) N.Stream N.defaultProtocol)
67− tryCloseSocket $ \sock -> do
68− when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1
69− N.bindSocket sock (N.addrAddress addr)
70− N.listen sock backlog
71− -- We start listening for incoming requests in a separate thread. When
72− -- that thread is killed, we close the server socket and the termination
73− -- handler. We have to make sure that the exception handler is installed
74− -- /before/ any asynchronous exception occurs. So we mask_, then fork
75− -- (the child thread inherits the masked state from the parent), then
76− -- unmask only inside the catch.
77− mask_ $ forkIOWithUnmask $ \unmask ->
78− catch (unmask (forever $ acceptRequest sock)) $ \ex -> do
79− tryCloseSocket sock
80− terminationHandler ex
81− where
82− acceptRequest :: N.Socket -> IO ()
83− acceptRequest sock = bracketOnError (N.accept sock)
84− (tryCloseSocket . fst)
85− (requestHandler . fst)
86−
87−-- | Read a length and then a payload of that length
88−recvWithLength :: N.Socket -> IO [ByteString]
89−recvWithLength sock = recvInt32 sock >>= recvExact sock
90−
91−-- | Receive a 32-bit integer
92−recvInt32 :: Num a => N.Socket -> IO a
93−recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
94−
95−-- | Close a socket, ignoring I/O exceptions
96−tryCloseSocket :: N.Socket -> IO ()
97−tryCloseSocket sock = void . tryIO $
98− N.sClose sock
99−
100−-- | Read an exact number of bytes from a socket
101−--
102−-- Throws an I/O exception if the socket closes before the specified
103−-- number of bytes could be read
104−recvExact :: N.Socket -- ^ Socket to read from
105− -> Int32 -- ^ Number of bytes to read
106− -> IO [ByteString]
107−recvExact _ len | len <= 0 = throwIO (userError "recvExact: Negative length")
108−recvExact sock len = go [] len
109− where
110− go :: [ByteString] -> Int32 -> IO [ByteString]
111− go acc 0 = return (reverse acc)
112− go acc l = do
113− bs <- NBS.recv sock (fromIntegral l `min` 4096)
114− if BS.null bs
115− then throwIO (userError "recvExact: Socket closed")
116− else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport-tcp/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-tcp/tests/TestTCP.hsdeleted−786
@@ -1,786 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Main where
4−
5−import Prelude hiding (catch, (>>=), (>>), return, fail)
6−import TestTransport (testTransport)
7−import TestAuxiliary (forkTry, runTests)
8−import Network.Transport
9−import Network.Transport.TCP ( createTransport
10− , createTransportExposeInternals
11− , TransportInternals(..)
12− , encodeEndPointAddress
13− , defaultTCPParameters
14− )
15−import Data.Int (Int32)
16−import Control.Concurrent (threadDelay, killThread)
17−import Control.Concurrent.MVar ( MVar
18− , newEmptyMVar
19− , putMVar
20− , takeMVar
21− , readMVar
22− , isEmptyMVar
23− , newMVar
24− , modifyMVar
25− )
26−import Control.Monad (replicateM, guard, forM_, replicateM_, when)
27−import Control.Applicative ((<$>))
28−import Control.Exception (throwIO, try, SomeException)
29−import Network.Transport.TCP ( ControlHeader(..)
30− , ConnectionRequestResponse(..)
31− , socketToEndPoint
32− )
33−import Network.Transport.Internal ( encodeInt32
34− , prependLength
35− , tlog
36− , tryIO
37− , void
38− )
39−import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)
40−import qualified Network.Socket as N ( sClose
41− , ServiceName
42− , Socket
43− , AddrInfo
44− , shutdown
45− , ShutdownCmd(ShutdownSend)
46− )
47−import Network.Socket.ByteString (sendMany)
48−import Data.String (fromString)
49−import Traced
50−import GHC.IO.Exception (ioe_errno)
51−import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)
52−import System.Timeout (timeout)
53−
54−instance Traceable ControlHeader where
55− trace = traceShow
56−
57−instance Traceable ConnectionRequestResponse where
58− trace = traceShow
59−
60−instance Traceable N.Socket where
61− trace = traceShow
62−
63−instance Traceable N.AddrInfo where
64− trace = traceShow
65−
66−instance Traceable TransportInternals where
67− trace = const Nothing
68−
69−-- Test that the server gets a ConnectionClosed message when the client closes
70−-- the socket without sending an explicit control message to the server first
71−testEarlyDisconnect :: IO N.ServiceName -> IO ()
72−testEarlyDisconnect nextPort = do
73− clientAddr <- newEmptyMVar
74− serverAddr <- newEmptyMVar
75− serverDone <- newEmptyMVar
76−
77− tlog "testEarlyDisconnect"
78− forkTry $ server serverAddr clientAddr serverDone
79− forkTry $ client serverAddr clientAddr
80−
81− takeMVar serverDone
82− where
83− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
84− server serverAddr clientAddr serverDone = do
85− tlog "Server"
86− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
87− Right endpoint <- newEndPoint transport
88− putMVar serverAddr (address endpoint)
89− theirAddr <- readMVar clientAddr
90−
91− -- TEST 1: they connect to us, then drop the connection
92− do
93− ConnectionOpened cid _ addr <- receive endpoint
94− True <- return $ addr == theirAddr
95−
96− ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid']) _) <- receive endpoint
97− True <- return $ addr' == theirAddr && cid' == cid
98−
99− return ()
100−
101− -- TEST 2: after they dropped their connection to us, we now try to
102− -- establish a connection to them. This should re-establish the broken
103− -- TCP connection.
104− tlog "Trying to connect to client"
105− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
106−
107− -- TEST 3: To test the connection, we do a simple ping test; as before,
108− -- however, the remote client won't close the connection nicely but just
109− -- closes the socket
110− do
111− Right () <- send conn ["ping"]
112−
113− ConnectionOpened cid _ addr <- receive endpoint
114− True <- return $ addr == theirAddr
115−
116− Received cid' ["pong"] <- receive endpoint
117− True <- return $ cid == cid'
118−
119− ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid'']) _) <- receive endpoint
120− True <- return $ addr' == theirAddr && cid'' == cid
121−
122− return ()
123−
124− -- TEST 4: A subsequent send on an already-open connection will now break
125− Left (TransportError SendFailed _) <- send conn ["ping2"]
126−
127− -- *Pfew*
128− putMVar serverDone ()
129−
130− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
131− client serverAddr clientAddr = do
132− tlog "Client"
133− clientPort <- nextPort
134− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
135− putMVar clientAddr ourAddress
136−
137− -- Listen for incoming messages
138− forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
139− -- Initial setup
140− 0 <- recvInt32 sock :: IO Int
141− _ <- recvWithLength sock
142− sendMany sock [encodeInt32 ConnectionRequestAccepted]
143−
144− -- Server requests a logical connection
145− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
146− reqId <- recvInt32 sock :: IO Int
147− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
148−
149− -- Server sends a message
150− 10001 <- recvInt32 sock :: IO Int
151− ["ping"] <- recvWithLength sock
152−
153− -- Reply
154− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
155− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
156− 10002 <- recvInt32 sock :: IO Int
157− [cid] <- recvWithLength sock
158− sendMany sock (cid : prependLength ["pong"])
159−
160− -- Close the socket
161− N.sClose sock
162−
163− -- Connect to the server
164− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
165−
166− -- Request a new connection, but don't wait for the response
167− let reqId = 0 :: Int32
168− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
169−
170− -- Close the socket without closing the connection explicitly
171− -- The server should receive an error event
172− N.sClose sock
173−
174−-- | Test the behaviour of a premature CloseSocket request
175−testEarlyCloseSocket :: IO N.ServiceName -> IO ()
176−testEarlyCloseSocket nextPort = do
177− clientAddr <- newEmptyMVar
178− serverAddr <- newEmptyMVar
179− serverDone <- newEmptyMVar
180−
181− tlog "testEarlyDisconnect"
182− forkTry $ server serverAddr clientAddr serverDone
183− forkTry $ client serverAddr clientAddr
184−
185− takeMVar serverDone
186− where
187− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
188− server serverAddr clientAddr serverDone = do
189− tlog "Server"
190− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
191− Right endpoint <- newEndPoint transport
192− putMVar serverAddr (address endpoint)
193− theirAddr <- readMVar clientAddr
194−
195− -- TEST 1: they connect to us, then send a CloseSocket. Since we don't
196− -- have any outgoing connections, this means we will agree to close the
197− -- socket
198− do
199− ConnectionOpened cid _ addr <- receive endpoint
200− True <- return $ addr == theirAddr
201−
202− ConnectionClosed cid' <- receive endpoint
203− True <- return $ cid' == cid
204−
205− return ()
206−
207− -- TEST 2: after they dropped their connection to us, we now try to
208− -- establish a connection to them. This should re-establish the broken
209− -- TCP connection.
210− tlog "Trying to connect to client"
211− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
212−
213− -- TEST 3: To test the connection, we do a simple ping test; as before,
214− -- however, the remote client won't close the connection nicely but just
215− -- sends a CloseSocket -- except that now we *do* have outgoing
216− -- connections, so we won't agree and hence will receive an error when
217− -- the socket gets closed
218− do
219− Right () <- send conn ["ping"]
220−
221− ConnectionOpened cid _ addr <- receive endpoint
222− True <- return $ addr == theirAddr
223−
224− Received cid' ["pong"] <- receive endpoint
225− True <- return $ cid' == cid
226−
227− ConnectionClosed cid'' <- receive endpoint
228− True <- return $ cid'' == cid
229−
230− ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint
231− True <- return $ addr' == theirAddr
232−
233− return ()
234−
235− -- TEST 4: A subsequent send on an already-open connection will now break
236− Left (TransportError SendFailed _) <- send conn ["ping2"]
237−
238− -- *Pfew*
239− putMVar serverDone ()
240−
241− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
242− client serverAddr clientAddr = do
243− tlog "Client"
244− clientPort <- nextPort
245− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
246− putMVar clientAddr ourAddress
247−
248− -- Listen for incoming messages
249− forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
250− -- Initial setup
251− 0 <- recvInt32 sock :: IO Int
252− _ <- recvWithLength sock
253− sendMany sock [encodeInt32 ConnectionRequestAccepted]
254−
255− -- Server requests a logical connection
256− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
257− reqId <- recvInt32 sock :: IO Int
258− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
259−
260− -- Server sends a message
261− 10001 <- recvInt32 sock :: IO Int
262− ["ping"] <- recvWithLength sock
263−
264− -- Reply
265− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
266− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
267− 10002 <- recvInt32 sock :: IO Int
268− [cid] <- recvWithLength sock
269− sendMany sock (cid : prependLength ["pong"])
270−
271− -- Send a CloseSocket even though there are still connections *in both
272− -- directions*
273− sendMany sock [encodeInt32 CloseSocket]
274− N.sClose sock
275−
276− -- Connect to the server
277− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
278−
279− -- Request a new connection, but don't wait for the response
280− let reqId = 0 :: Int32
281− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
282−
283− -- Send a CloseSocket without sending a closeconnecton
284− -- The server should still receive a ConnectionClosed message
285− sendMany sock [encodeInt32 CloseSocket]
286− N.sClose sock
287−
288−-- | Test the creation of a transport with an invalid address
289−testInvalidAddress :: IO N.ServiceName -> IO ()
290−testInvalidAddress nextPort = do
291− Left _ <- nextPort >>= \port -> createTransport "invalidHostName" port defaultTCPParameters
292− return ()
293−
294−-- | Test connecting to invalid or non-existing endpoints
295−testInvalidConnect :: IO N.ServiceName -> IO ()
296−testInvalidConnect nextPort = do
297− port <- nextPort
298− Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
299− Right endpoint <- newEndPoint transport
300−
301− -- Syntax error in the endpoint address
302− Left (TransportError ConnectFailed _) <-
303− connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints
304−
305− -- Syntax connect, but invalid hostname (TCP address lookup failure)
306− Left (TransportError ConnectNotFound _) <-
307− connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints
308−
309− -- TCP address correct, but nobody home at that address
310− Left (TransportError ConnectNotFound _) <-
311− connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints
312−
313− -- Valid TCP address but invalid endpoint number
314− Left (TransportError ConnectNotFound _) <-
315− connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered defaultConnectHints
316−
317− return ()
318−
319−-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
320−-- would happen when the endpoint sends a new connection request before
321−-- receiving an (already underway) CloseSocket request)
322−testIgnoreCloseSocket :: IO N.ServiceName -> IO ()
323−testIgnoreCloseSocket nextPort = do
324− serverAddr <- newEmptyMVar
325− clientDone <- newEmptyMVar
326− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
327−
328− forkTry $ server transport serverAddr
329− forkTry $ client transport serverAddr clientDone
330−
331− takeMVar clientDone
332−
333− where
334− server :: Transport -> MVar EndPointAddress -> IO ()
335− server transport serverAddr = do
336− tlog "Server"
337− Right endpoint <- newEndPoint transport
338− putMVar serverAddr (address endpoint)
339−
340− -- Wait for the client to connect and disconnect
341− tlog "Waiting for ConnectionOpened"
342− ConnectionOpened _ _ _ <- receive endpoint
343− tlog "Waiting for ConnectionClosed"
344− ConnectionClosed _ <- receive endpoint
345−
346− -- At this point the server will have sent a CloseSocket request to the
347− -- client, which however ignores it, instead it requests and closes
348− -- another connection
349− tlog "Waiting for ConnectionOpened"
350− ConnectionOpened _ _ _ <- receive endpoint
351− tlog "Waiting for ConnectionClosed"
352− ConnectionClosed _ <- receive endpoint
353−
354−
355− tlog "Server waiting.."
356−
357− client :: Transport -> MVar EndPointAddress -> MVar () -> IO ()
358− client transport serverAddr clientDone = do
359− tlog "Client"
360− Right endpoint <- newEndPoint transport
361− let ourAddress = address endpoint
362−
363− -- Connect to the server
364− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
365−
366− -- Request a new connection
367− tlog "Requesting connection"
368− let reqId = 0 :: Int32
369− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
370− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
371−
372− -- Close the connection again
373− tlog "Closing connection"
374− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
375−
376− -- Server will now send a CloseSocket request as its refcount reached 0
377− tlog "Waiting for CloseSocket request"
378− CloseSocket <- toEnum <$> recvInt32 sock
379−
380− -- But we ignore it and request another connection
381− tlog "Ignoring it, requesting another connection"
382− let reqId' = 1 :: Int32
383− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
384− response' <- replicateM 4 $ recvInt32 sock :: IO [Int32]
385−
386− -- Close it again
387− tlog "Closing connection"
388− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response' !! 3)]
389−
390− -- We now get a CloseSocket again, and this time we heed it
391− tlog "Waiting for second CloseSocket request"
392− CloseSocket <- toEnum <$> recvInt32 sock
393−
394− tlog "Closing socket"
395− sendMany sock [encodeInt32 CloseSocket]
396− N.sClose sock
397−
398− putMVar clientDone ()
399−
400−-- | Like 'testIgnoreSocket', but now the server requests a connection after the
401−-- client closed their connection. In the meantime, the server will have sent a
402−-- CloseSocket request to the client, and must block until the client responds.
403−testBlockAfterCloseSocket :: IO N.ServiceName -> IO ()
404−testBlockAfterCloseSocket nextPort = do
405− serverAddr <- newEmptyMVar
406− clientAddr <- newEmptyMVar
407− clientDone <- newEmptyMVar
408− port <- nextPort
409− Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
410−
411− forkTry $ server transport serverAddr clientAddr
412− forkTry $ client transport serverAddr clientAddr clientDone
413−
414− takeMVar clientDone
415−
416− where
417− server :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> IO ()
418− server transport serverAddr clientAddr = do
419− tlog "Server"
420− Right endpoint <- newEndPoint transport
421− putMVar serverAddr (address endpoint)
422−
423− -- Wait for the client to connect and disconnect
424− tlog "Waiting for ConnectionOpened"
425− ConnectionOpened _ _ _ <- receive endpoint
426− tlog "Waiting for ConnectionClosed"
427− ConnectionClosed _ <- receive endpoint
428−
429− -- At this point the server will have sent a CloseSocket request to the
430− -- client, and must block until the client responds
431− tlog "Server waiting to connect to the client.."
432− Right _ <- readMVar clientAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
433−
434− tlog "Server waiting.."
435−
436− client :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
437− client transport serverAddr clientAddr clientDone = do
438− tlog "Client"
439− Right endpoint <- newEndPoint transport
440− putMVar clientAddr (address endpoint)
441− let ourAddress = address endpoint
442−
443− -- Connect to the server
444− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
445−
446− -- Request a new connection
447− tlog "Requesting connection"
448− let reqId = 0 :: Int32
449− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
450− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
451−
452− -- Close the connection again
453− tlog "Closing connection"
454− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
455−
456− -- Server will now send a CloseSocket request as its refcount reached 0
457− tlog "Waiting for CloseSocket request"
458− CloseSocket <- toEnum <$> recvInt32 sock
459−
460− unblocked <- newEmptyMVar
461−
462− -- We should not hear from the server until we unblock him by
463− -- responding to the CloseSocket request (in this case, we
464− -- respond by sending a ConnectionRequest)
465− forkTry $ do
466− recvInt32 sock :: IO Int32
467− isEmptyMVar unblocked >>= (guard . not)
468− putMVar clientDone ()
469−
470− threadDelay 1000000
471−
472− tlog "Client ignores close socket and sends connection request"
473− tlog "This should unblock the server"
474− putMVar unblocked ()
475− let reqId' = 1 :: Int32
476− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
477−
478−-- | Test what happens when a remote endpoint sends a connection request to our
479−-- transport for an endpoint it already has a connection to
480−testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()
481−testUnnecessaryConnect nextPort numThreads = do
482− clientDone <- newEmptyMVar
483− serverAddr <- newEmptyMVar
484−
485− forkTry $ do
486− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
487− Right endpoint <- newEndPoint transport
488− putMVar serverAddr (address endpoint)
489−
490− forkTry $ do
491− -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check
492− let ourAddress = EndPointAddress "126.0.0.1"
493−
494− -- We should only get a single 'Accepted' reply
495− gotAccepted <- newEmptyMVar
496− dones <- replicateM numThreads $ do
497− done <- newEmptyMVar
498− forkTry $ do
499− -- It is possible that the remote endpoint just rejects the request by closing the socket
500− -- immediately (depending on far the remote endpoint got with the initialization)
501− response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
502− case response of
503− Right (_, ConnectionRequestAccepted) ->
504− -- We don't close this socket because we want to keep this connection open
505− putMVar gotAccepted ()
506− -- We might get either Invalid or Crossed (the transport does not
507− -- maintain enough history to be able to tell)
508− Right (sock, ConnectionRequestInvalid) ->
509− N.sClose sock
510− Right (sock, ConnectionRequestCrossed) ->
511− N.sClose sock
512− Left _ ->
513− return ()
514− putMVar done ()
515− return done
516−
517− mapM_ readMVar (gotAccepted : dones)
518− putMVar clientDone ()
519−
520− takeMVar clientDone
521−
522−-- | Test that we can create "many" transport instances
523−testMany :: IO N.ServiceName -> IO ()
524−testMany nextPort = do
525− Right masterTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
526− Right masterEndPoint <- newEndPoint masterTransport
527−
528− replicateM_ 10 $ do
529− mTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
530− case mTransport of
531− Left ex -> do
532− putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)
533− case (ioe_errno ex) of
534− Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"
535− _ -> return ()
536− throwIO ex
537− Right transport ->
538− replicateM_ 2 $ do
539− Right endpoint <- newEndPoint transport
540− Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered defaultConnectHints
541− return ()
542−
543−-- | Test what happens when the transport breaks completely
544−testBreakTransport :: IO N.ServiceName -> IO ()
545−testBreakTransport nextPort = do
546− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
547− Right endpoint <- newEndPoint transport
548−
549− killThread (transportThread internals) -- Uh oh
550−
551− ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint
552−
553− return ()
554−
555−-- | Test that a second call to 'connect' might succeed even if the first
556−-- failed. This is a TCP specific test rather than an endpoint specific test
557−-- because we must manually create the endpoint address to match an endpoint we
558−-- have yet to set up.
559−-- Then test that we get a connection lost message after the remote endpoint
560−-- suddenly closes the socket, and that a subsequent 'connect' allows us to
561−-- re-establish a connection to the same endpoint
562−testReconnect :: IO N.ServiceName -> IO ()
563−testReconnect nextPort = do
564− serverPort <- nextPort
565− serverDone <- newEmptyMVar
566− firstAttempt <- newEmptyMVar
567− endpointCreated <- newEmptyMVar
568−
569− -- Server
570− forkTry $ do
571− -- Wait for the client to do its first attempt
572− readMVar firstAttempt
573−
574− counter <- newMVar (0 :: Int)
575−
576− forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
577− -- Accept the connection
578− Right 0 <- tryIO $ (recvInt32 sock :: IO Int)
579− Right _ <- tryIO $ recvWithLength sock
580− Right () <- tryIO $ sendMany sock [encodeInt32 ConnectionRequestAccepted]
581−
582− -- The first time we close the socket before accepting the logical connection
583− count <- modifyMVar counter $ \i -> return (i + 1, i)
584−
585− when (count > 0) $ do
586− -- Client requests a logical connection
587− Right RequestConnectionId <- tryIO $ toEnum <$> (recvInt32 sock :: IO Int)
588− Right reqId <- tryIO $ (recvInt32 sock :: IO Int)
589− Right () <- tryIO $ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
590− return ()
591−
592− when (count > 1) $ do
593− -- Client sends a message
594− Right 10001 <- tryIO $ (recvInt32 sock :: IO Int)
595− Right ["ping"] <- tryIO $ recvWithLength sock
596− putMVar serverDone ()
597−
598− Right () <- tryIO $ N.sClose sock
599− return ()
600−
601− putMVar endpointCreated ()
602−
603− -- Client
604− forkTry $ do
605− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
606− Right endpoint <- newEndPoint transport
607− let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
608−
609− -- The first attempt will fail because no endpoint is yet set up
610− -- Left (TransportError ConnectNotFound _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
611− putMVar firstAttempt ()
612−
613− -- The second attempt will fail because the server closes the socket before we can request a connection
614− takeMVar endpointCreated
615− -- This might time out or not, depending on whether the server closes the
616− -- socket before or after we can send the RequestConnectionId request
617− resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints
618− case resultConnect of
619− Nothing -> return ()
620− Just (Left (TransportError ConnectFailed _)) -> return ()
621− Just (Left err) -> throwIO err
622− Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
623−
624− -- The third attempt succeeds
625− Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
626−
627− -- But a send will fail because the server has closed the connection again
628− Left (TransportError SendFailed _) <- send conn1 ["ping"]
629− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
630−
631− -- But a subsequent call to connect should reestablish the connection
632− Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
633−
634− -- Send should now succeed
635− Right () <- send conn2 ["ping"]
636− return ()
637−
638− takeMVar serverDone
639−
640−-- Test what happens if we close the socket one way only. This means that the
641−-- 'recv' in 'handleIncomingMessages' will not fail, but a 'send' or 'connect'
642−-- *will* fail. We are testing that error handling everywhere does the right
643−-- thing.
644−testUnidirectionalError :: IO N.ServiceName -> IO ()
645−testUnidirectionalError nextPort = do
646− clientDone <- newEmptyMVar
647− serverPort <- nextPort
648− serverGotPing <- newEmptyMVar
649−
650− -- Server
651− forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
652− -- We accept connections, but when an exception occurs we don't do
653− -- anything (in particular, we don't close the socket). This is important
654− -- because when we shutdown one direction of the socket a recv here will
655− -- fail, but we don't want to close that socket at that point (which
656− -- would shutdown the socket in the other direction)
657− void . (try :: IO () -> IO (Either SomeException ())) $ do
658− 0 <- recvInt32 sock :: IO Int
659− _ <- recvWithLength sock
660− () <- sendMany sock [encodeInt32 ConnectionRequestAccepted]
661−
662− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
663− reqId <- recvInt32 sock :: IO Int
664− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
665−
666− 10001 <- recvInt32 sock :: IO Int
667− ["ping"] <- recvWithLength sock
668− putMVar serverGotPing ()
669−
670− -- Client
671− forkTry $ do
672− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
673− Right endpoint <- newEndPoint transport
674− let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
675−
676− -- Establish a connection to the server
677− Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
678− send conn1 ["ping"]
679− takeMVar serverGotPing
680−
681− -- Close the *outgoing* part of the socket only
682− sock <- socketBetween internals (address endpoint) theirAddr
683− N.shutdown sock N.ShutdownSend
684−
685− -- At this point we cannot notice the problem yet so we shouldn't receive an event yet
686− Nothing <- timeout 500000 $ receive endpoint
687−
688− -- But when we send we find the error
689− Left (TransportError SendFailed _) <- send conn1 ["ping"]
690− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
691−
692− -- A call to connect should now re-establish the connection
693− Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
694− send conn2 ["ping"]
695− takeMVar serverGotPing
696−
697− -- Again, close the outgoing part of the socket
698− sock' <- socketBetween internals (address endpoint) theirAddr
699− N.shutdown sock' N.ShutdownSend
700−
701− -- We now find the error when we attempt to close the connection
702− Nothing <- timeout 500000 $ receive endpoint
703− close conn2
704− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
705− Right conn3 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
706− send conn3 ["ping"]
707− takeMVar serverGotPing
708−
709− -- We repeat once more.
710− sock'' <- socketBetween internals (address endpoint) theirAddr
711− N.shutdown sock'' N.ShutdownSend
712−
713− -- Now we notice the problem when we try to connect
714− Nothing <- timeout 500000 $ receive endpoint
715− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
716− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
717− Right conn4 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
718− send conn4 ["ping"]
719− takeMVar serverGotPing
720−
721− putMVar clientDone ()
722−
723− takeMVar clientDone
724−
725−testInvalidCloseConnection :: IO N.ServiceName -> IO ()
726−testInvalidCloseConnection nextPort = do
727− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
728− serverAddr <- newEmptyMVar
729− clientDone <- newEmptyMVar
730− serverDone <- newEmptyMVar
731−
732− -- Server
733− forkTry $ do
734− Right endpoint <- newEndPoint transport
735− putMVar serverAddr (address endpoint)
736−
737− ConnectionOpened _ _ _ <- receive endpoint
738−
739− -- At this point the client sends an invalid request, so we terminate the
740− -- connection
741− ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint
742−
743− putMVar serverDone ()
744−
745− -- Client
746− forkTry $ do
747− Right endpoint <- newEndPoint transport
748− let ourAddr = address endpoint
749−
750− -- Connect so that we have a TCP connection
751− theirAddr <- readMVar serverAddr
752− Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
753−
754− -- Get a handle on the TCP connection and manually send an invalid CloseConnection request
755− sock <- socketBetween internals ourAddr theirAddr
756− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (12345 :: Int)]
757−
758− putMVar clientDone ()
759−
760− mapM_ takeMVar [clientDone, serverDone]
761−
762−main :: IO ()
763−main = do
764− portMVar <- newEmptyMVar
765− forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
766− let nextPort = takeMVar portMVar
767− tcpResult <- tryIO $ runTests
768− [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
769− , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
770− , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
771− , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)
772− , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort 10)
773− , ("InvalidAddress", testInvalidAddress nextPort)
774− , ("InvalidConnect", testInvalidConnect nextPort)
775− , ("Many", testMany nextPort)
776− , ("BreakTransport", testBreakTransport nextPort)
777− , ("Reconnect", testReconnect nextPort)
778− , ("UnidirectionalError", testUnidirectionalError nextPort)
779− , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)
780− ]
781− -- Run the generic tests even if the TCP specific tests failed..
782− testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)
783− -- ..but if the generic tests pass, still fail if the specific tests did not
784− case tcpResult of
785− Left err -> throwIO err
786− Right () -> return ()
network-transport-tcp/tests/TestTransport.hsdeleted−956

This diff is too big to show here.

network-transport-tcp/tests/Traced.hsdeleted−191

This diff is too big to show here.

network-transport/ChangeLogdeleted−3

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

This diff is too big to show here.

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

This diff is too big to show here.

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

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.

src/Control/Distributed/Process.hsnew file+447

This diff is too big to show here.

src/Control/Distributed/Process/Closure.hsnew file+244

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.

src/Control/Distributed/Process/Internal/Closure/BuiltIn.hsnew file+320

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