git.iko.soy/distributed-process
on master help sign in
swap
660d554825 ahead, 0 behind
139 files changed+14134−13563
since splitsnapshots
unifiedsplit
.gitignore+3−12 .travis.yml+43 CONTRIBUTING.md+1 ChangeLog+236 network-transport/LICENSE → LICENSE+1 README.md+11−24 azure-service-api/Setup.hs → Setup.hs azure-service-api/LICENSE−30 azure-service-api/azure-service-api.cabal−46 azure-service-api/src/Network/Azure/ServiceManagement.hs−119 azure-service-api/src/Network/Azure/ServiceManagement/CommandLine.hs−71 benchmarks/Channels.hs+43 benchmarks/Latency.hs+39 benchmarks/ProcessRing.hs+117 benchmarks/Spawns.hs+49 benchmarks/Throughput.hs+74 benchmarks/erlang/latency.erl+35 benchmarks/erlang/ring.erl+62 benchmarks/erlang/throughput.erl+39 benchmarks/remote/Latency.hs+32 benchmarks/remote/Throughput.hs+39 distributed-process-simplelocalnet/ChangeLog−15 distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal−63 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs−332 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-simplelocalnet/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−35 distributed-process/LICENSE−31 distributed-process/Setup.hs−2 distributed-process/distributed-process.cabal−138 distributed-process/src/Control/Distributed/Process/Closure.hs−322 distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs−105 distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs−330 distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hs−25 distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs−34 distributed-process/src/Control/Distributed/Process/Internal/Closure/Static.hs−190 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs−229 distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hs−112 distributed-process/src/Control/Distributed/Process/Internal/Node.hs−91 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−524 distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hs−33 distributed-process/src/Control/Distributed/Process/Internal/Types.hs−602 distributed-process/src/Control/Distributed/Process/Node.hs−722 distributed-process/tests/TestAuxiliary.hs−75 distributed-process/tests/TestCH.hs−622 distributed-process/tests/TestClosure.hs−332 doc/InternalsTransportMulticast.txt−181 doc/InternalsTransportTCP.txt−81 doc/NetworkTCP.png doc/NetworkTCP.svg−657 doc/reconnect/blacklist.tex−255 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 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-tcp/ChangeLog−12 network-transport-tcp/LICENSE−31 network-transport-tcp/Setup.hs−2 network-transport-tcp/network-transport-tcp.cabal−59 network-transport-tcp/src/Network/Transport/TCP.hs−1655 network-transport-tcp/src/Network/Transport/TCP/Internal.hs−119 network-transport-tcp/tests/TestAuxiliary.hs−111 network-transport-tcp/tests/TestTCP.hs−794 network-transport-tcp/tests/TestTransport.hs−964 network-transport-tcp/tests/Traced.hs−199 network-transport/ChangeLog−12 network-transport/Setup.hs−2 network-transport/network-transport.cabal−81 network-transport/src/Network/Transport.hs−226 network-transport/src/Network/Transport/Internal.hs−153 network-transport/src/Network/Transport/Util.hs−24 network-transport/tests/chat/ChatClient.hs−107 network-transport/tests/chat/ChatServer.hs−28 network-transport/tests/sumeuler/SumEulerMaster.hs−44 network-transport/tests/sumeuler/SumEulerWorker.hs−52 network-transport/tests/sumeuler/sumeuler.sh−20 distributed-process/src/Control/Distributed/Process.hs → src/Control/Distributed/Process.hs+236−174 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−12
@@ -1,13 +1,4 @@
1−tags
2−TAGS
31dist/
4−\#*#
5−*~
6−*.aux
7−*.hp
8−*.hi
9−*.o
10−*.prof
11−*.ps
12−*.swp
13−cabal-dev
2+.cabal-sandbox
3+cabal.sandbox.config
4+.stack*
.travis.ymlnew file+43
@@ -0,0 +1,43 @@
1+language: c
2+
3+sudo: false
4+
5+matrix:
6+ include:
7+ - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"
8+ addons: {apt: {packages: [libgmp-dev]}}
9+ - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"
10+ addons: {apt: {packages: [libgmp-dev]}}
11+ - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"
12+ addons: {apt: {packages: [libgmp-dev]}}
13+ - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"
14+ addons: {apt: {packages: [libgmp-dev]}}
15+
16+cache:
17+ directories:
18+ - $HOME/.stack
19+
20+before_install:
21+- export PATH=$HOME/.local/bin:$PATH;
22+ mkdir -p ~/.local/bin;
23+ travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';
24+ stack --version
25+
26+install:
27+- stack $ARGS setup --no-terminal;
28+ stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;
29+
30+script:
31+- export ARG='--test-arguments'
32+ export TEST_PACKAGE="distributed-process-tests:"
33+- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory
34+- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP
35+- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure
36+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats
37+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory
38+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP
39+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory
40+
41+notifications:
42+ slack:
43+ secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=
CONTRIBUTING.mdnew file+1
@@ -0,0 +1 @@
1+See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
ChangeLognew file+236
@@ -0,0 +1,236 @@
1+[Unrealeased]
2+
3+*
4+
5+2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4
6+
7+* Added support for exceptions >= 0.10
8+
9+2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3
10+
11+* Drop support for ghc-7.8.* and earlier.
12+
13+2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2
14+
15+* Fixed build errors with ghc-8.2.1.
16+
17+2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1
18+
19+* Relax upper bounds in dependencies to build with ghc-8.2.1.
20+
21+2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0
22+
23+* Change type of message sent by `say` from a 3-tuple to a proper
24+type (`SayMessage`) with a proper `UTCTime`. (#291)
25+* Expose the MonitorRef in the withMonitor call.
26+* Have unmonitor remove the monitor message in the inbox. (#268)
27+* Remove Mx Data Tables. This API isn't used, is easy to replace with various
28+other packages. (#276)
29+* Add Ord instance to SpawnRef.
30+
31+2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6
32+
33+* Remove monitors from remote nodes when a process dies. (#295)
34+
35+2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5
36+
37+* Use only one connection to communicate between NCs. (#296, #297)
38+* Improve documentation of CQueue.
39+* Implement bidirectional multimaps for links and monitors. (#293, #294)
40+* Fix various warnings. (#292)
41+* Fix some of the intermittent failures in tests.
42+* Improve error messages when node controllers receive invalid requests.
43+(#290)
44+
45+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4
46+
47+* Fixup build errors.
48+
49+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3
50+
51+* Relax template-haskell upper bound.
52+
53+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2
54+
55+* Provide compatibility with ghc-8.0.1
56+* Remove dependency on ghc-prim.
57+* Don't throw exceptions asynchronously.
58+* Bump upper bounds of dependencies.
59+* Fix exception handling in callLocal.
60+* Have spawnLocal inherit the masking state of the caller.
61+* Have nsend send unencoded messages to local processes.
62+
63+2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1
64+
65+* Implement MonadCatch, MonadThrow, MonadMask for Process.
66+
67+2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0
68+
69+* Have nsendRemote skip the transport for local communication.
70+* Unsafe primitives for usend and nsendRemote.
71+* Stop using the transport for local communication.
72+* Skip the transport for whereisRemoteAsync and registerRemoteAsync.
73+* Have nsendRemote skip the transport for local communication.
74+* Have runProcess forward exceptions.
75+* Reimport distributed-process-tests. d-p and d-p-test now can be kept in
76+sync.
77+* Add a stack.yaml file for building tests and d-p all at once conveniently.
78+* Implement unreliable forward (uforward).
79+* Add Functor instance for Match data type
80+* Have `spawnAsync` not use the transport in the local case.
81+* Fix monitor race in 'call'.
82+* Add compatibility with ghc-7.10: support new typeable, loosen deps, write
83+proper NFData instances, support new TH.
84+* Kill processes on a local node upon closeLocalNode.
85+* Fix getNodeStats function, see DP-97
86+* Return size of the queue in ProcessInfo.
87+* Implement unreliable send (usend).
88+* Implement MonadFix instance for Process.
89+* Introduce callLocal primitive.
90+* Prevent message loss due to timeouts in CQueue.
91+* More informative ProcessRegistrationException. Now includes the identifier
92+of the process that owns the name, if any.
93+* Avoid message loop between threads when tracing received messages.
94+
95+2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5
96+
97+* Fix dependencies.
98+* Add compatibility with GHC-7.10.
99+* Fix various race conditions (DP-99, DP-103).
100+
101+2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.5.2
102+
103+* Fix docstring for `register`
104+* Added Data instance to ProcessId, LocalProcessId and NodeId
105+* Add static serialiation dictionary for 'Static', for completeness
106+* Add Closure static serialization dictionary
107+* Replacement for modifyMVarMasked for GHC <= 7.4
108+* Document the use of built-in trace flags
109+* Make forkProcess exception-safe
110+* Make -Wall clean
111+
112+2014-08-13 Tim Watson <watson.timothy@gmail.com> 0.5.1
113+
114+* Fix cabal docs (thanks Markus Barenhoff)
115+* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)
116+
117+2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.5.0
118+
119+* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file
120+* Race condition in local monitoring when using call
121+* mask now works correctly if unmask is called by another process
122+* Improve efficiency of local message passing
123+* nsend uses local communication channels
124+* Link Node Controller and Network Listener
125+* Label spawned processes using labelThread
126+* Relaxed upper bound on syb in the cabal manifest
127+* Bump binary version to include 0.7.*
128+* Exposed process info
129+* Exposed node statistics
130+* Moved tests to https://github.com/haskell-distributed/distributed-process-tests
131+* Added "polymorphic expect"
132+* Exposed Message type and broaden scope of polymorphic expect
133+* Added Management API (for working with internal/system events)
134+* Tracing can no longer be disabled
135+* We now report node statistics for monitoring/management
136+* Node.runProcess now propagates exceptions to its caller
137+* Added simple micro benchmarks
138+
139+2013-01-27 Tim Watson <watson.timothy@gmail.com> 0.4.2
140+
141+* Improved exception handling for deferred type checked exit reasons
142+* Add matchChan primitive (thanks Simon Marlow)
143+* Expose deferred message handling/checking for AbstractMessage
144+* Add `getProcessInfo' API
145+* Add `trace' API backed by the GHC eventlog
146+
147+2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.4.1
148+
149+* Make behaviour of 'register' more Erlang-like (register will now fail if the
150+name is already registered). Patch by Jeff Epstein.
151+* Functor, Applicative, Alternative and Monad instances for ReceivePort
152+* Add support for receiveChanTimeout
153+* Improved documentation
154+* Avoid name clashes in the TH generation for closures
155+* Relax package bounds to allow for Binary 0.6
156+
157+2012-10-23 Edsko de Vries <edsko@well-typed.com> 0.4.0.2
158+
159+* Fix race condition in spawn
160+
161+2012-10-04 Edsko de Vries <edsko@well-typed.com> 0.4.0.1
162+
163+* Relax package boundaries
164+
165+2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.4.0
166+
167+* Improved treatment of network failure, using new failure semantics of
168+Network.Transport.
169+* Make NodeId Typeable
170+* Extend Template Haskell support with "remotableDec" so that you can refer to
171+$(mkClosure 'f) within the body of "f".
172+* Fix bug in spawnChannelLocal
173+* Numerous memory leaks plugged
174+* Relax upper bound on dependency on 'network'
175+* New primitive 'matchAny'
176+* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync')
177+
178+2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1
179+
180+* Fix memory leaks
181+* Make Template Haskell support optional
182+* Relax dependency constraints
183+
184+2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0
185+
186+* Extract 'static' into a separate package (C.D.Static)
187+* Use new package rank1dynamic to proper runtime checks for polymorphic values
188+
189+2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0
190+
191+* Expose the constructors of Closure
192+* Add instance (Typeable a => Serializable (Static a)) and make sure we only
193+use the internal representation of Static where really necessary
194+* Improved docs
195+
196+2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0
197+
198+* Add exception handling primitives
199+* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on
200+MVar' exception would be thrown.
201+
202+2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
203+
204+* Bugfix in the node controller
205+(one way this bug materialized: when using the SimpleLocalnet backend,
206+slave nodes could not be reused)
207+* Improved documentation in Control.Distributed.Process.Closure
208+
209+2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
210+
211+* Improve docs
212+* Local versions of spawn
213+
214+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
215+
216+* Base 4.6 compatibility
217+* Relax constraints on bytestring and containers
218+
219+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1
220+
221+* Relax upper bound on 'time' dependency
222+
223+2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1
224+
225+* Complete redesign of the underlying implementation of static values and
226+closures.
227+
228+* Add support for 'spawnChannel'
229+
230+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
231+
232+* Bugfix: Continue processing messages when a connection breaks.
233+
234+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
235+
236+* Initial release.
network-transport/LICENSE → LICENSErenamed+1
@@ -1,4 +1,5 @@
11Copyright Well-Typed LLP, 2011-2012
2+Copyright Tweag I/O Limited, 2015
23
34All rights reserved.
45
README.md+11−24
@@ -1,29 +1,16 @@
1−Haskell Distributed Project
2−===========================
1+# distributed-process
2+[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)
3+[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)
34
4−This repository holds an implementation of [Cloud Haskell][1].
5+This repository is part of Cloud Haskell.
56
6−At present, this repository hosts
7+See http://haskell-distributed.github.com for documentation, user guides,
8+tutorials and assistance.
79
8−* network-transport
9−* network-transport-tcp
10−* network-transport-inmemory (incomplete)
11−* distributed-process
12−* distributed-process-simplelocalnet
13−* azure-service-api (skeleton only)
10+## Getting Help / Raising Issues
1411
15−For more detailed information about the interfaces provided by these packages,
16−please refer to the [distributed-process repository wiki][2]. People who wish
17−to get started with Cloud Haskell should cabal install
18−distributed-process and possibly distributed-process-simplelocalnet and refer
19−to the corresponding Haddock documentation ([Control.Distributed.Process][3],
20−[Control.Distributed.Process.Closure][4],
21−[Control.Distributed.Process.Node][5], and
22−[Control.Distributed.Process.Backend.SimpleLocalnet][6]).
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.
2313
24−[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
25−[2]: https://github.com/haskell-distributed/distributed-process/wiki
26−[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html
27−[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html
28−[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html
29−[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html
14+## License
15+
16+This package is made available under a 3-clause BSD-style license.
azure-service-api/Setup.hs → Setup.hsrenamed

The content is the same.

azure-service-api/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2012, Edsko de Vries
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Edsko de Vries nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
azure-service-api/azure-service-api.cabaldeleted−46
@@ -1,46 +0,0 @@
1−-- Initial azure-service-api.cabal generated by cabal init. For further
2−-- documentation, see http://haskell.org/cabal/users-guide/
3−
4−Name: azure-service-api
5−Version: 0.1.0.0
6−Synopsis: Haskell bindings for the Azure Service Management API
7−-- description:
8−Homepage: github.com/haskell-distributed/azure-service-api
9−License: BSD3
10−License-File: LICENSE
11−Author: Edsko de Vries
12−Maintainer: edsko@well-typed.com
13−Copyright: Well-Typed LLP
14−Category: Network
15−Build-Type: Simple
16−Cabal-Version: >=1.8
17−
18−Library
19− Exposed-Modules: Network.Azure.ServiceManagement
20− Build-Depends: base ==4.5.*,
21− http-conduit >= 1.5.1 && < 1.6,
22− tls >= 1.0 && < 1.1,
23− tls-extra >= 0.5 && < 0.6,
24− bytestring >= 0.9 && < 1.0,
25− certificate >= 1.2 && < 1.3,
26− case-insensitive >= 0.4 && < 0.5,
27− hxt >= 9.2 && < 9.3
28− HS-Source-Dirs: src
29− ghc-options: -Wall
30−
31−Executable hs-azure-service-api
32− Main-Is: src/Network/Azure/ServiceManagement/CommandLine.hs
33− Build-Depends: base ==4.5.*,
34− http-conduit >= 1.5.1 && < 1.6,
35− tls >= 1.0 && < 1.1,
36− tls-extra >= 0.5 && < 0.6,
37− bytestring >= 0.9 && < 1.0,
38− certificate >= 1.2 && < 1.3,
39− case-insensitive >= 0.4 && < 0.5,
40− utf8-string >= 0.3 && < 0.4,
41− filepath >= 1.3 && < 1.4,
42− azure-service-api >= 0.1 && < 0.2,
43− hxt,
44− libssh2
45− Extensions: ScopedTypeVariables
46− ghc-options: -Wall -rtsopts
azure-service-api/src/Network/Azure/ServiceManagement.hsdeleted−119
@@ -1,119 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−module Network.Azure.ServiceManagement
3− ( -- * Setup
4− AzureSetup(..)
5− , azureSetup
6− -- * High-level API
7− , hostedServices
8− -- * Low-level API
9− , azureRequest
10− , azureRawRequest
11− ) where
12−
13−import Prelude hiding (id)
14−import Control.Category (id, (>>>))
15−import Data.ByteString.Lazy (ByteString)
16−import Data.ByteString.Char8 as BSC (pack)
17−import Data.ByteString.Lazy.Char8 as BSLC (unpack)
18−import Network.TLS (PrivateKey)
19−import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
20−import Data.Certificate.X509 (X509)
21−import Network.HTTP.Conduit
22− ( parseUrl
23− , clientCertificates
24− , requestHeaders
25− , withManager
26− , Response(Response)
27− , httpLbs
28− )
29−import Data.CaseInsensitive as CI (mk)
30−import Text.XML.HXT.Core
31− ( runX
32− , readString
33− , withValidate
34− , no
35− , XmlTree
36− , IOSArrow
37− , XNode
38− , ArrowXml
39− , deep
40− , hasName
41− , getText
42− )
43−
44−--------------------------------------------------------------------------------
45−-- Setup --
46−--------------------------------------------------------------------------------
47−
48−-- | Azure setup
49−data AzureSetup = AzureSetup
50− { subscriptionId :: String
51− , certificate :: X509
52− , privateKey :: PrivateKey
53− , baseURL :: String
54− }
55−
56−-- | Initialize Azure
57−azureSetup :: String -- ^ Subscription ID
58− -> String -- ^ Path to certificate
59− -> String -- ^ Path to private key
60− -> IO AzureSetup
61−azureSetup sid certPath pkeyPath = do
62− cert <- fileReadCertificate certPath
63− pkey <- fileReadPrivateKey pkeyPath
64− return AzureSetup {
65− subscriptionId = sid
66− , certificate = cert
67− , privateKey = pkey
68− , baseURL = "https://management.core.windows.net"
69− }
70−
71−--------------------------------------------------------------------------------
72−-- High-level API --
73−--------------------------------------------------------------------------------
74−
75−hostedServices :: AzureSetup -> IO [(String, String)]
76−hostedServices setup =
77− azureRequest setup "/services/hostedservices" "2012-03-01" $ proc xml -> do
78− hostedService <- deep (hasName "HostedService") -< xml
79− url <- getTextNode "Url" -< hostedService
80− serviceName <- getTextNode "ServiceName" -< hostedService
81− id -< (url, serviceName)
82−
83−--------------------------------------------------------------------------------
84−-- Low-level API --
85−--------------------------------------------------------------------------------
86−
87−-- | Execute an Azure request and parse the XML data
88−azureRequest :: AzureSetup
89− -> String
90− -> String
91− -> IOSArrow XmlTree c
92− -> IO [c]
93−azureRequest setup subURL version f = do
94− raw <- azureRawRequest setup subURL version
95− runX $ readString [withValidate no] (BSLC.unpack raw) >>> f
96−
97−-- | Execute an Azure request and return the raw data
98−azureRawRequest :: AzureSetup
99− -> String -- ^ Relative path
100− -> String -- ^ Version
101− -> IO ByteString
102−azureRawRequest setup subURL version = do
103− req <- parseUrl $ baseURL setup ++ "/" ++ subscriptionId setup ++ "/" ++ subURL
104− withManager $ \manager -> do
105− let req' = req {
106− clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
107− , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack version)
108− , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
109− ]
110− }
111− Response _ _ _ lbs <- httpLbs req' manager
112− return lbs
113−
114−--------------------------------------------------------------------------------
115−-- XML convenience functions --
116−--------------------------------------------------------------------------------
117−
118−getTextNode :: ArrowXml a => String -> a XmlTree String
119−getTextNode node = deep (hasName node) >>> deep getText
azure-service-api/src/Network/Azure/ServiceManagement/CommandLine.hsdeleted−71
@@ -1,71 +0,0 @@
1−-- Base
2−import System.Environment (getArgs, getEnv)
3−import System.FilePath ((</>))
4−import System.Posix.Types (Fd)
5−
6−-- SSL
7−import Network.Azure.ServiceManagement
8− ( azureSetup
9− , hostedServices
10− )
11−
12−-- SSH
13−import Network.SSH.Client.LibSSH2
14− ( withSSH2
15− , readAllChannel
16− , retryIfNeeded
17− , Session
18− , Channel
19− )
20−import Network.SSH.Client.LibSSH2.Foreign
21− ( initialize
22− , exit
23− , channelExecute
24− )
25−import Codec.Binary.UTF8.String (decodeString)
26−
27−main :: IO ()
28−main = do
29− args <- getArgs
30− case args of
31− ["azure", subscriptionId, pathToCert, pathToKey] ->
32− tryConnectToAzure subscriptionId pathToCert pathToKey
33− ["command", user, host, port, cmd] ->
34− runCommand user host (read port) cmd
35− _ ->
36− putStrLn "Invalid command line arguments"
37−
38−--------------------------------------------------------------------------------
39−-- Taken from libssh2/ssh-client --
40−--------------------------------------------------------------------------------
41−
42−runCommand :: String -> String -> Int -> String -> IO ()
43−runCommand login host port command =
44− ssh login host port $ \fd s ch -> do
45− _ <- retryIfNeeded fd s $ channelExecute ch command
46− result <- readAllChannel fd ch
47− let r = decodeString result
48− print (length result)
49− print (length r)
50− putStrLn r
51−
52−ssh :: String -> String -> Int -> (Fd -> Session -> Channel -> IO a) -> IO ()
53−ssh login host port actions = do
54− _ <- initialize True
55− home <- getEnv "HOME"
56− let known_hosts = home </> ".ssh" </> "known_hosts"
57− public = home </> ".ssh" </> "id_rsa.pub"
58− private = home </> ".ssh" </> "id_rsa"
59− _ <- withSSH2 known_hosts public private login host port $ actions
60− exit
61−
62−--------------------------------------------------------------------------------
63−-- Taken from tls-debug/src/SimpleClient.hs --
64−--------------------------------------------------------------------------------
65−
66−tryConnectToAzure :: String -> String -> String -> IO ()
67−tryConnectToAzure sid pathToCert pathToKey = do
68− setup <- azureSetup sid pathToCert pathToKey
69− services <- hostedServices setup
70− mapM_ print services
71−
benchmarks/Channels.hsnew file+43
@@ -0,0 +1,43 @@
1+-- | Like Latency, but creating lots of channels
2+import System.Environment
3+import Control.Monad
4+import Control.Applicative
5+import Control.Distributed.Process
6+import Control.Distributed.Process.Node
7+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
8+import Data.Binary (encode, decode)
9+import qualified Data.ByteString.Lazy as BSL
10+
11+pingServer :: Process ()
12+pingServer = forever $ do
13+ them <- expect
14+ sendChan them ()
15+ -- TODO: should this be automatic?
16+ reconnectPort them
17+
18+pingClient :: Int -> ProcessId -> Process ()
19+pingClient n them = do
20+ replicateM_ n $ do
21+ (sc, rc) <- newChan :: Process (SendPort (), ReceivePort ())
22+ send them sc
23+ receiveChan rc
24+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
25+
26+initialProcess :: String -> Process ()
27+initialProcess "SERVER" = do
28+ us <- getSelfPid
29+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
30+ pingServer
31+initialProcess "CLIENT" = do
32+ n <- liftIO $ getLine
33+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
34+ pingClient (read n) them
35+
36+main :: IO ()
37+main = do
38+ [role, host, port] <- getArgs
39+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
40+ case trans of
41+ Right transport -> do node <- newLocalNode transport initRemoteTable
42+ runProcess node $ initialProcess role
43+ Left other -> error $ show other
benchmarks/Latency.hsnew file+39
@@ -0,0 +1,39 @@
1+import System.Environment
2+import Control.Monad
3+import Control.Applicative
4+import Control.Distributed.Process
5+import Control.Distributed.Process.Node
6+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
7+import Data.Binary (encode, decode)
8+import qualified Data.ByteString.Lazy as BSL
9+
10+pingServer :: Process ()
11+pingServer = forever $ do
12+ them <- expect
13+ send them ()
14+
15+pingClient :: Int -> ProcessId -> Process ()
16+pingClient n them = do
17+ us <- getSelfPid
18+ replicateM_ n $ send them us >> (expect :: Process ())
19+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20+
21+initialProcess :: String -> Process ()
22+initialProcess "SERVER" = do
23+ us <- getSelfPid
24+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25+ pingServer
26+initialProcess "CLIENT" = do
27+ n <- liftIO $ getLine
28+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29+ pingClient (read n) them
30+
31+main :: IO ()
32+main = do
33+ [role, host, port] <- getArgs
34+ trans <- createTransport
35+ (defaultTCPAddr host port) defaultTCPParameters
36+ case trans of
37+ Right transport -> do node <- newLocalNode transport initRemoteTable
38+ runProcess node $ initialProcess role
39+ Left other -> error $ show other
benchmarks/ProcessRing.hsnew file+117
@@ -0,0 +1,117 @@
1+{- ProcessRing benchmarks.
2+
3+To run the benchmarks, select a value for the ring size (sz) and
4+the number of times to send a message around the ring
5+
6+-}
7+
8+{-# LANGUAGE BangPatterns #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+
11+import Control.Monad
12+import Control.Distributed.Process hiding (catch)
13+import Control.Distributed.Process.Node
14+import Control.Exception (catch, SomeException)
15+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
16+import System.Environment
17+import System.Console.GetOpt
18+
19+data Options = Options
20+ { optRingSize :: Int
21+ , optIterations :: Int
22+ , optForward :: Bool
23+ , optParallel :: Bool
24+ , optUnsafe :: Bool
25+ } deriving Show
26+
27+initialProcess :: Options -> Process ()
28+initialProcess op =
29+ let ringSz = optRingSize op
30+ msgCnt = optIterations op
31+ fwd = optForward op
32+ unsafe = optUnsafe op
33+ msg = ("foobar", "baz")
34+ in do
35+ self <- getSelfPid
36+ ring <- makeRing fwd unsafe ringSz self
37+ forM_ [1..msgCnt] (\_ -> send ring msg)
38+ collect msgCnt
39+ where relay fsend pid = do
40+ msg <- expect :: Process (String, String)
41+ fsend pid msg
42+ relay fsend pid
43+
44+ forward' pid =
45+ receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid
46+
47+ makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId
48+ makeRing !f !u !n !pid
49+ | n == 0 = go f u pid
50+ | otherwise = go f u pid >>= makeRing f u (n - 1)
51+
52+ go :: Bool -> Bool -> ProcessId -> Process ProcessId
53+ go False False next = spawnLocal $ relay send next
54+ go False True next = spawnLocal $ relay unsafeSend next
55+ go True _ next = spawnLocal $ forward' next
56+
57+ collect :: Int -> Process ()
58+ collect !n
59+ | n == 0 = return ()
60+ | otherwise = do
61+ receiveWait [
62+ matchIf (\(a, b) -> a == "foobar" && b == "baz")
63+ (\_ -> return ())
64+ , matchAny (\_ -> error "unexpected input!")
65+ ]
66+ collect (n - 1)
67+
68+defaultOptions :: Options
69+defaultOptions = Options
70+ { optRingSize = 10
71+ , optIterations = 100
72+ , optForward = False
73+ , optParallel = False
74+ , optUnsafe = False
75+ }
76+
77+options :: [OptDescr (Options -> Options)]
78+options =
79+ [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"
80+ , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"
81+ , Option ['f'] ["forward"]
82+ (NoArg (\opts -> opts { optForward = True }))
83+ "use `forward' instead of send - default = False"
84+ , Option ['u'] ["unsafe-send"]
85+ (NoArg (\opts -> opts { optUnsafe = True }))
86+ "use 'unsafeSend' (ignored with -f) - default = False"
87+ , Option ['p'] ["parallel"]
88+ (NoArg (\opts -> opts { optParallel = True }))
89+ "send in parallel and consume sequentially - default = False"
90+ ]
91+
92+optMsgCnt :: Maybe String -> Options -> Options
93+optMsgCnt Nothing opts = opts
94+optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }
95+
96+optSz :: Maybe String -> Options -> Options
97+optSz Nothing opts = opts
98+optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }
99+
100+parseArgv :: [String] -> IO (Options, [String])
101+parseArgv argv = do
102+ pn <- getProgName
103+ case getOpt Permute options argv of
104+ (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
105+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))
106+ where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"
107+
108+main :: IO ()
109+main = do
110+ argv <- getArgs
111+ (opt, _) <- parseArgv argv
112+ putStrLn $ "options: " ++ (show opt)
113+ Right transport <- createTransport
114+ (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters
115+ node <- newLocalNode transport initRemoteTable
116+ catch (void $ runProcess node $ initialProcess opt)
117+ (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
benchmarks/Spawns.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+-- | Like Throughput, but send every ping from a different process
4+-- (i.e., require a lightweight connection per ping)
5+import System.Environment
6+import Control.Monad
7+import Control.Applicative
8+import Control.Distributed.Process
9+import Control.Distributed.Process.Node
10+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
11+import Data.Binary (encode, decode)
12+import qualified Data.ByteString.Lazy as BSL
13+
14+counter :: Process ()
15+counter = go 0
16+ where
17+ go :: Int -> Process ()
18+ go !n = do
19+ b <- expect
20+ case b of
21+ Nothing -> go (n + 1)
22+ Just them -> send them n >> go 0
23+
24+count :: Int -> ProcessId -> Process ()
25+count n them = do
26+ us <- getSelfPid
27+ replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)
28+ send them (Just us)
29+ n' <- expect
30+ liftIO $ print (n == n')
31+
32+initialProcess :: String -> Process ()
33+initialProcess "SERVER" = do
34+ us <- getSelfPid
35+ liftIO $ BSL.writeFile "counter.pid" (encode us)
36+ counter
37+initialProcess "CLIENT" = do
38+ n <- liftIO $ getLine
39+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
40+ count (read n) them
41+
42+main :: IO ()
43+main = do
44+ [role, host, port] <- getArgs
45+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
46+ case trans of
47+ Right transport -> do node <- newLocalNode transport initRemoteTable
48+ runProcess node $ initialProcess role
49+ Left other -> error $ show other
benchmarks/Throughput.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+
4+import System.Environment
5+import Control.Monad
6+import Control.Applicative
7+import Control.Distributed.Process
8+import Control.Distributed.Process.Node
9+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)
10+import Data.Binary
11+import qualified Data.ByteString.Lazy as BSL
12+import Data.Typeable
13+
14+data SizedList a = SizedList { size :: Int , elems :: [a] }
15+ deriving (Typeable)
16+
17+instance Binary a => Binary (SizedList a) where
18+ put (SizedList sz xs) = put sz >> mapM_ put xs
19+ get = do
20+ sz <- get
21+ xs <- getMany sz
22+ return (SizedList sz xs)
23+
24+-- Copied from Data.Binary
25+getMany :: Binary a => Int -> Get [a]
26+getMany = go []
27+ where
28+ go xs 0 = return $! reverse xs
29+ go xs i = do x <- get
30+ x `seq` go (x:xs) (i-1)
31+{-# INLINE getMany #-}
32+
33+nats :: Int -> SizedList Int
34+nats = \n -> SizedList n (aux n)
35+ where
36+ aux 0 = []
37+ aux n = n : aux (n - 1)
38+
39+counter :: Process ()
40+counter = go 0
41+ where
42+ go :: Int -> Process ()
43+ go !n =
44+ receiveWait
45+ [ match $ \xs -> go (n + size (xs :: SizedList Int))
46+ , match $ \them -> send them n >> go 0
47+ ]
48+
49+count :: (Int, Int) -> ProcessId -> Process ()
50+count (packets, sz) them = do
51+ us <- getSelfPid
52+ replicateM_ packets $ send them (nats sz)
53+ send them us
54+ n' <- expect
55+ liftIO $ print (packets * sz, n' == packets * sz)
56+
57+initialProcess :: String -> Process ()
58+initialProcess "SERVER" = do
59+ us <- getSelfPid
60+ liftIO $ BSL.writeFile "counter.pid" (encode us)
61+ counter
62+initialProcess "CLIENT" = do
63+ n <- liftIO getLine
64+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
65+ count (read n) them
66+
67+main :: IO ()
68+main = do
69+ [role, host, port] <- getArgs
70+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
71+ case trans of
72+ Right transport -> do node <- newLocalNode transport initRemoteTable
73+ runProcess node $ initialProcess role
74+ Left other -> error $ show other
benchmarks/erlang/latency.erlnew file+35
@@ -0,0 +1,35 @@
1+-module(latency).
2+
3+-export([server/0, client/2, start_server/0, start_client/2]).
4+
5+forever(What) ->
6+ What(),
7+ forever(What).
8+
9+replicate(0, _) ->
10+ ok;
11+replicate(N, What) ->
12+ What(),
13+ replicate(N - 1, What).
14+
15+server() ->
16+ forever(fun () ->
17+ receive
18+ Them -> Them ! pong
19+ end
20+ end).
21+
22+client(N, Them) ->
23+ replicate(N, fun() ->
24+ {pingServer, Them} ! self(),
25+ receive
26+ pong -> ok
27+ end
28+ end),
29+ io:format("Did ~B pings", [N]).
30+
31+start_server() ->
32+ register(pingServer, spawn(latency, server, [])).
33+
34+start_client(N, Them) ->
35+ client(N, Them).
benchmarks/erlang/ring.erlnew file+62
@@ -0,0 +1,62 @@
1+%% can be run via escript if desired...
2+-module(ring).
3+
4+-export([main/1]).
5+
6+-record(opts, {
7+ ring_size = 1 :: non_neg_integer(),
8+ iterations = 1 :: non_neg_integer()
9+}).
10+
11+main(Argv) when is_list(Argv) ->
12+ Opts = parse_args(Argv),
13+ {Time, ok} = timer:tc(fun() -> run(Opts) end),
14+ io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).
15+
16+run(#opts{ ring_size=RingSize, iterations=SendCount }) ->
17+ Self = self(),
18+ Msg = {"foobar", "baz"},
19+ Pid = make_ring(RingSize, Self),
20+ [Pid ! Msg || _ <- lists:seq(1, SendCount)],
21+ collect(SendCount).
22+
23+collect(0) ->
24+ ok;
25+collect(N) ->
26+ receive
27+ {"foobar", "baz"} -> collect(N - 1);
28+ Other -> exit({unexpected_message, Other})
29+ end.
30+
31+-spec(make_ring(integer(), pid()) -> pid()).
32+make_ring(0, NextPid) ->
33+ go(NextPid);
34+make_ring(NumProcs, NextPid) ->
35+ make_ring(NumProcs - 1, go(NextPid)).
36+
37+-spec(go(pid()) -> pid()).
38+go(NextPid) ->
39+ spawn(fun() -> relay(NextPid) end).
40+
41+-spec(relay(pid()) -> no_return()).
42+relay(NextPid) ->
43+ receive
44+ {_, _}=Msg -> NextPid ! Msg, relay(NextPid)
45+ end.
46+
47+-spec(parse_args([string()]) -> #opts{}).
48+parse_args(Argv) ->
49+ lists:foldl(fun parse_args/2, #opts{}, Argv).
50+
51+parse_args(("-r" ++ Val), Opts) ->
52+ Sz = check_positive(ring_size, list_to_integer(Val)),
53+ Opts#opts{ ring_size = Sz };
54+parse_args(("-i" ++ Val), Opts) ->
55+ Iter = check_positive(iterations, list_to_integer(Val)),
56+ Opts#opts{ iterations = Iter }.
57+
58+check_positive(K, N) when N < 1 ->
59+ io:format("~p must be >= 1~n", [K]),
60+ error({K, N});
61+check_positive(_, N) ->
62+ N.
benchmarks/erlang/throughput.erlnew file+39
@@ -0,0 +1,39 @@
1+-module(throughput).
2+
3+-export([start_counter/0, start_count/3, counter/0, count/3, nats/1]).
4+
5+nats(0) ->
6+ [];
7+nats(N) ->
8+ [N | nats(N - 1)].
9+
10+counter() ->
11+ counter(0).
12+
13+counter(N) ->
14+ receive
15+ {count, List} ->
16+ counter(N + length(List));
17+ {get, Them} ->
18+ Them ! N,
19+ counter(0)
20+ end.
21+
22+replicate(0, _) ->
23+ ok;
24+replicate(N, What) ->
25+ What(),
26+ replicate(N - 1, What).
27+
28+count(Packets, Size, Them) ->
29+ replicate(Packets, fun() -> {counter, Them} ! {count, nats(Size)} end),
30+ {counter, Them} ! {get, self()},
31+ receive
32+ N -> io:format("Did ~B pings", [N])
33+ end.
34+
35+start_counter() ->
36+ register(counter, spawn(throughput, counter, [])).
37+
38+start_count(Packets, Size, Them) ->
39+ count(Packets, Size, Them).
benchmarks/remote/Latency.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2+
3+import Control.Monad
4+import Control.Applicative
5+import Control.Monad.IO.Class (liftIO)
6+import qualified Data.ByteString.Lazy as BSL
7+import Data.Binary (encode, decode)
8+import Remote
9+
10+pingServer :: ProcessM ()
11+pingServer = forever $ do
12+ them <- expect
13+ send them ()
14+
15+pingClient :: Int -> ProcessId -> ProcessM ()
16+pingClient n them = do
17+ us <- getSelfPid
18+ replicateM_ n $ send them us >> (expect :: ProcessM ())
19+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20+
21+initialProcess :: String -> ProcessM ()
22+initialProcess "SERVER" = do
23+ us <- getSelfPid
24+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25+ pingServer
26+initialProcess "CLIENT" = do
27+ n <- liftIO $ getLine
28+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29+ pingClient (read n) them
30+
31+main :: IO ()
32+main = remoteInit (Just "config") [] initialProcess
benchmarks/remote/Throughput.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2+
3+import Control.Monad
4+import Control.Applicative
5+import Control.Monad.IO.Class (liftIO)
6+import qualified Data.ByteString.Lazy as BSL
7+import Data.Binary (encode, decode)
8+import Remote
9+
10+counter :: ProcessM ()
11+counter = go 0
12+ where
13+ go :: Int -> ProcessM ()
14+ go !n = do
15+ b <- expect
16+ case b of
17+ Nothing -> go (n + 1)
18+ Just them -> send them n >> go 0
19+
20+count :: Int -> ProcessId -> ProcessM ()
21+count n them = do
22+ us <- getSelfPid
23+ replicateM_ n $ send them (Nothing :: Maybe ProcessId)
24+ send them (Just us)
25+ n' <- expect
26+ liftIO $ print (n == n')
27+
28+initialProcess :: String -> ProcessM ()
29+initialProcess "SERVER" = do
30+ us <- getSelfPid
31+ liftIO $ BSL.writeFile "counter.pid" (encode us)
32+ counter
33+initialProcess "CLIENT" = do
34+ n <- liftIO $ getLine
35+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
36+ count (read n) them
37+
38+main :: IO ()
39+main = remoteInit (Just "config") [] initialProcess
distributed-process-simplelocalnet/ChangeLogdeleted−15
@@ -1,15 +0,0 @@
1−2012-07-17 Edsko de Vries <edsko@well-typed.com> 0.2.0.3
2−
3−* Improve documentation
4−
5−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2
6−
7−* Relax contraints on bytestring and containers
8−
9−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
10−
11−* Bugfix: Documentation referred to old module name
12−
13−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
14−
15−* Initial release.
distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabaldeleted−63
@@ -1,63 +0,0 @@
1−Name: distributed-process-simplelocalnet
2−Version: 0.2.0.3
3−Cabal-Version: >=1.8
4−Build-Type: Simple
5−License: BSD3
6−License-File: LICENSE
7−Copyright: Well-Typed LLP
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10−Stability: experimental
11−Homepage: http://github.com/haskell-distributed/distributed-process
12−Bug-Reports: mailto:edsko@well-typed.com
13−Synopsis: Simple zero-configuration backend for Cloud Haskell
14−Description: Simple backend based on the TCP transport which offers node
15− discovery based on UDP multicast. This is a zero-configuration
16− backend designed to get you going with Cloud Haskell quickly
17− without imposing any structure on your application.
18−Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
19−Category: Control
20−
21−Source-Repository head
22− Type: git
23− Location: https://github.com/haskell-distributed/distributed-process
24− SubDir: distributed-process-simplelocalnet
25−
26−Library
27− Build-Depends: base >= 4.4 && < 5,
28− bytestring >= 0.9 && < 0.11,
29− network >= 2.3 && < 2.4,
30− network-multicast >= 0.0 && < 0.1,
31− data-accessor >= 0.2 && < 0.3,
32− binary >= 0.5 && < 0.6,
33− containers >= 0.4 && < 0.6,
34− transformers >= 0.2 && < 0.4,
35− network-transport >= 0.2 && < 0.3,
36− network-transport-tcp >= 0.2 && < 0.3,
37− distributed-process >= 0.2 && < 0.3
38− Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet,
39− Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast
40− Extensions: RankNTypes,
41− DeriveDataTypeable
42− ghc-options: -Wall
43− HS-Source-Dirs: src
44−
45−-- Not a proper test, but we want to use cabal to compile it
46−Test-Suite TestSimpleLocalnet
47− Type: exitcode-stdio-1.0
48− Main-Is: TestSimpleLocalnet.hs
49− Build-Depends: base >= 4.4 && < 5,
50− bytestring >= 0.9 && < 0.11,
51− network >= 2.3 && < 2.4,
52− network-multicast >= 0.0 && < 0.1,
53− data-accessor >= 0.2 && < 0.3,
54− binary >= 0.5 && < 0.6,
55− containers >= 0.4 && < 0.6,
56− transformers >= 0.2 && < 0.4,
57− network-transport >= 0.2 && < 0.3,
58− network-transport-tcp >= 0.2 && < 0.3,
59− distributed-process >= 0.2 && < 0.3
60− Extensions: RankNTypes,
61− DeriveDataTypeable
62− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
63− HS-Source-Dirs: tests src
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hsdeleted−332
@@ -1,332 +0,0 @@
1−-- | Simple backend based on the TCP transport which offers node discovery
2−-- based on UDP multicast. This is a zero-configuration backend designed to
3−-- get you going with Cloud Haskell quickly without imposing any structure
4−-- on your application.
5−--
6−-- To simplify getting started we provide special support for /master/ and
7−-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions
8−-- is completely optional; you can use the local backend without making use
9−-- of the predefined master and slave nodes.
10−--
11−-- [Minimal example]
12−--
13−-- > import System.Environment (getArgs)
14−-- > import Control.Distributed.Process
15−-- > import Control.Distributed.Process.Node (initRemoteTable)
16−-- > import Control.Distributed.Process.Backend.SimpleLocalnet
17−-- >
18−-- > master :: Backend -> [NodeId] -> Process ()
19−-- > master backend slaves = do
20−-- > -- Do something interesting with the slaves
21−-- > liftIO . putStrLn $ "Slaves: " ++ show slaves
22−-- > -- Terminate the slaves when the master terminates (this is optional)
23−-- > terminateAllSlaves backend
24−-- >
25−-- > main :: IO ()
26−-- > main = do
27−-- > args <- getArgs
28−-- >
29−-- > case args of
30−-- > ["master", host, port] -> do
31−-- > backend <- initializeBackend host port initRemoteTable
32−-- > startMaster backend (master backend)
33−-- > ["slave", host, port] -> do
34−-- > backend <- initializeBackend host port initRemoteTable
35−-- > startSlave backend
36−--
37−-- [Compiling and Running]
38−--
39−-- Save to @example.hs@ and compile using
40−--
41−-- > ghc -threaded example.hs
42−--
43−-- Fire up some slave nodes (for the example, we run them on a single machine):
44−--
45−-- > ./example slave localhost 8080 &
46−-- > ./example slave localhost 8081 &
47−-- > ./example slave localhost 8082 &
48−-- > ./example slave localhost 8083 &
49−--
50−-- And start the master node:
51−--
52−-- > ./example master localhost 8084
53−--
54−-- which should then output:
55−--
56−-- > Slaves: [nid://localhost:8083:0,nid://localhost:8082:0,nid://localhost:8081:0,nid://localhost:8080:0]
57−--
58−-- at which point the slaves should exit.
59−--
60−-- To run the example on multiple machines, you could run
61−--
62−-- > ./example slave 198.51.100.1 8080 &
63−-- > ./example slave 198.51.100.2 8080 &
64−-- > ./example slave 198.51.100.3 8080 &
65−-- > ./example slave 198.51.100.4 8080 &
66−--
67−-- on four different machines (with IP addresses 198.51.100.1..4), and run the
68−-- master on a fifth node (or on any of the four machines that run the slave
69−-- nodes).
70−--
71−-- It is important that every node has a unique (hostname, port number) pair,
72−-- and that the hostname you use to initialize the node can be resolved by
73−-- peer nodes. In other words, if you start a node and pass hostname @localhost@
74−-- then peer nodes won't be able to reach it because @localhost@ will resolve
75−-- to a different IP address for them.
76−{-# OPTIONS_GHC -fno-warn-orphans #-}
77−module Control.Distributed.Process.Backend.SimpleLocalnet
78− ( -- * Initialization
79− Backend(..)
80− , initializeBackend
81− -- * Slave nodes
82− , startSlave
83− , terminateSlave
84− , findSlaves
85− , terminateAllSlaves
86− -- * Master nodes
87− , startMaster
88− ) where
89−
90−import System.IO (fixIO)
91−import Data.Maybe (catMaybes)
92−import Data.Binary (Binary(get, put), getWord8, putWord8)
93−import Data.Accessor (Accessor, accessor, (^:), (^.))
94−import Data.Set (Set)
95−import qualified Data.Set as Set (insert, empty, toList)
96−import Data.Foldable (forM_)
97−import Data.Typeable (Typeable)
98−import Control.Applicative ((<$>))
99−import Control.Exception (throw)
100−import Control.Monad (forever, forM)
101−import Control.Monad.IO.Class (liftIO)
102−import Control.Concurrent (forkIO, threadDelay, ThreadId)
103−import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
104−import Control.Distributed.Process
105− ( RemoteTable
106− , NodeId
107− , Process
108− , WhereIsReply(..)
109− , whereis
110− , whereisRemoteAsync
111− , registerRemote
112− , getSelfPid
113− , register
114− , expect
115− , nsendRemote
116− , receiveWait
117− , matchIf
118− , processNodeId
119− )
120−import qualified Control.Distributed.Process.Node as Node
121− ( LocalNode
122− , newLocalNode
123− , localNodeId
124− , runProcess
125− )
126−import qualified Network.Transport.TCP as NT
127− ( createTransport
128− , defaultTCPParameters
129− )
130−import qualified Network.Transport as NT (Transport)
131−import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
132−import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)
133−
134−-- | Local backend
135−data Backend = Backend {
136− -- | Create a new local node
137− newLocalNode :: IO Node.LocalNode
138− -- | @findPeers t@ broadcasts a /who's there?/ message on the local
139− -- network, waits 't' msec, and then collects and returns the answers.
140− -- You can use this to dynamically discover peer nodes.
141− , findPeers :: Int -> IO [NodeId]
142− -- | Make sure that all log messages are printed by the logger on the
143− -- current node
144− , redirectLogsHere :: Process ()
145− }
146−
147−data BackendState = BackendState {
148− _localNodes :: [Node.LocalNode]
149− , _peers :: Set NodeId
150− , discoveryDaemon :: ThreadId
151− }
152−
153−-- | Initialize the backend
154−initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend
155−initializeBackend host port rtable = do
156− mTransport <- NT.createTransport host port NT.defaultTCPParameters
157− (recv, send) <- initMulticast "224.0.0.99" 9999 1024
158− (_, backendState) <- fixIO $ \ ~(tid, _) -> do
159− backendState <- newMVar BackendState
160− { _localNodes = []
161− , _peers = Set.empty
162− , discoveryDaemon = tid
163− }
164− tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
165− return (tid', backendState)
166− case mTransport of
167− Left err -> throw err
168− Right transport ->
169− let backend = Backend {
170− newLocalNode = apiNewLocalNode transport rtable backendState
171− , findPeers = apiFindPeers send backendState
172− , redirectLogsHere = apiRedirectLogsHere backend
173− }
174− in return backend
175−
176−-- | Create a new local node
177−apiNewLocalNode :: NT.Transport
178− -> RemoteTable
179− -> MVar BackendState
180− -> IO Node.LocalNode
181−apiNewLocalNode transport rtable backendState = do
182− localNode <- Node.newLocalNode transport rtable
183− modifyMVar_ backendState $ return . (localNodes ^: (localNode :))
184− return localNode
185−
186−-- | Peer discovery
187−apiFindPeers :: (PeerDiscoveryMsg -> IO ())
188− -> MVar BackendState
189− -> Int
190− -> IO [NodeId]
191−apiFindPeers send backendState delay = do
192− send PeerDiscoveryRequest
193− threadDelay delay
194− Set.toList . (^. peers) <$> readMVar backendState
195−
196−data PeerDiscoveryMsg =
197− PeerDiscoveryRequest
198− | PeerDiscoveryReply NodeId
199−
200−instance Binary PeerDiscoveryMsg where
201− put PeerDiscoveryRequest = putWord8 0
202− put (PeerDiscoveryReply nid) = putWord8 1 >> put nid
203− get = do
204− header <- getWord8
205− case header of
206− 0 -> return PeerDiscoveryRequest
207− 1 -> PeerDiscoveryReply <$> get
208− _ -> fail "PeerDiscoveryMsg.get: invalid"
209−
210−-- | Respond to peer discovery requests sent by other nodes
211−peerDiscoveryDaemon :: MVar BackendState
212− -> IO (PeerDiscoveryMsg, N.SockAddr)
213− -> (PeerDiscoveryMsg -> IO ())
214− -> IO ()
215−peerDiscoveryDaemon backendState recv send = forever go
216− where
217− go = do
218− (msg, _) <- recv
219− case msg of
220− PeerDiscoveryRequest -> do
221− nodes <- (^. localNodes) <$> readMVar backendState
222− forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
223− PeerDiscoveryReply nid ->
224− modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
225−
226−--------------------------------------------------------------------------------
227−-- Back-end specific primitives --
228−--------------------------------------------------------------------------------
229−
230−-- | Make sure that all log messages are printed by the logger on this node
231−apiRedirectLogsHere :: Backend -> Process ()
232−apiRedirectLogsHere backend = do
233− mLogger <- whereis "logger"
234− forM_ mLogger $ \logger -> do
235− nids <- liftIO $ findPeers backend 1000000
236− forM_ nids $ \nid -> registerRemote nid "logger" logger
237−
238−--------------------------------------------------------------------------------
239−-- Slaves --
240−--------------------------------------------------------------------------------
241−
242−-- | Messages to slave nodes
243−--
244−-- This datatype is not exposed; instead, we expose primitives for dealing
245−-- with slaves.
246−data SlaveControllerMsg =
247− SlaveTerminate
248− deriving (Typeable, Show)
249−
250−instance Binary SlaveControllerMsg where
251− put SlaveTerminate = putWord8 0
252− get = do
253− header <- getWord8
254− case header of
255− 0 -> return SlaveTerminate
256− _ -> fail "SlaveControllerMsg.get: invalid"
257−
258−-- | Calling 'slave' sets up a new local node and then waits. You start
259−-- processes on the slave by calling 'spawn' from other nodes.
260−--
261−-- This function does not return. The only way to exit the slave is to CTRL-C
262−-- the process or call terminateSlave from another node.
263−startSlave :: Backend -> IO ()
264−startSlave backend = do
265− node <- newLocalNode backend
266− Node.runProcess node slaveController
267−
268−-- | The slave controller interprets 'SlaveControllerMsg's
269−slaveController :: Process ()
270−slaveController = do
271− pid <- getSelfPid
272− register "slaveController" pid
273− go
274− where
275− go = do
276− msg <- expect
277− case msg of
278− SlaveTerminate -> return ()
279−
280−-- | Terminate the slave at the given node ID
281−terminateSlave :: NodeId -> Process ()
282−terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate
283−
284−-- | Find slave nodes
285−findSlaves :: Backend -> Process [NodeId]
286−findSlaves backend = do
287− nodes <- liftIO $ findPeers backend 1000000
288− -- Fire of asynchronous requests for the slave controller
289− forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController"
290− -- Wait for the replies
291− catMaybes <$> forM nodes (\_ ->
292− receiveWait
293− [ matchIf (\(WhereIsReply label _) -> label == "slaveController")
294− (\(WhereIsReply _ mPid) -> return (processNodeId <$> mPid))
295− ])
296−
297−-- | Terminate all slaves
298−terminateAllSlaves :: Backend -> Process ()
299−terminateAllSlaves backend = do
300− slaves <- findSlaves backend
301− forM_ slaves terminateSlave
302− liftIO $ threadDelay 1000000
303−
304−--------------------------------------------------------------------------------
305−-- Master nodes
306−--------------------------------------------------------------------------------
307−
308−-- | 'startMaster' finds all slaves currently available on the local network
309−-- (which should therefore be started first), redirects all log messages to
310−-- itself, and then calls the specified process, passing the list of slaves
311−-- nodes.
312−--
313−-- Terminates when the specified process terminates. If you want to terminate
314−-- the slaves when the master terminates, you should manually call
315−-- 'terminateAllSlaves'.
316−startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()
317−startMaster backend proc = do
318− node <- newLocalNode backend
319− Node.runProcess node $ do
320− slaves <- findSlaves backend
321− redirectLogsHere backend
322− proc slaves
323−
324−--------------------------------------------------------------------------------
325−-- Accessors --
326−--------------------------------------------------------------------------------
327−
328−localNodes :: Accessor BackendState [Node.LocalNode]
329−localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })
330−
331−peers :: Accessor BackendState (Set NodeId)
332−peers = accessor _peers (\ps st -> st { _peers = ps })
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.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-simplelocalnet/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−35
@@ -1,35 +0,0 @@
1−2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
2−
3−* Bugfix in the node controller
4−(one way this bug materialized: when using the SimpleLocalnet backend,
5−slave nodes could not be reused)
6−* Improved documentation in Control.Distributed.Process.Closure
7−
8−2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
9−
10−* Improve docs
11−* Local versions of spawn
12−
13−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
14−
15−* Base 4.6 compatibility
16−* Relax constraints on bytestring and containers
17−
18−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1
19−
20−* Relax upper bound on 'time' dependency
21−
22−2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1
23−
24−* Complete redesign of the underlying implementation of static values and
25−closures.
26−
27−* Add support for 'spawnChannel'
28−
29−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
30−
31−* Bugfix: Continue processing messages when a connection breaks.
32−
33−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
34−
35−* Initial release.
distributed-process/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Well-Typed LLP, 2011-2012
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of the owner nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31−
distributed-process/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
distributed-process/distributed-process.cabaldeleted−138
@@ -1,138 +0,0 @@
1−Name: distributed-process
2−Version: 0.2.1.4
3−Cabal-Version: >=1.8
4−Build-Type: Simple
5−License: BSD3
6−License-File: LICENSE
7−Copyright: Well-Typed LLP
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10−Stability: experimental
11−Homepage: http://github.com/haskell-distributed/distributed-process
12−Bug-Reports: mailto:edsko@well-typed.com
13−Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell
14−Description: This is an implementation of Cloud Haskell, as described in
15− /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,
16− and Simon Peyton Jones
17− (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
18− although some of the details are different. The precise message
19− passing semantics are based on /A unified semantics for future Erlang/
20− by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.
21−
22− You will probably also want to install a Cloud Haskell backend such
23− as distributed-process-simplelocalnet.
24−Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
25−Category: Control
26−
27−Source-Repository head
28− Type: git
29− Location: https://github.com/haskell-distributed/distributed-process
30− SubDir: distributed-process
31−
32−Library
33− Build-Depends: base >= 4.4 && < 5,
34− binary >= 0.5 && < 0.6,
35− network-transport >= 0.2 && < 0.3,
36− stm >= 2.3 && < 2.5,
37− transformers >= 0.2 && < 0.4,
38− mtl >= 2.0 && < 2.2,
39− data-accessor >= 0.2 && < 0.3,
40− bytestring >= 0.9 && < 0.11,
41− containers >= 0.4 && < 0.6,
42− old-locale >= 1.0 && < 1.1,
43− time >= 1.2 && < 1.5,
44− template-haskell >= 2.6 && < 2.8,
45− random >= 1.0 && < 1.1,
46− ghc-prim >= 0.2 && < 0.3
47− Exposed-modules: Control.Distributed.Process,
48− Control.Distributed.Process.Serializable,
49− Control.Distributed.Process.Closure,
50− Control.Distributed.Process.Node,
51− Control.Distributed.Process.Internal.Primitives,
52− Control.Distributed.Process.Internal.CQueue,
53− Control.Distributed.Process.Internal.Dynamic,
54− Control.Distributed.Process.Internal.TypeRep,
55− Control.Distributed.Process.Internal.Types,
56− Control.Distributed.Process.Internal.Closure.Static,
57− Control.Distributed.Process.Internal.Closure.MkClosure,
58− Control.Distributed.Process.Internal.Closure.CP,
59− Control.Distributed.Process.Internal.Closure.TH,
60− Control.Distributed.Process.Internal.Closure.Resolution,
61− Control.Distributed.Process.Internal.Node
62− Extensions: RankNTypes,
63− ScopedTypeVariables,
64− FlexibleInstances,
65− UndecidableInstances,
66− ExistentialQuantification,
67− GADTs,
68− GeneralizedNewtypeDeriving,
69− DeriveDataTypeable,
70− TemplateHaskell,
71− CPP
72− ghc-options: -Wall
73− HS-Source-Dirs: src
74−
75−Test-Suite TestCH
76− Type: exitcode-stdio-1.0
77− Main-Is: TestCH.hs
78− Build-Depends: base >= 4.4 && < 5,
79− binary >= 0.5 && < 0.6,
80− network-transport >= 0.2 && < 0.3,
81− network-transport-tcp >= 0.2 && < 0.3,
82− stm >= 2.3 && < 2.5,
83− transformers >= 0.2 && < 0.4,
84− mtl >= 2.0 && < 2.2,
85− data-accessor >= 0.2 && < 0.3,
86− bytestring >= 0.9 && < 0.11,
87− containers >= 0.4 && < 0.6,
88− old-locale >= 1.0 && < 1.1,
89− time >= 1.2 && < 1.5,
90− template-haskell >= 2.6 && < 2.8,
91− random >= 1.0 && < 1.1,
92− ghc-prim >= 0.2 && < 0.3,
93− ansi-terminal >= 0.5 && < 0.6
94− Extensions: RankNTypes,
95− ScopedTypeVariables,
96− FlexibleInstances,
97− UndecidableInstances,
98− ExistentialQuantification,
99− GADTs,
100− GeneralizedNewtypeDeriving,
101− DeriveDataTypeable,
102− TemplateHaskell,
103− CPP
104− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
105− HS-Source-Dirs: tests src
106−
107−Test-Suite TestClosure
108− Type: exitcode-stdio-1.0
109− Main-Is: TestClosure.hs
110− Build-Depends: base >= 4.4 && < 5,
111− binary >= 0.5 && < 0.6,
112− network-transport >= 0.2 && < 0.3,
113− network-transport-tcp >= 0.2 && < 0.3,
114− stm >= 2.3 && < 2.5,
115− transformers >= 0.2 && < 0.4,
116− mtl >= 2.0 && < 2.2,
117− data-accessor >= 0.2 && < 0.3,
118− bytestring >= 0.9 && < 0.11,
119− containers >= 0.4 && < 0.6,
120− old-locale >= 1.0 && < 1.1,
121− time >= 1.2 && < 1.5,
122− template-haskell >= 2.6 && < 2.8,
123− random >= 1.0 && < 1.1,
124− ghc-prim >= 0.2 && < 0.3,
125− ansi-terminal >= 0.5 && < 0.6
126− Other-modules: TestAuxiliary
127− Extensions: RankNTypes,
128− ScopedTypeVariables,
129− FlexibleInstances,
130− UndecidableInstances,
131− ExistentialQuantification,
132− GADTs,
133− GeneralizedNewtypeDeriving,
134− DeriveDataTypeable,
135− TemplateHaskell,
136− CPP
137− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
138− HS-Source-Dirs: tests src
distributed-process/src/Control/Distributed/Process/Closure.hsdeleted−322
@@ -1,322 +0,0 @@
1−-- | Static values and Closures
2−--
3−-- [Static values]
4−--
5−-- /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)
6−-- proposes a new type construct called 'static' that characterizes values that
7−-- are known statically. There is no support for 'static' in ghc yet, however,
8−-- so we emulate it using Template Haskell. Given a top-level definition
9−--
10−-- > f :: forall a1 .. an. T
11−-- > f = ...
12−--
13−-- you can use a Template Haskell splice to create a static version of 'f':
14−--
15−-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T
16−--
17−-- Every module that you write that contains calls to 'mkStatic' needs to
18−-- have a call to 'remotable':
19−--
20−-- > remotable [ 'f, 'g, ... ]
21−--
22−-- where you must pass every function (or other value) that you pass as an
23−-- argument to 'mkStatic'. The call to 'remotable' will create a definition
24−--
25−-- > __remoteTable :: RemoteTable -> RemoteTable
26−--
27−-- which can be used to construct the 'RemoteTable' used to initialize
28−-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,
29−-- and compose all created functions when initializing Cloud Haskell:
30−--
31−-- > let rtable :: RemoteTable
32−-- > rtable = M1.__remoteTable
33−-- > . M2.__remoteTable
34−-- > . ...
35−-- > . Mn.__remoteTable
36−-- > $ initRemoteTable
37−--
38−-- [Dealing with type class qualifiers]
39−--
40−-- Although 'mkStatic' supports polymorphic types, it does not support
41−-- qualified types. For instance, you cannot call 'mkStatic' on
42−--
43−-- > decode :: Serializable a => ByteString -> a
44−--
45−-- Instead, you will need to reify the type class dictionary. Cloud Haskell
46−-- comes with a reified version of 'Serializable':
47−--
48−-- > data SerializableDict a where
49−-- > SerializableDict :: Serializable a => SerializableDict a
50−--
51−-- Using the reified dictionary you can define
52−--
53−-- > decodeDict :: SerializableDict a -> ByteString -> a
54−-- > decodeDict SerializableDict = decode
55−--
56−-- where 'decodeDict' is a normal (unqualified) polymorphic value and hence
57−-- can be passed as an argument to remotable:
58−--
59−-- > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)
60−--
61−-- [Composing static values]
62−--
63−-- The version of 'static' provided by this implementation of Cloud Haskell is
64−-- strictly more expressive than the one proposed in the paper, and additionally
65−-- supports
66−--
67−-- > staticApply :: Static (a -> b) -> Static a -> Static b
68−--
69−-- This is extremely useful. For example, Cloud Haskell comes with
70−-- 'staticDecode' defined as
71−--
72−-- > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
73−-- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
74−--
75−-- 'staticDecode' is used when defining closures (see below), and makes
76−-- essential use of 'staticApply'.
77−--
78−-- Support for 'staticApply' also makes it possible to define a rich set of
79−-- combinators on 'static' values, a number of which are provided in this
80−-- module.
81−--
82−-- [Static serialization dictionaries]
83−--
84−-- Many Cloud Haskell primitives (like 'staticDecode', above) require static
85−-- serialization dictionaries. In principle these dictionaries require nothing
86−-- special; for instance, given some serializable type 'T' you can define
87−--
88−-- > sdictT :: SerializableDict T
89−-- > sdictT = SerializableDict
90−--
91−-- and then have
92−--
93−-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)
94−--
95−-- However, since these dictionaries are so frequently required Cloud Haskell
96−-- provides special support for them. When you call 'remotable' on a
97−-- /monomorphic/ function @f :: T1 -> T2@
98−--
99−-- > remotable ['f]
100−--
101−-- then a serialization dictionary is automatically created for you, which you
102−-- can access with
103−--
104−-- > $(functionSDict 'f) :: Static (SerializableDict T1)
105−--
106−-- In addition, if @f :: T1 -> Process T2@, then a second dictionary is created
107−--
108−-- > $(functionTDict 'f) :: Static (SerializableDict T2)
109−--
110−-- [Closures]
111−--
112−-- Suppose you have a process
113−--
114−-- > isPrime :: Integer -> Process Bool
115−--
116−-- Then
117−--
118−-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)
119−--
120−-- which you can then 'call', for example, to have a remote node check if
121−-- a number is prime.
122−--
123−-- In general, if you have a /monomorphic/ function
124−--
125−-- > f :: T1 -> T2
126−--
127−-- then
128−--
129−-- > $(mkClosure 'f) :: T1 -> Closure T2
130−--
131−-- provided that 'T1' is serializable (*).
132−--
133−-- [Creating closures manually]
134−--
135−-- You don't /need/ to use 'mkClosure', however. Closures are defined exactly
136−-- as described in /Towards Haskell in the Cloud/:
137−--
138−-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
139−--
140−-- The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit):
141−--
142−-- > let decoder :: Static (ByteString -> Process Bool)
143−-- > decoder = $(mkStatic 'isPrime)
144−-- > `staticCompose`
145−-- > staticDecode $(functionSDict 'isPrime)
146−-- > in Closure decoder (encode n)
147−--
148−-- where 'staticCompose' is composition of static functions. Note that
149−-- 'mkClosure' makes use of the static serialization dictionary
150−-- ('functionSDict') created by 'remotable'.
151−--
152−-- [Combinators on Closures]
153−--
154−-- Support for 'staticApply' (described above) also means that we can define
155−-- combinators on Closures, and we provide a number of them in this module,
156−-- the most important of which is 'cpBind'. Have a look at the implementation
157−-- of 'Control.Distributed.Process.call' for an example use.
158−--
159−-- [Example]
160−--
161−-- Here is a small self-contained example that uses closures and serialization
162−-- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet
163−-- Cloud Haskell backend.
164−--
165−-- > {-# LANGUAGE TemplateHaskell #-}
166−-- > import System.Environment (getArgs)
167−-- > import Control.Distributed.Process
168−-- > import Control.Distributed.Process.Closure
169−-- > import Control.Distributed.Process.Backend.SimpleLocalnet
170−-- > import Control.Distributed.Process.Node (initRemoteTable)
171−-- >
172−-- > isPrime :: Integer -> Process Bool
173−-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
174−-- > where
175−-- > sieve :: [Integer] -> [Integer]
176−-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
177−-- >
178−-- > remotable ['isPrime]
179−-- >
180−-- > master :: [NodeId] -> Process ()
181−-- > master [] = liftIO $ putStrLn "no slaves"
182−-- > master (slave:_) = do
183−-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))
184−-- > liftIO $ print isPrime79
185−-- >
186−-- > main :: IO ()
187−-- > main = do
188−-- > args <- getArgs
189−-- > case args of
190−-- > ["master", host, port] -> do
191−-- > backend <- initializeBackend host port rtable
192−-- > startMaster backend master
193−-- > ["slave", host, port] -> do
194−-- > backend <- initializeBackend host port rtable
195−-- > startSlave backend
196−-- > where
197−-- > rtable :: RemoteTable
198−-- > rtable = __remoteTable initRemoteTable
199−--
200−-- [Notes]
201−--
202−-- (*) If 'T1' is not serializable you will get a type error in the generated
203−-- code. Unfortunately, the Template Haskell infrastructure cannot check
204−-- a priori if 'T1' is serializable or not due to a bug in the Template
205−-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)
206−--
207−-- (**) Even though 'staticDecode' is passed an explicit serialization
208−-- dictionary, we still need the 'Typeable' constraint because
209−-- 'Static' is not the /true/ static. If it was, we could 'unstatic'
210−-- the dictionary and pattern match on it to bring the 'Typeable'
211−-- instance into scope, but unless proper 'static' support is added to
212−-- ghc we need both the type class argument and the explicit dictionary.
213−module Control.Distributed.Process.Closure
214− ( -- * Creating static values
215− remotable
216− , mkStatic
217− -- * Template-Haskell support for creating closures
218− , mkClosure
219− , functionSDict
220− , functionTDict
221− -- * Primitive operations on static values
222− , staticApply
223− , staticDuplicate
224− -- * Static functionals
225− , staticConst
226− , staticFlip
227− , staticFst
228− , staticSnd
229− , staticCompose
230− , staticFirst
231− , staticSecond
232− , staticSplit
233− -- * Static constants
234− , staticUnit
235− -- * Creating closures
236− , staticDecode
237− , staticClosure
238− , toClosure
239− -- * Serialization dictionaries (and their static versions)
240− , SerializableDict(..)
241− , sdictUnit
242− , sdictProcessId
243− , sdictSendPort
244− -- * Definition of CP and the generalized arrow combinators
245− , CP
246− , cpIntro
247− , cpElim
248− , cpId
249− , cpComp
250− , cpFirst
251− , cpSecond
252− , cpSplit
253− , cpCancelL
254− , cpCancelR
255− -- * Closure versions of CH primitives
256− , cpLink
257− , cpUnlink
258− , cpSend
259− , cpExpect
260− , cpNewChan
261− -- * @Closure (Process a)@ as a not-quite-monad
262− , cpReturn
263− , cpBind
264− , cpSeq
265− ) where
266−
267−import Control.Distributed.Process.Internal.Types
268− ( SerializableDict(..)
269− , staticApply
270− , staticDuplicate
271− )
272−import Control.Distributed.Process.Internal.Closure.TH
273− ( remotable
274− , mkStatic
275− , functionSDict
276− , functionTDict
277− )
278−import Control.Distributed.Process.Internal.Closure.Static
279− ( -- Static functionals
280− staticConst
281− , staticFlip
282− , staticFst
283− , staticSnd
284− , staticCompose
285− , staticFirst
286− , staticSecond
287− , staticSplit
288− -- Static constants
289− , staticUnit
290− -- Creating closures
291− , staticDecode
292− , staticClosure
293− , toClosure
294− -- Serialization dictionaries (and their static versions)
295− , sdictUnit
296− , sdictProcessId
297− , sdictSendPort
298− )
299−import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
300−import Control.Distributed.Process.Internal.Closure.CP
301− ( -- Definition of CP and the generalized arrow combinators
302− CP
303− , cpIntro
304− , cpElim
305− , cpId
306− , cpComp
307− , cpFirst
308− , cpSecond
309− , cpSplit
310− , cpCancelL
311− , cpCancelR
312− -- Closure versions of CH primitives
313− , cpLink
314− , cpUnlink
315− , cpSend
316− , cpExpect
317− , cpNewChan
318− -- @Closure (Process a)@ as a not-quite-monad
319− , cpReturn
320− , cpBind
321− , cpSeq
322− )
distributed-process/src/Control/Distributed/Process/Internal/CQueue.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−330
@@ -1,330 +0,0 @@
1−-- | Combinator for process closures
2−{-# LANGUAGE MagicHash #-}
3−module Control.Distributed.Process.Internal.Closure.CP
4− ( -- * Definition of CP and the generalized arrow combinators
5− CP
6− , cpIntro
7− , cpElim
8− , cpId
9− , cpComp
10− , cpFirst
11− , cpSecond
12− , cpSplit
13− , cpCancelL
14− , cpCancelR
15− -- * Closure versions of CH primitives
16− , cpLink
17− , cpUnlink
18− , cpSend
19− , cpExpect
20− , cpNewChan
21− -- * @Closure (Process a)@ as a not-quite-monad
22− , cpReturn
23− , cpBind
24− , cpSeq
25− -- * Runtime support
26− , __remoteTable
27− ) where
28−
29−import Data.Binary (encode)
30−import Data.ByteString.Lazy (ByteString)
31−import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
32−import Control.Applicative ((<$>))
33−import Control.Monad ((>=>))
34−import Control.Monad.Reader (ask)
35−import Control.Distributed.Process.Serializable (Serializable)
36−import Control.Distributed.Process.Internal.Types
37− ( Closure(Closure)
38− , SerializableDict(SerializableDict)
39− , Static(Static)
40− , Process
41− , staticApply
42− , staticDuplicate
43− , staticTypeOf
44− , typeOfStaticLabel
45− , ProcessId
46− , LocalNode(remoteTable)
47− , LocalProcess(processNode)
48− , SendPort
49− , ReceivePort
50− )
51−import Control.Distributed.Process.Internal.Primitives
52− ( link
53− , unlink
54− , send
55− , expect
56− , newChan
57− )
58−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
59−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
60−import Control.Distributed.Process.Internal.Closure.Static
61− ( staticCompose
62− , staticDecode
63− , staticClosure
64− , staticSplit
65− , staticConst
66− , staticUnit
67− , staticFlip
68− , staticFst
69− , staticSnd
70− , sdictProcessId
71− )
72−import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
73−import Control.Distributed.Process.Internal.Dynamic
74− ( Dynamic(Dynamic)
75− , unsafeCoerce#
76− , dynTypeRep
77− , dynKleisli
78− )
79−import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)
80−
81−--------------------------------------------------------------------------------
82−-- Setup: A number of functions that we will pass to 'remotable' --
83−--------------------------------------------------------------------------------
84−
85−---- Type specializations of monadic operations on Processes -------------------
86−
87−returnProcess :: a -> Process a
88−returnProcess = return
89−
90−bindProcess :: Process a -> (a -> Process b) -> Process b
91−bindProcess = (>>=)
92−
93−kleisliProcess :: (a -> Process b) -> (b -> Process c) -> a -> Process c
94−kleisliProcess = (>=>)
95−
96−parJoinProcess :: Process (a -> Process b) -> a -> Process b
97−parJoinProcess proc a = proc >>= ($ a)
98−
99−---- Variations on standard or CH functions with an explicit dictionary arg ----
100−
101−sendDict :: SerializableDict a -> ProcessId -> a -> Process ()
102−sendDict SerializableDict = send
103−
104−expectDict :: SerializableDict a -> Process a
105−expectDict SerializableDict = expect
106−
107−newChanDict :: SerializableDict a -> Process (SendPort a, ReceivePort a)
108−newChanDict SerializableDict = newChan
109−
110−---- Serialization dictionaries ------------------------------------------------
111−
112−-- | Specialized serialization dictionary required in 'cpBind'
113−sdictComp :: SerializableDict (ByteString, ByteString)
114−sdictComp = SerializableDict
115−
116−---- Some specialised processes necessary to implement the combinators ---------
117−
118−-- | Resolve a closure
119−unClosure :: Static a -> ByteString -> Process Dynamic
120−unClosure (Static label) env = do
121− rtable <- remoteTable . processNode <$> ask
122− case resolveClosure rtable label env of
123− Nothing -> fail "Derived.unClosure: resolveClosure failed"
124− Just dyn -> return dyn
125−
126−-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the
127−-- type of the first static argument (the value of that argument is not used)
128−unDynamic :: Static a -> Process Dynamic -> Process a
129−unDynamic (Static label) pdyn = do
130− Dynamic typ val <- pdyn
131− if typ `compareTypeRep` typeOfStaticLabel label
132− then return (unsafeCoerce# val)
133− else fail $ "unDynamic: cannot match "
134− ++ show typ
135− ++ " against expected type "
136− ++ show (typeOfStaticLabel label)
137−
138−-- | Dynamic kleisli composition
139−--
140−-- The first argument stops remotable from trying to generate a SerializableDict
141−-- for (Process Dynamic, Process Dynamic)
142−kleisliCompDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
143−kleisliCompDyn () (pf, pg) = do
144− f <- pf -- a -> Process b
145− g <- pg -- b -> Process c
146− case dynKleisli tyConProcess kleisliProcess f g of
147− Just dyn -> return dyn
148− Nothing -> fail $ "kleisliCompDyn: could not compose "
149− ++ show (dynTypeRep f)
150− ++ " with "
151− ++ show (dynTypeRep g)
152− where
153− tyConProcess :: TyCon
154− tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))
155−
156−cpFirstAux :: (a -> Process b) -> (a, c) -> Process (b, c)
157−cpFirstAux f (a, c) = f a >>= \b -> return (b, c)
158−
159−cpSecondAux :: (a -> Process b) -> (c, a) -> Process (c, b)
160−cpSecondAux f (c, a) = f a >>= \b -> return (c, b)
161−
162−---- Finally, the call to remotable --------------------------------------------
163−
164−remotable [ -- Monadic operations
165− 'returnProcess
166− , 'bindProcess
167− , 'parJoinProcess
168− -- CH primitives
169− , 'link
170− , 'unlink
171− -- Explicit dictionaries
172− , 'sendDict
173− , 'expectDict
174− , 'newChanDict
175− -- Serialization dictionaries
176− , 'sdictComp
177− -- Specialized processes
178− , 'unClosure
179− , 'unDynamic
180− , 'kleisliCompDyn
181− , 'cpFirstAux
182− , 'cpSecondAux
183− ]
184−
185−--------------------------------------------------------------------------------
186−-- Some derived static functions --
187−--------------------------------------------------------------------------------
188−
189−staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)
190−staticUndynamic =
191− $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))
192−
193−staticKleisliCompDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
194−staticKleisliCompDyn = $(mkStatic 'kleisliCompDyn) `staticApply` staticUnit
195−
196−--------------------------------------------------------------------------------
197−-- Definition of CP and the generalized arrow combinators --
198−--------------------------------------------------------------------------------
199−
200−-- | 'CP a b' represents the closure of a process parameterized by 'a' and
201−-- returning 'b'. 'CP a b' forms a (restricted) generalized arrow
202−-- (<http://www.cs.berkeley.edu/~megacz/garrows/>)
203−type CP a b = Closure (a -> Process b)
204−
205−-- | 'CP' introduction form
206−cpIntro :: forall a b. (Typeable a, Typeable b)
207− => Closure (Process b) -> Closure (a -> Process b)
208−cpIntro (Closure static env) = Closure decoder env
209− where
210− decoder :: Static (ByteString -> a -> Process b)
211− decoder = staticConst `staticCompose` static
212−
213−-- | 'CP' elimination form
214−cpElim :: forall a. Typeable a => CP () a -> Closure (Process a)
215−cpElim (Closure static env) = Closure decoder env
216− where
217− decoder :: Static (ByteString -> Process a)
218− decoder = staticFlip static `staticApply` staticUnit
219−
220−-- | Identity ('Closure' version of 'return')
221−cpId :: Typeable a => CP a a
222−cpId = staticClosure $(mkStatic 'returnProcess)
223−
224−-- | Left-to-right composition ('Closure' version of '>=>')
225−cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)
226− => CP a b -> CP b c -> CP a c
227−cpComp (Closure fstatic fenv) (Closure gstatic genv) =
228− Closure decoder (encode (fenv, genv))
229− where
230− decoder :: Static (ByteString -> a -> Process c)
231− decoder = $(mkStatic 'parJoinProcess)
232− `staticCompose`
233− staticUndynamic
234− `staticCompose`
235− staticKleisliCompDyn
236− `staticCompose`
237− (staticUnclosure fstatic `staticSplit` staticUnclosure gstatic)
238− `staticCompose`
239− staticDecode $(mkStatic 'sdictComp)
240−
241−-- | First
242−cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)
243− => CP a b -> CP (a, c) (b, c)
244−cpFirst (Closure static env) = Closure decoder env
245− where
246− decoder :: Static (ByteString -> (a, c) -> Process (b, c))
247− decoder = $(mkStatic 'cpFirstAux) `staticCompose` static
248−
249−-- | Second
250−cpSecond :: forall a b c. (Typeable a, Typeable b, Typeable c)
251− => CP a b -> CP (c, a) (c, b)
252−cpSecond (Closure static env) = Closure decoder env
253− where
254− decoder :: Static (ByteString -> (c, a) -> Process (c, b))
255− decoder = $(mkStatic 'cpSecondAux) `staticCompose` static
256−
257−-- | Split (Like 'Control.Arrow.***')
258−cpSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
259− => CP a c -> CP b d -> CP (a, b) (c, d)
260−cpSplit f g = cpFirst f `cpComp` cpSecond g
261−
262−-- | Left cancellation
263−cpCancelL :: Typeable a => CP ((), a) a
264−-- Closure (((), a) -> Process a)
265−cpCancelL = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticSnd)
266−
267−-- | Right cancellation
268−cpCancelR :: Typeable a => CP (a, ()) a
269−cpCancelR = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticFst)
270−
271−--------------------------------------------------------------------------------
272−-- Closure versions of CH primitives --
273−--------------------------------------------------------------------------------
274−
275−-- | Closure version of 'link'
276−cpLink :: ProcessId -> Closure (Process ())
277−cpLink = $(mkClosure 'link)
278−
279−-- | Closure version of 'unlink'
280−cpUnlink :: ProcessId -> Closure (Process ())
281−cpUnlink = $(mkClosure 'unlink)
282−
283−-- | Closure version of 'send'
284−cpSend :: forall a. Typeable a
285− => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())
286−cpSend dict pid = Closure decoder (encode pid)
287− where
288− decoder :: Static (ByteString -> a -> Process ())
289− decoder = ($(mkStatic 'sendDict) `staticApply` dict)
290− `staticCompose`
291− staticDecode sdictProcessId
292−
293−-- | Closure version of 'expect'
294−cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
295−cpExpect dict = staticClosure ($(mkStatic 'expectDict) `staticApply` dict)
296−
297−-- | Closure version of 'newChan'
298−cpNewChan :: Typeable a
299− => Static (SerializableDict a)
300− -> Closure (Process (SendPort a, ReceivePort a))
301−cpNewChan dict = staticClosure ($(mkStatic 'newChanDict) `staticApply` dict)
302−
303−--------------------------------------------------------------------------------
304−-- (Closure . Process) as a not-quite-monad --
305−--------------------------------------------------------------------------------
306−
307−-- | Not-quite-monadic 'return'
308−cpReturn :: forall a. Serializable a
309− => Static (SerializableDict a) -> a -> Closure (Process a)
310−cpReturn dict x = Closure decoder (encode x)
311− where
312− decoder :: Static (ByteString -> Process a)
313− decoder = $(mkStatic 'returnProcess)
314− `staticCompose`
315− staticDecode dict
316−
317−
318−staticUnclosure :: Typeable a
319− => Static a -> Static (ByteString -> Process Dynamic)
320−staticUnclosure s =
321− $(mkStatic 'unClosure) `staticApply` staticDuplicate s
322−
323−-- | Not-quite-monadic bind ('>>=')
324−cpBind :: forall a b. (Typeable a, Typeable b)
325− => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
326−cpBind x f = cpElim (cpIntro x `cpComp` f)
327−
328−-- | Monadic sequencing ('>>')
329−cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())
330−cpSeq p q = p `cpBind` cpIntro q
distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hsdeleted−25
@@ -1,25 +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−-- | Create a closure
17−--
18−-- If @f : T1 -> T2@ is a /monomorphic/ function
19−-- then @$(mkClosure 'f) :: T1 -> Closure T2@.
20−-- Be sure to pass 'f' to 'remotable'.
21−mkClosure :: Name -> Q Exp
22−mkClosure n =
23− [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
24− . encode
25− |]
distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.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−190
@@ -1,190 +0,0 @@
1−-- | Combinators on static values
2−{-# LANGUAGE MagicHash #-}
3−module Control.Distributed.Process.Internal.Closure.Static
4− ( -- * Static functionals
5− staticConst
6− , staticFlip
7− , staticFst
8− , staticSnd
9− , staticCompose
10− , staticFirst
11− , staticSecond
12− , staticSplit
13− -- * Static constants
14− , staticUnit
15− -- * Creating closures
16− , staticDecode
17− , staticClosure
18− , toClosure
19− -- * Serialization dictionaries (and their static versions)
20− , sdictUnit
21− , sdictProcessId
22− , sdictSendPort
23− -- * Runtime support
24− , __remoteTable
25− ) where
26−
27−import Data.Binary (encode, decode)
28−import Data.ByteString.Lazy (ByteString, empty)
29−import Data.Typeable (Typeable)
30−import Control.Distributed.Process.Serializable (Serializable)
31−import Control.Distributed.Process.Internal.Types
32− ( Closure(Closure)
33− , SerializableDict(SerializableDict)
34− , Static
35− , staticApply
36− , ProcessId
37− , SendPort
38− )
39−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
40−import qualified Control.Arrow as Arrow (first, second, (***))
41−
42−--------------------------------------------------------------------------------
43−-- Setup: A number of functions that we will pass to 'remotable' --
44−--------------------------------------------------------------------------------
45−
46−---- Functionals ---------------------------------------------------------------
47−
48−compose :: (b -> c) -> (a -> b) -> a -> c
49−compose = (.)
50−
51−first :: (a -> b) -> (a, c) -> (b, c)
52−first = Arrow.first
53−
54−second :: (a -> b) -> (c, a) -> (c, b)
55−second = Arrow.second
56−
57−split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
58−split = (Arrow.***)
59−
60−---- Constants -----------------------------------------------------------------
61−
62−unit :: ()
63−unit = ()
64−
65−---- Variations on standard or CH functions with an explicit dictionary arg ----
66−
67−decodeDict :: SerializableDict a -> ByteString -> a
68−decodeDict SerializableDict = decode
69−
70−---- Serialization dictionaries ------------------------------------------------
71−
72−sdictUnit_ :: SerializableDict ()
73−sdictUnit_ = SerializableDict
74−
75−sdictProcessId_ :: SerializableDict ProcessId
76−sdictProcessId_ = SerializableDict
77−
78−sdictSendPort_ :: SerializableDict a -> SerializableDict (SendPort a)
79−sdictSendPort_ SerializableDict = SerializableDict
80−
81−---- Finally, the call to remotable --------------------------------------------
82−
83−remotable [ -- Functionals (predefined)
84− 'const
85− , 'flip
86− , 'fst
87− , 'snd
88− -- Functionals (defined above)
89− , 'compose
90− , 'first
91− , 'second
92− , 'split
93− -- Constants
94− , 'unit
95− -- Explicit dictionaries
96− , 'decodeDict
97− -- Serialization dictionaries
98− , 'sdictUnit_
99− , 'sdictProcessId_
100− , 'sdictSendPort_
101− ]
102−
103−--------------------------------------------------------------------------------
104−-- Static versions of the functionals --
105−-- (We give these explicit names because they are useful outside this module) --
106−--------------------------------------------------------------------------------
107−
108−-- | Static version of 'const'
109−staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)
110−staticConst = $(mkStatic 'const)
111−
112−-- | Static version of 'flip'
113−staticFlip :: (Typeable a, Typeable b, Typeable c)
114− => Static (a -> b -> c) -> Static (b -> a -> c)
115−staticFlip f = $(mkStatic 'flip) `staticApply` f
116−
117−-- | Static version of 'fst'
118−staticFst :: (Typeable a, Typeable b)
119− => Static ((a, b) -> a)
120−staticFst = $(mkStatic 'fst)
121−
122−-- | Static version of 'snd'
123−staticSnd :: (Typeable a, Typeable b)
124− => Static ((a, b) -> b)
125−staticSnd = $(mkStatic 'snd)
126−
127−-- | Static version of ('Prelude..')
128−staticCompose :: (Typeable a, Typeable b, Typeable c)
129− => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
130−staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x
131−
132−-- | Static version of 'Control.Arrow.first'
133−staticFirst :: (Typeable a, Typeable b, Typeable c)
134− => Static ((a -> b) -> (a, c) -> (b, c))
135−staticFirst = $(mkStatic 'first)
136−
137−-- | Static version of 'Control.Arrow.second'
138−staticSecond :: (Typeable a, Typeable b, Typeable c)
139− => Static ((a -> b) -> (c, a) -> (c, b))
140−staticSecond = $(mkStatic 'second)
141−
142−-- | Static version of ('Control.Arrow.***')
143−staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
144− => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))
145−staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g
146−
147−--------------------------------------------------------------------------------
148−-- Constants --
149−--------------------------------------------------------------------------------
150−
151−-- | Static version of '()'
152−staticUnit :: Static ()
153−staticUnit = $(mkStatic 'unit)
154−
155−--------------------------------------------------------------------------------
156−-- Dictionaries --
157−--------------------------------------------------------------------------------
158−
159−-- | Serialization dictionary for '()'
160−sdictUnit :: Static (SerializableDict ())
161−sdictUnit = $(mkStatic 'sdictUnit_)
162−
163−-- | Serialization dictionary for 'ProcessId'
164−sdictProcessId :: Static (SerializableDict ProcessId)
165−sdictProcessId = $(mkStatic 'sdictProcessId_)
166−
167−-- | Serialization dictionary for 'SendPort'
168−sdictSendPort :: Typeable a
169− => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))
170−sdictSendPort = staticApply $(mkStatic 'sdictSendPort_)
171−
172−--------------------------------------------------------------------------------
173−-- Creating closures --
174−--------------------------------------------------------------------------------
175−
176−-- | Static decoder, given a static serialization dictionary.
177−--
178−-- See module documentation of "Control.Distributed.Process.Closure" for an
179−-- example.
180−staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
181−staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
182−
183−-- | Convert a static value into a closure.
184−staticClosure :: forall a. Typeable a => Static a -> Closure a
185−staticClosure static = Closure (staticConst `staticApply` static) empty
186−
187−-- | Convert a serializable value into a closure.
188−toClosure :: forall a. Serializable a
189− => Static (SerializableDict a) -> a -> Closure a
190−toClosure dict x = Closure (staticDecode dict) (encode x)
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hsdeleted−229
@@ -1,229 +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− , functionTDict
11− ) where
12−
13−import Prelude hiding (lookup)
14−import Data.Accessor ((^=))
15−import Data.Typeable (typeOf)
16−import Control.Applicative ((<$>))
17−import Language.Haskell.TH
18− ( -- Q monad and operations
19− Q
20− , reify
21− -- Names
22− , Name
23− , mkName
24− , nameBase
25− -- Algebraic data types
26− , Dec
27− , Exp
28− , Type(AppT, ForallT, VarT, ArrowT)
29− , Info(VarI)
30− , TyVarBndr(PlainTV, KindedTV)
31− , Pred(ClassP)
32− -- Lifted constructors
33− -- .. Literals
34− , stringL
35− -- .. Patterns
36− , normalB
37− , clause
38− -- .. Expressions
39− , varE
40− , litE
41− -- .. Top-level declarations
42− , funD
43− , sigD
44− )
45−import Control.Distributed.Process.Internal.Types
46− ( RemoteTable
47− , Static(Static)
48− , StaticLabel(StaticLabel)
49− , remoteTableLabel
50− , SerializableDict(SerializableDict)
51− , Process
52− )
53−import Control.Distributed.Process.Internal.Dynamic
54− ( Dynamic(..)
55− , unsafeCoerce#
56− , toDyn
57− )
58−
59−--------------------------------------------------------------------------------
60−-- User-level API --
61−--------------------------------------------------------------------------------
62−
63−-- | Create the closure, decoder, and metadata definitions for the given list
64−-- of functions
65−remotable :: [Name] -> Q [Dec]
66−remotable ns = do
67− (closures, inserts) <- unzip <$> mapM generateDefs ns
68− rtable <- createMetaData (concat inserts)
69− return $ concat closures ++ rtable
70−
71−-- | Construct a static value.
72−--
73−-- If @f : forall a1 .. an. T@
74−-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
75−-- Be sure to pass 'f' to 'remotable'.
76−mkStatic :: Name -> Q Exp
77−mkStatic = varE . staticName
78−
79−-- | If @f : T1 -> T2@ is a monomorphic function
80−-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
81−--
82−-- Be sure to pass 'f' to 'remotable'.
83−functionSDict :: Name -> Q Exp
84−functionSDict = varE . sdictName
85−
86−-- | If @f : T1 -> Process T2@ is a monomorphic function
87−-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
88−--
89−-- Be sure to pass 'f' to 'remotable'.
90−functionTDict :: Name -> Q Exp
91−functionTDict = varE . tdictName
92−
93−--------------------------------------------------------------------------------
94−-- Internal (Template Haskell) --
95−--------------------------------------------------------------------------------
96−
97−-- | Generate the code to add the metadata to the CH runtime
98−createMetaData :: [Q Exp] -> Q [Dec]
99−createMetaData is =
100− [d| __remoteTable :: RemoteTable -> RemoteTable ;
101− __remoteTable = $(compose is)
102− |]
103−
104−generateDefs :: Name -> Q ([Dec], [Q Exp])
105−generateDefs n = do
106− proc <- [t| Process |]
107− mType <- getType n
108− case mType of
109− Just (origName, typ) -> do
110− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
111− _ -> ([], typ)
112−
113− -- The main "static" entry
114− (static, register) <- makeStatic origName typVars typ'
115−
116− -- If n :: T1 -> T2, static serializable dictionary for T1
117− -- TODO: we should check if arg is an instance of Serializable, but we cannot
118− -- http://hackage.haskell.org/trac/ghc/ticket/7066
119− (sdict, registerSDict) <- case (typVars, typ') of
120− ([], ArrowT `AppT` arg `AppT` _res) ->
121− makeDict (sdictName origName) arg
122− _ ->
123− return ([], [])
124−
125− -- If n :: T1 -> Process T2, static serializable dictionary for T2
126− -- TODO: check if T2 is serializable (same as above)
127− (tdict, registerTDict) <- case (typVars, typ') of
128− ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
129− makeDict (tdictName origName) res
130− _ ->
131− return ([], [])
132−
133− return ( concat [static, sdict, tdict]
134− , concat [register, registerSDict, registerTDict]
135− )
136− _ ->
137− fail $ "remotable: " ++ show n ++ " not found"
138− where
139− makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
140− makeStatic origName typVars typ = do
141− static <- generateStatic origName typVars typ
142− let dyn = case typVars of
143− [] -> [| toDyn $(varE origName) |]
144− _ -> [| Dynamic (error "Polymorphic value")
145− (unsafeCoerce# $(varE origName))
146− |]
147− return ( static
148− , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
149− )
150−
151− makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
152− makeDict dictName typ = do
153− sdict <- generateDict dictName typ
154− let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]
155− return ( sdict
156− , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
157− )
158−
159−
160−registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
161−registerStatic label dyn = remoteTableLabel label ^= Just dyn
162−
163−-- | Generate a static value
164−generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
165−generateStatic n xs typ = do
166− staticTyp <- [t| Static |]
167− sequence
168− [ sigD (staticName n) $
169− return (ForallT xs
170− (map typeable xs)
171− (staticTyp `AppT` typ)
172− )
173− , sfnD (staticName n)
174− [| Static $ StaticLabel
175− $(stringE (show n))
176− (typeOf (undefined :: $(return typ)))
177− |]
178− ]
179− where
180− typeable :: TyVarBndr -> Pred
181− typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
182− typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
183−
184−-- | Generate a serialization dictionary with name 'n' for type 'typ'
185−generateDict :: Name -> Type -> Q [Dec]
186−generateDict n typ = do
187− sequence
188− [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
189− , sfnD n
190− [| Static $ StaticLabel
191− $(stringE (show n))
192− (typeOf (undefined :: SerializableDict $(return typ)))
193− |]
194− ]
195−
196−staticName :: Name -> Name
197−staticName n = mkName $ nameBase n ++ "__static"
198−
199−sdictName :: Name -> Name
200−sdictName n = mkName $ nameBase n ++ "__sdict"
201−
202−tdictName :: Name -> Name
203−tdictName n = mkName $ nameBase n ++ "__tdict"
204−
205−--------------------------------------------------------------------------------
206−-- Generic Template Haskell auxiliary functions --
207−--------------------------------------------------------------------------------
208−
209−-- | Compose a set of expressions
210−compose :: [Q Exp] -> Q Exp
211−compose [] = [| id |]
212−compose [e] = e
213−compose (e:es) = [| $e . $(compose es) |]
214−
215−-- | Literal string as an expression
216−stringE :: String -> Q Exp
217−stringE = litE . stringL
218−
219−-- | Look up the "original name" (module:name) and type of a top-level function
220−getType :: Name -> Q (Maybe (Name, Type))
221−getType name = do
222− info <- reify name
223− case info of
224− VarI origName typ _ _ -> return $ Just (origName, typ)
225− _ -> return Nothing
226−
227−-- | Variation on 'funD' which takes a single expression to define the function
228−sfnD :: Name -> Q Exp -> Q Dec
229−sfnD n e = funD n [clause [] (normalB e) []]
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hsdeleted−112
@@ -1,112 +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− , dynKleisli
19− , GHC.unsafeCoerce#
20− ) where
21−
22−import Data.Typeable
23− ( Typeable
24− , TypeRep
25− , typeOf
26− , funResultTy
27− , TyCon
28− , splitTyConApp
29− , mkFunTy
30− )
31−import Data.Typeable.Internal (funTc)
32−import qualified GHC.Prim as GHC (Any, unsafeCoerce#)
33−import Data.Maybe (fromMaybe)
34−
35−data Dynamic = Dynamic TypeRep GHC.Any
36− deriving Typeable
37−
38−toDyn :: Typeable a => a -> Dynamic
39−toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)
40−
41−fromDyn :: Typeable a => Dynamic -> a -> a
42−fromDyn (Dynamic rep val) a =
43− if rep == typeOf a
44− then GHC.unsafeCoerce# val
45− else a
46−
47−fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a
48−fromDynamic (Dynamic rep val) =
49− if rep == typeOf (undefined :: a)
50− then Just (GHC.unsafeCoerce# val)
51− else Nothing
52−
53−dynTypeRep :: Dynamic -> TypeRep
54−dynTypeRep (Dynamic t _) = t
55−
56−instance Show Dynamic where
57− show = show . dynTypeRep
58−
59−dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
60−dynApply (Dynamic t1 f) (Dynamic t2 x) =
61− case funResultTy t1 t2 of
62− Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))
63− Nothing -> Nothing
64−
65−dynApp :: Dynamic -> Dynamic -> Dynamic
66−dynApp f x = fromMaybe (error typeError) (dynApply f x)
67− where
68− typeError = "Type error in dynamic application.\n"
69− ++ "Can't apply function " ++ show f
70− ++ " to argument " ++ show x
71−
72−dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic
73−dynBind m bind (Dynamic t1 x) (Dynamic t2 f) =
74− case splitTyConApp t1 of
75− (m', [a]) | m' == m ->
76− case funResultTy t2 a of
77− Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))
78− _ -> Nothing
79− _ -> Nothing
80−
81−dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic
82−dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)
83− where
84− typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f
85−
86−
87−
88−
89−-- | Dynamically typed Kleisli composition
90−dynKleisli :: TyCon
91− -> (forall a b c. (a -> m b) -> (b -> m c) -> a -> m c)
92− -> Dynamic
93− -> Dynamic
94− -> Maybe Dynamic
95−dynKleisli m comp (Dynamic tf f) (Dynamic tg g) =
96− case splitTyConApp tf of
97− (arr1, [a, mb]) | arr1 == funTc ->
98− case splitTyConApp tg of
99− (arr2, [b, mc]) | arr2 == funTc ->
100− case splitTyConApp mb of
101− (m', [b']) | m' == m && b' == b ->
102− case splitTyConApp mc of
103− (m'', [_c]) | m'' == m ->
104− Just (Dynamic (mkFunTy a mc) (GHC.unsafeCoerce# comp f g))
105− _ ->
106− Nothing
107− _ ->
108− Nothing
109− _ ->
110− Nothing
111− _ ->
112− Nothing
distributed-process/src/Control/Distributed/Process/Internal/Node.hsdeleted−91
@@ -1,91 +0,0 @@
1−module Control.Distributed.Process.Internal.Node
2− ( -- * Message sending
3− sendPayload
4− , sendBinary
5− , sendMessage
6− ) where
7−
8−import Data.Accessor ((^.), (^=))
9−import Data.Binary (Binary, encode)
10−import qualified Data.ByteString.Lazy as BSL (toChunks)
11−import qualified Data.ByteString as BSS (ByteString)
12−import Control.Concurrent.MVar (withMVar, modifyMVar_)
13−import Control.Concurrent.Chan (writeChan)
14−import Control.Monad (unless)
15−import qualified Network.Transport as NT
16− ( Connection
17− , send
18− , defaultConnectHints
19− , connect
20− , Reliability(ReliableOrdered)
21− )
22−import Control.Distributed.Process.Internal.Types
23− ( LocalNode(localState, localEndPoint, localCtrlChan)
24− , Identifier
25− , localConnectionBetween
26− , nodeAddress
27− , nodeOf
28− , messageToPayload
29− , createMessage
30− , NCMsg(..)
31− , ProcessSignal(Died)
32− , DiedReason(DiedDisconnect)
33− )
34−import Control.Distributed.Process.Serializable (Serializable)
35−
36−--------------------------------------------------------------------------------
37−-- Message sending --
38−--------------------------------------------------------------------------------
39−
40−sendPayload :: LocalNode -> Identifier -> Identifier -> [BSS.ByteString] -> IO ()
41−sendPayload node from to payload = do
42− mConn <- connBetween node from to
43− didSend <- case mConn of
44− Just conn -> do
45− didSend <- NT.send conn payload
46− case didSend of
47− Left _ -> return False
48− Right _ -> return True
49− Nothing -> return False
50− unless didSend $
51− writeChan (localCtrlChan node) NCMsg
52− { ctrlMsgSender = to
53− , ctrlMsgSignal = Died to DiedDisconnect
54− }
55−
56−sendBinary :: Binary a => LocalNode -> Identifier -> Identifier -> a -> IO ()
57−sendBinary node from to = sendPayload node from to . BSL.toChunks . encode
58−
59−sendMessage :: Serializable a => LocalNode -> Identifier -> Identifier -> a -> IO ()
60−sendMessage node from to = sendPayload node from to . messageToPayload . createMessage
61−
62−setupConnBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
63−setupConnBetween node from to = do
64− mConn <- NT.connect endPoint
65− (nodeAddress . nodeOf $ to)
66− NT.ReliableOrdered
67− NT.defaultConnectHints
68− case mConn of
69− Right conn -> do
70− didSend <- NT.send conn (BSL.toChunks . encode $ to)
71− case didSend of
72− Left _ ->
73− return Nothing
74− Right () -> do
75− modifyMVar_ nodeState $ return .
76− (localConnectionBetween from to ^= Just conn)
77− return $ Just conn
78− Left _ ->
79− return Nothing
80− where
81− endPoint = localEndPoint node
82− nodeState = localState node
83−
84−connBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
85−connBetween node from to = do
86− mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)
87− case mConn of
88− Just conn -> return $ Just conn
89− Nothing -> setupConnBetween node from to
90− where
91− nodeState = localState node
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hsdeleted−524
@@ -1,524 +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−#if ! MIN_VERSION_base(4,6,0)
59−import Prelude hiding (catch)
60−#endif
61−
62−import Data.Binary (decode)
63−import Data.Typeable (Typeable, typeOf)
64−import Data.Time.Clock (getCurrentTime)
65−import Data.Time.Format (formatTime)
66−import System.Locale (defaultTimeLocale)
67−import Control.Monad.Reader (ask)
68−import Control.Monad.IO.Class (MonadIO, liftIO)
69−import Control.Applicative ((<$>))
70−import Control.Exception (Exception, throw)
71−import qualified Control.Exception as Ex (catch)
72−import Control.Concurrent.MVar (modifyMVar)
73−import Control.Concurrent.Chan (writeChan)
74−import Control.Concurrent.STM
75− ( STM
76− , atomically
77− , orElse
78− , newTChan
79− , readTChan
80− , newTVar
81− , readTVar
82− , writeTVar
83− )
84−import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..))
85−import Control.Distributed.Process.Serializable (Serializable, fingerprint)
86−import Data.Accessor ((^.), (^:), (^=))
87−import Control.Distributed.Process.Internal.Types
88− ( NodeId(..)
89− , ProcessId(..)
90− , LocalNode(..)
91− , LocalProcess(..)
92− , Process(..)
93− , Closure(..)
94− , Message(..)
95− , MonitorRef(..)
96− , SpawnRef(..)
97− , NCMsg(..)
98− , ProcessSignal(..)
99− , monitorCounter
100− , spawnCounter
101− , Closure(..)
102− , SendPort(..)
103− , ReceivePort(..)
104− , channelCounter
105− , typedChannelWithId
106− , TypedChannel(..)
107− , SendPortId(..)
108− , Identifier(..)
109− , DidUnmonitor(..)
110− , DidUnlinkProcess(..)
111− , DidUnlinkNode(..)
112− , DidUnlinkPort(..)
113− , WhereIsReply(..)
114− , createMessage
115− , Static(..)
116− , runLocalProcess
117− )
118−import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)
119−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
120−import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
121−
122−--------------------------------------------------------------------------------
123−-- Basic messaging --
124−--------------------------------------------------------------------------------
125−
126−-- | Send a message
127−send :: Serializable a => ProcessId -> a -> Process ()
128−-- This requires a lookup on every send. If we want to avoid that we need to
129−-- modify serializable to allow for stateful (IO) deserialization
130−send them msg = do
131− proc <- ask
132− liftIO $ sendMessage (processNode proc)
133− (ProcessIdentifier (processId proc))
134− (ProcessIdentifier them)
135− msg
136−
137−-- | Wait for a message of a specific type
138−expect :: forall a. Serializable a => Process a
139−expect = receiveWait [match return]
140−
141−--------------------------------------------------------------------------------
142−-- Channels --
143−--------------------------------------------------------------------------------
144−
145−-- | Create a new typed channel
146−newChan :: Serializable a => Process (SendPort a, ReceivePort a)
147−newChan = do
148− proc <- ask
149− liftIO . modifyMVar (processState proc) $ \st -> do
150− chan <- liftIO . atomically $ newTChan
151− let lcid = st ^. channelCounter
152− cid = SendPortId { sendPortProcessId = processId proc
153− , sendPortLocalId = lcid
154− }
155− sport = SendPort cid
156− rport = ReceivePortSingle chan
157− tch = TypedChannel chan
158− return ( (channelCounter ^: (+ 1))
159− . (typedChannelWithId lcid ^= Just tch)
160− $ st
161− , (sport, rport)
162− )
163−
164−-- | Send a message on a typed channel
165−sendChan :: Serializable a => SendPort a -> a -> Process ()
166−sendChan (SendPort cid) msg = do
167− proc <- ask
168− liftIO $ sendBinary (processNode proc)
169− (ProcessIdentifier (processId proc))
170− (SendPortIdentifier cid)
171− msg
172−
173−-- | Wait for a message on a typed channel
174−receiveChan :: Serializable a => ReceivePort a -> Process a
175−receiveChan = liftIO . atomically . receiveSTM
176− where
177− receiveSTM :: ReceivePort a -> STM a
178− receiveSTM (ReceivePortSingle c) =
179− readTChan c
180− receiveSTM (ReceivePortBiased ps) =
181− foldr1 orElse (map receiveSTM ps)
182− receiveSTM (ReceivePortRR psVar) = do
183− ps <- readTVar psVar
184− a <- foldr1 orElse (map receiveSTM ps)
185− writeTVar psVar (rotate ps)
186− return a
187−
188− rotate :: [a] -> [a]
189− rotate [] = []
190− rotate (x:xs) = xs ++ [x]
191−
192−-- | Merge a list of typed channels.
193−--
194−-- The result port is left-biased: if there are messages available on more
195−-- than one port, the first available message is returned.
196−mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
197−mergePortsBiased = return . ReceivePortBiased
198−
199−-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than
200−-- left-biased)
201−mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
202−mergePortsRR ps = liftIO . atomically $ ReceivePortRR <$> newTVar ps
203−
204−--------------------------------------------------------------------------------
205−-- Advanced messaging --
206−--------------------------------------------------------------------------------
207−
208−-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
209−newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }
210−
211−-- | Test the matches in order against each message in the queue
212−receiveWait :: [Match b] -> Process b
213−receiveWait ms = do
214− queue <- processQueue <$> ask
215− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
216− proc
217−
218−-- | Like 'receiveWait' but with a timeout.
219−--
220−-- If the timeout is zero do a non-blocking check for matching messages. A
221−-- non-zero timeout is applied only when waiting for incoming messages (that is,
222−-- /after/ we have checked the messages that are already in the mailbox).
223−receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
224−receiveTimeout t ms = do
225− queue <- processQueue <$> ask
226− let blockSpec = if t == 0 then NonBlocking else Timeout t
227− mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)
228− case mProc of
229− Nothing -> return Nothing
230− Just proc -> Just <$> proc
231−
232−-- | Match against any message of the right type
233−match :: forall a b. Serializable a => (a -> Process b) -> Match b
234−match = matchIf (const True)
235−
236−-- | Match against any message of the right type that satisfies a predicate
237−matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
238−matchIf c p = Match $ \msg ->
239− let decoded :: a
240− decoded = decode . messageEncoding $ msg in
241− if messageFingerprint msg == fingerprint (undefined :: a) && c decoded
242− then Just $ p decoded
243− else Nothing
244−
245−-- | Remove any message from the queue
246−matchUnknown :: Process b -> Match b
247−matchUnknown = Match . const . Just
248−
249−--------------------------------------------------------------------------------
250−-- Process management --
251−--------------------------------------------------------------------------------
252−
253−-- | Thrown by 'terminate'
254−data ProcessTerminationException = ProcessTerminationException
255− deriving (Show, Typeable)
256−
257−instance Exception ProcessTerminationException
258−
259−-- | Terminate (throws a ProcessTerminationException)
260−terminate :: Process a
261−terminate = liftIO $ throw ProcessTerminationException
262−
263−-- | Our own process ID
264−getSelfPid :: Process ProcessId
265−getSelfPid = processId <$> ask
266−
267−-- | Get the node ID of our local node
268−getSelfNode :: Process NodeId
269−getSelfNode = localNodeId . processNode <$> ask
270−
271−--------------------------------------------------------------------------------
272−-- Monitoring and linking --
273−--------------------------------------------------------------------------------
274−
275−-- | Link to a remote process (asynchronous)
276−--
277−-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').
278−-- Linking makes no distinction between normal and abnormal termination of
279−-- the remote process.
280−link :: ProcessId -> Process ()
281−link = sendCtrlMsg Nothing . Link . ProcessIdentifier
282−
283−-- | Monitor another process (asynchronous)
284−monitor :: ProcessId -> Process MonitorRef
285−monitor = monitor' . ProcessIdentifier
286−
287−-- | Remove a link (synchronous)
288−unlink :: ProcessId -> Process ()
289−unlink pid = do
290− unlinkAsync pid
291− receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
292− (\_ -> return ())
293− ]
294−
295−-- | Remove a node link (synchronous)
296−unlinkNode :: NodeId -> Process ()
297−unlinkNode nid = do
298− unlinkNodeAsync nid
299− receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)
300− (\_ -> return ())
301− ]
302−
303−-- | Remove a channel (send port) link (synchronous)
304−unlinkPort :: SendPort a -> Process ()
305−unlinkPort sport = do
306− unlinkPortAsync sport
307− receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)
308− (\_ -> return ())
309− ]
310−
311−-- | Remove a monitor (synchronous)
312−unmonitor :: MonitorRef -> Process ()
313−unmonitor ref = do
314− unmonitorAsync ref
315− receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)
316− (\_ -> return ())
317− ]
318−
319−--------------------------------------------------------------------------------
320−-- Auxiliary API --
321−--------------------------------------------------------------------------------
322−
323−-- | Catch exceptions within a process
324−catch :: Exception e => Process a -> (e -> Process a) -> Process a
325−catch p h = do
326− lproc <- ask
327− liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
328−
329−-- | Like 'expect' but with a timeout
330−expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
331−expectTimeout timeout = receiveTimeout timeout [match return]
332−
333−-- | Asynchronous version of 'spawn'
334−--
335−-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
336−spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
337−spawnAsync nid proc = do
338− spawnRef <- getSpawnRef
339− sendCtrlMsg (Just nid) $ Spawn proc spawnRef
340− return spawnRef
341−
342−-- | Monitor a node
343−monitorNode :: NodeId -> Process MonitorRef
344−monitorNode =
345− monitor' . NodeIdentifier
346−
347−-- | Monitor a typed channel
348−monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
349−monitorPort (SendPort cid) =
350− monitor' (SendPortIdentifier cid)
351−
352−-- | Remove a monitor (asynchronous)
353−unmonitorAsync :: MonitorRef -> Process ()
354−unmonitorAsync =
355− sendCtrlMsg Nothing . Unmonitor
356−
357−-- | Link to a node
358−linkNode :: NodeId -> Process ()
359−linkNode = link' . NodeIdentifier
360−
361−-- | Link to a channel (send port)
362−linkPort :: SendPort a -> Process ()
363−linkPort (SendPort cid) =
364− link' (SendPortIdentifier cid)
365−
366−-- | Remove a process link (asynchronous)
367−unlinkAsync :: ProcessId -> Process ()
368−unlinkAsync =
369− sendCtrlMsg Nothing . Unlink . ProcessIdentifier
370−
371−-- | Remove a node link (asynchronous)
372−unlinkNodeAsync :: NodeId -> Process ()
373−unlinkNodeAsync =
374− sendCtrlMsg Nothing . Unlink . NodeIdentifier
375−
376−-- | Remove a channel (send port) link (asynchronous)
377−unlinkPortAsync :: SendPort a -> Process ()
378−unlinkPortAsync (SendPort cid) =
379− sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
380−
381−--------------------------------------------------------------------------------
382−-- Logging --
383−--------------------------------------------------------------------------------
384−
385−-- | Log a string
386−--
387−-- @say message@ sends a message (time, pid of the current process, message)
388−-- to the process registered as 'logger'. By default, this process simply
389−-- sends the string to 'stderr'. Individual Cloud Haskell backends might
390−-- replace this with a different logger process, however.
391−say :: String -> Process ()
392−say string = do
393− now <- liftIO getCurrentTime
394− us <- getSelfPid
395− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)
396−
397−--------------------------------------------------------------------------------
398−-- Registry --
399−--------------------------------------------------------------------------------
400−
401−-- | Register a process with the local registry (asynchronous).
402−--
403−-- The process to be registered does not have to be local itself.
404−register :: String -> ProcessId -> Process ()
405−register label pid =
406− sendCtrlMsg Nothing (Register label (Just pid))
407−
408−-- | Register a process with a remote registry (asynchronous).
409−--
410−-- The process to be registered does not have to live on the same remote node.
411−registerRemote :: NodeId -> String -> ProcessId -> Process ()
412−registerRemote nid label pid =
413− sendCtrlMsg (Just nid) (Register label (Just pid))
414−
415−-- | Remove a process from the local registry (asynchronous).
416−unregister :: String -> Process ()
417−unregister label =
418− sendCtrlMsg Nothing (Register label Nothing)
419−
420−-- | Remove a process from a remote registry (asynchronous).
421−unregisterRemote :: NodeId -> String -> Process ()
422−unregisterRemote nid label =
423− sendCtrlMsg (Just nid) (Register label Nothing)
424−
425−-- | Query the local process registry (synchronous).
426−whereis :: String -> Process (Maybe ProcessId)
427−whereis label = do
428− sendCtrlMsg Nothing (WhereIs label)
429− receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
430− (\(WhereIsReply _ mPid) -> return mPid)
431− ]
432−
433−-- | Query a remote process registry (synchronous)
434−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
435−whereisRemote nid label = do
436− whereisRemoteAsync nid label
437− receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
438− (\(WhereIsReply _ mPid) -> return mPid)
439− ]
440−
441−-- | Query a remote process registry (asynchronous)
442−--
443−-- Reply will come in the form of a 'WhereIsReply' message
444−whereisRemoteAsync :: NodeId -> String -> Process ()
445−whereisRemoteAsync nid label =
446− sendCtrlMsg (Just nid) (WhereIs label)
447−
448−-- | Named send to a process in the local registry (asynchronous)
449−nsend :: Serializable a => String -> a -> Process ()
450−nsend label msg =
451− sendCtrlMsg Nothing (NamedSend label (createMessage msg))
452−
453−-- | Named send to a process in a remote registry (asynchronous)
454−nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
455−nsendRemote nid label msg =
456− sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
457−
458−--------------------------------------------------------------------------------
459−-- Closures --
460−--------------------------------------------------------------------------------
461−
462−-- | Deserialize a closure
463−unClosure :: forall a. Typeable a => Closure a -> Process a
464−unClosure (Closure (Static label) env) = do
465− rtable <- remoteTable . processNode <$> ask
466− case resolveClosure rtable label env of
467− Nothing -> throw . userError $ "Unregistered closure " ++ show label
468− Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
469− where
470− typeError dyn = userError $ "lookupStatic type error: "
471− ++ "cannot match " ++ show (dynTypeRep dyn)
472− ++ " against " ++ show (typeOf (undefined :: a))
473−
474−--------------------------------------------------------------------------------
475−-- Auxiliary functions --
476−--------------------------------------------------------------------------------
477−
478−getMonitorRefFor :: Identifier -> Process MonitorRef
479−getMonitorRefFor ident = do
480− proc <- ask
481− liftIO $ modifyMVar (processState proc) $ \st -> do
482− let counter = st ^. monitorCounter
483− return ( monitorCounter ^: (+ 1) $ st
484− , MonitorRef ident counter
485− )
486−
487−getSpawnRef :: Process SpawnRef
488−getSpawnRef = do
489− proc <- ask
490− liftIO $ modifyMVar (processState proc) $ \st -> do
491− let counter = st ^. spawnCounter
492− return ( spawnCounter ^: (+ 1) $ st
493− , SpawnRef counter
494− )
495−
496−-- | Monitor a process/node/channel
497−monitor' :: Identifier -> Process MonitorRef
498−monitor' ident = do
499− monitorRef <- getMonitorRefFor ident
500− sendCtrlMsg Nothing $ Monitor monitorRef
501− return monitorRef
502−
503−-- | Link to a process/node/channel
504−link' :: Identifier -> Process ()
505−link' = sendCtrlMsg Nothing . Link
506−
507−-- Send a control message
508−sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
509− -> ProcessSignal -- ^ Message to send
510− -> Process ()
511−sendCtrlMsg mNid signal = do
512− proc <- ask
513− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
514− , ctrlMsgSignal = signal
515− }
516− case mNid of
517− Nothing -> do
518− ctrlChan <- localCtrlChan . processNode <$> ask
519− liftIO $ writeChan ctrlChan msg
520− Just nid ->
521− liftIO $ sendBinary (processNode proc)
522− (ProcessIdentifier (processId proc))
523− (NodeIdentifier nid)
524− msg
distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hsdeleted−33
@@ -1,33 +0,0 @@
1−-- | 'Binary' instances for 'TypeRep', and 'TypeRep' equality (bug workaround)
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where
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−
22−-- | Compare two type representations
23−--
24−-- For base >= 4.6 this compares fingerprints, but older versions of base
25−-- have a bug in the fingerprint construction
26−-- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)
27−compareTypeRep :: TypeRep -> TypeRep -> Bool
28−#if ! MIN_VERSION_base(4,6,0)
29−compareTypeRep (TypeRep _ con ts) (TypeRep _ con' ts')
30− = con == con' && all (uncurry compareTypeRep) (zip ts ts')
31−#else
32−compareTypeRep = (==)
33−#endif
distributed-process/src/Control/Distributed/Process/Internal/Types.hsdeleted−602
@@ -1,602 +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− , runLocalProcess
21− -- * Typed channels
22− , LocalSendPortId
23− , SendPortId(..)
24− , TypedChannel(..)
25− , SendPort(..)
26− , ReceivePort(..)
27− -- * Closures
28− , StaticLabel(..)
29− , Static(..)
30− , staticApply
31− , staticDuplicate
32− , staticTypeOf
33− , typeOfStaticLabel
34− , Closure(..)
35− , RemoteTable(..)
36− , SerializableDict(..)
37− -- * Messages
38− , Message(..)
39− , createMessage
40− , messageToPayload
41− , payloadToMessage
42− -- * Node controller user-visible data types
43− , MonitorRef(..)
44− , ProcessMonitorNotification(..)
45− , NodeMonitorNotification(..)
46− , PortMonitorNotification(..)
47− , ProcessLinkException(..)
48− , NodeLinkException(..)
49− , PortLinkException(..)
50− , DiedReason(..)
51− , DidUnmonitor(..)
52− , DidUnlinkProcess(..)
53− , DidUnlinkNode(..)
54− , DidUnlinkPort(..)
55− , SpawnRef(..)
56− , DidSpawn(..)
57− , WhereIsReply(..)
58− -- * Node controller internal data types
59− , NCMsg(..)
60− , ProcessSignal(..)
61− -- * Accessors
62− , localProcesses
63− , localPidCounter
64− , localPidUnique
65− , localConnections
66− , localProcessWithId
67− , localConnectionBetween
68− , monitorCounter
69− , spawnCounter
70− , channelCounter
71− , typedChannels
72− , typedChannelWithId
73− , remoteTableLabels
74− , remoteTableLabel
75− ) where
76−
77−import Data.Map (Map)
78−import Data.Int (Int32)
79−import Data.Maybe (fromJust)
80−import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)
81−import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
82−import qualified Data.ByteString as BSS (ByteString, concat)
83−import qualified Data.ByteString.Lazy as BSL
84− ( ByteString
85− , toChunks
86− , splitAt
87− , fromChunks
88− )
89−import Data.Accessor (Accessor, accessor)
90−import qualified Data.Accessor.Container as DAC (mapMaybe)
91−import Control.Category ((>>>))
92−import Control.Exception (Exception)
93−import Control.Concurrent (ThreadId)
94−import Control.Concurrent.MVar (MVar)
95−import Control.Concurrent.Chan (Chan)
96−import Control.Concurrent.STM (TChan, TVar)
97−import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
98−import Control.Applicative (Applicative, (<$>), (<*>))
99−import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
100−import Control.Monad.IO.Class (MonadIO)
101−import Control.Distributed.Process.Serializable
102− ( Fingerprint
103− , Serializable
104− , fingerprint
105− , encodeFingerprint
106− , sizeOfFingerprint
107− , decodeFingerprint
108− , showFingerprint
109− )
110−import Control.Distributed.Process.Internal.CQueue (CQueue)
111−import Control.Distributed.Process.Internal.Dynamic (Dynamic)
112−import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
113−
114−--------------------------------------------------------------------------------
115−-- Node and process identifiers --
116−--------------------------------------------------------------------------------
117−
118−-- | Node identifier
119−newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
120− deriving (Eq, Ord, Binary)
121−
122−instance Show NodeId where
123− show (NodeId addr) = "nid://" ++ show addr
124−
125−-- | A local process ID consists of a seed which distinguishes processes from
126−-- different instances of the same local node and a counter
127−data LocalProcessId = LocalProcessId
128− { lpidUnique :: Int32
129− , lpidCounter :: Int32
130− }
131− deriving (Eq, Ord, Typeable, Show)
132−
133−-- | Process identifier
134−data ProcessId = ProcessId
135− { -- | The ID of the node the process is running on
136− processNodeId :: NodeId
137− -- | Node-local identifier for the process
138− , processLocalId :: LocalProcessId
139− }
140− deriving (Eq, Ord, Typeable)
141−
142−instance Show ProcessId where
143− show (ProcessId (NodeId addr) (LocalProcessId _ lid))
144− = "pid://" ++ show addr ++ ":" ++ show lid
145−
146−-- | Union of all kinds of identifiers
147−data Identifier =
148− NodeIdentifier NodeId
149− | ProcessIdentifier ProcessId
150− | SendPortIdentifier SendPortId
151− deriving (Eq, Ord)
152−
153−instance Show Identifier where
154− show (NodeIdentifier nid) = show nid
155− show (ProcessIdentifier pid) = show pid
156− show (SendPortIdentifier cid) = show cid
157−
158−nodeOf :: Identifier -> NodeId
159−nodeOf (NodeIdentifier nid) = nid
160−nodeOf (ProcessIdentifier pid) = processNodeId pid
161−nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)
162−
163−--------------------------------------------------------------------------------
164−-- Local nodes and processes --
165−--------------------------------------------------------------------------------
166−
167−-- | Local nodes
168−data LocalNode = LocalNode
169− { -- | 'NodeId' of the node
170− localNodeId :: NodeId
171− -- | The network endpoint associated with this node
172− , localEndPoint :: NT.EndPoint
173− -- | Local node state
174− , localState :: MVar LocalNodeState
175− -- | Channel for the node controller
176− , localCtrlChan :: Chan NCMsg
177− -- | Runtime lookup table for supporting closures
178− -- TODO: this should be part of the CH state, not the local endpoint state
179− , remoteTable :: RemoteTable
180− }
181−
182−-- | Local node state
183−data LocalNodeState = LocalNodeState
184− { _localProcesses :: Map LocalProcessId LocalProcess
185− , _localPidCounter :: Int32
186− , _localPidUnique :: Int32
187− , _localConnections :: Map (Identifier, Identifier) NT.Connection
188− }
189−
190−-- | Processes running on our local node
191−data LocalProcess = LocalProcess
192− { processQueue :: CQueue Message
193− , processId :: ProcessId
194− , processState :: MVar LocalProcessState
195− , processThread :: ThreadId
196− , processNode :: LocalNode
197− }
198−
199−-- | Deconstructor for 'Process' (not exported to the public API)
200−runLocalProcess :: LocalProcess -> Process a -> IO a
201−runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
202−
203−-- | Local process state
204−data LocalProcessState = LocalProcessState
205− { _monitorCounter :: Int32
206− , _spawnCounter :: Int32
207− , _channelCounter :: Int32
208− , _typedChannels :: Map LocalSendPortId TypedChannel
209− }
210−
211−-- | The Cloud Haskell 'Process' type
212−newtype Process a = Process {
213− unProcess :: ReaderT LocalProcess IO a
214− }
215− deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
216−
217−--------------------------------------------------------------------------------
218−-- Typed channels --
219−--------------------------------------------------------------------------------
220−
221−type LocalSendPortId = Int32
222−
223−-- | A send port is identified by a SendPortId.
224−--
225−-- You cannot send directly to a SendPortId; instead, use 'newChan'
226−-- to create a SendPort.
227−data SendPortId = SendPortId {
228− -- | The ID of the process that will receive messages sent on this port
229− sendPortProcessId :: ProcessId
230− -- | Process-local ID of the channel
231− , sendPortLocalId :: LocalSendPortId
232− }
233− deriving (Eq, Ord)
234−
235−instance Show SendPortId where
236− show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
237− = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
238−
239−data TypedChannel = forall a. Serializable a => TypedChannel (TChan a)
240−
241−-- | The send send of a typed channel (serializable)
242−newtype SendPort a = SendPort {
243− -- | The (unique) ID of this send port
244− sendPortId :: SendPortId
245− }
246− deriving (Typeable, Binary, Show, Eq, Ord)
247−
248−-- | The receive end of a typed channel (not serializable)
249−data ReceivePort a =
250− -- | A single receive port
251− ReceivePortSingle (TChan a)
252− -- | A left-biased combination of receive ports
253− | ReceivePortBiased [ReceivePort a]
254− -- | A round-robin combination of receive ports
255− | ReceivePortRR (TVar [ReceivePort a])
256− deriving Typeable
257−
258−--------------------------------------------------------------------------------
259−-- Closures --
260−--------------------------------------------------------------------------------
261−
262−data StaticLabel =
263− StaticLabel String TypeRep
264− | StaticApply StaticLabel StaticLabel
265− | StaticDuplicate StaticLabel TypeRep
266− deriving (Typeable, Show)
267−
268−-- | A static value is top-level bound or the application of two static values
269−newtype Static a = Static StaticLabel
270− deriving (Typeable, Show)
271−
272−-- | Apply two static values
273−staticApply :: Static (a -> b) -> Static a -> Static b
274−staticApply (Static f) (Static x) = Static (StaticApply f x)
275−
276−-- | Co-monadic 'duplicate' for static values
277−staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)
278−staticDuplicate (Static x) =
279− Static (StaticDuplicate x (typeOf (undefined :: Static a)))
280−
281−staticTypeOf :: forall a. Typeable a => a -> Static a
282−staticTypeOf _ = Static (StaticLabel "undefined" (typeOf (undefined :: a)))
283−
284−typeOfStaticLabel :: StaticLabel -> TypeRep
285−typeOfStaticLabel (StaticLabel _ typ)
286− = typ
287−typeOfStaticLabel (StaticApply f x)
288− = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)
289−typeOfStaticLabel (StaticDuplicate _ typ)
290− = typ
291−
292−-- | A closure is a static value and an encoded environment
293−data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString
294− deriving (Typeable, Show)
295−
296−-- | Runtime dictionary for 'unstatic' lookups
297−data RemoteTable = RemoteTable {
298− _remoteTableLabels :: Map String Dynamic
299− }
300−
301−-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")
302−data SerializableDict a where
303− SerializableDict :: Serializable a => SerializableDict a
304− deriving (Typeable)
305−
306−--------------------------------------------------------------------------------
307−-- Messages --
308−--------------------------------------------------------------------------------
309−
310−-- | Messages consist of their typeRep fingerprint and their encoding
311−data Message = Message
312− { messageFingerprint :: Fingerprint
313− , messageEncoding :: BSL.ByteString
314− }
315−
316−instance Show Message where
317− show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
318−
319−-- | Turn any serialiable term into a message
320−createMessage :: Serializable a => a -> Message
321−createMessage a = Message (fingerprint a) (encode a)
322−
323−-- | Serialize a message
324−messageToPayload :: Message -> [BSS.ByteString]
325−messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc
326−
327−-- | Deserialize a message
328−payloadToMessage :: [BSS.ByteString] -> Message
329−payloadToMessage payload = Message fp msg
330− where
331− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
332− $ BSL.fromChunks payload
333− fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
334−
335−--------------------------------------------------------------------------------
336−-- Node controller user-visible data types --
337−--------------------------------------------------------------------------------
338−
339−-- | MonitorRef is opaque for regular Cloud Haskell processes
340−data MonitorRef = MonitorRef
341− { -- | ID of the entity to be monitored
342− monitorRefIdent :: Identifier
343− -- | Unique to distinguish multiple monitor requests by the same process
344− , monitorRefCounter :: Int32
345− }
346− deriving (Eq, Ord, Show)
347−
348−-- | Message sent by process monitors
349−data ProcessMonitorNotification =
350− ProcessMonitorNotification MonitorRef ProcessId DiedReason
351− deriving (Typeable, Show)
352−
353−-- | Message sent by node monitors
354−data NodeMonitorNotification =
355− NodeMonitorNotification MonitorRef NodeId DiedReason
356− deriving (Typeable, Show)
357−
358−-- | Message sent by channel (port) monitors
359−data PortMonitorNotification =
360− PortMonitorNotification MonitorRef SendPortId DiedReason
361− deriving (Typeable, Show)
362−
363−-- | Exceptions thrown when a linked process dies
364−data ProcessLinkException =
365− ProcessLinkException ProcessId DiedReason
366− deriving (Typeable, Show)
367−
368−-- | Exception thrown when a linked node dies
369−data NodeLinkException =
370− NodeLinkException NodeId DiedReason
371− deriving (Typeable, Show)
372−
373−-- | Exception thrown when a linked channel (port) dies
374−data PortLinkException =
375− PortLinkException SendPortId DiedReason
376− deriving (Typeable, Show)
377−
378−instance Exception ProcessLinkException
379−instance Exception NodeLinkException
380−instance Exception PortLinkException
381−
382−-- | Why did a process die?
383−data DiedReason =
384− -- | Normal termination
385− DiedNormal
386− -- | The process exited with an exception
387− -- (provided as 'String' because 'Exception' does not implement 'Binary')
388− | DiedException String
389− -- | We got disconnected from the process node
390− | DiedDisconnect
391− -- | The process node died
392− | DiedNodeDown
393− -- | Invalid (process/node/channel) identifier
394− | DiedUnknownId
395− deriving (Show, Eq)
396−
397−-- | (Asynchronous) reply from unmonitor
398−newtype DidUnmonitor = DidUnmonitor MonitorRef
399− deriving (Typeable, Binary)
400−
401−-- | (Asynchronous) reply from unlink
402−newtype DidUnlinkProcess = DidUnlinkProcess ProcessId
403− deriving (Typeable, Binary)
404−
405−-- | (Asynchronous) reply from unlinkNode
406−newtype DidUnlinkNode = DidUnlinkNode NodeId
407− deriving (Typeable, Binary)
408−
409−-- | (Asynchronous) reply from unlinkPort
410−newtype DidUnlinkPort = DidUnlinkPort SendPortId
411− deriving (Typeable, Binary)
412−
413−-- | 'SpawnRef' are used to return pids of spawned processes
414−newtype SpawnRef = SpawnRef Int32
415− deriving (Show, Binary, Typeable, Eq)
416−
417−-- | (Asynchronius) reply from 'spawn'
418−data DidSpawn = DidSpawn SpawnRef ProcessId
419− deriving (Show, Typeable)
420−
421−-- | (Asynchronous) reply from 'whereis'
422−data WhereIsReply = WhereIsReply String (Maybe ProcessId)
423− deriving (Show, Typeable)
424−
425−--------------------------------------------------------------------------------
426−-- Node controller internal data types --
427−--------------------------------------------------------------------------------
428−
429−-- | Messages to the node controller
430−data NCMsg = NCMsg
431− { ctrlMsgSender :: Identifier
432− , ctrlMsgSignal :: ProcessSignal
433− }
434− deriving Show
435−
436−-- | Signals to the node controller (see 'NCMsg')
437−data ProcessSignal =
438− Link Identifier
439− | Unlink Identifier
440− | Monitor MonitorRef
441− | Unmonitor MonitorRef
442− | Died Identifier DiedReason
443− | Spawn (Closure (Process ())) SpawnRef
444− | WhereIs String
445− | Register String (Maybe ProcessId) -- Nothing to unregister
446− | NamedSend String Message
447− deriving Show
448−
449−--------------------------------------------------------------------------------
450−-- Binary instances --
451−--------------------------------------------------------------------------------
452−
453−instance Binary LocalProcessId where
454− put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
455− get = LocalProcessId <$> get <*> get
456−
457−instance Binary ProcessId where
458− put pid = put (processNodeId pid) >> put (processLocalId pid)
459− get = ProcessId <$> get <*> get
460−
461−instance Binary ProcessMonitorNotification where
462− put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
463− get = ProcessMonitorNotification <$> get <*> get <*> get
464−
465−instance Binary NodeMonitorNotification where
466− put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason
467− get = NodeMonitorNotification <$> get <*> get <*> get
468−
469−instance Binary PortMonitorNotification where
470− put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason
471− get = PortMonitorNotification <$> get <*> get <*> get
472−
473−instance Binary NCMsg where
474− put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)
475− get = NCMsg <$> get <*> get
476−
477−instance Binary MonitorRef where
478− put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)
479− get = MonitorRef <$> get <*> get
480−
481−instance Binary ProcessSignal where
482− put (Link pid) = putWord8 0 >> put pid
483− put (Unlink pid) = putWord8 1 >> put pid
484− put (Monitor ref) = putWord8 2 >> put ref
485− put (Unmonitor ref) = putWord8 3 >> put ref
486− put (Died who reason) = putWord8 4 >> put who >> put reason
487− put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
488− put (WhereIs label) = putWord8 6 >> put label
489− put (Register label pid) = putWord8 7 >> put label >> put pid
490− put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
491− get = do
492− header <- getWord8
493− case header of
494− 0 -> Link <$> get
495− 1 -> Unlink <$> get
496− 2 -> Monitor <$> get
497− 3 -> Unmonitor <$> get
498− 4 -> Died <$> get <*> get
499− 5 -> Spawn <$> get <*> get
500− 6 -> WhereIs <$> get
501− 7 -> Register <$> get <*> get
502− 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
503− _ -> fail "ProcessSignal.get: invalid"
504−
505−instance Binary DiedReason where
506− put DiedNormal = putWord8 0
507− put (DiedException e) = putWord8 1 >> put e
508− put DiedDisconnect = putWord8 2
509− put DiedNodeDown = putWord8 3
510− put DiedUnknownId = putWord8 4
511− get = do
512− header <- getWord8
513− case header of
514− 0 -> return DiedNormal
515− 1 -> DiedException <$> get
516− 2 -> return DiedDisconnect
517− 3 -> return DiedNodeDown
518− 4 -> return DiedUnknownId
519− _ -> fail "DiedReason.get: invalid"
520−
521−instance Binary (Closure a) where
522− put (Closure (Static label) env) = put label >> put env
523− get = Closure <$> (Static <$> get) <*> get
524−
525−instance Binary DidSpawn where
526− put (DidSpawn ref pid) = put ref >> put pid
527− get = DidSpawn <$> get <*> get
528−
529−instance Binary SendPortId where
530− put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
531− get = SendPortId <$> get <*> get
532−
533−instance Binary Identifier where
534− put (ProcessIdentifier pid) = putWord8 0 >> put pid
535− put (NodeIdentifier nid) = putWord8 1 >> put nid
536− put (SendPortIdentifier cid) = putWord8 2 >> put cid
537− get = do
538− header <- getWord8
539− case header of
540− 0 -> ProcessIdentifier <$> get
541− 1 -> NodeIdentifier <$> get
542− 2 -> SendPortIdentifier <$> get
543− _ -> fail "Identifier.get: invalid"
544−
545−instance Binary StaticLabel where
546− put (StaticLabel string typ) = putWord8 0 >> put string >> put typ
547− put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2
548− put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ
549− get = do
550− header <- getWord8
551− case header of
552− 0 -> StaticLabel <$> get <*> get
553− 1 -> StaticApply <$> get <*> get
554− 2 -> StaticDuplicate <$> get <*> get
555− _ -> fail "StaticLabel.get: invalid"
556−
557−instance Binary WhereIsReply where
558− put (WhereIsReply label mPid) = put label >> put mPid
559− get = WhereIsReply <$> get <*> get
560−
561−--------------------------------------------------------------------------------
562−-- Accessors --
563−--------------------------------------------------------------------------------
564−
565−localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)
566−localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })
567−
568−localPidCounter :: Accessor LocalNodeState Int32
569−localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })
570−
571−localPidUnique :: Accessor LocalNodeState Int32
572−localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
573−
574−localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) NT.Connection)
575−localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })
576−
577−localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
578−localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
579−
580−localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe NT.Connection)
581−localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)
582−
583−monitorCounter :: Accessor LocalProcessState Int32
584−monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
585−
586−spawnCounter :: Accessor LocalProcessState Int32
587−spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })
588−
589−channelCounter :: Accessor LocalProcessState LocalSendPortId
590−channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })
591−
592−typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)
593−typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })
594−
595−typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)
596−typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid
597−
598−remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)
599−remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })
600−
601−remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
602−remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label
distributed-process/src/Control/Distributed/Process/Node.hsdeleted−722
@@ -1,722 +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−
13−#if ! MIN_VERSION_base(4,6,0)
14−import Prelude hiding (catch)
15−#endif
16−
17−import System.IO (fixIO, hPutStrLn, stderr)
18−import qualified Data.ByteString.Lazy as BSL (fromChunks)
19−import Data.Binary (decode)
20−import Data.Map (Map)
21−import qualified Data.Map as Map
22− ( empty
23− , lookup
24− , insert
25− , delete
26− , toList
27− , partitionWithKey
28− , filterWithKey
29− )
30−import qualified Data.List as List (delete, (\\))
31−import Data.Set (Set)
32−import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)
33−import Data.Foldable (forM_)
34−import Data.Maybe (isJust, fromMaybe)
35−import Data.Typeable (Typeable)
36−import Control.Category ((>>>))
37−import Control.Applicative ((<$>))
38−import Control.Monad (void, when, forever)
39−import Control.Monad.IO.Class (MonadIO, liftIO)
40−import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
41−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
42−import Control.Exception (throwIO, SomeException, Exception, throwTo)
43−import qualified Control.Exception as Exception (catch)
44−import Control.Concurrent (forkIO)
45−import Control.Concurrent.MVar
46− ( newMVar
47− , withMVar
48− , modifyMVar
49− , modifyMVar_
50− , newEmptyMVar
51− , putMVar
52− , takeMVar
53− )
54−import Control.Concurrent.Chan (newChan, writeChan, readChan)
55−import Control.Concurrent.STM (atomically, writeTChan)
56−import Control.Distributed.Process.Internal.CQueue (enqueue, newCQueue)
57−import qualified Network.Transport as NT
58− ( Transport
59− , EndPoint
60− , newEndPoint
61− , receive
62− , Event(..)
63− , EventErrorCode(..)
64− , TransportError(..)
65− , address
66− , closeEndPoint
67− , ConnectionId
68− )
69−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
70−import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)
71−import System.Random (randomIO)
72−import Control.Distributed.Process.Internal.Types
73− ( RemoteTable
74− , NodeId(..)
75− , LocalProcessId(..)
76− , ProcessId(..)
77− , LocalNode(..)
78− , LocalNodeState(..)
79− , LocalProcess(..)
80− , LocalProcessState(..)
81− , Process(..)
82− , DiedReason(..)
83− , NCMsg(..)
84− , ProcessSignal(..)
85− , localPidCounter
86− , localPidUnique
87− , localProcessWithId
88− , MonitorRef(..)
89− , ProcessMonitorNotification(..)
90− , NodeMonitorNotification(..)
91− , PortMonitorNotification(..)
92− , ProcessLinkException(..)
93− , NodeLinkException(..)
94− , PortLinkException(..)
95− , DidUnmonitor(..)
96− , DidUnlinkProcess(..)
97− , DidUnlinkNode(..)
98− , DidUnlinkPort(..)
99− , SpawnRef
100− , DidSpawn(..)
101− , Closure(..)
102− , Static(..)
103− , Message
104− , TypedChannel(..)
105− , Identifier(..)
106− , nodeOf
107− , SendPortId(..)
108− , typedChannelWithId
109− , WhereIsReply(..)
110− , messageToPayload
111− , RemoteTable(..)
112− , payloadToMessage
113− , createMessage
114− , runLocalProcess
115− )
116−import Control.Distributed.Process.Serializable (Serializable)
117−import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
118−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
119−import Control.Distributed.Process.Internal.Node
120− ( sendBinary
121− , sendMessage
122− , sendPayload
123− )
124−import Control.Distributed.Process.Internal.Primitives (expect, register)
125−import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
126−import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
127−
128−--------------------------------------------------------------------------------
129−-- Initialization --
130−--------------------------------------------------------------------------------
131−
132−initRemoteTable :: RemoteTable
133−initRemoteTable = Static.__remoteTable
134− . CP.__remoteTable
135− $ RemoteTable Map.empty
136−
137−-- | Initialize a new local node.
138−--
139−-- Note that proper Cloud Haskell initialization and configuration is still
140−-- to do.
141−newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode
142−newLocalNode transport rtable = do
143− mEndPoint <- NT.newEndPoint transport
144− case mEndPoint of
145− Left ex -> throwIO ex
146− Right endPoint -> do
147− localNode <- createBareLocalNode endPoint rtable
148− startServiceProcesses localNode
149− return localNode
150−
151−-- | Create a new local node (without any service processes running)
152−createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
153−createBareLocalNode endPoint rtable = do
154− unq <- randomIO
155− state <- newMVar LocalNodeState
156− { _localProcesses = Map.empty
157− , _localPidCounter = 0
158− , _localPidUnique = unq
159− , _localConnections = Map.empty
160− }
161− ctrlChan <- newChan
162− let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
163− , localEndPoint = endPoint
164− , localState = state
165− , localCtrlChan = ctrlChan
166− , remoteTable = rtable
167− }
168− void . forkIO $ runNodeController node
169− void . forkIO $ handleIncomingMessages node
170− return node
171−
172−-- | Start and register the service processes on a node
173−-- (for now, this is only the logger)
174−startServiceProcesses :: LocalNode -> IO ()
175−startServiceProcesses node = do
176− logger <- forkProcess node . forever $ do
177− (time, pid, string) <- expect :: Process (String, ProcessId, String)
178− liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
179− runProcess node $ register "logger" logger
180−
181−-- | Force-close a local node
182−--
183−-- TODO: for now we just close the associated endpoint
184−closeLocalNode :: LocalNode -> IO ()
185−closeLocalNode node =
186− NT.closeEndPoint (localEndPoint node)
187−
188−-- | Run a process on a local node and wait for it to finish
189−runProcess :: LocalNode -> Process () -> IO ()
190−runProcess node proc = do
191− done <- newEmptyMVar
192− void $ forkProcess node (proc >> liftIO (putMVar done ()))
193− takeMVar done
194−
195−-- | Spawn a new process on a local node
196−forkProcess :: LocalNode -> Process () -> IO ProcessId
197−forkProcess node proc = modifyMVar (localState node) $ \st -> do
198− let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter
199− , lpidUnique = st ^. localPidUnique
200− }
201− let pid = ProcessId { processNodeId = localNodeId node
202− , processLocalId = lpid
203− }
204− pst <- newMVar LocalProcessState { _monitorCounter = 0
205− , _spawnCounter = 0
206− , _channelCounter = 0
207− , _typedChannels = Map.empty
208− }
209− queue <- newCQueue
210− (_, lproc) <- fixIO $ \ ~(tid, _) -> do
211− let lproc = LocalProcess { processQueue = queue
212− , processId = pid
213− , processState = pst
214− , processThread = tid
215− , processNode = node
216− }
217− tid' <- forkIO $ do
218− reason <- Exception.catch
219− (runLocalProcess lproc proc >> return DiedNormal)
220− (return . DiedException . (show :: SomeException -> String))
221− -- [Unified: Table 4, rules termination and exiting]
222− modifyMVar_ (localState node) $
223− return . (localProcessWithId lpid ^= Nothing)
224− writeChan (localCtrlChan node) NCMsg
225− { ctrlMsgSender = ProcessIdentifier pid
226− , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
227− }
228− return (tid', lproc)
229−
230− if lpidCounter lpid == maxBound
231− then do
232− newUnique <- randomIO
233− return ( (localProcessWithId lpid ^= Just lproc)
234− . (localPidCounter ^= 0)
235− . (localPidUnique ^= newUnique)
236− $ st
237− , pid
238− )
239− else
240− return ( (localProcessWithId lpid ^= Just lproc)
241− . (localPidCounter ^: (+ 1))
242− $ st
243− , pid
244− )
245−
246−handleIncomingMessages :: LocalNode -> IO ()
247−handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
248− where
249− go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know
250− -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes
251− -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels
252− -> Set NT.ConnectionId -- ^ Connections to our controller
253− -> IO ()
254− go uninitConns procs chans ctrls = do
255− event <- NT.receive endpoint
256− case event of
257− NT.ConnectionOpened cid _rel _theirAddr ->
258− -- TODO: Check if _rel is ReliableOrdered, and if not, treat as
259− -- (**) below.
260− go (cid : uninitConns) procs chans ctrls
261− NT.Received cid payload ->
262− case ( Map.lookup cid procs
263− , Map.lookup cid chans
264− , cid `Set.member` ctrls
265− , cid `elem` uninitConns
266− ) of
267− (Just proc, _, _, _) -> do
268− let msg = payloadToMessage payload
269− enqueue (processQueue proc) msg
270− go uninitConns procs chans ctrls
271− (_, Just (TypedChannel chan), _, _) -> do
272− atomically $ writeTChan chan . decode . BSL.fromChunks $ payload
273− go uninitConns procs chans ctrls
274− (_, _, True, _) -> do
275− let ctrlMsg = decode . BSL.fromChunks $ payload
276− writeChan ctrlChan ctrlMsg
277− go uninitConns procs chans ctrls
278− (_, _, _, True) ->
279− case decode (BSL.fromChunks payload) of
280− ProcessIdentifier pid -> do
281− let lpid = processLocalId pid
282− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
283− case mProc of
284− Just proc ->
285− go (List.delete cid uninitConns)
286− (Map.insert cid proc procs)
287− chans
288− ctrls
289− Nothing ->
290− -- Request for an unknown process.
291− --
292− -- TODO: We should treat this as a fatal error on the
293− -- part of the remote node. That is, we should report the
294− -- remote node as having died, and we should close
295− -- incoming connections (this requires a Transport layer
296− -- extension). (**)
297− go (List.delete cid uninitConns) procs chans ctrls
298− SendPortIdentifier chId -> do
299− let lcid = sendPortLocalId chId
300− lpid = processLocalId (sendPortProcessId chId)
301− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
302− case mProc of
303− Just proc -> do
304− mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
305− case mChannel of
306− Just channel ->
307− go (List.delete cid uninitConns)
308− procs
309− (Map.insert cid channel chans)
310− ctrls
311− Nothing ->
312− -- Unknown typed channel
313− -- TODO (**) above
314− go (List.delete cid uninitConns) procs chans ctrls
315− Nothing ->
316− -- Unknown process
317− -- TODO (**) above
318− go (List.delete cid uninitConns) procs chans ctrls
319− NodeIdentifier _ ->
320− go (List.delete cid uninitConns)
321− procs
322− chans
323− (Set.insert cid ctrls)
324− _ ->
325− -- Unexpected message
326− -- TODO (**) above
327− go uninitConns procs chans ctrls
328− NT.ConnectionClosed cid ->
329− go (List.delete cid uninitConns)
330− (Map.delete cid procs)
331− (Map.delete cid chans)
332− (Set.delete cid ctrls)
333− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost (Just theirAddr) cids) _) -> do
334− -- [Unified table 9, rule node_disconnect]
335− let nid = NodeIdentifier $ NodeId theirAddr
336− writeChan ctrlChan NCMsg
337− { ctrlMsgSender = nid
338− , ctrlMsgSignal = Died nid DiedDisconnect
339− }
340− go (uninitConns List.\\ cids)
341− (Map.filterWithKey (\k _ -> k `notElem` cids) procs)
342− (Map.filterWithKey (\k _ -> k `notElem` cids) chans)
343− (ctrls Set.\\ Set.fromList cids)
344− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->
345− -- TODO: We should treat an asymetrical connection loss (incoming
346− -- connection broken, but outgoing connection still potentially ok)
347− -- as a fatal error on the part of the remote node (like (**), above)
348− fail "handleIncomingMessages: TODO"
349− NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
350− fail $ "Cloud Haskell fatal error: end point failed: " ++ str
351− NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
352− fail $ "Cloud Haskell fatal error: transport failed: " ++ str
353− NT.EndPointClosed ->
354− return ()
355− NT.ReceivedMulticast _ _ ->
356− -- If we received a multicast message, something went horribly wrong
357− -- and we just give up
358− fail "Cloud Haskell fatal error: received unexpected multicast"
359−
360− state = localState node
361− endpoint = localEndPoint node
362− ctrlChan = localCtrlChan node
363−
364−--------------------------------------------------------------------------------
365−-- Top-level access to the node controller --
366−--------------------------------------------------------------------------------
367−
368−runNodeController :: LocalNode -> IO ()
369−runNodeController =
370− runReaderT (evalStateT (unNC nodeController) initNCState)
371−
372−--------------------------------------------------------------------------------
373−-- Internal data types --
374−--------------------------------------------------------------------------------
375−
376−data NCState = NCState
377− { -- Mapping from remote processes to linked local processes
378− _links :: Map Identifier (Set ProcessId)
379− -- Mapping from remote processes to monitoring local processes
380− , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))
381− -- Process registry
382− , _registry :: Map String ProcessId
383− }
384−
385−newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }
386− deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)
387−
388−initNCState :: NCState
389−initNCState = NCState { _links = Map.empty
390− , _monitors = Map.empty
391− , _registry = Map.empty
392− }
393−
394−--------------------------------------------------------------------------------
395−-- Core functionality --
396−--------------------------------------------------------------------------------
397−
398−-- [Unified: Table 7]
399−nodeController :: NC ()
400−nodeController = do
401− node <- ask
402− forever $ do
403− msg <- liftIO $ readChan (localCtrlChan node)
404−
405− -- [Unified: Table 7, rule nc_forward]
406− case destNid (ctrlMsgSignal msg) of
407− Just nid' | nid' /= localNodeId node ->
408− liftIO $ sendBinary node
409− (ctrlMsgSender msg)
410− (NodeIdentifier nid')
411− msg
412− _ ->
413− return ()
414−
415− case msg of
416− NCMsg (ProcessIdentifier from) (Link them) ->
417− ncEffectMonitor from them Nothing
418− NCMsg (ProcessIdentifier from) (Monitor ref) ->
419− ncEffectMonitor from (monitorRefIdent ref) (Just ref)
420− NCMsg (ProcessIdentifier from) (Unlink them) ->
421− ncEffectUnlink from them
422− NCMsg (ProcessIdentifier from) (Unmonitor ref) ->
423− ncEffectUnmonitor from ref
424− NCMsg _from (Died ident reason) ->
425− ncEffectDied ident reason
426− NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
427− ncEffectSpawn from proc ref
428− NCMsg _from (Register label pid) ->
429− ncEffectRegister label pid
430− NCMsg (ProcessIdentifier from) (WhereIs label) ->
431− ncEffectWhereIs from label
432− NCMsg from (NamedSend label msg') ->
433− ncEffectNamedSend from label msg'
434− unexpected ->
435− error $ "nodeController: unexpected message " ++ show unexpected
436−
437−-- [Unified: Table 10]
438−ncEffectMonitor :: ProcessId -- ^ Who's watching?
439− -> Identifier -- ^ Who's being watched?
440− -> Maybe MonitorRef -- ^ 'Nothing' to link
441− -> NC ()
442−ncEffectMonitor from them mRef = do
443− node <- ask
444− shouldLink <-
445− if not (isLocal node them)
446− then return True
447− else isValidLocalIdentifier them
448− case (shouldLink, isLocal node (ProcessIdentifier from)) of
449− (True, _) -> -- [Unified: first rule]
450− case mRef of
451− Just ref -> modify $ monitorsFor them ^: Set.insert (from, ref)
452− Nothing -> modify $ linksFor them ^: Set.insert from
453− (False, True) -> -- [Unified: second rule]
454− notifyDied from them DiedUnknownId mRef
455− (False, False) -> -- [Unified: third rule]
456− -- TODO: this is the right sender according to the Unified semantics,
457− -- but perhaps having 'them' as the sender would make more sense
458− -- (see also: notifyDied)
459− liftIO $ sendBinary node
460− (NodeIdentifier $ localNodeId node)
461− (NodeIdentifier $ processNodeId from)
462− NCMsg
463− { ctrlMsgSender = NodeIdentifier (localNodeId node)
464− , ctrlMsgSignal = Died them DiedUnknownId
465− }
466−
467−-- [Unified: Table 11]
468−ncEffectUnlink :: ProcessId -> Identifier -> NC ()
469−ncEffectUnlink from them = do
470− node <- ask
471− when (isLocal node (ProcessIdentifier from)) $
472− case them of
473− ProcessIdentifier pid ->
474− postAsMessage from $ DidUnlinkProcess pid
475− NodeIdentifier nid ->
476− postAsMessage from $ DidUnlinkNode nid
477− SendPortIdentifier cid ->
478− postAsMessage from $ DidUnlinkPort cid
479− modify $ linksFor them ^: Set.delete from
480−
481−-- [Unified: Table 11]
482−ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
483−ncEffectUnmonitor from ref = do
484− node <- ask
485− when (isLocal node (ProcessIdentifier from)) $
486− postAsMessage from $ DidUnmonitor ref
487− modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
488−
489−-- [Unified: Table 12]
490−ncEffectDied :: Identifier -> DiedReason -> NC ()
491−ncEffectDied ident reason = do
492− node <- ask
493− (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
494− (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
495−
496− let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False
497−
498− forM_ (Map.toList affectedLinks) $ \(them, uss) ->
499− forM_ uss $ \us ->
500− when (localOnly <= isLocal node (ProcessIdentifier us)) $
501− notifyDied us them reason Nothing
502−
503− forM_ (Map.toList affectedMons) $ \(them, refs) ->
504− forM_ refs $ \(us, ref) ->
505− when (localOnly <= isLocal node (ProcessIdentifier us)) $
506− notifyDied us them reason (Just ref)
507−
508− modify $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)
509−
510−-- [Unified: Table 13]
511−ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
512−ncEffectSpawn pid cProc ref = do
513− mProc <- unClosure cProc
514− -- If the closure does not exist, we spawn a process that throws an exception
515− -- This allows the remote node to find out what's happening
516− let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
517− node <- ask
518− pid' <- liftIO $ forkProcess node proc
519− liftIO $ sendMessage node
520− (NodeIdentifier (localNodeId node))
521− (ProcessIdentifier pid)
522− (DidSpawn ref pid')
523−
524−-- Unified semantics does not explicitly describe how to implement 'register',
525−-- but mentions it's "very similar to nsend" (Table 14)
526−ncEffectRegister :: String -> Maybe ProcessId -> NC ()
527−ncEffectRegister label mPid =
528− modify $ registryFor label ^= mPid
529− -- An acknowledgement is not necessary. If we want a synchronous register,
530− -- it suffices to send a whereis requiry immediately after the register
531− -- (that may not suffice if we do decide for unreliable messaging instead)
532−
533−-- Unified semantics does not explicitly describe 'whereis'
534−ncEffectWhereIs :: ProcessId -> String -> NC ()
535−ncEffectWhereIs from label = do
536− node <- ask
537− mPid <- gets (^. registryFor label)
538− liftIO $ sendMessage node
539− (NodeIdentifier (localNodeId node))
540− (ProcessIdentifier from)
541− (WhereIsReply label mPid)
542−
543−-- [Unified: Table 14]
544−ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
545−ncEffectNamedSend from label msg = do
546− mPid <- gets (^. registryFor label)
547− -- If mPid is Nothing, we just ignore the named send (as per Table 14)
548− node <- ask
549− forM_ mPid $ \pid ->
550− liftIO $ sendPayload node
551− from
552− (ProcessIdentifier pid)
553− (messageToPayload msg)
554−
555−--------------------------------------------------------------------------------
556−-- Auxiliary --
557−--------------------------------------------------------------------------------
558−
559−notifyDied :: ProcessId -- ^ Who to notify?
560− -> Identifier -- ^ Who died?
561− -> DiedReason -- ^ How did they die?
562− -> Maybe MonitorRef -- ^ 'Nothing' for linking
563− -> NC ()
564−notifyDied dest src reason mRef = do
565− node <- ask
566− case (isLocal node (ProcessIdentifier dest), mRef, src) of
567− (True, Just ref, ProcessIdentifier pid) ->
568− postAsMessage dest $ ProcessMonitorNotification ref pid reason
569− (True, Just ref, NodeIdentifier nid) ->
570− postAsMessage dest $ NodeMonitorNotification ref nid reason
571− (True, Just ref, SendPortIdentifier cid) ->
572− postAsMessage dest $ PortMonitorNotification ref cid reason
573− (True, Nothing, ProcessIdentifier pid) ->
574− throwException dest $ ProcessLinkException pid reason
575− (True, Nothing, NodeIdentifier pid) ->
576− throwException dest $ NodeLinkException pid reason
577− (True, Nothing, SendPortIdentifier pid) ->
578− throwException dest $ PortLinkException pid reason
579− (False, _, _) ->
580− -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
581− -- (see [Unified: Table 10]
582− liftIO $ sendBinary node
583− (NodeIdentifier $ localNodeId node)
584− (NodeIdentifier $ processNodeId dest)
585− NCMsg
586− { ctrlMsgSender = NodeIdentifier (localNodeId node)
587− , ctrlMsgSignal = Died src reason
588− }
589−
590−-- | [Unified: Table 8]
591−destNid :: ProcessSignal -> Maybe NodeId
592−destNid (Link ident) = Just $ nodeOf ident
593−destNid (Unlink ident) = Just $ nodeOf ident
594−destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
595−destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
596−destNid (Spawn _ _) = Nothing
597−destNid (Register _ _) = Nothing
598−destNid (WhereIs _) = Nothing
599−destNid (NamedSend _ _) = Nothing
600−-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
601−-- then when a local process dies the monitoring/linking machinery will take
602−-- care of notifying remote nodes
603−destNid (Died _ _) = Nothing
604−
605−-- | Check if a process is local to our own node
606−isLocal :: LocalNode -> Identifier -> Bool
607−isLocal nid ident = nodeOf ident == localNodeId nid
608−
609−-- | Lookup a local closure
610−unClosure :: Typeable a => Closure a -> NC (Maybe a)
611−unClosure (Closure (Static label) env) = do
612− rtable <- remoteTable <$> ask
613− return (resolveClosure rtable label env >>= fromDynamic)
614−
615−-- | Check if an identifier refers to a valid local object
616−isValidLocalIdentifier :: Identifier -> NC Bool
617−isValidLocalIdentifier ident = do
618− node <- ask
619− liftIO . withMVar (localState node) $ \nSt ->
620− case ident of
621− NodeIdentifier nid ->
622− return $ nid == localNodeId node
623− ProcessIdentifier pid -> do
624− let mProc = nSt ^. localProcessWithId (processLocalId pid)
625− return $ isJust mProc
626− SendPortIdentifier cid -> do
627− let pid = sendPortProcessId cid
628− mProc = nSt ^. localProcessWithId (processLocalId pid)
629− case mProc of
630− Nothing -> return False
631− Just proc -> withMVar (processState proc) $ \pSt -> do
632− let mCh = pSt ^. typedChannelWithId (sendPortLocalId cid)
633− return $ isJust mCh
634−
635−--------------------------------------------------------------------------------
636−-- Messages to local processes --
637−--------------------------------------------------------------------------------
638−
639−postAsMessage :: Serializable a => ProcessId -> a -> NC ()
640−postAsMessage pid = postMessage pid . createMessage
641−
642−postMessage :: ProcessId -> Message -> NC ()
643−postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
644−
645−throwException :: Exception e => ProcessId -> e -> NC ()
646−throwException pid e = withLocalProc pid $ \p ->
647− throwTo (processThread p) e
648−
649−withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
650−withLocalProc pid p = do
651− node <- ask
652− liftIO $ do
653− -- By [Unified: table 6, rule missing_process] messages to dead processes
654− -- can silently be dropped
655− let lpid = processLocalId pid
656− mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
657− forM_ mProc p
658−
659−--------------------------------------------------------------------------------
660−-- Accessors --
661−--------------------------------------------------------------------------------
662−
663−links :: Accessor NCState (Map Identifier (Set ProcessId))
664−links = accessor _links (\ls st -> st { _links = ls })
665−
666−monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))
667−monitors = accessor _monitors (\ms st -> st { _monitors = ms })
668−
669−registry :: Accessor NCState (Map String ProcessId)
670−registry = accessor _registry (\ry st -> st { _registry = ry })
671−
672−linksFor :: Identifier -> Accessor NCState (Set ProcessId)
673−linksFor ident = links >>> DAC.mapDefault Set.empty ident
674−
675−monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))
676−monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident
677−
678−registryFor :: String -> Accessor NCState (Maybe ProcessId)
679−registryFor ident = registry >>> DAC.mapMaybe ident
680−
681−-- | @splitNotif ident@ splits a notifications map into those
682−-- notifications that should trigger when 'ident' fails and those links that
683−-- should not.
684−--
685−-- There is a hierarchy between identifiers: failure of a node implies failure
686−-- of all processes on that node, and failure of a process implies failure of
687−-- all typed channels to that process. In other words, if 'ident' refers to a
688−-- node, then the /should trigger/ set will include
689−--
690−-- * the notifications for the node specifically
691−-- * the notifications for processes on that node, and
692−-- * the notifications for typed channels to processes on that node.
693−--
694−-- Similarly, if 'ident' refers to a process, the /should trigger/ set will
695−-- include
696−--
697−-- * the notifications for that process specifically and
698−-- * the notifications for typed channels to that process.
699−splitNotif :: Identifier
700− -> Map Identifier a
701− -> (Map Identifier a, Map Identifier a)
702−splitNotif ident = Map.partitionWithKey (const . impliesDeathOf ident)
703−
704−-- | Does the death of one entity (node, project, channel) imply the death
705−-- of another?
706−impliesDeathOf :: Identifier -- ^ Who died
707− -> Identifier -- ^ Who's being watched
708− -> Bool -- ^ Does this death implies the death of the watchee?
709−NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
710− nid' == nid
711−NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
712− processNodeId pid == nid
713−NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =
714− processNodeId (sendPortProcessId cid) == nid
715−ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =
716− pid' == pid
717−ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =
718− sendPortProcessId cid == pid
719−SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =
720− cid' == cid
721−_ `impliesDeathOf` _ =
722− False
distributed-process/tests/TestAuxiliary.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module TestAuxiliary ( -- Running tests
3− runTest
4− , runTests
5− -- Writing tests
6− , forkTry
7− , trySome
8− , randomThreadDelay
9− ) where
10−
11−
12−#if ! MIN_VERSION_base(4,6,0)
13−import Prelude hiding (catch)
14−#endif
15−
16−import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
17−import Control.Monad (liftM2, unless)
18−import Control.Exception (SomeException, try, catch)
19−import System.Timeout (timeout)
20−import System.IO (stdout, hFlush)
21−import System.Console.ANSI ( SGR(SetColor, Reset)
22− , Color(Red, Green)
23− , ConsoleLayer(Foreground)
24− , ColorIntensity(Vivid)
25− , setSGR
26− )
27−import System.Random (randomIO)
28−
29−-- | Like fork, but throw exceptions in the child thread to the parent
30−forkTry :: IO () -> IO ThreadId
31−forkTry p = do
32− tid <- myThreadId
33− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
34−
35−-- | Like try, but specialized to SomeException
36−trySome :: IO a -> IO (Either SomeException a)
37−trySome = try
38−
39−-- | Run the given test, catching timeouts and exceptions
40−runTest :: String -> IO () -> IO Bool
41−runTest description test = do
42− putStr $ "Running " ++ show description ++ ": "
43− hFlush stdout
44− done <- try . timeout 60000000 $ test -- 60 seconds
45− case done of
46− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
47− Right Nothing -> failed "(timeout)"
48− Right (Just ()) -> ok
49− where
50− failed :: String -> IO Bool
51− failed err = do
52− setSGR [SetColor Foreground Vivid Red]
53− putStr "failed "
54− setSGR [Reset]
55− putStrLn err
56− return False
57−
58− ok :: IO Bool
59− ok = do
60− setSGR [SetColor Foreground Vivid Green]
61− putStrLn "ok"
62− setSGR [Reset]
63− return True
64−
65−-- | Run a bunch of tests and throw an exception if any fails
66−runTests :: [(String, IO ())] -> IO ()
67−runTests tests = do
68− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests
69− unless success $ fail "Some tests failed"
70−
71−-- | Random thread delay between 0 and the specified max
72−randomThreadDelay :: Int -> IO ()
73−randomThreadDelay maxDelay = do
74− delay <- randomIO :: IO Int
75− threadDelay (delay `mod` maxDelay)
distributed-process/tests/TestCH.hsdeleted−622
@@ -1,622 +0,0 @@
1−module Main where
2−
3−#if ! MIN_VERSION_base(4,6,0)
4−import Prelude hiding (catch)
5−#endif
6−
7−import Data.Binary (Binary(..))
8−import Data.Typeable (Typeable)
9−import Data.Foldable (forM_)
10−import Control.Concurrent (forkIO, threadDelay)
11−import Control.Concurrent.MVar
12− ( MVar
13− , newEmptyMVar
14− , putMVar
15− , takeMVar
16− , readMVar
17− )
18−import Control.Monad (replicateM_, replicateM)
19−import Control.Exception (throwIO)
20−import Control.Applicative ((<$>), (<*>))
21−import qualified Network.Transport as NT (Transport, closeEndPoint)
22−import Network.Transport.TCP (createTransport, defaultTCPParameters)
23−import Control.Distributed.Process
24−import Control.Distributed.Process.Internal.Types (LocalNode(localEndPoint))
25−import Control.Distributed.Process.Node
26−import Control.Distributed.Process.Serializable (Serializable)
27−import TestAuxiliary
28−
29−newtype Ping = Ping ProcessId
30− deriving (Typeable, Binary, Show)
31−
32−newtype Pong = Pong ProcessId
33− deriving (Typeable, Binary, Show)
34−
35−-- | The ping server from the paper
36−ping :: Process ()
37−ping = do
38− Pong partner <- expect
39− self <- getSelfPid
40− send partner (Ping self)
41− ping
42−
43−-- | Basic ping test
44−testPing :: NT.Transport -> IO ()
45−testPing transport = do
46− serverAddr <- newEmptyMVar
47− clientDone <- newEmptyMVar
48−
49− -- Server
50− forkIO $ do
51− localNode <- newLocalNode transport initRemoteTable
52− addr <- forkProcess localNode ping
53− putMVar serverAddr addr
54−
55− -- Client
56− forkIO $ do
57− localNode <- newLocalNode transport initRemoteTable
58− pingServer <- readMVar serverAddr
59−
60− let numPings = 10000
61−
62− runProcess localNode $ do
63− pid <- getSelfPid
64− replicateM_ numPings $ do
65− send pingServer (Pong pid)
66− Ping _ <- expect
67− return ()
68−
69− putMVar clientDone ()
70−
71− takeMVar clientDone
72−
73−-- | Monitor or link to a remote node
74−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
75− -> ProcessId -- Process to monitor/link to
76− -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
77− -> Process (Maybe MonitorRef)
78−monitorOrLink mOrL pid mSignal = do
79− result <- if mOrL then Just <$> monitor pid
80− else link pid >> return Nothing
81− -- Monitor is asynchronous, which usually does not matter but if we want a
82− -- *specific* signal then it does. Therefore we wait an arbitrary delay and
83− -- hope that this means the monitor has been set up
84− forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
85− return result
86−
87−monitorTestProcess :: ProcessId -- Process to monitor/link to
88− -> Bool -- 'True' for monitor, 'False' for link
89− -> Bool -- Should we unmonitor?
90− -> DiedReason -- Expected cause of death
91− -> Maybe (MVar ()) -- Signal for 'monitor set up'
92− -> MVar () -- Signal for successful termination
93− -> Process ()
94−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
95− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
96− case (un, mRef) of
97− (True, Nothing) -> do
98− unlink theirAddr
99− liftIO $ putMVar done ()
100− (True, Just ref) -> do
101− unmonitor ref
102− liftIO $ putMVar done ()
103− (False, ref) -> do
104− ProcessMonitorNotification ref' pid reason' <- expect
105− True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
106− liftIO $ putMVar done ()
107− )
108− (\(ProcessLinkException pid reason') -> do
109− True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
110− liftIO $ putMVar done ()
111− )
112−
113−
114−-- | Monitor a process on an unreachable node
115−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
116−testMonitorUnreachable transport mOrL un = do
117− deadProcess <- newEmptyMVar
118− done <- newEmptyMVar
119−
120− forkIO $ do
121− localNode <- newLocalNode transport initRemoteTable
122− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
123− closeLocalNode localNode
124− putMVar deadProcess addr
125−
126− forkIO $ do
127− localNode <- newLocalNode transport initRemoteTable
128− theirAddr <- readMVar deadProcess
129− runProcess localNode $
130− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
131−
132− takeMVar done
133−
134−-- | Monitor a process which terminates normally
135−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
136−testMonitorNormalTermination transport mOrL un = do
137− monitorSetup <- newEmptyMVar
138− monitoredProcess <- newEmptyMVar
139− done <- newEmptyMVar
140−
141− forkIO $ do
142− localNode <- newLocalNode transport initRemoteTable
143− addr <- forkProcess localNode $
144− liftIO $ readMVar monitorSetup
145− putMVar monitoredProcess addr
146−
147− forkIO $ do
148− localNode <- newLocalNode transport initRemoteTable
149− theirAddr <- readMVar monitoredProcess
150− runProcess localNode $
151− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
152−
153− takeMVar done
154−
155−-- | Monitor a process which terminates abnormally
156−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
157−testMonitorAbnormalTermination transport mOrL un = do
158− monitorSetup <- newEmptyMVar
159− monitoredProcess <- newEmptyMVar
160− done <- newEmptyMVar
161−
162− let err = userError "Abnormal termination"
163−
164− forkIO $ do
165− localNode <- newLocalNode transport initRemoteTable
166− addr <- forkProcess localNode . liftIO $ do
167− readMVar monitorSetup
168− throwIO err
169− putMVar monitoredProcess addr
170−
171− forkIO $ do
172− localNode <- newLocalNode transport initRemoteTable
173− theirAddr <- readMVar monitoredProcess
174− runProcess localNode $
175− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
176−
177− takeMVar done
178−
179−-- | Monitor a local process that is already dead
180−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
181−testMonitorLocalDeadProcess transport mOrL un = do
182− processDead <- newEmptyMVar
183− processAddr <- newEmptyMVar
184− localNode <- newLocalNode transport initRemoteTable
185− done <- newEmptyMVar
186−
187− forkIO $ do
188− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
189− putMVar processAddr addr
190−
191− forkIO $ do
192− theirAddr <- readMVar processAddr
193− readMVar processDead
194− runProcess localNode $ do
195− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
196−
197− takeMVar done
198−
199−-- | Monitor a remote process that is already dead
200−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
201−testMonitorRemoteDeadProcess transport mOrL un = do
202− processDead <- newEmptyMVar
203− processAddr <- newEmptyMVar
204− done <- newEmptyMVar
205−
206− forkIO $ do
207− localNode <- newLocalNode transport initRemoteTable
208− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
209− putMVar processAddr addr
210−
211− forkIO $ do
212− localNode <- newLocalNode transport initRemoteTable
213− theirAddr <- readMVar processAddr
214− readMVar processDead
215− runProcess localNode $ do
216− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
217−
218− takeMVar done
219−
220−-- | Monitor a process that becomes disconnected
221−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
222−testMonitorDisconnect transport mOrL un = do
223− processAddr <- newEmptyMVar
224− monitorSetup <- newEmptyMVar
225− done <- newEmptyMVar
226−
227− forkIO $ do
228− localNode <- newLocalNode transport initRemoteTable
229− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
230− putMVar processAddr addr
231− readMVar monitorSetup
232− NT.closeEndPoint (localEndPoint localNode)
233−
234− forkIO $ do
235− localNode <- newLocalNode transport initRemoteTable
236− theirAddr <- readMVar processAddr
237− runProcess localNode $ do
238− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
239−
240− takeMVar done
241−
242−data Add = Add ProcessId Double Double deriving (Typeable)
243−data Divide = Divide ProcessId Double Double deriving (Typeable)
244−data DivByZero = DivByZero deriving (Typeable)
245−
246−instance Binary Add where
247− put (Add pid x y) = put pid >> put x >> put y
248− get = Add <$> get <*> get <*> get
249−
250−instance Binary Divide where
251− put (Divide pid x y) = put pid >> put x >> put y
252− get = Divide <$> get <*> get <*> get
253−
254−instance Binary DivByZero where
255− put DivByZero = return ()
256− get = return DivByZero
257−
258−math :: Process ()
259−math = do
260− receiveWait
261− [ match (\(Add pid x y) -> send pid (x + y))
262− , matchIf (\(Divide _ _ y) -> y /= 0)
263− (\(Divide pid x y) -> send pid (x / y))
264− , match (\(Divide pid _ _) -> send pid DivByZero)
265− ]
266− math
267−
268−-- | Test the math server (i.e., receiveWait)
269−testMath :: NT.Transport -> IO ()
270−testMath transport = do
271− serverAddr <- newEmptyMVar
272− clientDone <- newEmptyMVar
273−
274− -- Server
275− forkIO $ do
276− localNode <- newLocalNode transport initRemoteTable
277− addr <- forkProcess localNode math
278− putMVar serverAddr addr
279−
280− -- Client
281− forkIO $ do
282− localNode <- newLocalNode transport initRemoteTable
283− mathServer <- readMVar serverAddr
284−
285− runProcess localNode $ do
286− pid <- getSelfPid
287− send mathServer (Add pid 1 2)
288− 3 <- expect :: Process Double
289− send mathServer (Divide pid 8 2)
290− 4 <- expect :: Process Double
291− send mathServer (Divide pid 8 0)
292− DivByZero <- expect
293− liftIO $ putMVar clientDone ()
294−
295− takeMVar clientDone
296−
297−-- | Send first message (i.e. connect) to an already terminated process
298−-- (without monitoring); then send another message to a second process on
299−-- the same remote node (we're checking that the remote node did not die)
300−testSendToTerminated :: NT.Transport -> IO ()
301−testSendToTerminated transport = do
302− serverAddr1 <- newEmptyMVar
303− serverAddr2 <- newEmptyMVar
304− clientDone <- newEmptyMVar
305−
306− forkIO $ do
307− terminated <- newEmptyMVar
308− localNode <- newLocalNode transport initRemoteTable
309− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
310− addr2 <- forkProcess localNode $ ping
311− readMVar terminated
312− putMVar serverAddr1 addr1
313− putMVar serverAddr2 addr2
314−
315− forkIO $ do
316− localNode <- newLocalNode transport initRemoteTable
317− server1 <- readMVar serverAddr1
318− server2 <- readMVar serverAddr2
319− runProcess localNode $ do
320− pid <- getSelfPid
321− send server1 "Hi"
322− send server2 (Pong pid)
323− Ping pid' <- expect
324− True <- return $ pid' == server2
325− liftIO $ putMVar clientDone ()
326−
327− takeMVar clientDone
328−
329−-- | Test (non-zero) timeout
330−testTimeout :: NT.Transport -> IO ()
331−testTimeout transport = do
332− localNode <- newLocalNode transport initRemoteTable
333− runProcess localNode $ do
334− Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
335− return ()
336−
337−-- | Test zero timeout
338−testTimeout0 :: NT.Transport -> IO ()
339−testTimeout0 transport = do
340− serverAddr <- newEmptyMVar
341− clientDone <- newEmptyMVar
342− messagesSent <- newEmptyMVar
343−
344− forkIO $ do
345− localNode <- newLocalNode transport initRemoteTable
346− addr <- forkProcess localNode $ do
347− liftIO $ readMVar messagesSent >> threadDelay 1000000
348− -- Variation on the venerable ping server which uses a zero timeout
349− -- Since we wait for all messages to be sent before doing this receive,
350− -- we should nevertheless find the right message immediately
351− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
352− self <- getSelfPid
353− send partner (Ping self)
354− putMVar serverAddr addr
355−
356− forkIO $ do
357− localNode <- newLocalNode transport initRemoteTable
358− server <- readMVar serverAddr
359− runProcess localNode $ do
360− pid <- getSelfPid
361− -- Send a bunch of messages. A large number of messages that the server
362− -- is not interested in, and then a single message that it wants
363− replicateM_ 10000 $ send server "Irrelevant message"
364− send server (Pong pid)
365− liftIO $ putMVar messagesSent ()
366− Ping _ <- expect
367− liftIO $ putMVar clientDone ()
368−
369− takeMVar clientDone
370−
371−-- | Test typed channels
372−testTypedChannels :: NT.Transport -> IO ()
373−testTypedChannels transport = do
374− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
375− clientDone <- newEmptyMVar
376−
377− forkIO $ do
378− localNode <- newLocalNode transport initRemoteTable
379− forkProcess localNode $ do
380− (serverSendPort, rport) <- newChan
381− liftIO $ putMVar serverChannel serverSendPort
382− (clientSendPort, i) <- receiveChan rport
383− sendChan clientSendPort (even i)
384− return ()
385−
386− forkIO $ do
387− localNode <- newLocalNode transport initRemoteTable
388− serverSendPort <- readMVar serverChannel
389− runProcess localNode $ do
390− (clientSendPort, rport) <- newChan
391− sendChan serverSendPort (clientSendPort, 5)
392− False <- receiveChan rport
393− liftIO $ putMVar clientDone ()
394−
395− takeMVar clientDone
396−
397−-- | Test merging receive ports
398−testMergeChannels :: NT.Transport -> IO ()
399−testMergeChannels transport = do
400− localNode <- newLocalNode transport initRemoteTable
401− testFlat localNode True "aaabbbccc"
402− testFlat localNode False "abcabcabc"
403− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
404− testNested localNode True False "adgadgadgbehbehbehcficficfi"
405− testNested localNode False True "abcabcabcdefdefdefghighighi"
406− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
407− testBlocked localNode True
408− testBlocked localNode False
409− where
410− -- Single layer of merging
411− testFlat :: LocalNode -> Bool -> String -> IO ()
412− testFlat localNode biased expected =
413− runProcess localNode $ do
414− rs <- mapM charChannel "abc"
415− m <- mergePorts biased rs
416− xs <- replicateM 9 $ receiveChan m
417− True <- return $ xs == expected
418− return ()
419−
420− -- Two layers of merging
421− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
422− testNested localNode biasedInner biasedOuter expected =
423− runProcess localNode $ do
424− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
425− ms <- mapM (mergePorts biasedInner) rss
426− m <- mergePorts biasedOuter ms
427− xs <- replicateM (9 * 3) $ receiveChan m
428− True <- return $ xs == expected
429− return ()
430−
431− -- Test that if no messages are (immediately) available, the scheduler makes no difference
432− testBlocked :: LocalNode -> Bool -> IO ()
433− testBlocked localNode biased = do
434− vs <- replicateM 3 newEmptyMVar
435−
436− forkProcess localNode $ do
437− [sa, sb, sc] <- liftIO $ mapM readMVar vs
438− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
439− [ -- a, b, c
440− (sa, 'a')
441− , (sb, 'b')
442− , (sc, 'c')
443− -- a, c, b
444− , (sa, 'a')
445− , (sc, 'c')
446− , (sb, 'b')
447− -- b, a, c
448− , (sb, 'b')
449− , (sa, 'a')
450− , (sc, 'c')
451− -- b, c, a
452− , (sb, 'b')
453− , (sc, 'c')
454− , (sa, 'a')
455− -- c, a, b
456− , (sc, 'c')
457− , (sa, 'a')
458− , (sb, 'b')
459− -- c, b, a
460− , (sc, 'c')
461− , (sb, 'b')
462− , (sa, 'a')
463− ]
464−
465− runProcess localNode $ do
466− (ss, rs) <- unzip <$> replicateM 3 newChan
467− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
468− m <- mergePorts biased rs
469− xs <- replicateM (6 * 3) $ receiveChan m
470− True <- return $ xs == "abcacbbacbcacabcba"
471− return ()
472−
473− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
474− mergePorts True = mergePortsBiased
475− mergePorts False = mergePortsRR
476−
477− charChannel :: Char -> Process (ReceivePort Char)
478− charChannel c = do
479− (sport, rport) <- newChan
480− replicateM_ 3 $ sendChan sport c
481− liftIO $ threadDelay 10000 -- Make sure messages have been sent
482− return rport
483−
484−testTerminate :: NT.Transport -> IO ()
485−testTerminate transport = do
486− localNode <- newLocalNode transport initRemoteTable
487−
488− pid <- forkProcess localNode $ do
489− liftIO $ threadDelay 100000
490− terminate
491−
492− runProcess localNode $ do
493− ref <- monitor pid
494− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
495− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
496− return ()
497−
498−testMonitorNode :: NT.Transport -> IO ()
499−testMonitorNode transport = do
500− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
501−
502− closeLocalNode node1
503−
504− runProcess node2 $ do
505− ref <- monitorNode (localNodeId node1)
506− NodeMonitorNotification ref' nid DiedDisconnect <- expect
507− True <- return $ ref == ref' && nid == localNodeId node1
508− return ()
509−
510−testMonitorChannel :: NT.Transport -> IO ()
511−testMonitorChannel transport = do
512− [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
513− gotNotification <- newEmptyMVar
514−
515− pid <- forkProcess node1 $ do
516− sport <- expect :: Process (SendPort ())
517− ref <- monitorPort sport
518− PortMonitorNotification ref' port' DiedNormal <- expect
519− return $ ref' == ref && port' == sendPortId sport
520− liftIO $ putMVar gotNotification ()
521−
522− runProcess node2 $ do
523− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
524− send pid sport
525− liftIO $ threadDelay 100000
526−
527− takeMVar gotNotification
528−
529−testRegistry :: NT.Transport -> IO ()
530−testRegistry transport = do
531− node <- newLocalNode transport initRemoteTable
532−
533− pingServer <- forkProcess node ping
534−
535− runProcess node $ do
536− register "ping" pingServer
537− Just pid <- whereis "ping"
538− True <- return $ pingServer == pid
539− us <- getSelfPid
540− nsend "ping" (Pong us)
541− Ping pid' <- expect
542− True <- return $ pingServer == pid'
543− return ()
544−
545−testRemoteRegistry :: NT.Transport -> IO ()
546−testRemoteRegistry transport = do
547− node1 <- newLocalNode transport initRemoteTable
548− node2 <- newLocalNode transport initRemoteTable
549−
550− pingServer <- forkProcess node1 ping
551−
552− runProcess node2 $ do
553− let nid1 = localNodeId node1
554− registerRemote nid1 "ping" pingServer
555− Just pid <- whereisRemote nid1 "ping"
556− True <- return $ pingServer == pid
557− us <- getSelfPid
558− nsendRemote nid1 "ping" (Pong us)
559− Ping pid' <- expect
560− True <- return $ pingServer == pid'
561− return ()
562−
563−testSpawnLocal :: NT.Transport -> IO ()
564−testSpawnLocal transport = do
565− node <- newLocalNode transport initRemoteTable
566−
567− runProcess node $ do
568− us <- getSelfPid
569−
570− pid <- spawnLocal $ do
571− sport <- expect
572− sendChan sport (1234 :: Int)
573−
574− sport <- spawnChannelLocal $ \rport -> do
575− (1234 :: Int) <- receiveChan rport
576− send us ()
577−
578− send pid sport
579− expect
580−
581−main :: IO ()
582−main = do
583− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
584− runTests
585− [ ("Ping", testPing transport)
586− , ("Math", testMath transport)
587− , ("Timeout", testTimeout transport)
588− , ("Timeout0", testTimeout0 transport)
589− , ("SendToTerminated", testSendToTerminated transport)
590− , ("TypedChannnels", testTypedChannels transport)
591− , ("MergeChannels", testMergeChannels transport)
592− , ("Terminate", testTerminate transport)
593− , ("Registry", testRegistry transport)
594− , ("RemoteRegistry", testRemoteRegistry transport)
595− , ("SpawnLocal", testSpawnLocal transport)
596− -- Monitoring processes
597− --
598− -- The "missing" combinations in the list below don't make much sense, as
599− -- we cannot guarantee that the monitor reply or link exception will not
600− -- happen before the unmonitor or unlink
601− , ("MonitorUnreachable", testMonitorUnreachable transport True False)
602− , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
603− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
604− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
605− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
606− , ("MonitorDisconnect", testMonitorDisconnect transport True False)
607− , ("LinkUnreachable", testMonitorUnreachable transport False False)
608− , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
609− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
610− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
611− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
612− , ("LinkDisconnect", testMonitorDisconnect transport False False)
613− , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
614− , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
615− , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
616− , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
617− , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
618− , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
619− -- Monitoring nodes and channels
620− , ("MonitorNode", testMonitorNode transport)
621− , ("MonitorChannel", testMonitorChannel transport)
622− ]
distributed-process/tests/TestClosure.hsdeleted−332
@@ -1,332 +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, forever)
6−import Control.Exception (IOException, throw)
7−import Control.Concurrent (forkIO, threadDelay)
8−import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, takeMVar, putMVar)
9−import Control.Applicative ((<$>))
10−import Network.Transport (Transport)
11−import Network.Transport.TCP (createTransport, defaultTCPParameters)
12−import Control.Distributed.Process
13−import Control.Distributed.Process.Closure
14−import Control.Distributed.Process.Node
15−import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))
16−import TestAuxiliary
17−
18−sdictInt :: SerializableDict Int
19−sdictInt = SerializableDict
20−
21−factorial :: Int -> Process Int
22−factorial 0 = return 1
23−factorial n = (n *) <$> factorial (n - 1)
24−
25−addInt :: Int -> Int -> Int
26−addInt x y = x + y
27−
28−putInt :: Int -> MVar Int -> IO ()
29−putInt = flip putMVar
30−
31−sendPid :: ProcessId -> Process ()
32−sendPid toPid = do
33− fromPid <- getSelfPid
34− send toPid fromPid
35−
36−wait :: Int -> Process ()
37−wait = liftIO . threadDelay
38−
39−isPrime :: Integer -> Process Bool
40−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
41− where
42− sieve :: [Integer] -> [Integer]
43− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
44−
45−-- | First argument indicates empty closure environment
46−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
47−typedPingServer () rport = forever $ do
48− sport <- receiveChan rport
49− sendChan sport ()
50−
51−remotable [ 'factorial
52− , 'addInt
53− , 'putInt
54− , 'sendPid
55− , 'sdictInt
56− , 'wait
57− , 'typedPingServer
58− , 'isPrime
59− ]
60−
61−factorialClosure :: Int -> Closure (Process Int)
62−factorialClosure = $(mkClosure 'factorial)
63−
64−addIntClosure :: Int -> Closure (Int -> Int)
65−addIntClosure = $(mkClosure 'addInt)
66−
67−putIntClosure :: Int -> Closure (MVar Int -> IO ())
68−putIntClosure = $(mkClosure 'putInt)
69−
70−sendPidClosure :: ProcessId -> Closure (Process ())
71−sendPidClosure = $(mkClosure 'sendPid)
72−
73−sendFac :: Int -> ProcessId -> Closure (Process ())
74−sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid
75−
76−factorialOf :: Closure (Int -> Process Int)
77−factorialOf = staticClosure $(mkStatic 'factorial)
78−
79−factorial' :: Int -> Closure (Process Int)
80−factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf
81−
82−waitClosure :: Int -> Closure (Process ())
83−waitClosure = $(mkClosure 'wait)
84−
85−testUnclosure :: Transport -> RemoteTable -> IO ()
86−testUnclosure transport rtable = do
87− node <- newLocalNode transport rtable
88− runProcess node $ do
89− 120 <- join . unClosure $ factorialClosure 5
90− return ()
91−
92−testBind :: Transport -> RemoteTable -> IO ()
93−testBind transport rtable = do
94− node <- newLocalNode transport rtable
95− runProcess node $ do
96− us <- getSelfPid
97− join . unClosure $ sendFac 6 us
98− (720 :: Int) <- expect
99− return ()
100−
101−testSendPureClosure :: Transport -> RemoteTable -> IO ()
102−testSendPureClosure transport rtable = do
103− serverAddr <- newEmptyMVar
104− serverDone <- newEmptyMVar
105−
106− forkIO $ do
107− node <- newLocalNode transport rtable
108− addr <- forkProcess node $ do
109− cl <- expect
110− fn <- unClosure cl :: Process (Int -> Int)
111− 13 <- return $ fn 6
112− liftIO $ putMVar serverDone ()
113− putMVar serverAddr addr
114−
115− forkIO $ do
116− node <- newLocalNode transport rtable
117− theirAddr <- readMVar serverAddr
118− runProcess node $ send theirAddr (addIntClosure 7)
119−
120− takeMVar serverDone
121−
122−testSendIOClosure :: Transport -> RemoteTable -> IO ()
123−testSendIOClosure transport rtable = do
124− serverAddr <- newEmptyMVar
125− serverDone <- newEmptyMVar
126−
127− forkIO $ do
128− node <- newLocalNode transport rtable
129− addr <- forkProcess node $ do
130− cl <- expect
131− io <- unClosure cl :: Process (MVar Int -> IO ())
132− liftIO $ do
133− someMVar <- newEmptyMVar
134− io someMVar
135− 5 <- readMVar someMVar
136− putMVar serverDone ()
137− putMVar serverAddr addr
138−
139− forkIO $ do
140− node <- newLocalNode transport rtable
141− theirAddr <- readMVar serverAddr
142− runProcess node $ send theirAddr (putIntClosure 5)
143−
144− takeMVar serverDone
145−
146−testSendProcClosure :: Transport -> RemoteTable -> IO ()
147−testSendProcClosure transport rtable = do
148− serverAddr <- newEmptyMVar
149− clientDone <- newEmptyMVar
150−
151− forkIO $ do
152− node <- newLocalNode transport rtable
153− addr <- forkProcess node $ do
154− cl <- expect
155− pr <- unClosure cl :: Process (Int -> Process ())
156− pr 5
157− putMVar serverAddr addr
158−
159− forkIO $ do
160− node <- newLocalNode transport rtable
161− theirAddr <- readMVar serverAddr
162− runProcess node $ do
163− pid <- getSelfPid
164− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
165− 5 <- expect :: Process Int
166− liftIO $ putMVar clientDone ()
167−
168− takeMVar clientDone
169−
170−testSpawn :: Transport -> RemoteTable -> IO ()
171−testSpawn transport rtable = do
172− serverNodeAddr <- newEmptyMVar
173− clientDone <- newEmptyMVar
174−
175− forkIO $ do
176− node <- newLocalNode transport rtable
177− putMVar serverNodeAddr (localNodeId node)
178−
179− forkIO $ do
180− node <- newLocalNode transport rtable
181− nid <- readMVar serverNodeAddr
182− runProcess node $ do
183− pid <- getSelfPid
184− pid' <- spawn nid (sendPidClosure pid)
185− pid'' <- expect
186− True <- return $ pid' == pid''
187− liftIO $ putMVar clientDone ()
188−
189− takeMVar clientDone
190−
191−testCall :: Transport -> RemoteTable -> IO ()
192−testCall transport rtable = do
193− serverNodeAddr <- newEmptyMVar
194− clientDone <- newEmptyMVar
195−
196− forkIO $ do
197− node <- newLocalNode transport rtable
198− putMVar serverNodeAddr (localNodeId node)
199−
200− forkIO $ do
201− node <- newLocalNode transport rtable
202− nid <- readMVar serverNodeAddr
203− runProcess node $ do
204− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
205− liftIO $ putMVar clientDone ()
206−
207− takeMVar clientDone
208−
209−testCallBind :: Transport -> RemoteTable -> IO ()
210−testCallBind transport rtable = do
211− serverNodeAddr <- newEmptyMVar
212− clientDone <- newEmptyMVar
213−
214− forkIO $ do
215− node <- newLocalNode transport rtable
216− putMVar serverNodeAddr (localNodeId node)
217−
218− forkIO $ do
219− node <- newLocalNode transport rtable
220− nid <- readMVar serverNodeAddr
221− runProcess node $ do
222− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
223− liftIO $ putMVar clientDone ()
224−
225− takeMVar clientDone
226−
227−testSeq :: Transport -> RemoteTable -> IO ()
228−testSeq transport rtable = do
229− node <- newLocalNode transport rtable
230− runProcess node $ do
231− us <- getSelfPid
232− join . unClosure $ sendFac 5 us `cpSeq` sendFac 6 us
233− 120 :: Int <- expect
234− 720 :: Int <- expect
235− return ()
236−
237−-- Test 'spawnSupervised'
238−--
239−-- Set up a supervisor, spawn a child, then have a third process monitor the
240−-- child. The supervisor then throws an exception, the child dies because it
241−-- was linked to the supervisor, and the third process notices that the child
242−-- dies.
243−testSpawnSupervised :: Transport -> RemoteTable -> IO ()
244−testSpawnSupervised transport rtable = do
245− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
246− [superPid, childPid] <- replicateM 2 $ newEmptyMVar
247− thirdProcessDone <- newEmptyMVar
248−
249− forkProcess node1 $ do
250− us <- getSelfPid
251− liftIO $ putMVar superPid us
252− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
253− liftIO $ do
254− putMVar childPid child
255− threadDelay 500000 -- Give the child a chance to link to us
256− throw supervisorDeath
257−
258− forkProcess node2 $ do
259− [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
260− ref <- monitor child
261− ProcessMonitorNotification ref' pid' (DiedException e) <- expect
262− True <- return $ ref' == ref
263− && pid' == child
264− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
265− liftIO $ putMVar thirdProcessDone ()
266−
267− takeMVar thirdProcessDone
268− where
269− supervisorDeath :: IOException
270− supervisorDeath = userError "Supervisor died"
271−
272−testSpawnInvalid :: Transport -> RemoteTable -> IO ()
273−testSpawnInvalid transport rtable = do
274− node <- newLocalNode transport rtable
275− runProcess node $ do
276− (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (StaticLabel "ThisDoesNotExist" (typeOf ()))) empty)
277− ProcessMonitorNotification ref' pid' _reason <- expect
278− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
279− True <- return $ ref' == ref && pid == pid'
280− return ()
281−
282−testClosureExpect :: Transport -> RemoteTable -> IO ()
283−testClosureExpect transport rtable = do
284− node <- newLocalNode transport rtable
285− runProcess node $ do
286− nodeId <- getSelfNode
287− us <- getSelfPid
288− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `cpBind` cpSend $(mkStatic 'sdictInt) us
289− send them (1234 :: Int)
290− (1234 :: Int) <- expect
291− return ()
292−
293−testSpawnChannel :: Transport -> RemoteTable -> IO ()
294−testSpawnChannel transport rtable = do
295− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
296−
297− runProcess node1 $ do
298− pingServer <- spawnChannel
299− (sdictSendPort sdictUnit)
300− (localNodeId node2)
301− ($(mkClosure 'typedPingServer) ())
302− (sendReply, receiveReply) <- newChan
303− sendChan pingServer sendReply
304− receiveChan receiveReply
305−
306−testTDict :: Transport -> RemoteTable -> IO ()
307−testTDict transport rtable = do
308− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
309− runProcess node1 $ do
310− True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
311− return ()
312−
313−main :: IO ()
314−main = do
315− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
316− let rtable = __remoteTable initRemoteTable
317− runTests
318− [ ("Unclosure", testUnclosure transport rtable)
319− , ("Bind", testBind transport rtable)
320− , ("SendPureClosure", testSendPureClosure transport rtable)
321− , ("SendIOClosure", testSendIOClosure transport rtable)
322− , ("SendProcClosure", testSendProcClosure transport rtable)
323− , ("Spawn", testSpawn transport rtable)
324− , ("Call", testCall transport rtable)
325− , ("CallBind", testCallBind transport rtable)
326− , ("Seq", testSeq transport rtable)
327− , ("SpawnSupervised", testSpawnSupervised transport rtable)
328− , ("SpawnInvalid", testSpawnInvalid transport rtable)
329− , ("ClosureExpect", testClosureExpect transport rtable)
330− , ("SpawnChannel", testSpawnChannel transport rtable)
331− , ("TDict", testTDict transport rtable)
332− ]
doc/InternalsTransportMulticast.txtdeleted−181
@@ -1,181 +0,0 @@
1−Adding Support for Multicast to the Transport API
2−=================================================
3−
4−This document describes various design options for adding support for multicast
5−to the Transport API.
6−
7−Creating a new multicast group
8−------------------------------
9−
10−We can either have this as part of the transport
11−
12− data Transport = Transport {
13− ...
14− , newMulticastGroup :: IO (Either Error MulticastGroup)
15− }
16−
17− data MulticastGroup = MulticastGroup {
18− ...
19− , multicastAddress :: MulticastAddress
20− , deleteMulticastGroup :: IO ()
21− }
22−
23−or as part of an endpoint:
24−
25− data Transport = Transport {
26− newEndPoint :: IO (Either Error EndPoint)
27− }
28−
29− data EndPoint = EndPoint {
30− ...
31− , newMulticastGroup :: IO (Either Error MulticastGroup)
32− }
33−
34−It should probably be part of the `Transport`, as there is no real connection
35−between an endpoint and the creation of the multigroup (however, see section
36−"Sending messages to a multicast group").
37−
38−Subscribing to a multicast group
39−--------------------------------
40−
41−This should be part of an endpoint; subscribing basically means that the
42−endpoint wants to receive events when multicast messages are sent.
43−
44−We could reify a subscription:
45−
46− data EndPoint = EndPoint {
47− ...
48− , multicastSubscribe :: MulticastAddress -> IO MulticastSubscription
49− }
50−
51− data MulticastSubscription = MulticastSubscription {
52− ...
53− , multicastSubscriptionClose :: IO ()
54− }
55−
56−but this suggests that one might have multiple subscriptions to the same group
57−which can be distinguished, which is misleading. Probably better to have:
58−
59− data EndPoint = EndPoint {
60− multicastSubscribe :: MulticastAddress -> IO ()
61− , multicastUnsubscribe :: MulticastAddress -> IO ()
62− }
63−
64−Sending messages to a multicast group
65−-------------------------------------
66−
67−An important feature of the Transport API is that we are clear about which
68−operations are *lightweight* and which are not. For instance, creating new
69−endpoints is not lightweight, but opening new connections to endpoints is (as
70−light-weight as possible).
71−
72−Clearly the creation of a new multicast group is a heavyweight operation. It is
73−less evident however if we can support multiple lightweight "connections" to the
74−same multicast group, and if so, whether it is useful.
75−
76−If we decide that multiple lightweight connections to the multigroup is useful,
77−one option might be
78−
79− data EndPoint = EndPoint {
80− ...
81− , connect :: Address -> Reliability -> IO (Either Error Connection)
82− , multicastConnect :: MulticastAddress -> IO (Either Error Connection)
83− }
84−
85− data Connection = Connection {
86− connectionId :: ConnectionId
87− , send :: [ByteString] -> IO ()
88− , close :: IO ()
89− , maxMsgSize :: Maybe Int
90− }
91−
92− data Event =
93− Receive ConnectionId [ByteString]
94− | ConnectionClosed ConnectionId
95− | ConnectionOpened ConnectionId ConnectionType Reliability Address
96−
97−The advantage of this approach is it's consistency with the rest of the
98−interface. The problem is that with multicast we cannot reliably send any
99−control messages, so we cannot make sure that the subscribers of the multicast
100−group will receive ConnectionOpened events when an endpoint creates a new
101−connection. Since we don't support these "connectionless connections" anywhere
102−else in the API this seems inconsistent with the rest of the design (this
103−implies that an "unreliable" Transport over UDP still needs to have reliable
104−control messages). (On the other hand, if we were going to support reliable
105−multicast protocols, then that would fit this design).
106−
107−If we don't want to support multiple lightweight connections to a multicast
108−group then a better design would be
109−
110− data EndPoint = EndPoint {
111− , connect :: Address -> Reliability -> IO (Either Error Connection)
112− , multicastSend :: MulticastAddress -> [ByteString] -> IO ()
113− }
114−
115− data Event =
116− ...
117− | MulticastReceive Address [ByteString]
118−
119−or alternatively
120−
121− data EndPoint = EndPoint {
122− ...
123− , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup)
124− }
125−
126− data MulticastGroup = MulticastGroup {
127− , ...
128− , send :: [ByteString] -> IO ()
129− }
130−
131−If we do this however we need to make sure that newGroup is part an `EndPoint`,
132−not the `Transport`, otherwise `send` will not know the source of the message.
133−The version with `resolveMulticastGroup` has the additional benefit that in
134−"real" implementations we will probably need to allocate some resources before
135−we can send to the multicast group, and need to deallocate these resources at
136−some point too.
137−
138−The current solution
139−--------------------
140−
141−The above considerations lead to the following tentative proposal:
142−
143− data Transport = Transport {
144− newEndPoint :: IO (Either Error EndPoint)
145− }
146−
147− data EndPoint = EndPoint {
148− receive :: IO Event
149− , address :: Address
150− , connect :: Address -> Reliability -> IO (Either Error Connection)
151− , newMulticastGroup :: IO (Either Error MulticastGroup)
152− , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup)
153− }
154−
155− data Connection = Connection {
156− send :: [ByteString] -> IO ()
157− , close :: IO ()
158− }
159−
160− data Event =
161− Receive ConnectionId [ByteString]
162− | ConnectionClosed ConnectionId
163− | ConnectionOpened ConnectionId Reliability Address
164− | MulticastReceive MulticastAddress [ByteString]
165−
166− data MulticastGroup = MulticastGroup {
167− multicastAddress :: MulticastAddress
168− , deleteMulticastGroup :: IO ()
169− , maxMsgSize :: Maybe Int
170− , multicastSend :: [ByteString] -> IO ()
171− , multicastSubscribe :: IO ()
172− , multicastUnsubscribe :: IO ()
173− , multicastClose :: IO ()
174− }
175−
176−where `multicastClose` indicates to the runtime that this endpoint no longer
177−wishes to send to this multicast group, and we can therefore deallocate the
178−resources we needed to send to the group (these resources can be allocated on
179−`resolveMulticastGroup` or on the first `multicastSend`; the advantage of the
180−latter is that is somebody resolves a group only to subscribe to it, not to
181−send to it, we don't allocate any unneeded resources).
doc/InternalsTransportTCP.txtdeleted−81
@@ -1,81 +0,0 @@
1−The TCP Transport
2−=================
3−
4−Overview
5−--------
6−
7−When a TCP transport is created a new server is started which listens on a
8−given port number on the local host. In order to support multiple connections
9−the transport maintains a set of channels, one per connection, represented as a
10−pair of a `MVar [ByteString]` and a list of pairs `(ThreadId, Socket)` of
11−threads that are listening on this channel. A source end then corresponds to a
12−hostname (the hostname used by clients to identity the local host), port
13−number, and channel ID; a receive end simply corresponds to a channel ID.
14−
15−When `mkTransport` creates a new transport it spawns a thread that listens for
16−incoming connections, running `procConnections` (see below). The set of
17−channels (connections) associated with the transport is initialized to be
18−empty.
19−
20−`newConnectionWith` creates a new channel and add its to the transport channel
21−map (with an empty list of associated threads).
22−
23−To serialize the source end we encode the triple of the local host name, port
24−number, and channel ID, and to deserialize we just decode the same triple
25−(deserialize does not need any other properties of the TCP transport).
26−
27−To connect to the source end we create a new socket, connect to the server at
28−the IP address specified in the TCPConfig, and send the channel number over the
29−connection. Then to `closeSourceEnd` we simply close the socket, and to send a
30−bunch of byte strings we output them on the socket.
31−
32−To receive from the target end we just read from the channel associated with
33−the target end. To `closeTargetEnd` we find kill all threads associated with
34−the channel and close their sockets.
35−
36−When somebody connects to server (running `procConnections`), he first sends a
37−channel ID. `procConnections` then spawns a new thread running
38−`procMessages` which listens for bytestrings on the socket and output them on
39−the specified channel. The ID of this new thread (and the socket it uses) are
40−added to the channel map of the transport.
41−
42−`closeTransport` kills the server thread and all threads that were listening on
43−the channels associated with the transport, and closes all associated sockets.
44−
45−Improving Latency
46−-----------------
47−
48−A series of benchmarks has shown that
49−
50−* The use of `-threaded` triples the latency.
51−
52−* Prepending a header to messages has a negligible effect on latency, even when
53− sending very small packets. However, the way that we turn the length from an
54− `Int32` to a `ByteString` _does_ have a significant impact; in particular,
55− using `Data.Serialize` is very slow (and using Blaze.ByteString not much
56− better). This is fast:
57−
58− foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
59−
60− encodeLength :: Int32 -> IO ByteString
61− encodeLength i32 =
62− BSI.create 4 $ \p ->
63− pokeByteOff p 0 (htonl (fromIntegral i32))
64−
65−* We do not need to use `blaze-builder` or related;
66− `Network.Socket.Bytestring.sendMany` uses vectored I/O. On the client side
67− doing a single `recv` to try and read the message header and message, rather
68− one to read the header and one to read the payload improves latency, but only
69− by a tiny amount.
70−
71−* Indirection through an `MVar` or a `Chan` does not have an observable effect
72− on latency.
73−
74−* When two nodes _A_ and _B_ communicate, latency is worse when they
75− communicate over two pairs of sockets (used unidirectionally) rather than one
76− pair (used bidirectionally) by about 20%. This is not improved by using
77− `TCP_NODELAY`, and might be because [acknowledgements cannot piggyback with
78− payload][1] this way. It might thus be worthwhile to try and reuse TCP
79− connections (or use UDP).
80−
81−[1]: http://lists.freebsd.org/pipermail/freebsd-hackers/2009-March/028006.html "2 uni-directional TCP connection good?"
doc/NetworkTCP.pngdeleted

Binary file not shown.

doc/NetworkTCP.svgdeleted−657
@@ -1,657 +0,0 @@
1−<?xml version="1.0" encoding="UTF-8" standalone="no"?>
2−<!-- Created with Inkscape (http://www.inkscape.org/) -->
3−
4−<svg
5− xmlns:dc="http://purl.org/dc/elements/1.1/"
6− xmlns:cc="http://creativecommons.org/ns#"
7− xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
8− xmlns:svg="http://www.w3.org/2000/svg"
9− xmlns="http://www.w3.org/2000/svg"
10− xmlns:xlink="http://www.w3.org/1999/xlink"
11− xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
12− xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
13− width="1024px"
14− height="768px"
15− id="svg4129"
16− version="1.1"
17− inkscape:version="0.48.2 r9819"
18− sodipodi:docname="NetworkTCP.svg"
19− inkscape:export-filename="/tmp/distributed-process/doc/NetworkTCP.png"
20− inkscape:export-xdpi="90.040001"
21− inkscape:export-ydpi="90.040001">
22− <defs
23− id="defs4131">
24− <linearGradient
25− id="linearGradient4726">
26− <stop
27− style="stop-color:#800000;stop-opacity:1;"
28− offset="0"
29− id="stop4728" />
30− <stop
31− style="stop-color:#ffffff;stop-opacity:1;"
32− offset="1"
33− id="stop4730" />
34− </linearGradient>
35− <linearGradient
36− id="linearGradient4647">
37− <stop
38− style="stop-color:#008080;stop-opacity:1;"
39− offset="0"
40− id="stop4649" />
41− <stop
42− style="stop-color:#ffffff;stop-opacity:1;"
43− offset="1"
44− id="stop4651" />
45− </linearGradient>
46− <linearGradient
47− inkscape:collect="always"
48− xlink:href="#linearGradient4647-0"
49− id="linearGradient4655-9"
50− x1="-666.70703"
51− y1="18.113195"
52− x2="952.4931"
53− y2="345.05661"
54− gradientUnits="userSpaceOnUse"
55− gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
56− <linearGradient
57− id="linearGradient4647-0">
58− <stop
59− style="stop-color:#008080;stop-opacity:1;"
60− offset="0"
61− id="stop4649-1" />
62− <stop
63− style="stop-color:#ffffff;stop-opacity:1;"
64− offset="1"
65− id="stop4651-0" />
66− </linearGradient>
67− <linearGradient
68− inkscape:collect="always"
69− xlink:href="#linearGradient4647-9"
70− id="linearGradient4655-8"
71− x1="-666.70703"
72− y1="18.113195"
73− x2="952.4931"
74− y2="345.05661"
75− gradientUnits="userSpaceOnUse"
76− gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
77− <linearGradient
78− id="linearGradient4647-9">
79− <stop
80− style="stop-color:#008080;stop-opacity:1;"
81− offset="0"
82− id="stop4649-4" />
83− <stop
84− style="stop-color:#ffffff;stop-opacity:1;"
85− offset="1"
86− id="stop4651-7" />
87− </linearGradient>
88− <linearGradient
89− inkscape:collect="always"
90− xlink:href="#linearGradient4726-0"
91− id="linearGradient4732-1"
92− x1="484.52829"
93− y1="88.754707"
94− x2="18.113218"
95− y2="336.90564"
96− gradientUnits="userSpaceOnUse" />
97− <linearGradient
98− inkscape:collect="always"
99− id="linearGradient4726-0">
100− <stop
101− style="stop-color:#800000;stop-opacity:1;"
102− offset="0"
103− id="stop4728-2" />
104− <stop
105− style="stop-color:#800000;stop-opacity:0;"
106− offset="1"
107− id="stop4730-5" />
108− </linearGradient>
109− <linearGradient
110− gradientTransform="translate(539.26415,1.83019)"
111− y2="336.90564"
112− x2="18.113218"
113− y1="88.754707"
114− x1="484.52829"
115− gradientUnits="userSpaceOnUse"
116− id="linearGradient4755"
117− xlink:href="#linearGradient4726-0"
118− inkscape:collect="always" />
119− <linearGradient
120− inkscape:collect="always"
121− xlink:href="#linearGradient4726-6"
122− id="linearGradient4732-4"
123− x1="484.52829"
124− y1="88.754707"
125− x2="18.113218"
126− y2="336.90564"
127− gradientUnits="userSpaceOnUse" />
128− <linearGradient
129− id="linearGradient4726-6">
130− <stop
131− style="stop-color:#800000;stop-opacity:1;"
132− offset="0"
133− id="stop4728-4" />
134− <stop
135− style="stop-color:#ffffff;stop-opacity:1;"
136− offset="1"
137− id="stop4730-53" />
138− </linearGradient>
139− <linearGradient
140− inkscape:collect="always"
141− xlink:href="#linearGradient4726-4"
142− id="linearGradient4732-6"
143− x1="484.52829"
144− y1="88.754707"
145− x2="18.113218"
146− y2="336.90564"
147− gradientUnits="userSpaceOnUse" />
148− <linearGradient
149− id="linearGradient4726-4">
150− <stop
151− style="stop-color:#800000;stop-opacity:1;"
152− offset="0"
153− id="stop4728-40" />
154− <stop
155− style="stop-color:#ffffff;stop-opacity:1;"
156− offset="1"
157− id="stop4730-7" />
158− </linearGradient>
159− <linearGradient
160− inkscape:collect="always"
161− xlink:href="#linearGradient4726-3"
162− id="linearGradient4732-2"
163− x1="484.52829"
164− y1="88.754707"
165− x2="18.113218"
166− y2="336.90564"
167− gradientUnits="userSpaceOnUse" />
168− <linearGradient
169− id="linearGradient4726-3">
170− <stop
171− style="stop-color:#800000;stop-opacity:1;"
172− offset="0"
173− id="stop4728-8" />
174− <stop
175− style="stop-color:#ffffff;stop-opacity:1;"
176− offset="1"
177− id="stop4730-1" />
178− </linearGradient>
179− </defs>
180− <sodipodi:namedview
181− id="base"
182− pagecolor="#ffffff"
183− bordercolor="#666666"
184− borderopacity="1.0"
185− inkscape:pageopacity="0.0"
186− inkscape:pageshadow="2"
187− inkscape:zoom="0.70710678"
188− inkscape:cx="510.54885"
189− inkscape:cy="435.44033"
190− inkscape:current-layer="layer1"
191− inkscape:document-units="px"
192− showgrid="false"
193− showguides="true"
194− inkscape:guide-bbox="true"
195− inkscape:window-width="1393"
196− inkscape:window-height="789"
197− inkscape:window-x="47"
198− inkscape:window-y="3"
199− inkscape:window-maximized="0">
200− <sodipodi:guide
201− orientation="1,0"
202− position="984,175"
203− id="guide4870" />
204− </sodipodi:namedview>
205− <metadata
206− id="metadata4134">
207− <rdf:RDF>
208− <cc:Work
209− rdf:about="">
210− <dc:format>image/svg+xml</dc:format>
211− <dc:type
212− rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
213− <dc:title />
214− </cc:Work>
215− </rdf:RDF>
216− </metadata>
217− <g
218− id="layer1"
219− inkscape:label="Layer 1"
220− inkscape:groupmode="layer">
221− <rect
222− style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24376427999999994;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
223− id="rect4137-5"
224− width="412.79617"
225− height="287.24374"
226− x="571.56415"
227− y="34.192436" />
228− <rect
229− style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24167538000000000;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
230− id="rect4137"
231− width="412.79617"
232− height="286.27966"
233− x="33.567425"
234− y="34.473083" />
235− <rect
236− style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.89734482999999998;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
237− id="rect4137-6"
238− width="950.33942"
239− height="290.35135"
240− x="32.696255"
241− y="448.07922" />
242− <rect
243− style="fill:#999999;stroke:none;stroke-width:1.97458196000000008;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
244− id="rect4657-9"
245− width="582.76776"
246− height="145.3952"
247− x="109.61612"
248− y="-307.5813"
249− transform="matrix(0,1,-1,0,0,0)" />
250− <rect
251− style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1;opacity:1"
252− id="rect4657"
253− width="582.76776"
254− height="149.16254"
255− x="256.99347"
256− y="124.76707" />
257− <text
258− xml:space="preserve"
259− style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
260− x="36.887089"
261− y="73.584908"
262− id="text4659"
263− sodipodi:linespacing="125%"><tspan
264− sodipodi:role="line"
265− id="tspan4661"
266− x="36.887089"
267− y="73.584908"
268− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
269− style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
270− id="tspan4038">1</tspan>:<tspan
271− style="font-weight:normal;-inkscape-font-specification:Courier New;fill:#800000"
272− id="tspan4036">1080</tspan></tspan></text>
273− <text
274− xml:space="preserve"
275− style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
276− x="574.88385"
277− y="73.30426"
278− id="text4659-2"
279− sodipodi:linespacing="125%"><tspan
280− sodipodi:role="line"
281− id="tspan4661-9"
282− x="574.88385"
283− y="73.30426"
284− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
285− style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
286− id="tspan4042">1</tspan>:<tspan
287− style="fill:#800000"
288− id="tspan4044">1081</tspan></tspan></text>
289− <rect
290− style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
291− id="rect4657-7"
292− width="582.76776"
293− height="149.16254"
294− x="229.61612"
295− y="535.4187" />
296− <text
297− xml:space="preserve"
298− style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
299− x="321.0159"
300− y="488.19104"
301− id="text4659-9"
302− sodipodi:linespacing="125%"><tspan
303− sodipodi:role="line"
304− id="tspan4661-90"
305− x="321.0159"
306− y="488.19104"
307− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
308− style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
309− id="tspan4046">2</tspan>:<tspan
310− style="fill:#800000"
311− id="tspan4048">1080</tspan></tspan></text>
312− <rect
313− style="fill:#ffa23a;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1"
314− id="rect4724"
315− width="366.79245"
316− height="200.15094"
317− x="54.339622"
318− y="95.094337" />
319− <text
320− xml:space="preserve"
321− style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
322− x="62.264153"
323− y="117.35849"
324− id="text4734"
325− sodipodi:linespacing="125%"><tspan
326− sodipodi:role="line"
327− id="tspan4736"
328− x="62.264153"
329− y="117.35849"
330− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1080:0</tspan></text>
331− <rect
332− style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
333− id="rect4724-0"
334− width="366.79245"
335− height="200.15094"
336− x="597.60376"
337− y="98.92453" />
338− <text
339− xml:space="preserve"
340− style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
341− x="605.52832"
342− y="121.18868"
343− id="text4734-8"
344− sodipodi:linespacing="125%"><tspan
345− sodipodi:role="line"
346− id="tspan4736-8"
347− x="605.52832"
348− y="121.18868"
349− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1081:0</tspan></text>
350− <rect
351− style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
352− id="rect4724-6"
353− width="366.79245"
354− height="200.15094"
355− x="53.60376"
356− y="511.92453" />
357− <text
358− xml:space="preserve"
359− style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier New;-inkscape-font-specification:Courier New"
360− x="63.52832"
361− y="534.18872"
362− id="text4734-0"
363− sodipodi:linespacing="125%"><tspan
364− sodipodi:role="line"
365− id="tspan4736-9"
366− x="63.52832"
367− y="534.18872">198.51.100.2:1080:0</tspan></text>
368− <rect
369− style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
370− id="rect4724-06"
371− width="366.79245"
372− height="200.15094"
373− x="596.60376"
374− y="510.92456" />
375− <text
376− xml:space="preserve"
377− style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
378− x="604.52832"
379− y="533.18872"
380− id="text4734-02"
381− sodipodi:linespacing="125%"><tspan
382− sodipodi:role="line"
383− id="tspan4736-4"
384− x="604.52832"
385− y="533.18872"
386− style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.2:1080:1</tspan></text>
387− <path
388− sodipodi:type="arc"
389− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
390− id="path5106"
391− sodipodi:cx="215.5"
392− sodipodi:cy="197.5"
393− sodipodi:rx="14.5"
394− sodipodi:ry="14.5"
395− d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
396− transform="translate(22.235847,-2.3301926)" />
397− <path
398− sodipodi:type="arc"
399− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
400− id="path5106-0"
401− sodipodi:cx="215.5"
402− sodipodi:cy="197.5"
403− sodipodi:rx="14.5"
404− sodipodi:ry="14.5"
405− d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
406− transform="translate(565.49998,1.5)" />
407− <path
408− sodipodi:type="arc"
409− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
410− id="path5106-7"
411− sodipodi:cx="215.5"
412− sodipodi:cy="197.5"
413− sodipodi:rx="14.5"
414− sodipodi:ry="14.5"
415− d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
416− transform="translate(564.49998,413.50003)" />
417− <path
418− sodipodi:type="arc"
419− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
420− id="path5106-06"
421− sodipodi:cx="215.5"
422− sodipodi:cy="197.5"
423− sodipodi:rx="14.5"
424− sodipodi:ry="14.5"
425− d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
426− transform="translate(21.499985,414.5)" />
427− <path
428− sodipodi:type="star"
429− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
430− id="path5217"
431− sodipodi:sides="3"
432− sodipodi:cx="-58"
433− sodipodi:cy="224"
434− sodipodi:r1="15.033296"
435− sodipodi:r2="7.5166483"
436− sodipodi:arg1="-1.5707963"
437− sodipodi:arg2="-0.52359878"
438− inkscape:flatsided="true"
439− inkscape:rounded="0"
440− inkscape:randomized="0"
441− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
442− inkscape:transform-center-y="-3.7583241"
443− transform="translate(250,279.48335)" />
444− <path
445− sodipodi:type="star"
446− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
447− id="path5217-1"
448− sodipodi:sides="3"
449− sodipodi:cx="-58"
450− sodipodi:cy="224"
451− sodipodi:r1="15.033296"
452− sodipodi:r2="7.5166483"
453− sodipodi:arg1="-1.5707963"
454− sodipodi:arg2="-0.52359878"
455− inkscape:flatsided="true"
456− inkscape:rounded="0"
457− inkscape:randomized="0"
458− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
459− inkscape:transform-center-y="-3.7583241"
460− transform="translate(336,278.75832)" />
461− <path
462− sodipodi:type="star"
463− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
464− id="path5217-0"
465− sodipodi:sides="3"
466− sodipodi:cx="-58"
467− sodipodi:cy="224"
468− sodipodi:r1="15.033296"
469− sodipodi:r2="7.5166483"
470− sodipodi:arg1="-1.5707963"
471− sodipodi:arg2="-0.52359878"
472− inkscape:flatsided="true"
473− inkscape:rounded="0"
474− inkscape:randomized="0"
475− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
476− inkscape:transform-center-y="-3.7583241"
477− transform="translate(292,278.75832)" />
478− <path
479− sodipodi:type="star"
480− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
481− id="path5217-7"
482− sodipodi:sides="3"
483− sodipodi:cx="-58"
484− sodipodi:cy="224"
485− sodipodi:r1="15.033296"
486− sodipodi:r2="7.5166483"
487− sodipodi:arg1="-1.5707963"
488− sodipodi:arg2="-0.52359878"
489− inkscape:flatsided="true"
490− inkscape:rounded="0"
491− inkscape:randomized="0"
492− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
493− transform="matrix(0,1,-1,0,654,214.75832)"
494− inkscape:transform-center-x="-3.7583239" />
495− <path
496− sodipodi:type="star"
497− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
498− id="path5217-4"
499− sodipodi:sides="3"
500− sodipodi:cx="-58"
501− sodipodi:cy="224"
502− sodipodi:r1="15.033296"
503− sodipodi:r2="7.5166483"
504− sodipodi:arg1="-1.5707963"
505− sodipodi:arg2="-0.52359878"
506− inkscape:flatsided="true"
507− inkscape:rounded="0"
508− inkscape:randomized="0"
509− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
510− transform="matrix(0,1,-1,0,653,299.75832)"
511− inkscape:transform-center-x="-3.7583239" />
512− <path
513− sodipodi:type="star"
514− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
515− id="path5217-49"
516− sodipodi:sides="3"
517− sodipodi:cx="-58"
518− sodipodi:cy="224"
519− sodipodi:r1="15.033296"
520− sodipodi:r2="7.5166483"
521− sodipodi:arg1="-1.5707963"
522− sodipodi:arg2="-0.52359878"
523− inkscape:flatsided="true"
524− inkscape:rounded="0"
525− inkscape:randomized="0"
526− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
527− transform="matrix(0,-1,1,0,365,140.75832)"
528− inkscape:transform-center-x="3.7583235" />
529− <path
530− sodipodi:type="star"
531− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
532− id="path5217-70"
533− sodipodi:sides="3"
534− sodipodi:cx="-58"
535− sodipodi:cy="224"
536− sodipodi:r1="15.033296"
537− sodipodi:r2="7.5166483"
538− sodipodi:arg1="-1.5707963"
539− sodipodi:arg2="-0.52359878"
540− inkscape:flatsided="true"
541− inkscape:rounded="0"
542− inkscape:randomized="0"
543− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
544− transform="matrix(0,1,-1,0,653,665.75832)"
545− inkscape:transform-center-x="-3.7583239" />
546− <path
547− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
548− id="path5272"
549− d="m 193.68926,500.34844 c -0.0623,-0.011 -3.1352,-0.097 -2.77128,-1.41324 0.2615,-0.94576 1.83318,-1.37784 1.76404,-2.35665 -0.0476,-0.67399 -2.3566,0.0555 -1.96552,-0.49551 3.61436,-5.09213 7.40016,-2.72086 3.75441,-4.53186 -1.02814,0.14511 -2.14021,0.86727 -3.08442,0.43531 -0.51327,-0.2348 0.48469,-1.05111 0.89792,-1.43558 1.1048,-1.02792 2.49187,-1.72109 3.59807,-2.74751 0.46707,-0.43338 1.70248,-1.66102 1.07001,-1.58392 -5.6701,0.69128 -9.05745,4.75136 -4.37921,0.0443 -0.70285,-0.0451 -1.58092,0.33122 -2.10855,-0.13529 -0.36515,-0.32287 0.13779,-0.98089 0.34974,-1.41981 0.746,-1.54482 2.04183,-2.71312 3.1089,-4.00945 0.4506,-0.54741 1.18336,-0.99124 1.28844,-1.69243 0.0528,-0.35257 -0.64405,-0.30591 -0.96608,-0.45886 -0.29448,-0.23467 -0.54733,-0.53426 -0.88345,-0.704 -4.59528,-2.32065 4.03029,4.51864 2.22179,-3.3353 -0.30962,-1.34461 -4.25255,2.34931 -4.01941,0.98936 0.49925,-2.91216 11.67979,-5.28818 -0.97921,-1.80297 2.24958,4.51807 3.74218,-3.55163 2.31947,-3.58424 -1.2249,-0.0281 -2.37028,0.65039 -3.58472,0.8125 -0.52552,0.0702 -1.82785,0.34942 -1.58584,-0.1223 0.5628,-1.09696 1.92657,-1.54028 2.85501,-2.35149 0.70996,-0.62032 1.37164,-1.29381 2.05746,-1.94071 -0.89522,0.15512 -1.79044,0.31024 -2.68566,0.46535 0.40052,-0.43099 1.78504,-1.21739 1.20156,-1.29297 -1.00554,-0.13025 -3.61463,1.73864 -2.84352,1.08028 2.61678,-2.23416 7.40375,-3.51247 2.7139,-2.27363 -0.68863,-0.56914 -4.0411,1.72327 -3.46573,0.69506 6.10702,-10.91337 6.03578,15.71084 15.20135,-9.25342 1.34953,-3.67571 -7.11657,3.28455 -10.78034,4.66617 -0.56483,0.21299 -1.20609,0.0542 -1.80913,0.0813 0.76568,-2.82657 9.84801,-2.83331 8.08522,-5.59671 -1.3756,-2.15643 -4.67918,2.20115 -7.19335,2.67169 -0.59179,0.11076 0.56857,-1.08069 0.98997,-1.51069 0.9071,-0.92561 3.07293,-1.22924 2.96045,-2.52034 -0.0925,-1.06133 -2.0796,0.46382 -3.1194,0.69573 -1.9254,-1.61777 -0.23831,-2.25512 1.24604,-3.92389 0.51908,-0.58358 2.26263,-1.8224 1.48163,-1.81517 -4.72816,0.0437 -15.68126,8.0904 3.31529,-3.96387 -2.08474,0.72265 -4.12918,1.57418 -6.25422,2.16795 -6.19352,1.73056 1.93855,-2.61924 2.43539,-3.11862 0.23788,-0.23911 -1.011,-0.39289 -0.78275,-0.64119 1.19525,-1.30024 3.85496,-1.42731 4.26366,-3.14549 0.29345,-1.23365 -2.47514,0.55288 -3.71271,0.82932 -0.47093,1.29702 -2.86607,-0.7275 -2.30369,-1.43649 1.13698,-1.43339 6.00313,-3.6915 4.17835,-3.55914 -3.87338,0.28095 -7.04111,4.03354 -10.92463,4.04848 -2.19049,0.008 3.44176,-2.71129 5.19354,-4.02643 2.07031,-1.55429 4.18104,-3.054 6.27156,-4.581 -2.38158,0.72626 -4.66588,1.94492 -7.14472,2.17878 -0.53269,0.0503 0.25632,-1.04063 0.43321,-1.5456 0.96518,-2.7553 0.80112,-1.64828 3.58926,-4.46916 0.67747,-0.68544 2.91667,-2.22292 1.95765,-2.12762 -2.73974,0.27225 -5.202,1.80566 -7.80301,2.70849 -8.68307,1.74603 11.86244,-6.07092 8.35137,-7.01022 -1.96335,-0.52524 -6.69769,3.57812 -5.84576,1.73289 1.22888,-2.6617 5.30375,-2.7549 7.30622,-4.89614 0.68666,-0.73425 -2.00109,0.19549 -3.00164,0.29323 0.87732,-0.86011 1.75464,-1.72023 2.63196,-2.58035 -9.58228,3.08729 -5.78397,4.19264 -6.58589,0.97012 -0.0902,-0.3624 -0.0624,-0.93313 -0.42075,-1.03836 -0.91483,-0.26865 -3.5847,0.69399 -2.8594,0.0751 8.61485,-7.35105 17.70344,-8.79375 5.26595,-5.85043 1.60054,-3.41758 1.28401,-1.02057 -0.60908,-2.58794 -0.3464,-0.2868 -0.289,-0.89839 -0.62771,-1.19424 -0.43227,-0.37759 -1.86567,-0.23189 -1.56403,-0.7202 2.34987,-3.80416 8.10292,-4.17851 0.0503,-2.68926 -1.15677,-3.65997 -0.0599,1.01346 5.25047,-5.42269 0.33771,-0.40931 -1.12483,-0.33282 -1.37625,-0.80012 -0.22134,-0.4114 0.2271,-0.9209 0.19939,-1.38724 -0.20588,-3.46551 -0.71496,1.54991 -0.16416,-2.39216 -5.64005,3.38956 6.40177,-4.28155 4.35608,-4.32495 -1.7082,-0.0362 -3.23754,1.16492 -4.92891,1.40681 -0.55643,0.0796 -2.04039,-0.0979 -1.61937,-0.47032 2.59221,-2.29286 6.19284,-3.30617 8.64724,-5.74599 0.70785,-0.70364 -1.99446,0.0827 -2.99169,0.12404 -0.76412,-0.0589 -2.58888,0.52999 -2.29238,-0.17673 0.62545,-1.49077 4.87787,-2.0553 3.688,-3.14973 -1.3995,-1.28723 -3.63271,1.17661 -5.51093,1.47304 -0.6753,0.10658 -1.96892,0.39814 -2.03141,-0.28266 2.03577,-2.47367 2.13582,-1.3059 1.42131,-3.21609 0.58154,-2.04915 3.24163,-2.36974 4.11535,-4.097 -0.79817,-0.13876 -2.2949,0.11553 -1.46683,-1.35383 0.38381,-0.68104 2.31695,-1.56406 1.55829,-1.75265 -1.35197,-0.33608 -2.68049,0.76035 -4.02074,1.14053 10.77595,-7.1105 3.36075,-1.66253 -0.19448,-1.41063 -0.80754,0.0572 1.50647,-0.94746 1.70133,-1.73322 0.0991,-0.39958 -0.87355,-0.0758 -1.18632,-0.34348 -0.22941,-0.19634 -0.44034,-0.65146 -0.2367,-0.87442 1.11915,-1.22532 2.58807,-2.07788 3.88211,-3.11681 0.46226,-0.59368 2.13907,-1.7945 1.38677,-1.78102 -14.87693,0.26652 -1.27125,4.70958 -2.16014,-1.06114 -0.19906,-1.29234 -2.99053,1.78966 -3.84104,0.79648 -2.43359,-2.8418 7.84171,-2.59072 -0.18106,-2.32196 1.26696,-1.11062 2.53393,-2.22125 3.80089,-3.33188 -0.37381,-0.36169 -1.34521,-0.61552 -1.12142,-1.08506 0.6859,-1.4391 2.50279,-2.08411 3.29206,-3.46921 0.30719,-0.53911 0.33063,-1.66965 -0.26531,-1.84246 -1.52437,-0.44204 -4.51329,1.95947 -4.74554,0.38939 -0.28847,-1.95008 2.79003,-2.78566 4.18504,-4.17849 -2.84688,0.77924 -5.61536,1.94441 -8.54064,2.33772 -0.86059,0.11571 -2.88311,-0.10077 -2.4594,-0.85871 1.22634,-2.19374 3.76055,-3.33687 5.69902,-4.93647 2.28197,-1.88304 5.17285,-3.1505 6.95922,-5.5089 0.48483,-0.64009 -1.53136,-0.56213 -2.33353,-0.59804 -1.34734,-0.0603 -2.6893,0.20862 -4.03395,0.31293 0.68463,-0.93535 1.93126,-1.65341 2.0539,-2.80605 0.14342,-1.34792 -3.60803,-0.10431 -3.67727,-1.17576 -0.0618,-0.95616 1.17488,-1.51652 1.82059,-2.22442 3.91139,-4.28816 5.04581,-3.35568 -6.18155,0.79961 3.2876,-2.35602 5.31447,-2.73015 6.79781,-5.80474 0.18346,-0.38028 0.74816,-1.16656 0.32973,-1.223 -1.22167,-0.16479 -2.80483,1.70893 -3.61503,0.77985 -0.71461,-0.81948 1.69757,-1.45353 2.17622,-2.42979 0.17131,-0.3494 -0.3057,-0.71572 -0.45855,-1.07358 0.20589,-0.53947 1.0395,-1.22409 0.61769,-1.61843 -0.59794,-0.559 -1.71607,0.25692 -2.45368,-0.098 -0.35235,-0.16954 -0.12335,-0.77263 -0.16402,-1.16153 -0.35068,-3.35404 1.76007,-2.61899 -2.06169,-3.55371 0.97288,-0.96358 6.7044,-6.50628 7.49127,-7.802 0.42498,-0.6998 1.09682,-2.25813 0.2981,-2.43805 -2.14748,-0.48373 -4.40681,1.64541 -6.52208,1.03607 -0.89757,-0.25856 0.33999,-1.8897 0.85608,-2.66825 0.97958,-1.47772 2.36172,-2.64483 3.54258,-3.96725 0.0597,-0.68098 0.49091,-1.4346 0.17912,-2.04295 -1.44492,-2.81925 -3.89682,2.01552 0.0472,-3.44476 0.58877,-0.81511 2.85288,-2.38727 1.84737,-2.38469 -5.49626,0.0141 -12.52399,6.39939 -2.52177,-1.41194 0.1794,-0.46573 0.24889,-0.99051 0.53821,-1.39719 4.68594,-6.58674 -0.51929,4.47458 -3.32287,-0.5112 -0.864,-1.53652 3.5875,-1.65903 4.094,-3.34747 0.30845,-1.02819 -2.13504,0.50427 -3.19953,0.36577 -0.41883,-0.0545 -0.59573,-0.59889 -0.8936,-0.89833 0.92251,-0.92192 1.84502,-1.84384 2.76752,-2.76576 -1.55796,0.31564 -5.53053,2.28596 -4.67389,0.94692 1.58563,-2.47854 5.13653,-2.97992 7.27047,-5.00568 0.39453,-0.37453 -1.07912,-0.19012 -1.5841,-0.39242 -2.59907,-1.04122 1.45702,-1.10305 -3.99527,-0.0413 0.23249,-0.50921 2.4381,-3.75255 2.14815,-3.95163 -0.6386,-0.43846 -1.56195,0.16288 -2.3238,0.0227 -0.41951,-0.0772 -0.73377,-0.43517 -1.10066,-0.65276 -1.05703,0.094 -2.11405,0.18798 -3.17108,0.28197 14.56659,-10.91162 6.60855,-1.66215 5.19861,-5.97316 -0.7148,-2.18559 1.24321,-1.65251 -0.51252,-3.60095 -0.48504,-0.53828 -1.8482,-0.40764 -1.85561,-1.13218 -0.0121,-1.18458 1.20852,-2.03788 1.81278,-3.05682 -9.27694,-0.46414 -0.43422,1.04567 -1.03621,-3.77995 -0.14103,-1.13058 -2.45562,0.40168 -3.41099,-0.2191 -0.53557,-0.348 -0.27624,-1.42029 0.13193,-1.91155 1.52211,-1.83192 3.75639,-2.96142 5.37142,-4.71197 0.69547,-0.75384 0.97981,-1.80216 1.46971,-2.70325 -0.96071,-0.0793 -1.91817,-0.23172 -2.88212,-0.23794 -8.55832,-0.0551 2.30363,2.43158 5.84613,-5.75478 1.04199,-2.40794 -6.05494,4.67811 -7.47329,2.47082 -1.97994,-3.08124 13.63059,-6.08404 2.2912,-3.51859 -0.25021,-0.2252 -0.8741,-0.36244 -0.75064,-0.67561 0.33861,-0.85888 1.28474,-1.33325 1.8349,-2.07463 0.3234,-0.4358 1.30072,-1.54508 0.76935,-1.4348 -2.61741,0.54321 -4.9249,2.12483 -7.50279,2.83224 -0.26475,0.0727 -0.6308,-0.3697 -0.53436,-0.62673 0.22699,-0.60501 0.87117,-0.95461 1.30676,-1.43191 8.33195,-4.95149 5.03236,-1.13737 6.11797,-4.3184 0.10381,-0.30416 0.66881,-0.79561 0.36265,-0.89337 -0.70346,-0.22461 -2.72427,0.82235 -2.19373,0.30871 3.86981,-3.74657 7.01351,-2.20799 4.21301,-3.35731 6.47296,-4.28612 -2.20647,1.73687 -2.12215,-0.0258 0.0771,-1.61222 3.0843,-1.12915 4.34522,-2.13676 0.70337,-0.56207 -1.70011,0.66929 -2.59767,0.74027 -0.317,0.0251 0.78281,-0.5597 2.49822,-1.51137 0.46567,-0.53737 0.66407,-0.83263 1.36374,-1.22722 0.98725,-0.55676 2.06782,-0.93963 3.04281,-1.51759 0.0706,-0.0419 -0.0426,-0.23655 -0.12151,-0.21413 -5.29503,1.50384 -4.40257,3.36258 -5.22385,1.37394 3.06387,-1.38383 6.12774,-2.76767 9.1916,-4.1515 -1.02417,0.2612 -2.73589,1.78554 -3.07252,0.78362 -0.34305,-1.02104 2.16911,-0.75459 2.7855,-1.63792 0.3836,-0.54973 -1.31058,0.6231 -1.95917,0.45373 -0.38527,-0.1006 0.60234,-0.53362 0.95654,-0.71554 1.47371,-0.75691 3.00581,-1.3943 4.50871,-2.09145 -0.63184,0.1759 -1.24071,0.5651 -1.89552,0.52772 -0.3639,-0.0208 0.62135,-0.38155 0.92504,-0.58312 3.01431,-2.00081 5.71058,-4.58179 9.02869,-6.02384 1.54675,-0.67223 -4.64784,3.89499 -4.52219,5.19822 0.0355,0.36779 0.73819,0.0341 1.10729,0.0512 4.32563,-0.80488 7.35768,-4.13082 11.1,-6.17039 0.43499,-0.23707 -1.10983,0.83769 -0.82002,1.23946 0.2765,0.38331 0.88036,-0.35243 1.29073,-0.58691 0.67659,-0.38659 1.30782,-0.84766 1.96173,-1.27149 -5.61569,3.81123 5.847,-4.12908 4.57733,-2.85552 -1.45264,1.4571 -6.72903,3.75042 -4.68856,4.01464 2.53042,0.32765 4.77089,-2.05254 6.66849,-3.75827 1.18442,-1.06466 -3.01765,1.13692 -4.60412,1.27648 -0.49565,0.11429 -1.88012,0.66559 -1.48695,0.34287 0.77429,-0.63555 1.7993,-0.88123 2.69333,-1.33308 0.97151,-0.49102 1.95644,-0.95806 2.9031,-1.49543 2.92382,-1.0436 -0.19707,-0.51294 -0.0215,-0.62582 1.25048,-0.80387 2.65543,-1.33729 3.98314,-2.00593 0,0 4.7807,-1.95243 4.7807,-1.95243 l 0,0 c -1.85659,1.05808 -3.72243,2.42084 -5.65484,3.34966 -9.08762,4.36805 -8.0472,3.12416 2.63095,-0.35854 0.20723,-0.0676 -0.32075,0.29522 -0.48112,0.44283 -2.06995,0.87954 -4.1399,1.75908 -6.20986,2.63862 0.9538,-0.27297 3.69622,-1.35491 2.86139,-0.81891 -2.24338,1.44037 -4.80919,2.30726 -7.15434,3.57521 -0.84863,0.45883 -2.71756,2.51318 -2.41323,1.5977 0.55196,-1.66044 2.99692,-2.07528 3.70559,-3.71809 2.47079,-5.12674 -0.15677,0.50283 -12.08956,8.85874 -0.3399,0.23801 0.52938,-0.68968 0.57986,-1.10155 0.0246,-0.20093 -0.29494,-0.28758 -0.38754,-0.4676 -0.11097,-0.21572 -0.0206,-0.54638 -0.21125,-0.69644 -0.23265,-0.18316 -0.58274,-0.10535 -0.8741,-0.15803 -1.08077,0.53197 -2.16154,1.06394 -3.2423,1.59591 0.61123,-0.74052 2.73074,-2.56403 1.8337,-2.22155 -2.15024,0.82093 -3.72623,2.75117 -5.80559,3.73796 -0.98272,0.46636 -3.62463,1.55286 -3.21762,0.54411 0.0771,-0.19114 4.26615,-1.34033 5.19748,-1.60123 -0.002,0.84843 0.0797,0.35024 -1.54628,1.13776 -2.43685,1.18026 -4.9713,2.16361 -7.35391,3.44985 -0.17851,0.0964 0.36821,0.22917 0.57035,0.21223 0.76295,-0.0639 2.88998,-0.87285 2.25259,-0.44871 -1.73923,1.15733 -3.76736,1.80676 -5.65104,2.71013 10.64971,-3.49618 2.1377,-0.93772 0.0559,0.71953 -0.87207,0.69424 4.11786,-1.63073 3.18387,-1.02234 -2.76085,1.79836 -4.83888,1.37533 -6.50296,3.57948 0.91407,-0.27289 1.78835,-0.80636 2.74221,-0.81867 0.91196,-0.0118 -3.46726,1.47612 -1.8579,1.29003 0.88484,-0.10231 1.72074,-1.001 2.56995,-0.7322 1.4859,0.47035 -9.20657,3.22381 1.57572,0.11558 -2.36017,1.26735 -4.72034,2.53469 -7.08052,3.80204 0.11469,0.19623 0.51051,0.43392 0.34406,0.58869 -1.0316,0.95918 -4.91768,2.38029 -3.50929,2.35433 2.37641,-0.0438 4.3475,-2.14947 6.70962,-2.41333 0.99204,-0.11081 -4.76651,2.1144 -1.8757,2.33444 -2.47051,2.27022 -1.40706,0.62544 -0.30171,1.4434 0.23656,0.17505 0.58096,0.61391 0.35865,0.80673 -10.38418,9.00668 -4.16531,0.51016 -6.4293,6.51935 2.63048,-0.9705 5.18095,-2.19421 7.89145,-2.91149 0.52827,-0.1398 2.01774,0.0636 1.58915,0.40263 -3.37773,2.67161 -8.32186,3.49544 -10.88911,6.95316 -1.61096,2.16972 5.0682,-1.89717 7.67205,-2.62025 1.25504,-0.34852 2.5621,-0.62886 3.86383,-0.5832 0.65675,0.023 1.20643,0.52147 1.80965,0.7822 -3.46414,2.44363 -7.191,4.55195 -10.39243,7.33089 -0.58409,0.50701 -1.35877,1.98436 -0.62675,2.2341 1.58563,0.54094 3.29876,-0.62716 4.96942,-0.75257 1.2209,-0.0917 4.12945,-1.03159 3.67154,0.10389 -2.69944,6.69376 -9.76124,4.11086 -2.82461,5.80978 6.90857,0.95619 0.9429,-0.72532 -1.57226,5.00935 -0.34511,0.78688 2.32093,-0.12806 2.47595,0.71707 0.20152,1.09859 -1.35608,1.79559 -1.82949,2.80722 -0.6057,1.2943 -0.13837,2.97783 -1.37315,4.06119 6.75468,-0.97119 2.63252,-1.01551 -0.36648,2.73408 -0.22941,0.28683 0.44063,0.77321 0.80719,0.75004 1.40095,-0.0885 4.53648,-2.38467 4.07603,-1.05858 -1.26042,3.62998 -8.23101,3.63354 -3.0188,3.37711 -1.05416,3.23385 -0.10913,-0.73895 4.56561,-0.24918 0.70549,0.0739 -0.68816,1.25315 -1.15449,1.78768 -0.64077,0.73448 -4.96366,4.6973 -5.48665,5.53109 -0.22878,0.36475 0.0942,0.85596 0.14131,1.28395 6.80006,0.91876 -1.15929,-0.83571 1.30873,1.95101 0.51573,0.58233 2.76862,-0.57122 2.33248,0.0729 -1.14053,1.68436 -4.05337,1.81352 -4.87103,3.67613 -0.54479,1.24101 4.28517,-2.52858 4.06555,0.0598 -0.63833,0.76458 -1.43148,1.42297 -1.915,2.29376 -0.0769,0.1384 -0.3511,2.69941 -0.12976,2.8934 0.56558,0.4957 2.22633,-0.20159 2.18825,0.54951 -0.064,1.2629 -1.57761,1.97665 -2.36641,2.96498 -0.019,0.66037 -0.0381,1.32074 -0.0571,1.98111 0.94651,0.22022 2.00211,0.1676 2.83952,0.66067 1.70887,1.0062 0.93959,2.64925 0.89198,4.10584 -0.0661,2.02294 0.18274,3.87611 1.1481,5.67875 -1.06661,1.09941 -2.13322,2.19882 -3.19983,3.29823 0.2676,0.37359 1.04509,0.73029 0.80279,1.12077 -0.8266,1.33216 -3.21601,1.62884 -3.46899,3.17607 -0.16227,0.99251 2.62242,-1.24441 3.00082,-0.31263 1.09046,2.68514 -8.21468,3.66408 1.80952,1.70153 -1.63218,1.29533 -4.86877,1.80245 -4.89653,3.88598 -0.0224,1.67689 3.19324,-1.46022 4.86198,-1.29358 0.65024,0.0649 -1.66078,1.77119 -1.014,1.67783 7.46951,-1.07821 11.3939,-6.41009 0.77149,1.84447 -0.88572,0.68828 -1.57915,1.5935 -2.36873,2.39026 1.30757,-0.26932 2.64879,-1.20722 3.92271,-0.80795 0.63932,0.20037 -0.58657,1.23688 -1.06824,1.70258 -1.32676,1.28278 -3.70274,1.74138 -4.29988,3.48758 -0.15335,0.44846 6.75296,-0.67501 6.46415,-0.24736 -1.58594,2.34843 -4.48718,3.46216 -6.73077,5.19323 1.3217,-0.0924 2.67555,-0.58142 3.96508,-0.27724 0.51852,0.1223 1.02338,0.92317 0.77805,1.39606 -0.77215,1.48839 -2.31758,2.42555 -3.41729,3.69131 -0.96138,1.10654 -2.78709,1.9559 -2.76247,3.42152 0.0163,0.96872 1.93043,0.30116 2.83102,0.65839 0.65744,0.26079 1.18121,0.77827 1.77181,1.16741 -2.81262,4.75928 -2.80872,3.10652 4.67589,1.64938 -1.26041,3.25333 -6.0635,3.67638 -8.34922,6.31233 -0.54709,0.63092 1.63108,0.59247 2.45866,0.48082 6.96578,-0.93979 6.8916,-4.14914 6.40783,-0.21327 -1.18995,1.02522 -2.55904,1.87345 -3.56986,3.07565 -0.54677,0.6503 0.29383,1.66499 0.74286,1.93962 0.0538,0.0329 2.28883,0.36373 1.51653,1.38907 -0.74758,0.99254 -1.85029,1.65906 -2.77544,2.48858 -2.01492,4.0117 0.0735,-1.05844 4.36134,-0.0885 1.08359,0.24512 -1.77515,1.36522 -2.48925,2.21628 -0.52276,0.62303 0.058,4.29809 2.41131,0.37226 -1.92105,1.23721 -3.8421,2.47441 -5.76316,3.71162 0.3956,0.10122 0.79231,0.40919 1.18678,0.30368 2.2344,-0.59765 5.44044,-4.40981 6.52306,-2.36587 3.53427,6.67249 -6.90959,1.38524 -6.55868,5.44393 0.0324,0.37432 0.7442,0.19661 1.04558,0.42095 0.25204,0.18763 0.3661,0.51079 0.54915,0.76618 0.0712,0.37017 -0.10001,0.90141 0.21364,1.11051 0.53553,0.35702 2.28266,-0.21938 1.90691,0.30318 -1.19701,1.66473 -3.90255,1.96694 -4.84762,3.78655 -0.45816,0.88212 2.94486,-1.17713 2.97633,-0.18363 0.0919,2.90267 -10.32021,4.68553 2.55412,1.32332 -13.88816,10.05064 -4.21703,1.92319 -0.25957,2.91804 1.17513,0.29542 -1.99914,1.5097 -2.55359,2.58711 -0.16659,0.32374 0.84505,0.2375 0.91628,0.59456 0.15946,0.79941 -1.27266,1.48463 -0.45859,2.40209 -0.70281,0.75107 -2.11627,1.22464 -2.10843,2.25323 0.027,3.53852 5.53042,-3.86509 0.87871,2.07078 -0.73188,0.93392 -3.50631,2.521 -2.33181,2.68947 4.62982,0.66407 18.02038,-9.23088 -2.55995,4.0518 0.41314,0.23165 0.79809,0.52297 1.23941,0.69496 0.55373,0.2158 1.74031,-0.13462 1.72268,0.45941 -0.03,1.01163 -1.4099,1.50852 -1.80872,2.4387 -0.19008,0.44335 0.29109,0.9798 0.14581,1.43979 -0.89241,2.82552 -2.35877,1.39391 0.18581,2.80361 1.15576,-0.0399 2.31084,-0.1194 3.4673,-0.11973 0.91829,-2.6e-4 2.02747,-0.44581 2.75234,0.11795 1.24736,0.97013 -3.54168,3.86915 -2.35717,3.83563 5.02162,-0.14213 14.14556,-7.29822 -0.0472,2.40961 2.98489,1.23449 0.18921,-0.41624 -0.68824,2.82616 -0.60033,2.21837 4.83753,-1.87475 0.42281,2.20368 -5.8186,5.37536 -11.65517,6.41542 5.10315,0.15479 -0.74735,0.80324 -1.36046,1.75663 -2.24204,2.40972 -2.59356,1.92134 -5.97818,2.8581 -8.12378,5.26942 -0.94007,1.05648 3.87672,-2.20293 4.1629,-0.81801 0.32872,1.59077 -5.29356,3.22403 -3.66927,3.20683 9.34954,-0.099 9.14109,-6.9726 8.95016,-1.77383 -0.66494,0.80063 -1.18496,1.74821 -1.99481,2.40188 -2.30911,1.8638 -6.64809,2.20309 -7.2977,5.09856 -0.49714,2.2159 4.34211,-1.35479 6.56359,-1.82642 1.09779,-0.23306 4.03951,-1.16883 3.35516,-0.27937 -5.32352,6.9192 -9.26326,2.75287 -6.07651,5.70641 1.67414,2.04701 0.30461,0.84469 5.41887,-0.72561 0.11184,0.1144 -6.91012,5.41422 -6.9318,5.49711 -0.24616,0.94113 1.90254,-0.44718 2.87321,-0.5114 0.52816,-0.0349 1.04869,0.14483 1.57303,0.21724 -1.52161,1.1575 -3.3167,2.0243 -4.56482,3.47251 -0.44671,0.51832 2.2492,0.46712 1.74568,1.2988 -0.6216,1.02671 -3.07583,1.37328 -2.61071,2.47971 1.65123,3.92793 4.90473,-3.87333 2.6877,0.77006 -6.66072,5.56962 0.36798,-0.83336 4.28539,-0.27792 1.1079,0.15709 -5.53866,3.34557 -5.46553,4.78461 0.037,0.72743 2.02338,-0.83333 2.15168,0.38075 4.12173,0.99404 -0.0563,-0.29498 -6.22292,4.83789 -0.56224,0.46799 1.47621,-0.0627 2.178,-0.26914 1.64502,-0.48384 3.21416,-1.19582 4.82264,-1.78991 1.49947,-0.55383 4.24314,-3.23134 4.50121,-1.65384 0.27342,1.67132 -2.893,1.76151 -4.3395,2.64227 -1.95306,2.20485 -4.62765,2.88503 -7.18354,4.55102 -0.27259,0.17768 0.66562,-0.2445 0.96818,-0.12476 0.19028,0.0753 0.12726,0.38899 0.19089,0.58349 1.80537,-0.61886 3.61073,-1.23772 5.4161,-1.85658 -0.84041,0.72567 -1.82938,1.30856 -2.52124,2.17702 -0.1752,0.21991 0.033,0.56791 0.12198,0.83464 0.96367,2.88967 4.76481,-1.02093 4.14926,2.23243 -2.60527,1.74858 -5.40667,3.23551 -7.81581,5.24574 -0.25305,0.21115 0.40301,0.70659 0.73015,0.66667 1.61028,-0.1965 3.11405,-0.91185 4.68222,-1.32713 5.53619,-1.46608 4.75726,-1.80858 1.75589,1.30793 -0.67715,0.70314 -1.3174,1.4409 -1.97611,2.16135 0.34892,0.13924 1.05014,0.0421 1.04674,0.41771 -0.003,0.31093 -2.48306,3.33637 -2.38036,3.44466 1.97496,2.08253 2.7307,-1.87751 3.63602,0.61954 0.13879,0.38282 -0.0124,0.81431 -0.0186,1.22147 -0.72121,0.73268 -1.83167,1.22502 -2.16363,2.19804 -0.14402,0.42214 0.92361,0.15463 1.26175,0.44549 0.23821,0.2049 0.0682,0.67886 0.29638,0.89481 1.89225,1.79045 3.97497,-3.22614 -2.61618,3.25198 -0.37523,0.3688 -0.44084,0.95545 -0.66126,1.43318 -0.74546,2.83605 -0.90252,1.57357 3.71736,0.86489 0.008,0.42841 -6.88909,5.34977 -7.0881,6.42457 -0.14836,0.80124 1.73679,-0.14013 2.42695,0.2931 0.35611,0.22354 0.032,0.84032 0.048,1.26048 0,0 0.60987,-0.29215 0.60987,-0.29215 z"
550− inkscape:connector-curvature="0" />
551− <path
552− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
553− id="path5274"
554− d="m 235.10087,494.853 c -1.72477,0.26384 -3.45101,1.06486 -5.1743,0.79153 -0.6595,-0.1046 -1.35563,-1.23186 -0.95104,-1.76306 1.85598,-2.43682 6.54502,-3.01774 6.90875,-6.05919 0.24847,-2.0776 -4.22104,1.06972 -6.25171,0.56521 -0.73743,-0.18322 -0.89283,-1.60823 -0.45989,-2.23268 1.45131,-2.09329 3.73816,-3.46105 5.60724,-5.19158 -1.30165,-0.0397 -3.61704,1.15104 -3.90497,-0.11899 -0.346,-1.52615 2.44277,-2.11658 3.07345,-3.54874 0.21772,-0.49443 -0.40056,-1.19952 -0.92452,-1.33116 -2.9824,-0.74933 -3.35447,1.04728 -6.00663,-0.1243 -0.44177,-0.19515 -0.59317,-0.76231 -0.88975,-1.14347 -1.62467,-2.19337 7.01252,-3.6846 6.03097,-6.4629 -0.35181,-0.99579 -2.82628,0.69214 -3.15292,-0.31219 -0.38064,-1.1704 1.77768,-1.8691 2.05342,-3.06855 0.13841,-0.60205 -0.6583,-1.04553 -0.98745,-1.56829 0.30475,-0.89097 0.60949,-1.78193 0.91424,-2.67289 -7.53264,-2.23618 2.38396,1.59728 1.54227,-5.15805 -0.19963,-1.60228 -4.7333,1.91176 -4.83467,0.30028 -0.13257,-2.10718 3.96145,-2.35795 4.5782,-4.3772 0.30919,-1.0123 -2.1105,-0.1648 -3.16575,-0.24721 1.05904,-1.13455 2.11809,-2.26911 3.17714,-3.40366 -0.0107,-0.005 -2.87769,-1.00308 -2.64038,-1.81722 0.28175,-0.96659 2.02632,-1.34668 1.90262,-2.34586 -0.0907,-0.7326 -2.66456,0.44301 -2.21022,-0.13879 4.30542,-5.51324 7.1961,-2.12072 4.55559,-4.73091 -10.33839,2.77071 -4.13255,1.83896 0.36955,-2.9086 0.29783,-0.31407 -0.57517,-0.86256 -1.00599,-0.821 -1.92044,0.18526 -4.33153,2.91099 -5.60131,1.45839 4.33291,-3.89435 5.22082,-2.41149 2.30678,-4.64367 -0.95622,-0.209 -2.72732,0.34155 -2.86867,-0.62699 -0.18982,-1.30072 1.45602,-2.19689 2.31084,-3.19549 1.82796,-2.13542 4.60067,-3.91377 5.39003,-6.85628 0.1612,-0.60094 0.29581,-1.49754 -0.21396,-1.85426 -0.8024,-0.56149 -1.9457,-0.22517 -2.91855,-0.33776 13.2084,-10.64887 -4.15898,2.78139 1.32237,-6.03641 0.64361,-1.03536 2.37686,-1.74659 2.16556,-2.94724 -3.43454,-0.58468 -2.63967,0.45586 -3.04384,-2.48312 -1.56436,2.8e-4 -3.65465,1.17085 -4.69308,8.6e-4 -0.85123,-0.95908 0.86545,-2.44305 1.58105,-3.50717 1.18764,-1.76606 2.96115,-3.10066 4.08003,-4.91106 5.48924,-8.88184 -2.19873,1.44113 -2.88812,-4.43772 -0.21626,-1.84413 2.23606,-2.96484 3.35409,-4.44726 -0.43526,2.04932 -5.52153,-1.4114 -4.49527,-2.86108 1.54224,-2.17853 4.97434,-2.83829 6.00046,-5.30235 0.48638,-1.16795 -3.85006,1.27155 -3.79552,0.008 0.29225,-6.77243 6.68102,-1.96905 2.60362,-4.63478 -1.03744,0.0157 -3.37206,1.05159 -3.11233,0.0471 0.4629,-1.79031 2.90142,-2.33554 4.07379,-3.76559 0.6145,-0.74957 0.86383,-1.74051 1.18878,-2.65368 0.33006,-0.92755 1.7161,-2.57839 0.77018,-2.8514 -7.79155,-2.2488 -8.87812,5.07596 -6.27386,-2.9532 -0.19249,-5.38304 7.51347,-6.23842 8.35735,-10.67915 0.32218,-1.6954 -4.83804,1.06359 -5.13804,-0.63588 -0.37881,-2.14591 3.18898,-3.10151 4.13147,-5.06624 0.37314,-0.77786 -0.50218,-1.68058 -0.48124,-2.54306 0.0239,-0.98457 0.40879,-1.92683 0.61318,-2.89025 -13.08296,-3e-5 0.34211,1.32306 -2.48426,-3.42912 -0.72627,-1.22112 -2.99658,0.75682 -4.26095,0.10876 -0.63537,-0.32567 0.43448,-1.404 0.35062,-2.11303 -0.59735,-5.05055 -8.30722,4.38127 5.7127,-6.54936 -0.0182,-1.2e-4 -4.80445,0.71053 -5.00217,-1.19016 -0.0931,-0.89458 1.35621,-1.63297 1.05882,-2.48178 -0.26951,-0.7692 -2.36655,-0.1317 -2.25749,-0.93942 0.21104,-1.56284 1.93828,-2.48832 2.89013,-3.74569 0.93981,-1.24147 1.8564,-2.50034 2.7846,-3.75051 -2.76858,-2.34245 -1.68916,-0.49431 -0.42062,-4.50395 0.27132,-0.8576 0.13894,-1.83132 0.51325,-2.64924 0.0839,-0.18345 4.09283,-3.81873 1.03007,-4.56276 -1.17187,-0.28469 -2.40782,0.1402 -3.61173,0.2103 0.44344,-0.69241 1.62548,-1.3098 1.33032,-2.07723 -0.27912,-0.72573 -1.74502,0.12468 -2.29333,-0.42664 -2.14536,-2.1571 2.94322,-3.721 4.63358,-7.16098 0.43562,-0.88652 -0.5755,-1.88984 -0.86326,-2.83476 1.38204,-1.92046 2.76407,-3.84091 4.1461,-5.76136 -1.12321,-2.72543 -5.51508,-1.70553 -6.87835,-3.97595 -0.64832,-1.07972 0.6824,-2.56943 0.29228,-3.76689 -0.32662,-1.00257 -2.37342,-1.18153 -2.24537,-2.22816 0.2216,-1.8113 4.5249,-3.42652 3.07232,-4.53103 -2.03388,-1.54653 -5.05737,0.73258 -7.58605,1.09887 3.45501,-4.83392 2.38586,-3.59475 6.51263,-8.25392 1.30105,-1.46891 3.68816,-2.41085 3.96198,-4.3539 0.1544,-1.09559 -3.26799,0.49128 -3.26173,-0.61512 0.0295,-5.20775 9.08516,-4.03102 -1.61053,-3.94352 1.95939,-1.79801 4.27984,-3.26861 5.87816,-5.39403 0.5383,-0.71582 1.049,-2.4148 0.1935,-2.67992 -2.17746,-0.6748 -4.83656,1.77094 -6.80983,0.62951 -1.14404,-0.66177 0.90074,-2.53951 1.7331,-3.56613 5.14504,-6.34577 8.38621,-4.56052 2.51601,-6.13981 -0.85199,-0.32077 -2.4474,-0.0584 -2.55599,-0.96231 -0.15992,-1.33111 1.81714,-2.15158 2.02274,-3.47641 0.10406,-0.6705 -0.95976,-0.99901 -1.23172,-1.62066 -0.25041,-0.57238 0.0184,-1.30737 -0.28754,-1.8521 -0.28092,-0.5002 -1.61971,-0.55889 -1.35127,-1.06589 0.82116,-1.55092 2.55255,-2.40897 3.82883,-3.61345 0.68857,-0.86315 3.1386,-2.32855 2.06571,-2.58945 -10.65886,-2.59195 -5.5639,9.83091 1.19302,-3.59935 0.81945,-1.62876 -6.02054,2.91187 -5.33113,1.22396 2.10963,-5.16508 13.61278,-6.44046 1.79364,-4.30704 0.21403,-0.73136 0.91552,-1.4828 0.64208,-2.1941 -0.26442,-0.68781 -1.27472,-0.73968 -1.91207,-1.10953 1.76068,-1.5448 5.50805,-2.30302 5.28205,-4.63441 -0.18401,-1.89836 -4.58115,2.58145 -5.63515,0.99188 -2.44934,-3.69394 14.48858,-5.96488 -2.32442,-2.54757 -1.7179,-1.85348 6.47741,-4.03448 5.12419,-6.41256 -0.5953,-1.04614 -2.55849,0.49122 -3.60971,-0.095 -0.53027,-0.29573 -0.24018,-1.38425 0.19132,-1.81139 2.01047,-1.99013 4.52431,-3.3972 6.78646,-5.0958 0,0 0.68933,-0.35123 0.68933,-0.35123 l 0,0 c -1.6505,1.38695 -3.301,2.7739 -4.9515,4.16084 1.18084,-0.0304 3.93897,-1.20381 3.54252,-0.0911 -0.76705,2.15293 -7.26975,3.74376 -5.1306,4.54845 4.99319,1.8783 18.98607,-10.22151 2.1677,2.69716 4.46028,0.74689 2.96356,-0.31341 -0.0889,3.77723 -0.63494,0.85088 -2.69281,2.50424 -1.65372,2.72204 2.33328,0.48909 4.58505,-1.63653 6.96887,-1.60791 0.61976,0.007 1.18756,1.25976 0.75189,1.70062 -2.49496,2.5247 -5.74404,4.17153 -8.61606,6.2573 12.12981,-2.41278 3.30013,-1.95214 3.56234,1.57757 0.054,0.72705 2.55848,-0.20768 2.15087,0.39678 -1.23294,1.82837 -6.14542,2.11983 -5.18729,4.10604 2.15892,4.47548 10.45489,-6.74524 4.2017,0.92413 2.15257,3.5125 1.16422,0.95894 -5.41535,6.17669 1.26621,2.35461 6.76352,-4.43669 7.77661,-1.96259 8.28333,20.22899 -28.85471,-8.50838 3.09217,3.12802 1.84928,0.67359 -2.68677,2.87671 -4.03016,4.31506 -0.92921,1.24117 -1.85842,2.48233 -2.78763,3.7235 0.58132,0.56011 1.79929,0.87498 1.74397,1.68034 -0.0987,1.43783 -1.97261,2.33537 -2.11827,3.76921 -0.0857,0.8441 1.28221,1.22332 1.52863,2.03519 1.49261,4.91758 -5.97031,3.63582 7.4952,1.34569 -0.55001,0.45931 -10.77994,8.64592 -11.73418,10.56561 -0.32217,0.64811 2.10161,0.84706 1.64937,1.41214 -2.09388,2.61633 -7.66175,2.96102 -7.82786,6.30795 -0.16991,3.4234 8.56273,-4.46712 10.27927,-0.27127 -1.76159,1.81971 -3.52318,3.63942 -5.28477,5.45913 0.76622,0.59813 2.4346,0.8319 2.29867,1.79438 -0.27968,1.9803 -3.80714,3.11034 -3.26317,5.0349 0.46282,1.63743 4.21131,-0.43752 4.99021,1.07532 3.93398,7.64091 -10.83273,3.14159 3.44758,5.72402 -0.9151,1.68254 -1.83021,3.36508 -2.74532,5.04762 -0.11662,1.15096 0.18214,2.42561 -0.34986,3.45288 -0.92725,1.79049 -2.95622,2.85717 -3.85317,4.66303 -1.3412,2.70028 4.81416,2.32838 5.47911,2.30305 -0.3941,0.74413 -1.64975,1.53203 -1.18229,2.23241 0.55364,0.82952 3.61797,-0.31799 2.96056,0.43196 -2.55013,2.90915 -6.77897,3.98142 -9.35743,6.86548 -0.53751,0.60121 1.34054,0.89766 1.99237,1.3725 3.00597,2.18979 0.67181,0.85532 4.1958,2.58013 0.97743,0.27897 3.12712,-0.1607 2.93229,0.83692 -0.37108,1.90014 -2.58726,2.88188 -3.93077,4.27586 -1.41178,1.46482 -5.0521,2.39525 -4.3329,4.29829 0.66993,1.77268 4.05322,-1.99686 5.61067,-0.91724 2.00902,1.39265 -6.05121,4.28837 -4.30844,5.93449 8.79644,-0.97427 2.46458,-1.29009 1.54772,2.85609 -0.55951,2.53017 5.57675,-0.6921 4.65189,1.63694 -4.43479,11.16791 -5.60958,0.57178 -4.52068,6.97527 -1.01107,1.36804 -2.96739,2.40428 -3.03319,4.10412 -0.0404,1.04402 1.88097,0.91014 2.82145,1.36521 0.80303,0.59941 2.46039,0.79749 2.40909,1.79825 -0.0133,0.25895 -5.43921,8.7383 -5.29443,9.14273 0.52067,1.4545 3.02467,0.63085 4.53701,0.94627 -0.64141,1.38413 -0.99081,2.94575 -1.92422,4.15238 -1.68564,2.17903 -8.12235,4.34484 -5.82411,5.86392 2.99789,1.98153 6.81296,-3.05371 10.40013,-2.83928 1.37703,0.0823 -2.60327,1.93867 -2.48051,3.31268 0.0835,0.9342 1.86713,0.1807 2.80069,0.27105 -2.14561,1.60336 -4.29121,3.20672 -6.43682,4.81008 3.30783,4.57067 -4.3191,-6.77248 -4.22041,5.45487 0.0138,1.70811 3.38667,-0.86784 5.08198,-0.6587 2.45197,0.30248 2.15812,5.02735 1.95842,6.42304 -3.19404,2.52625 -8.52248,3.64671 -9.58211,7.57875 -0.68106,2.52726 6.18106,-3.00764 7.79494,-0.94699 1.4073,1.79689 -3.96866,2.95153 -4.48356,5.17508 -0.24512,1.05851 2.84501,0.24565 2.9786,1.32394 0.65218,5.26442 -11.20032,5.62551 5.28419,2.39953 -0.67702,1.06264 -1.40702,2.09332 -2.03106,3.18792 -0.45821,0.80372 -1.7507,1.74672 -1.21035,2.49769 0.61904,0.86033 2.63525,-0.68635 3.17151,0.22788 0.50566,0.86208 -1.0545,1.6999 -1.52286,2.58281 -2.38314,4.49245 0.66315,0.65249 -5.01938,6.11325 2.51835,3.02589 0.23004,-0.58326 -2.18819,4.90305 -0.24233,0.54978 0.86402,0.916 0.99629,1.50207 0.16072,0.71214 -0.80005,1.82496 -0.16437,2.18397 1.16036,0.65534 2.71959,-0.39573 3.99784,-0.0189 0.60248,0.17759 0.73877,1.01601 1.10815,1.52402 -1.36074,1.34979 -3.20063,2.34749 -4.08221,4.04936 -0.27139,0.52391 1.05543,0.7318 1.64139,0.66261 1.97114,-0.23275 3.95028,-2.36609 5.75307,-1.53572 1.23577,0.5692 -2.05672,1.79651 -2.93984,2.8315 -0.48863,0.57266 -0.71854,1.32576 -1.13976,1.94967 -0.51361,0.76074 -1.1066,1.46475 -1.6599,2.19713 0.33873,0.23814 1.19514,0.34101 1.01619,0.71442 -0.51118,1.06668 -1.77446,1.57558 -2.54408,2.4738 -3.23585,3.77652 -0.50318,0.34945 -0.55933,2.92637 -0.0502,2.30217 -3.339,4.40022 -4.37743,5.39298 18.27135,-5.79195 7.34887,-3.82125 5.07084,1.06134 -0.30011,0.64325 1.3829,0.55521 1.80963,1.12243 0.39639,0.52689 0.0574,1.41202 0.47866,1.91923 2.55384,3.07493 4.72612,-2.11248 -1.30905,5.03921 0.59055,0.43479 1.11486,0.97814 1.77163,1.30437 0.77872,0.38681 2.79133,-0.004 2.4803,0.80765 -0.73427,1.91687 -3.09181,2.72119 -4.42871,4.27883 -3.95484,4.60782 -1.14208,11.46892 8.83243,0.8083 -2.78274,1.95014 -5.79944,3.60312 -8.34822,5.85044 -0.32391,0.28561 -0.30561,2.75922 0.50582,2.9271 1.34444,0.27816 4.07556,-1.66363 4.10843,-0.29112 0.0607,2.53601 -5.62402,2.95619 -4.29713,6.28092 2.63484,-0.56434 7.72239,-4.38145 7.90451,-1.69301 0.22273,3.28781 -5.39696,3.87479 -7.59009,6.33435 -0.4392,0.49256 -1.07168,4.84516 -0.91018,5.62296 0.13638,0.65682 1.15889,1.0274 1.08607,1.69426 -0.11092,1.01582 -1.03951,1.7596 -1.55927,2.6394 0,0 1.72998,-0.88147 1.72998,-0.88147 z"
555− inkscape:connector-curvature="0" />
556− <path
557− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
558− id="path5276"
559− d="m 271.40967,500.0231 c 0.84361,-1.11502 2.99222,-2.02518 2.53083,-3.34505 -0.4382,-1.25354 -3.99371,0.67052 -3.92942,-0.65585 0.10731,-2.21366 3.58902,-3.01826 4.21063,-5.14555 0.29949,-1.02491 -2.43266,-1.56527 -1.96867,-2.52695 1.35708,-2.81273 4.53987,-4.32256 6.46127,-6.78454 1.08733,-1.39324 1.65843,-3.12142 2.48765,-4.68213 -7.46636,-0.79001 -5.08221,1.28307 -4.90812,-4.06826 0.0316,-0.97271 -0.27942,-1.93215 -0.28908,-2.90532 -0.01,-0.98605 1.13592,-2.55748 0.23099,-2.94925 -1.80824,-0.78284 -6.00039,2.46658 -5.89015,0.49924 0.15148,-2.70327 4.10594,-3.5304 6.15891,-5.2956 0.0863,-0.32458 1.27486,-3.51563 0.28596,-4.10661 -1.01075,-0.60403 -5.10035,0.971 -2.93296,-2.24553 0.98758,-1.46562 4.18347,-2.1455 3.66196,-3.8341 -0.47465,-1.53684 -3.21662,0.0457 -4.82493,0.0686 2.53225,-3.24957 8.12982,-9.92119 3.34362,-13.96697 -0.84971,-0.71826 -2.89316,-0.3958 -2.97925,-1.50507 -0.13245,-1.70646 1.67665,-2.98445 2.51498,-4.47667 -0.58297,-0.66933 -1.16594,-1.33865 -1.74891,-2.00798 0.6124,-1.11344 2.66426,-2.37557 1.8372,-3.34034 -0.96917,-1.13053 -3.04522,0.75237 -4.45833,0.28279 -0.57763,-0.19194 -0.54641,-1.34538 -0.16369,-1.81869 1.64069,-2.02908 4.24365,-3.14716 5.84497,-5.20745 0.62197,-0.80025 0.35302,-1.99609 0.52954,-2.99413 1.18656,-1.71414 5.51829,-4.42825 3.55968,-5.14242 -3.68312,-1.34296 -7.74476,3.18213 -11.54765,2.2298 -1.60687,-0.4024 0.40917,-3.40618 1.31691,-4.79181 2.25208,-3.43772 11.80529,-7.67655 4.00813,-10.58092 -2.01538,-0.75071 -4.26368,-0.56779 -6.39552,-0.85169 18.31556,-19.35763 6.94798,-2.12539 4.25278,-10.10937 -0.45617,-1.35131 1.87569,-2.93051 1.10826,-4.13267 -0.81412,-1.27531 -3.9706,0.39684 -4.41614,-1.04908 3.1689,-5.21567 3.70236,-3.03245 1.23334,-6.62861 -8.18188,-0.007 -4.8163,1.36305 -2.0755,-4.06271 0.36854,-0.72956 0.7691,-1.82926 0.22758,-2.4415 -0.65309,-0.73837 -3.47767,0.21889 -2.89987,-0.57977 6.09343,-8.42267 10.79235,-3.56777 5.91985,-7.57855 -12.25386,-1.1019 4.27779,1.54129 1.65438,-6.69263 -0.80029,-2.51183 -5.25694,0.40437 -7.88541,0.60655 4.24469,-3.40941 9.75453,-5.67149 12.73406,-10.22823 0.98096,-1.50023 -4.44943,0.36646 -5.23091,-1.24669 -0.79604,-1.6432 1.46396,-3.34544 2.19595,-5.01817 -0.44562,-1.0569 -0.89124,-2.11379 -1.33686,-3.17069 1.21842,-1.89661 4.4227,-3.57023 3.65526,-5.68983 -0.096,-0.26526 -11.48,-0.72332 -11.66559,-0.80844 -0.84802,-0.38896 -1.35245,-1.93441 -0.79604,-2.68331 2.10967,-2.83952 5.32265,-4.66087 7.98397,-6.99131 2.34226,-3.02177 -2.3457,-2.92502 -2.13068,-5.33277 0.0676,-0.75729 1.50987,-1.53029 0.96915,-2.06479 -2.53936,-2.51012 -10.63271,6.31581 2.37228,-4.61883 -6.19474,1.66146 -9.1703,5.00092 -7.46109,-0.21769 0.33443,-1.02109 0.72495,-2.03797 1.27773,-2.95934 0.83764,-1.39618 2.56915,-2.35267 2.86929,-3.95293 0.18473,-0.98495 -4.34465,-3.06502 -4.46788,-3.13006 -0.99349,-2.65488 2.28337,-4.28846 2.23274,-6.61519 -0.008,-0.38838 -3.79592,-3.07607 -3.34144,-3.91339 1.29663,-2.38888 5.23411,-3.12425 5.73612,-5.79557 0.28158,-1.49837 -3.02289,-0.39958 -4.53434,-0.59936 -0.73879,-0.56327 -2.69562,-0.89392 -2.21638,-1.6898 1.57771,-2.62017 4.86309,-3.77022 6.8856,-6.06454 0.60727,-0.68889 1.19228,-1.81559 0.7877,-2.64001 -0.39219,-0.79916 -1.88839,-0.25903 -2.51884,-0.88752 -3.52309,-3.51214 5.42905,-1.06978 -3.64123,-2.45646 -1.28883,-1.47023 4.42724,-4.22495 3.00729,-5.92455 -0.87349,-1.04551 -4.62824,0.79539 -4.06292,-0.44416 1.2864,-2.82067 5.3809,-3.45971 7.0382,-6.07971 0.48077,-0.76003 -2.25924,-0.53635 -2.2845,-1.43532 -0.0391,-1.39345 1.42887,-2.394 2.14331,-3.591 0.57897,-1.13977 2.39829,-2.3253 1.7369,-3.4193 -0.70437,-1.16508 -2.77891,0.0285 -4.06202,-0.42667 -4.36529,-1.54853 1.70005,-4.13301 2.00734,-5.56729 0.1857,-0.86677 -1.69451,-0.52131 -2.54176,-0.78196 1.09797,-1.11213 2.19594,-2.22425 3.29391,-3.33638 -7.62803,0.34657 -0.62323,0.76416 0.31659,-3.27246 0.22707,-0.97527 -1.99998,0.10431 -2.99997,0.15647 1.88627,-1.35807 4.42344,-2.10539 5.65881,-4.0742 0.6094,-0.9712 -2.25983,0.52665 -3.40556,0.48318 -0.49695,-0.0188 -0.89097,-0.44207 -1.33646,-0.6631 -5.22674,-0.89819 -1.26314,0.31771 4.36293,-5.17642 0.40557,-0.39606 0.69638,-1.64645 0.13163,-1.69553 -1.86658,-0.16222 -5.82482,3.07279 -5.48453,1.23034 0.86459,-4.68123 15.40434,-8.00968 -0.85374,-3.14014 -0.53032,-0.34481 -1.68223,-0.40848 -1.59097,-1.03442 0.19075,-1.30836 3.0586,-2.26352 2.22094,-3.2865 -0.93884,-1.14654 -2.98163,1.04666 -4.40173,0.62324 -0.64237,-0.19154 0.3747,-1.67926 -0.21416,-1.99954 -5.42716,-2.95183 -2.51001,2.85865 -4.39836,-2.21361 -1.0113,-2.24228 -4.57355,0.1204 -5.66196,-1.50056 -0.59485,-0.88591 1.78009,-2.58036 0.84181,-3.08859 -1.49807,-0.81144 -3.4198,1.31804 -5.04636,0.81115 -0.75563,-0.23548 0.0205,-1.5828 0.0307,-2.37421 -0.78514,-0.23306 -1.57029,-0.46613 -2.35544,-0.6992 -18.82244,6.26303 -1.07068,2.06578 -7.70098,1.1906 -1.1255,-0.14856 -3.19802,1.33749 -3.39866,0.22011 -0.0112,-0.0625 5.46172,-7.20216 5.52409,-7.28374 0,0 -1.31152,0.82398 -1.31152,0.82398 l 0,0 c 0.10548,0.55469 -0.0164,1.20797 0.31643,1.66406 1.996,2.73517 7.61323,-1.59563 8.31169,-1.60148 0.86632,-0.007 -0.60768,1.62267 -0.91151,2.43401 1.32261,-0.19648 2.64522,-0.39296 3.96783,-0.58944 0.98298,4.11711 -0.6215,0.21591 4.5331,1.56511 3.1779,0.83181 -0.81124,5.16423 -0.63379,5.49385 1.18549,2.20203 6.22576,-1.97788 7.49509,0.33556 0.0419,3.06555 -0.51194,2.13147 1.3249,4.21502 0.41138,0.46665 0.67506,1.34969 1.2971,1.34182 1.97297,-0.025 4.46542,-2.93396 5.74383,-1.43099 1.16055,1.36441 -4.40317,2.5692 -3.47341,4.10022 0.93565,1.54072 3.52951,-0.73456 5.29427,-1.10184 0.24843,0.52021 0.45786,1.06092 0.74531,1.56063 0.28443,0.49446 1.19772,0.89213 0.96528,1.41305 -0.6129,1.37359 -2.07256,2.18119 -3.071,3.30614 -0.81192,0.9148 -3.20997,1.93322 -2.35835,2.81118 1.02778,1.05958 2.91649,-1.02103 4.36594,-0.74149 0.51104,0.0986 -0.10293,1.03582 -0.15439,1.55373 -0.90402,0.90742 -2.11634,1.58835 -2.71205,2.72228 -0.18254,0.34745 0.46747,0.83858 0.85858,0.80575 1.71116,-0.14364 3.53033,-2.2076 4.98576,-1.29633 1.08463,0.6791 -1.95527,1.68725 -2.70466,2.72456 -0.3822,0.52905 -0.40546,1.24075 -0.6082,1.86113 -0.73879,0.89107 -1.47759,1.78213 -2.21639,2.6732 -2.6156,4.34603 -1.72804,1.25734 2.28963,2.6141 0.6603,0.22298 1.61939,0.89052 1.4007,1.55225 -0.52966,1.60271 -3.05305,2.23698 -3.20843,3.91777 -0.0904,0.97838 1.83173,0.71158 2.7476,1.06737 -0.14246,0.9235 -0.28492,1.84701 -0.42738,2.77052 -17.69737,16.4527 -0.29839,-1.93789 0.46659,4.845 0.29603,2.62482 -4.02236,3.45288 -5.75948,5.44278 -2.96193,3.39292 -2.80901,4.63463 0.58667,6.56553 -0.71195,3.37109 -1.32723,2.23656 2.17358,3.20427 -0.25398,1.70167 -3.37311,2.17554 -3.38566,3.89601 -0.009,1.22027 7.05377,-0.32166 6.38009,1.54413 -0.87889,2.4341 -3.60347,3.71541 -5.4052,5.57312 1.47272,0.21953 3.73062,-0.66216 4.41814,0.6586 1.2021,2.30926 -4.75905,5.20232 -5.26915,8.38805 -0.29809,1.8617 8.33922,2.21527 5.25308,5.58725 -2.34657,2.11623 -4.82208,4.0977 -7.03972,6.34868 -1.35667,1.37707 -4.99171,3.11027 -3.65263,4.50445 1.62643,1.69336 4.64369,-1.4155 6.96405,-1.05677 0.72132,0.11151 -0.0472,1.51283 0.26216,2.17392 1.59106,3.40017 3.61933,-1.30155 -1.31458,4.69517 1.74643,5.18425 -1.91013,-4.03341 4.14083,1.28591 0.65697,0.57753 -0.7704,1.59325 -1.34315,2.25439 -1.20653,1.39272 -3.31939,2.13238 -3.95537,3.86181 -0.27479,0.74726 1.97176,0.24327 2.16143,1.01653 0.26163,1.06662 -0.77015,2.05703 -1.15523,3.08554 0.46488,0.70316 1.66986,1.31273 1.39465,2.10948 -0.70049,2.02806 -5.77724,4.09808 -3.89369,5.12569 2.954,1.6116 6.67212,-2.6877 9.92708,-1.83407 1.38407,0.36298 -0.26721,3.00285 -1.1364,4.13947 -7.69167,10.05825 -11.30113,4.9757 -5.50453,10.47003 12.1809,2.58454 0.68305,-1.60595 1.50332,7.04834 0.15075,1.59053 3.7325,0.0369 4.58818,1.38612 0.74593,1.17615 -1.03929,2.62565 -1.16411,4.01279 -0.0314,0.34944 0.93404,4.71611 1.05781,5.28963 -1.3802,1.51721 -4.84437,2.62508 -4.14062,4.55164 0.63712,1.74412 3.69816,-1.18051 5.51394,-0.79214 0.65481,0.14005 0.6238,1.53115 0.149,2.00335 -2.81355,2.79816 -8.04318,3.53205 -9.44682,7.2436 -0.82141,2.17201 11.13635,-5.11164 6.76838,1.64927 0.091,0.92514 -0.0854,1.91766 0.27296,2.77541 0.35755,0.85586 1.9948,1.23647 1.78003,2.13881 -0.48142,2.02267 -3.23036,3.09296 -3.51545,5.15249 -0.15382,1.11121 1.86813,1.33099 2.48861,2.26557 2.10332,3.16805 0.92404,4.31695 0.06,7.89324 -10.57418,17.09201 -0.63343,-3.00266 3.38288,6.60571 0.99622,2.38331 -2.8287,4.32307 -4.24305,6.48461 -0.25211,1.50129 -1.38497,3.11742 -0.75634,4.50387 0.56327,1.24229 2.56202,1.0317 3.64324,1.86327 0.79588,0.6121 1.24,1.57949 1.86,2.36924 -8.39878,9.58005 -3.85858,2.27949 2.00132,3.93387 0.86536,0.24431 -0.51486,1.78055 -1.10053,2.46285 -1.42711,1.6626 -4.03733,2.4121 -4.83549,4.45265 -0.34986,0.89445 1.79295,0.68927 2.68943,1.03391 -1.31854,1.63819 -2.63708,3.27639 -3.95562,4.91458 0.66656,0.72544 1.92921,1.19368 1.99967,2.17633 0.0985,1.37395 -1.25826,2.48092 -1.56948,3.82278 -0.31391,1.35345 0.11788,4.84884 0.11683,6.22575 -8e-4,1.05328 -0.46388,2.14171 -0.17615,3.15493 0.24138,0.85002 1.10612,1.3783 1.65918,2.06746 7.82248,2.82758 -3.54352,-2.1669 -3.75729,6.27252 -0.0553,2.18496 4.23975,-1.72368 6.40311,-1.4122 0.77116,0.11103 -0.28142,1.56687 -0.68022,2.23618 -0.55535,0.93205 -4.91731,6.04302 -5.54138,6.78439 1.57917,-0.0855 3.18481,-0.55678 4.73749,-0.2564 0.79773,0.15433 2.07487,0.7473 1.89058,1.53864 -0.42269,1.81501 -2.92768,2.68693 -3.29992,4.51295 -0.18906,0.92743 1.54302,1.20422 1.96139,2.05324 1.93613,3.92917 -1.20747,5.21438 -3.71401,8.46144 0.47992,0.89368 0.58071,2.14155 1.43974,2.68104 1.34606,0.84534 4.13572,-0.37781 4.63211,1.13218 0.93525,2.84501 -5.60155,6.20062 -3.45815,8.29218 1.10289,1.07621 3.61454,-0.86631 4.61266,0.30772 0.75374,0.88657 -1.21106,1.98741 -1.81659,2.98112 0,0 -9.14493,4.65958 -9.14493,4.65958 z"
560− inkscape:connector-curvature="0" />
561− <path
562− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
563− id="path5278"
564− d="m 581.73672,201.15421 c -5.84049,0.0226 -12.46977,3.74174 -18.23522,1.43917 -0.92495,-0.3694 -1.5343,-1.27727 -2.36778,-1.82253 -0.87794,-0.57434 -1.83477,-1.01794 -2.75215,-1.52691 -7.8597,-0.6834 -0.70651,-0.5885 -11.70003,2.01168 -1.54963,0.36652 -3.24586,1.07687 -4.74618,0.54324 -1.59834,-0.5685 0.85485,-5.45684 0.64497,-5.42188 -3.26191,0.54332 -5.93446,2.91946 -8.90169,4.37918 -1.07703,0.12394 -2.49605,1.16872 -3.23111,0.37181 -0.67458,-0.73134 1.68867,-2.13419 0.97042,-2.82271 -0.88828,-0.85153 -2.51436,-0.15881 -3.68494,0.22051 -3.53501,1.14552 -6.56729,4.25069 -10.28286,4.30575 -1.41951,0.021 0.58867,-2.77764 0.88301,-4.16646 -2.91053,0.68366 -5.82106,1.36733 -8.73159,2.05099 -8.55726,-7.49791 7.12666,4.81414 -14.40115,1.39085 -1.87303,-0.29784 3.21179,-4.26845 1.70996,-5.42666 -1.91086,-1.47365 -4.74198,0.90779 -7.13129,1.24574 -10.05799,1.42263 -1.29042,-0.848 -12.92141,2.92188 5.75912,-7.83975 5.57265,-5.71046 -3.55664,-2.09752 -2.02766,0.80245 -4.06024,1.61861 -6.16523,2.18815 -1.4706,0.39791 -3.76794,2.02901 -4.51623,0.70196 -7.88504,-13.98369 9.26915,0.86687 0.0352,-6.49718 -3.10338,1.17026 -6.20676,2.34052 -9.31014,3.51078 -0.57567,-0.69237 -0.83006,-2.15625 -1.72699,-2.0771 -3.09746,0.27333 -5.72754,2.79919 -8.82997,3.00868 -0.91247,0.0616 -0.59156,-2.08023 -1.47605,-2.31278 -1.66146,-0.43682 -4.08937,1.95174 -5.12124,0.57823 -0.99973,-1.33072 1.45413,-2.99444 2.18119,-4.49166 -5.27131,3.01667 -10.21343,6.70024 -15.81393,9.05001 -0.70494,0.29576 0.0899,-1.64484 -0.3563,-2.26558 -0.50641,-0.70446 -1.36894,-1.2616 -2.23327,-1.33677 -1.86367,-0.16207 -3.74223,1.04035 -5.57342,0.65787 -1.06648,-0.22276 -1.54432,-1.53723 -2.31648,-2.30585 -2.11262,0.0407 -4.22524,0.0813 -6.33786,0.12201 -12.42253,2.1242 -6.53573,2.91676 -15.18382,-0.38034 -1.73617,-0.66191 -3.38695,-1.91563 -5.24481,-1.8878 -3.53288,0.0529 -6.89889,2.69571 -10.38526,2.12195 -1.37022,-0.2255 -0.74241,-2.67624 -1.11361,-4.01436 -1.88368,-0.006 -3.76736,-0.012 -5.65104,-0.018 -24.28983,7.62107 -2.5727,3.42937 -7.44036,-1.19304 -1.17426,-1.1151 -3.36042,0.76142 -4.85605,0.14059 -0.9471,-0.39314 -0.37753,-2.78281 -1.40202,-2.73831 -17.07323,0.74169 -4.68269,5.70713 -13.15884,1.68512 -13.47711,1.23798 -0.53507,0.38388 -11.61335,0.31509 -1.85578,-0.0115 -3.70698,0.21371 -5.56273,0.2289 -1.65286,0.0135 -3.33144,-0.4439 -4.95669,-0.14277 -2.69057,0.49853 -5.20719,1.68414 -7.81614,2.50939 -2.13831,0.67638 -4.28365,1.33032 -6.42547,1.99548 -0.9837,-2.83624 -11.06653,5.91354 -9.75378,2.79645 1.53204,-3.63777 6.99404,-4.59873 8.4956,-8.24918 0.86063,-2.09228 -4.2097,1.67823 -6.21979,2.71644 -3.72203,1.92244 -6.92828,5.00691 -10.95697,6.15539 -1.36693,0.38967 1.46202,-2.43801 2.19303,-3.65701 -1.17023,0.0909 -2.53198,0.92049 -3.51069,0.27257 -0.68695,-0.45477 0.96331,-2.14961 0.20152,-2.46328 -4.37993,-1.80347 -8.71503,6.31425 -13.28098,5.05394 -9.4835,-2.61768 17.38499,-9.14192 -0.38289,-4.16034 -0.53601,-0.28526 -1.00462,-0.92342 -1.60803,-0.85578 -1.6592,0.18598 -3.16377,1.06881 -4.75661,1.56922 -1.28969,0.40517 -2.59751,0.75066 -3.88989,1.14719 -1.27067,0.38987 -2.49478,0.95467 -3.7988,1.21188 -0.57067,0.11256 -1.73101,0.46238 -1.74093,-0.1192 -0.0174,-1.01834 1.13036,-1.69456 1.69554,-2.54183 1.13752,-1.49935 -4.63996,2.07583 -4.03582,0.84154 0.66217,-1.35285 4.65116,-3.58371 3.19622,-3.19408 -2.64341,0.70788 -4.51559,3.1669 -7.03997,4.22341 -0.68424,0.28637 0.85778,-1.21035 1.28667,-1.81553 -1.25078,0.65196 -2.50155,1.30391 -3.75232,1.95586 9.21621,-7.98762 6.18858,-4.83213 -0.87423,-0.87619 -0.72387,0.40544 -1.54218,0.6125 -2.31326,0.91875 0,0 2.61292,-1.89841 2.61292,-1.89841 l 0,0 c 1.14285,-0.57635 2.16869,-1.50316 3.42856,-1.72905 0.47365,-0.0849 -0.48687,0.83017 -0.73031,1.24525 0.72034,-0.25777 1.44068,-0.51554 2.16102,-0.77331 -0.0129,0.26612 0.11092,0.57784 -0.0386,0.79836 -0.61275,0.9037 -3.19334,2.83016 -2.16774,2.45563 2.58273,-0.94316 4.57145,-3.1023 7.07165,-4.24644 0.52365,-0.23963 -1.37048,1.87365 -0.20579,1.9951 0.74974,0.0782 1.47219,-0.32486 2.20828,-0.48729 1.12167,-0.37799 2.86257,-2.20567 3.36502,-1.13396 0.5616,1.19787 -1.995,1.89173 -2.42282,3.14363 -0.14298,0.41839 0.66423,0.8732 1.09039,0.75536 2.14236,-0.59239 4.04954,-1.83414 6.08018,-2.73811 7.30472,-3.2518 6.963,-5.26487 6.23711,-0.62098 2.93608,2.63023 -0.0453,0.63795 6.49918,-0.28738 0.87818,-0.12417 1.74981,0.3045 2.63356,0.3793 1.00939,0.0854 2.02969,0.20481 3.03732,0.10065 1.47374,-0.15233 3.07086,-1.5959 4.35975,-0.86523 0.8671,0.49155 -0.53804,1.91949 -0.80707,2.87923 1.97363,-0.76926 3.95449,-1.52021 5.92088,-2.30778 1.9543,-0.78272 3.79068,-1.92385 5.84067,-2.40289 0.58192,-0.13598 1.89487,0.0929 1.67184,0.64736 -0.76788,1.90882 -4.79687,2.97497 -3.86747,4.81058 1.48135,2.92575 7.32339,-5.50614 9.48936,-2.59649 1.42331,-0.13101 2.86231,-0.14485 4.26993,-0.39303 2.16768,-0.38218 4.23629,-1.34177 6.43214,-1.49385 1.38899,-0.0962 2.73015,0.97425 4.10649,0.76394 3.11854,-0.47655 5.9479,-3.356 9.04853,-2.77417 1.44152,0.2705 -2.0691,4.5208 -0.61155,4.35735 4.97883,-0.55833 9.23228,-3.89449 13.84842,-5.84174 2.70996,5.53973 -0.455,1.31529 7.32522,2.53772 1.08502,0.17048 1.78761,1.32193 2.81267,1.71639 3.87458,1.49101 7.92222,0.0734 11.83057,1.37936 2.68235,-0.56484 5.31262,-1.88683 8.04704,-1.69452 1.35852,0.0955 2.16027,1.65891 3.24041,2.48837 2.61456,-0.0998 5.22912,-0.19951 7.84368,-0.29927 4.64473,-0.95021 8.88553,-3.87351 13.62142,-4.09202 1.60186,-0.0739 2.33226,2.20143 3.49839,3.30214 2.94984,-0.29944 5.89968,-0.59888 8.84953,-0.89833 1.33758,0.50801 2.58403,1.44687 4.01276,1.52403 2.28088,0.12319 5.73312,-2.96689 6.78773,-0.94072 1.14605,2.20185 -6.4441,5.77702 -4.01202,6.27356 3.87161,0.79045 6.92622,-4.10745 10.7999,-4.88771 0.91737,-0.18479 -1.29282,2.74099 -0.35803,2.78445 2.40459,0.11179 4.52016,-1.65725 6.78024,-2.48588 1.31945,0.0101 2.75475,-0.51033 3.95836,0.0304 0.78176,0.35121 0.32942,2.27564 1.18643,2.28098 2.67859,0.0167 5.04481,-2.12584 7.72159,-2.22554 0.94208,-0.0351 1.26601,1.48553 2.13182,1.8585 3.60961,1.55491 6.53653,0.002 10.21237,-0.83478 20.52329,-6.74084 1.89226,-2.51045 4.15948,3.45256 0.73899,1.94361 4.01445,-1.09539 5.98399,-1.76219 2.23019,-0.75505 4.26124,-2.7115 6.60629,-2.50033 1.06227,0.0957 -1.16158,1.92736 -1.13013,2.99346 0.0199,0.67426 0.84334,1.05302 1.26501,1.57952 4.12862,-2.00822 7.89397,-5.07526 12.38586,-6.02468 1.10106,-0.23272 -0.91579,3.05361 0.16356,3.37219 2.3053,0.68043 4.7056,-1.09801 7.10578,-1.22658 1.70439,-0.0913 3.40092,0.83038 5.0883,0.57341 3.51787,-0.53576 6.7499,-3.43107 10.27034,-2.91244 1.4619,0.21537 0.033,2.95518 0.0495,4.43277 0.30181,1.19077 -0.20039,3.03734 0.90543,3.57231 1.66477,0.80539 3.68366,-0.33775 5.52901,-0.45944 5.57141,-0.36741 4.65262,0.33142 10.53807,-2.04259 2.8186,-1.13693 5.21399,-3.79318 8.25207,-3.87782 1.47239,-0.041 -1.59556,2.4764 -2.39334,3.7146 0.73439,-0.24086 6.01373,-2.85719 7.87461,-1.29776 0.0775,0.0649 0.89268,4.62211 1.49732,4.43526 14.78199,-4.56792 12.68988,-12.15571 13.93555,-3.63588 2.66352,6.81078 -1.20811,-0.39314 10.26637,-0.38966 1.05436,3.1e-4 -0.57443,2.7161 0.39151,3.13875 2.9451,1.28864 13.55718,-4.08658 14.2252,-4.14987 0.94238,-0.0893 -0.4954,1.82723 -0.7431,2.74084 0,0 -1.4256,1.03576 -1.4256,1.03576 z"
565− inkscape:connector-curvature="0" />
566− <path
567− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
568− id="path5280"
569− d="m 437.91913,154.10856 c 1.23619,-0.0682 2.47239,-0.13636 3.70859,-0.20454 1.58967,0.0869 3.17891,0.33934 4.76902,0.2608 2.60001,-0.1284 5.26923,-1.63681 7.75984,-0.87957 1.37606,0.41837 0.54192,3.9983 1.97124,3.83817 35.88963,-4.02092 2.82269,-7.22874 20.51937,-5.03347 3.69136,2.35282 7.48018,-1.04865 11.12799,-0.36496 0.89607,0.16795 0.44139,2.40963 1.35248,2.3772 3.04143,-0.10825 5.79477,-1.86385 8.71066,-2.73538 3.21228,-0.96013 6.53974,-3.95409 9.67225,-2.75912 1.88961,0.72083 -0.98785,3.92236 -1.48177,5.88355 7.4778,-2.6997 15.0486,-0.18493 22.64137,-0.87945 2.98582,-0.27312 5.86817,-1.42005 8.86462,-1.52519 0.64451,-0.0226 7.36205,1.74657 8.38695,2.01041 22.66233,-6.2164 -5.59406,-0.006 1.79508,4.88026 3.01566,1.99414 6.60785,-3.07778 10.1398,-3.84989 1.21885,-0.26645 2.41213,0.66777 3.64842,0.83569 1.51909,0.20634 3.07181,0.49347 4.59038,0.28337 2.64393,-0.36579 5.17049,-1.32765 7.75573,-1.99148 4.22728,5.71577 -1.93151,-1.13286 8.0372,1.02932 0.90762,0.19686 0.25793,1.83945 0.38689,2.75918 3.89585,-1.98477 7.40915,-5.05301 11.68754,-5.95432 1.46572,-0.30877 -2.98474,2.70083 -2.15115,3.94534 0.81315,1.21397 2.88525,-0.46374 4.32788,-0.69561 -0.19386,1.02948 -1.62892,3.11096 -0.58158,3.08846 3.16055,-0.0679 5.77676,-2.79974 8.90328,-3.26728 1.17277,-0.17538 2.07855,1.64352 3.24848,1.4501 3.6131,-0.59735 6.7766,-2.87648 10.3455,-3.69758 2.04298,-0.47003 7.74632,0.36486 9.92961,0.62392 1.54872,0.10745 3.32447,-0.49201 4.64618,0.32236 0.83502,0.51449 -0.41383,2.96447 0.56398,2.88785 3.16131,-0.24772 5.68039,-3.03528 8.79677,-3.62136 0.63863,-0.1201 -0.0278,2.00105 0.60497,1.85324 13.56341,-3.16818 3.77193,-4.72057 10.23057,-3.37752 1.24491,-0.0989 2.70181,-0.99864 3.73472,-0.29674 0.77133,0.52414 -0.93495,2.48789 -0.0552,2.79714 1.80758,0.63537 3.81902,-0.40231 5.6897,-0.81658 2.85096,-0.63135 5.54036,-2.05462 8.44881,-2.31443 1.41531,-0.12642 2.67478,1.09344 4.09215,1.19417 2.08296,0.14804 4.16519,-0.30621 6.24779,-0.45931 3.35928,-1.08463 6.71857,-2.16926 10.07785,-3.25389 0.55553,0.85196 0.64963,2.54065 1.6666,2.55589 2.67042,-0.80363 5.34085,-1.60725 8.01128,-2.41088 0.47122,0.60211 0.67697,1.60175 1.41368,1.80633 1.24445,0.34558 4.10822,-1.60936 3.85951,-0.34198 -0.48472,2.4701 -3.27807,3.82095 -4.91711,5.73142 5.70103,-1.33877 10.12612,-5.88484 15.70457,-7.45129 0.58355,-0.16386 -0.0962,1.23344 0.0671,1.81715 0.12902,0.46112 0.31209,1.10095 0.77906,1.20689 3.35426,0.76105 3.63331,-2.23898 2.23264,1.86594 4.56137,3.27917 -3.43228,-1.96059 10.56193,-4.51534 1.97581,-0.3607 -3.49921,2.45408 -4.17344,4.34599 -0.32903,0.92328 1.91845,-0.40858 2.86324,-0.66949 3.86803,-1.06818 2.71345,-2.07285 4.06916,-0.29377 0.65874,-0.0329 2.02115,-0.75681 1.97621,-0.0988 -0.0787,1.1527 -3.30667,2.8058 -2.15487,2.7149 2.30435,-0.18187 4.05842,-2.25648 6.23422,-3.03687 0.64315,-0.23067 1.38324,0.22087 2.04874,0.0661 5.51896,-1.28379 3.78688,-3.25824 5.50883,-0.19721 -1.46583,1.71812 -4.57212,2.90268 -4.39748,5.15437 0.0156,0.20143 8.67506,-2.31725 8.69122,-1.51312 0.0418,2.08276 -5.97008,4.93862 -3.88739,4.89336 7.80888,-0.16971 16.70616,-11.4037 6.31714,0.11757 0.90308,0.0651 1.80616,0.1302 2.70924,0.1953 0.27814,0.42273 0.34662,1.1336 0.83442,1.26817 0.95893,0.26455 2.42441,-1.04441 2.97636,-0.21683 0.53135,0.79669 -2.30924,1.98837 -1.47786,2.46364 3.33256,1.90507 5.5039,-3.90126 3.07872,1.08059 4.23139,0.93002 -3.61451,3.89543 -2.08482,4.59396 2.0287,0.9264 4.18748,-2.97245 6.29916,-2.25506 1.45192,0.49325 -4.18448,2.13801 -3.19514,3.30956 1.96861,2.33118 11.74376,-7.47434 0.389,2.57794 -0.0375,0.53551 -0.64336,1.68584 -0.11242,1.60654 9.29633,-1.38852 9.7283,-6.25852 2.73533,1.82238 -0.71864,0.83044 -2.31993,2.03153 -1.61359,2.87246 4.45015,-0.20547 3.30627,-1.34009 4.63554,1.36899 6.1752,-0.54264 -0.212,2.16231 3.94226,3.83059 0.70833,0.28445 2.2706,-0.38153 2.25791,0.38168 -0.0534,3.21284 -8.33635,4.79542 2.76754,1.28484 0.83075,1.91899 -2.55661,2.61469 -2.23156,4.1519 0.16395,0.77534 1.75121,-0.54192 2.37683,-0.0555 0.43233,0.33616 -0.62952,1.09756 -0.39821,1.59396 0.32296,0.69309 3.34908,0.74132 3.53405,0.75722 -6.37567,7.34986 -1.26749,0.14391 -0.0687,2.59487 0.35848,0.73292 -0.86775,1.38193 -1.30163,2.07289 0,0 2.83108,-1.71491 2.83108,-1.71491 l 0,0 c -1.62573,0.55271 -3.171,1.46474 -4.87719,1.65811 -1.86292,0.21113 3.92214,-13.77688 3.30994,-4.54751 -0.43697,-0.22138 -0.82145,-0.64501 -1.31093,-0.66414 -1.08331,-0.0423 -2.45436,1.25905 -3.21571,0.48724 -0.62898,-0.63763 1.2009,-1.38762 1.49202,-2.23463 0.1294,-0.37651 0.0634,-1.08308 -0.32938,-1.14805 -1.07257,-0.17743 -2.83327,1.58094 -3.21263,0.56213 -0.4318,-1.15963 1.56848,-1.91432 2.35272,-2.87148 -2.08529,0.77586 -4.04044,2.122 -6.25586,2.3276 -1.2483,0.11584 1.87343,-2.85833 0.13022,-3.36272 -1.25443,-0.36296 -2.64297,0.7181 -3.9005,0.36606 -1.98283,-0.5551 0.33136,-8.6675 2.44939,-5.67082 -0.11377,-0.59785 0.0423,-1.32107 -0.34132,-1.79354 -0.44536,-0.54858 -1.18502,-0.96523 -1.89156,-0.95682 -1.75728,0.0209 -4.10153,2.43729 -5.16845,1.04082 -0.97742,-1.27933 2.58059,-2.13226 3.19884,-3.6188 0.35667,-0.85759 -3.97088,-0.70327 -0.94285,-2.62205 -0.30912,-0.2909 -1.07662,-0.47532 -0.92737,-0.87269 0.41542,-1.10604 3.15171,-1.92448 2.27577,-2.71734 -1.06356,-0.9627 -2.76722,1.17347 -4.18937,0.98523 -0.50454,-0.0668 0.67442,-1.53777 0.16587,-1.5178 -2.00217,0.0786 -4.22172,3.02759 -5.75464,1.73723 -1.28523,-1.08186 2.27523,-2.47231 3.41284,-3.70846 1.69334,-3.79201 1.02434,-0.89294 -2.96887,-1.10444 -0.43164,-0.0229 -0.70644,-0.64888 -0.71619,-1.08101 -0.0159,-0.70575 1.25738,-1.66328 0.64632,-2.01675 -3.18866,-1.84449 -5.78111,4.03437 -1.35578,-2.85334 -2.21776,-1.64947 -1.21018,-1.37236 -4.79348,-1.13862 -1.39043,0.0907 -2.84666,0.9726 -4.15193,0.48495 -0.65871,-0.2461 0.41497,-1.72217 -0.17671,-2.10214 -1.42729,-0.91658 -3.70494,0.93947 -5.03484,-0.73883 -0.60299,-0.21393 -1.16997,-0.67416 -1.80895,-0.64178 -1.28889,0.0653 -2.74506,1.72143 -3.75975,0.924 -0.80647,-0.63381 2.20098,-1.84945 1.56159,-2.65151 -0.65242,-0.81839 -2.00917,1.00735 -3.03556,0.80256 -0.45187,-0.0902 0.14067,-0.91075 0.21101,-1.36613 -1.21839,0.43181 -2.43678,0.86363 -3.65517,1.29544 -0.25354,-0.22264 -0.62939,-0.35707 -0.76062,-0.66793 -0.17042,-0.40368 0.34819,-1.20015 -0.0754,-1.31238 -1.8936,-0.50174 -8.19894,3.49373 -8.31461,3.19586 -0.81569,-2.10049 4.56795,-2.57491 4.73782,-4.82182 0.12012,-1.58882 -2.99734,1.0822 -4.49601,1.6233 -2.08036,0.93553 -4.14334,1.9107 -6.24108,2.80658 -1.80069,0.76903 -4.53985,3.91984 -5.45174,2.18712 -0.97455,-1.85178 3.0537,-2.94119 4.10168,-4.75242 0.26628,-0.46021 0.0615,-1.507 -0.46996,-1.52428 -1.58559,-0.0515 -2.99345,1.11425 -4.56062,1.36077 -0.79363,0.12484 -1.59692,-0.17771 -2.39537,-0.26657 -4.2548,2.37378 -7.90174,6.81699 -12.7644,7.12133 -2.94666,0.18442 3.87288,-4.45736 5.80931,-6.68603 -0.48591,-0.59114 -0.69261,-1.78416 -1.45775,-1.77341 -2.51475,0.0353 -4.81733,1.51195 -7.30276,1.89646 -5.06126,0.783 -4.67311,0.33438 -8.50322,-1.66221 -3.47983,1.1729 -6.95966,2.3458 -10.43949,3.5187 -0.30549,-1.1707 0.29338,-3.52556 -0.91645,-3.51209 -3.62555,0.0404 -6.62575,3.65582 -10.25148,3.63642 -1.23853,-0.007 1.66672,-3.89226 0.44498,-3.68891 -4.09903,0.68224 -7.13798,4.59273 -11.19787,5.47861 -1.12856,0.24626 0.7464,-2.18633 1.1196,-3.2795 -2.70903,1.27901 -5.1708,4.32182 -8.12711,3.83702 -1.90269,-0.31201 3.59746,-2.66683 3.5158,-4.59321 -0.0525,-1.23781 -2.45976,0.30037 -3.69255,0.4234 -1.46662,0.14638 -2.9419,0.20626 -4.40496,0.38477 -10.62024,1.29579 -0.63827,0.54815 -11.1481,1.16065 -2.80818,0.75238 -5.61635,1.50477 -8.42453,2.25716 0.42608,-1.63775 2.96629,-5.03264 1.27824,-4.91325 -4.77994,0.33808 -8.7824,3.8364 -13.1736,5.7546 0.15542,-1.38489 1.85968,-4.17566 0.46625,-4.15467 -13.75571,0.20727 -7.80115,8.29755 -11.47942,2.48146 -2.33385,0.88589 -4.51172,2.47751 -7.00154,2.65765 -0.71542,0.0518 0.18093,-1.61481 -0.32031,-2.12791 -1.69982,-1.74004 -6.36894,-4.9e-4 -7.57099,-0.11103 -0.99157,-0.0912 -1.76798,-0.91671 -2.65197,-1.37507 -2.09073,0.3287 -4.18146,0.65741 -6.27219,0.98612 -4.18788,-0.43557 -4.06426,-0.009 -7.55836,-1.74909 -0.90521,-0.4509 -1.58091,-1.59702 -2.59199,-1.5767 -2.46011,0.0494 -4.7061,1.70603 -7.1658,1.77273 -0.85835,0.0233 -1.38548,-1.01473 -2.07822,-1.52209 -1.71767,0.15619 -3.43533,0.31238 -5.153,0.46857 -12.16079,-1.35046 6.81819,0.27799 -13.25426,1.47955 -1.76161,0.10546 -3.40987,-1.20637 -5.17287,-1.12741 -3.27207,0.14656 -6.39822,1.50844 -9.66129,1.79185 -5.95391,0.51713 -6.23671,-0.2208 -11.03836,-2.32483 -2.57098,0.27277 -5.14197,0.54555 -7.71295,0.81832 -0.91766,-0.76156 -1.56555,-2.3947 -2.75298,-2.28469 -3.40416,0.31538 -6.37271,2.50981 -9.66387,3.43505 -1.89983,0.5341 -3.88985,0.6772 -5.84762,0.9257 -1.86103,0.23622 -4.98041,2.29736 -5.60307,0.52776 -0.83546,-2.3744 2.2799,-4.48833 3.41985,-6.7325 -6.30568,3.02597 -12.28992,6.842 -18.91706,9.07792 -2.01786,0.6808 -5.02029,1.10316 -6.3653,-0.54796 -1.28614,-1.57885 3.01586,-5.66819 1.01096,-6.02496 -4.18293,-0.74434 -7.97301,2.98121 -12.08383,4.05456 -18.47256,4.82328 8.73927,-5.16607 -13.65645,3.68169 0,0 8.30503,-6.03396 8.30503,-6.03396 z"
570− inkscape:connector-curvature="0" />
571− <path
572− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
573− id="path5282"
574− d="m 439.33369,237.08082 c -5.47439,-2.96028 -3.28562,5.72694 -1.53636,5.2325 3.44066,-0.97252 6.23707,-3.74491 9.72747,-4.52016 0.75774,-0.16831 0.0633,2.07164 0.83265,2.17464 2.67303,0.35787 13.46994,-4.64024 14.14779,-4.92121 2.04586,-0.54266 4.02194,-1.56426 6.13758,-1.62798 8.26835,-0.24902 -5.3663,4.92975 0.63623,6.00394 3.33252,0.59637 6.26374,-2.88469 9.6326,-3.21942 1.2112,-0.12034 2.05563,1.30397 3.08344,1.95596 4.62785,-1.95699 9.2557,-3.91398 13.88356,-5.87097 1.74763,0.52552 7.10975,2.28627 8.91991,2.20657 4.91708,-0.21649 9.55324,-2.7245 14.4705,-2.93685 0.96534,-0.0417 2.29151,0.18143 2.6989,1.05758 0.48206,1.03674 -0.42687,2.24646 -0.6403,3.36969 0.42808,-0.18104 13.87161,-6.49543 16.43017,-5.66676 1.26258,0.40892 -0.86067,3.47065 0.37133,3.96409 2.45886,0.98481 5.28458,-0.37938 7.92014,-0.64321 15.4825,-1.54984 2.47234,-0.73607 17.32767,-1.44683 20.16342,-0.68595 -0.61738,-1.19219 12.25354,1.71416 1.88649,0.42598 3.86273,0.35948 5.79515,0.2814 2.08666,-0.0843 4.32689,-1.6528 6.21799,-0.76679 1.05283,0.49326 -0.32071,2.30308 -0.48106,3.45461 1.74185,-0.3169 3.4837,-0.6338 5.22556,-0.9507 6.48171,0.58028 11.31801,-5.02464 17.37162,-5.86508 1.21646,-0.16889 0.92241,2.46374 1.96105,3.11914 1.64086,1.0354 3.65432,1.44253 5.58426,1.64206 12.40919,-0.10851 6.3507,-0.44262 18.18031,0.91002 5.2457,-0.519 10.31623,3.10438 15.5601,2.66514 4.34908,-0.36429 8.39276,-3.24534 12.74907,-2.98106 1.44232,0.0875 0.87592,2.90366 1.94781,3.87268 5.51735,4.98789 4.48486,-2.50811 3.9798,6.33873 5.76444,2.19985 12.43819,-6.60952 18.41769,-4.55109 1.44645,0.49794 -1.68101,4.66965 -0.15351,4.58671 4.81321,-0.26138 8.63125,-5.36947 13.45116,-5.30882 1.86087,0.0234 -0.76563,3.64243 -1.14845,5.46364 2.80475,-0.55712 5.6095,-1.11423 8.41425,-1.67135 4.05645,-1.59233 7.85344,-4.17428 12.16934,-4.777 1.04286,-0.14563 0.82904,1.93593 1.24356,2.90389 1.42922,0.0469 2.87497,0.36245 4.28766,0.14068 2.12504,-0.33359 4.1136,-1.26683 6.20077,-1.78717 8.61601,-2.14799 -0.68024,1.02577 9.22492,-2.7096 0.72398,-0.0381 1.46437,-0.27231 2.17195,-0.11441 0.35929,0.0802 0.5247,0.51649 0.78706,0.77473 2.09582,-1.26276 4.09681,-2.69827 6.28745,-3.78827 0.18826,-0.0937 0.30755,0.28684 0.46132,0.43026 0.20897,0.0476 0.43874,0.24546 0.62691,0.14284 1.47903,-0.80655 2.81173,-1.85645 4.21759,-2.78467 10.09216,-6.69652 -1.79879,0.91257 -0.29335,1.23767 1.96082,0.42344 3.21705,-2.44369 5.02727,-3.30811 1.21936,-0.58227 -3.94065,3.52558 -2.67863,3.04268 1.34115,-0.51318 2.40022,-1.57706 3.60033,-2.36559 3.58809,-1.94003 -0.10481,0.10832 -3.22044,1.2596 -1.18007,0.43606 2.73229,-0.76526 2.43591,-1.6751 -0.28452,-0.87342 -1.83157,-0.28546 -2.74741,-0.21451 24.89401,-13.44905 10.98443,-4.78107 6.10519,-4.80799 -0.5874,-0.003 0.47601,-1.09001 0.84739,-1.54512 0.68406,-0.83828 1.57306,-1.49001 2.29035,-2.30005 0.57577,-0.65021 1.0537,-1.38089 1.58056,-2.07134 0.79967,-0.87436 1.59935,-1.74871 2.39902,-2.62307 0.20201,-0.60032 1.14138,-1.46243 0.60604,-1.80097 -0.9444,-0.59722 -2.26102,0.30833 -3.35154,0.0648 -0.4229,-0.0944 -1.12945,-0.68431 -0.83167,-0.9991 2.87301,-3.03713 7.29695,-4.22652 10.35349,-7.07887 0.23764,-0.22177 -0.41926,-0.49684 -0.62888,-0.74526 -1.4682,-0.57082 -1.26023,-0.042 -1.06626,-1.32997 0,0 3.02138,-1.27939 3.02138,-1.27939 l 0,0 c -7.61861,4.36787 -7.57924,3.76889 1.37583,1.16192 -2.79852,1.96211 -7.60545,5.05804 -9.695,7.79492 -0.10971,0.14368 -1.22351,2.57933 -0.59404,3.03807 0.67307,0.49052 1.63956,0.29393 2.45934,0.4409 -10.69683,7.76533 -6.46048,2.28777 -3.95825,4.66925 0.28022,0.26669 0.34086,0.73833 0.2949,1.12243 -0.0613,0.51213 -1.11159,1.36151 -0.59991,1.42631 3.44049,0.43571 7.18169,-3.194 1.54058,1.27161 0.51455,0.0832 1.85256,-0.17022 1.54366,0.24963 -0.42993,0.58435 -5.88925,3.82593 -6.64539,4.28618 -2.25283,1.37126 -4.25988,3.13349 -6.56145,4.42126 -0.57965,0.32433 0.91585,-0.96229 1.37377,-1.44343 -0.97832,0.61888 -1.77788,1.82089 -2.93498,1.85665 -0.84725,0.0262 1.25052,-1.15506 1.77523,-1.8208 0.14614,-0.18543 0.39428,-0.8091 0.19623,-0.68058 -2.95533,1.9178 -5.47115,4.52716 -8.60483,6.13714 -1.41463,0.7268 7.50902,-5.73994 3.22744,-3.51403 -1.94695,1.35889 -3.46817,4.16386 -5.84085,4.07668 -2.00788,-0.0738 5.80425,-2.70226 4.39051,-4.12997 -1.44757,-1.46188 -3.44965,2.24521 -5.22143,3.29084 -1.58833,0.93737 -3.17327,1.89624 -4.85411,2.65534 -3.03629,1.37125 -2.45211,1.51547 -3.62353,-0.19057 -1.2459,0.29401 -2.4918,0.58801 -3.7377,0.88202 -0.94895,-0.0594 -1.91563,-0.37033 -2.84684,-0.17826 -0.90464,0.18658 -13.69919,4.55903 -14.20983,4.39414 -1.42497,-0.46012 2.23239,-3.95305 0.80923,-4.41875 -2.71665,-0.88896 -5.56686,1.30075 -8.35029,1.95112 -18.56769,0.0793 13.70185,-0.82956 -20.27406,5.77609 -1.24209,0.24149 -1.79361,-1.8371 -2.90263,-2.44636 -1.29963,-0.71396 -2.72775,-1.30777 -4.20303,-1.45723 -7.88112,-0.79842 -5.93835,3.28036 -6.95179,-3.55661 -4.15903,1.41034 -8.31806,2.82068 -12.47709,4.23101 0.13929,-1.64904 2.02947,-4.5709 0.41789,-4.94714 -3.68032,-0.8592 -7.29587,2.22135 -11.06755,2.46089 -19.20033,1.21941 3.42849,-1.74287 -8.44928,-6.51391 -3.19359,-1.2828 -6.88148,0.1533 -10.32222,0.22994 -4.01012,0.4663 -8.02025,0.93261 -12.03037,1.39891 -1.70721,-1.01184 -3.14481,-2.86055 -5.12161,-3.03552 -3.42478,-0.30314 -6.76114,2.07637 -10.17655,1.68141 -1.21543,-0.14056 -0.76145,-3.11341 -1.98472,-3.08777 -3.40485,0.0714 -6.28097,2.89341 -9.65823,3.33189 -0.82541,0.10716 -1.10923,-1.24127 -1.66384,-1.86191 -1.46833,0.1182 -2.93216,0.38115 -4.405,0.3546 -1.20724,-0.0218 -2.40792,-0.75508 -3.5878,-0.49866 -3.40511,0.74001 -6.46807,4.14784 -9.87684,3.42487 -1.76071,-0.37343 2.8545,-4.90599 1.09548,-5.28732 -6.30413,-1.36664 -12.36869,6.47925 -19.07787,3.24381 -2.81278,-1.15043 -8.0235,-3.73838 -11.21616,-2.99339 -5.30446,1.23778 -9.81702,5.25422 -15.21947,5.94913 -1.30931,0.16841 0.63002,-3.1138 -0.3995,-3.94008 -0.96711,-0.77619 -8.78805,0.52726 -9.49794,0.62362 -2.43958,0.81492 -4.75139,2.60053 -7.31876,2.44474 -3.96541,-0.24062 4.43728,-6.06793 -2.4985,-4.79696 -4.07548,0.74683 -7.54039,3.65131 -11.60589,4.45071 -3.28335,0.64561 -6.23377,-5.00667 -9.93337,-1.45023 -2.69658,0.53612 -5.34039,1.61546 -8.08974,1.60836 -1.29308,-0.003 -2.27044,-1.2921 -3.5163,-1.63834 -1.44221,-0.40081 -2.95661,-0.56492 -4.45344,-0.57657 -7.07426,-0.0551 -4.52877,1.11419 -12.43282,2.68962 -1.29287,0.25769 -2.63653,0.0199 -3.9548,0.0298 -0.74509,-0.3974 -1.39082,-1.19305 -2.23527,-1.19222 -8.48298,0.008 -5.99334,5.38203 -16.7296,6.92971 -1.63516,0.23571 1.50781,-2.94003 2.26172,-4.41004 -1.14109,0.0362 -2.31128,-0.14996 -3.42328,0.10862 -1.6719,0.38879 -3.21432,1.20574 -4.82148,1.80861 0,0 6.59652,-4.79266 6.59652,-4.79266 z"
575− inkscape:connector-curvature="0" />
576− <path
577− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
578− id="path5288"
579− d="m 427.09099,608.80296 c -0.54536,0.88302 -2.59373,3.0492 -1.6361,2.64907 3.94655,-2.30416 7.89309,-4.60832 11.83964,-6.91247 -0.48068,0.95507 -2.45697,2.52886 -1.44204,2.86521 1.68661,0.55895 3.34268,-1.22337 5.06375,-1.66497 1.38771,-0.35607 2.85207,-1.08817 4.237,-0.72145 0.74384,0.19697 0.64163,1.39882 0.96244,2.09823 1.37197,0.0822 2.78072,0.57276 4.11592,0.24671 3.459,-0.84467 6.54045,-2.94826 10.02108,-3.69889 2.35754,-0.50843 6.11513,1.00569 8.24077,1.90515 1.08276,0.45817 2.01316,1.647 3.18215,1.5214 3.04137,-0.32679 5.82554,-1.86816 8.73831,-2.80223 0.0213,1.01023 -0.88531,2.68436 0.064,3.03068 1.6579,0.60487 3.51554,-0.518 5.17469,-1.11943 3.10954,-1.12717 5.90095,-3.06895 9.06232,-4.04132 1.11082,-0.34167 3.56487,-0.97615 3.48173,0.18305 -0.17139,2.38956 -5.60845,4.31354 -3.92661,6.01963 1.90254,1.92996 5.2515,-1.34136 7.87725,-2.01204 5.57129,2.09339 10.88855,-4.38851 16.19806,-2.9901 1.5161,0.39931 -1.91863,4.4988 -0.36246,4.68943 3.61195,0.44246 6.80584,-2.64975 10.35214,-3.4657 4.75582,-1.09424 4.54067,-0.5378 7.56802,1.586 2.7685,-1.48955 4.99284,1.99196 7.53405,1.61787 3.37273,-0.49649 6.43938,-2.27591 9.75173,-3.08218 2.40251,-0.5848 4.93371,-0.50568 7.33922,-1.078 3.43034,-0.81613 6.59584,-3.15152 10.12112,-3.07612 1.16193,0.0249 0.71886,2.21042 1.07829,3.31564 1.42789,0.26396 2.89169,0.37849 4.28369,0.79187 4.40179,1.3072 2.47933,2.85169 8.61077,1.10238 2.82423,-0.80575 18.5379,-8.0104 22.90225,-7.58044 1.38563,0.1365 1.07795,2.56757 1.61692,3.85135 6.71637,11.01182 -3.68387,-3.37038 21.00188,-5.1411 2.86377,-0.20542 -5.40592,5.18669 -3.94363,7.65753 1.31649,2.22446 5.10447,-0.84577 7.6179,-1.44914 2.83592,-0.68079 5.59821,-1.63981 8.41404,-2.39945 2.34076,-0.63148 4.70255,-1.18227 7.05383,-1.7734 1.89507,-0.27942 3.83635,-1.33931 5.68522,-0.83825 0.91429,0.24778 0.67699,1.76946 1.01548,2.65418 2.87065,-0.87358 5.62729,-2.92999 8.61194,-2.62073 1.19443,0.12376 -0.64239,3.23232 0.51114,3.56602 2.02002,0.58437 15.38587,-3.38686 16.41366,-3.66716 -0.15304,1.37971 -1.82071,3.86876 -0.45913,4.13912 2.88522,0.57288 5.56173,-1.98169 8.44725,-2.55301 1.49987,-0.29697 3.07716,0.21428 4.58688,-0.0277 2.14755,-0.34421 4.12553,-1.5628 6.29505,-1.71648 0.71473,-0.0506 1.11339,1.25168 1.8214,1.14155 2.30654,-0.35876 4.37463,-1.63033 6.56195,-2.4455 -0.44888,1.15735 -2.31073,2.69008 -1.34663,3.47204 1.24004,1.00577 3.13873,-0.68571 4.73492,-0.72386 1.27427,-0.0305 5.97531,0.93232 7.19325,1.37508 1.00412,0.36504 1.79765,1.62936 2.85276,1.46128 3.30399,-0.52634 6.29112,-2.27935 9.43668,-3.41903 2.16754,7.29671 -1.34009,-1.02626 10.2382,-0.42077 1.26673,0.0662 -0.89534,2.46826 -0.75751,3.7292 0.0842,0.77019 0.82031,1.33174 1.37033,1.87741 3.25333,3.22757 4.14722,0.43976 9.52911,-1.62234 -5.67229,9.9542 2.19189,-5.35859 6.0963,-0.33515 1.76843,2.27527 -6.50408,3.21284 -6.15274,6.07304 0.29151,2.37311 4.145,-2.92278 6.53572,-2.95529 -2.29854,3.66744 -2.94659,2.96902 0.93035,2.70267 23.98881,-12.56081 6.53151,-5.05582 6.71984,-1.35229 0.0562,1.10418 2.14953,-0.59987 3.2544,-0.64052 0.59071,-0.0217 1.14215,0.30517 1.71323,0.45776 1.24821,-0.35158 2.46907,-0.82114 3.74464,-1.05472 0.6566,-0.12024 1.33503,0.002 2.00255,0.002 -7.56212,7.4632 -4.80566,3.75696 0.51507,2.0828 0.278,-0.0875 0.83108,0.29605 0.68233,0.54666 -0.69786,1.17578 -1.86061,2.00398 -2.79092,3.00597 0,0 -1.07469,0.77304 -1.07469,0.77304 l 0,0 c 0.29688,-0.55013 0.49344,-1.16768 0.89064,-1.65039 0.97731,-1.18769 4.73458,-3.44842 3.20163,-3.32283 -3.51078,0.28763 -5.88837,4.42533 -9.63666,4.33697 -0.15241,-0.37159 -0.34842,-0.72816 -0.45725,-1.11477 -0.29714,-1.0556 -0.24534,-2.79779 -0.8748,-2.62026 -2.57218,0.72544 -4.57165,3.54585 -7.24208,3.44002 -1.52804,-0.0605 1.88309,-2.41005 2.82464,-3.61508 -2.57134,1.22873 -5.14267,2.45745 -7.71401,3.68618 2.38555,-2.2552 5.77328,-3.78851 7.15663,-6.76561 0.72913,-1.56914 -3.24014,1.21524 -4.86007,1.82323 -1.6775,0.62961 -3.30811,1.40187 -5.03222,1.88956 -1.02074,0.28874 -3.10209,1.48551 -3.15373,0.42598 -0.0805,-1.65221 4.01255,-2.67402 2.98116,-3.96728 -1.08235,-1.35717 -3.33942,0.94959 -5.00913,1.42439 -20.13729,8.35134 -2.69796,2.67973 -3.51754,-2.53363 -0.30637,-1.94883 -3.85411,1.58588 -5.79195,1.21634 -0.87346,-0.16656 -0.0847,-2.23403 -0.93357,-2.49888 -11.84288,-3.69529 -1.16733,3.90973 -7.75074,-1.30702 -2.41838,0.61135 -4.85237,1.16396 -7.25514,1.83405 -2.78931,0.77789 -5.42146,2.48551 -8.31711,2.50877 -0.92506,0.007 -0.55731,-1.9355 -1.33837,-2.43121 -1.00483,-0.63771 -2.41681,-0.17922 -3.51128,-0.64664 -5.17393,-2.20964 4.51953,-3.02699 -6.76187,-0.29747 -1.8717,0.0522 -5.62004,0.0639 -7.3367,0.54341 -2.69541,0.75295 -5.09849,2.65578 -7.88857,2.87404 -0.88863,0.0695 -0.97674,-1.50932 -1.61597,-2.13053 -2.88746,-2.80607 -2.96741,-1.82144 -7.53922,-1.91209 -5.60568,-1.00025 -5.2968,-1.462 -12.0296,0.4822 -3.77819,1.09101 -7.17546,4.70648 -11.06137,4.10258 -1.96748,-0.30576 3.75004,-3.90954 2.47312,-5.43726 -3.21419,-3.84551 -12.45489,8.124 -14.52498,3.88536 0.16133,-1.24054 1.72133,-3.53728 0.484,-3.72163 -2.94633,-0.43896 -5.68485,1.79467 -8.57499,2.51619 -2.56637,0.64068 -5.14051,1.38245 -7.77923,1.56659 -1.88811,0.13176 -3.76204,-0.41995 -5.64306,-0.62993 0.13071,-1.79104 2.18522,-5.47173 0.39212,-5.37312 -5.55708,0.30559 -10.33401,4.13599 -15.50101,6.20399 -10.66645,-2.44406 0.68895,-0.62357 -14.71365,0.88811 -1.68946,0.16581 -3.35352,-0.60601 -5.05038,-0.65553 -1.88826,-0.0551 -3.83509,0.84291 -5.65682,0.34302 -0.93454,-0.25644 -0.73557,-2.23638 -1.69663,-2.36085 -2.36483,-0.30628 -4.69832,0.81892 -7.04748,1.22838 -2.97423,0.81182 -5.94845,1.62365 -8.92268,2.43547 -0.86665,-0.8126 -1.41221,-2.41128 -2.59994,-2.43779 -5.34668,-0.11933 -13.32985,5.97106 -18.52181,1.51644 -0.70103,-0.60147 -0.94151,-1.58947 -1.41227,-2.38421 -0.71473,0.22765 -15.04458,4.94998 -16.29418,4.75369 -1.16619,-0.18319 0.32544,-3.32233 -0.84936,-3.43812 -3.23005,-0.31834 -6.18554,2.3471 -9.4303,2.42499 -1.28344,0.0308 -2.14298,-1.4143 -3.21447,-2.12145 -4.57791,1.88547 -9.15581,3.77095 -13.73372,5.65642 -0.35422,-0.97953 -0.25778,-2.27745 -1.06266,-2.9386 -0.88974,-0.73085 -3.03618,0.38783 -3.38033,-0.71096 -0.44745,-1.42861 3.36536,-4.26694 1.8802,-4.07862 -3.91526,0.49646 -7.09459,3.45974 -10.64188,5.18961 0.003,-0.88328 0.88856,-2.56291 0.01,-2.64984 -2.39024,-0.23638 -4.62168,1.31014 -6.93253,1.9652 -21.18125,5.49534 1.18422,1.02595 -11.44132,0.93616 -2.29045,-0.0163 -4.51443,1.00604 -6.80442,0.95784 -1.30262,-0.0274 -2.42374,-1.16009 -3.72651,-1.17953 -2.1489,-0.0321 -4.24554,1.38622 -6.36478,1.02898 -0.87305,-0.14717 -0.86226,-1.54661 -1.29339,-2.31992 -2.244,0.83914 -8.96653,3.77305 -12.27692,3.87067 -0.63692,0.0188 -1.13222,-0.59394 -1.73219,-0.80855 -1.88608,-0.67465 -2.71984,-0.38168 -3.36282,-2.56718 0,0 -2.59014,1.88185 -2.59014,1.88185 z"
580− inkscape:connector-curvature="0" />
581− <text
582− xml:space="preserve"
583− style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
584− x="351"
585− y="282"
586− id="text4003"
587− sodipodi:linespacing="125%"><tspan
588− sodipodi:role="line"
589− id="tspan4005"
590− x="351"
591− y="282"
592− style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic">Endpoint</tspan></text>
593− <text
594− sodipodi:linespacing="125%"
595− id="text4030"
596− y="316"
597− x="373"
598− style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
599− xml:space="preserve"><tspan
600− style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic"
601− y="316"
602− x="373"
603− id="tspan4032"
604− sodipodi:role="line">Transport</tspan></text>
605− <text
606− xml:space="preserve"
607− style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
608− x="454.58578"
609− y="292.34314"
610− id="text4050"
611− sodipodi:linespacing="125%"><tspan
612− sodipodi:role="line"
613− id="tspan4052"
614− x="454.58578"
615− y="292.34314"
616− style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">TCP connection</tspan><tspan
617− sodipodi:role="line"
618− x="454.58578"
619− y="312.34314"
620− style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
621− id="tspan4068">(bi-directional)</tspan></text>
622− <path
623− style="fill:#b3b3b3;stroke:#000000;stroke-width:1;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:2,1;stroke-dashoffset:0"
624− d="m 554,248 86,108"
625− id="path4054"
626− inkscape:connector-curvature="0" />
627− <text
628− sodipodi:linespacing="125%"
629− id="text4056"
630− y="376"
631− x="594"
632− style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
633− xml:space="preserve"><tspan
634− style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
635− y="376"
636− x="594"
637− id="tspan4058"
638− sodipodi:role="line">Transport connection</tspan><tspan
639− style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
640− y="396"
641− x="594"
642− sodipodi:role="line"
643− id="tspan4070">(uni-directional)</tspan></text>
644− <text
645− xml:space="preserve"
646− style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
647− x="794"
648− y="226"
649− id="text4062"
650− sodipodi:linespacing="125%"><tspan
651− sodipodi:role="line"
652− id="tspan4064"
653− x="794"
654− y="226"
655− style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">Chan</tspan></text>
656− </g>
657−</svg>
doc/reconnect/blacklist.texdeleted−255
@@ -1,255 +0,0 @@
1−\documentclass{article}
2−\usepackage[margin=2.5cm]{geometry}
3−\usepackage{amsmath, amssymb}
4−\usepackage{mathpazo, times}
5−
6−\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
7−\newcommand{\sApp}[2]{{#1} {#2}}
8−\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
9−\newcommand{\sReturn}{\mathtt{return}}
10−
11−\newcommand{\sExpect}{\mathtt{expect}}
12−\newcommand{\sSend}{\mathtt{send}}
13−\newcommand{\sSpawn}{\mathtt{spawn}}
14−\newcommand{\sLink}{\mathtt{link}}
15−\newcommand{\sThrow}{\mathtt{throw}}
16−\newcommand{\sReconnect}{\mathtt{reconnect}}
17−
18−\newcommand{\sParP}{\mathrel{{\parallel}_P}}
19−\newcommand{\sParN}{\mathrel{{\parallel}_N}}
20−\newcommand{\sProc}[2]{{#1}_{#2}}
21−\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
22−\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
23−\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
24−\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
25−\newcommand{\sSystem}[3]{\left\langle #1 ; #2 ; #3 \right\rangle}
26−\newcommand{\sNodes}{\mathcal{N}}
27−\newcommand{\sQueue}{\mathcal{Q}}
28−\newcommand{\sProcesses}{\mathcal{P}}
29−\newcommand{\sBlacklist}{\mathcal{B}}
30−
31−\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
32−\newcommand{\sNothing}{\mathtt{Nothing}}
33−
34−\newcommand{\sCtxt}[1]{\mathbb{#1}}
35−
36−\newcommand{\sSenders}{\mathit{senders}}
37−
38−\newcommand{\OR}{\mathrel{|}}
39−
40−
41−\begin{document}
42−
43−\title{Cloud Haskell Semantics}
44−\author{Edsko de Vries, Well-Typed LLP}
45−\date{\today}
46−
47−\maketitle
48−
49−\section{Syntax}
50−
51−\subsection{Terms}
52−
53−\begin{equation*}
54−\begin{array}{ll@{\;::=\;}l}
55−\text{value} & V & \sLam{x}{M} \OR
56− \sExpect \OR
57− \sSend \; \sPid \; V \OR
58− \sSpawn \; \sNid \; V \OR
59− \sReturn \; M
60−\\
61−\text{term} & M, N & \sApp{M}{N} \OR
62− \sBind{M}{N}
63−\end{array}
64−\end{equation*}
65−
66−\subsection{Processes, Nodes, Systems}
67−
68−A \emph{process} $\sProc{M}{\sPid}$ is a pair of a term $M$ and a process ID $\sPid$.
69−A \emph{node}
70− $$\sNode{\sProcesses}
71− {\sLinks}
72− {\sNid}$$
73−is a tuple consisting of a set of
74−processes $\sProcesses$, sometimes written as
75− $$\sProc{M}{\sPid} \sParP \cdots \sParP \sProc{N}{\sPid'}$$
76−together with a set \sLinks{} of pairs of process IDs and a node ID \sNid.
77−A \emph{system}
78− $\sSystem{\sNodes}{\sQueue}{\sBlacklist}$
79−finally is a tuple containing a set $\sNodes$ of nodes, sometimes written
80− $$\sNode{\sProcesses}{\sLinks}{\sNid}
81− \sParN
82− \cdots
83− \sParN
84− \sNode{\sProcesses'}{\sLinks'}{\sNid'}
85− $$
86−a \emph{system queue} $\sQueue$, and a \emph{blacklist} $\sBlacklist$. The
87−system queue is a set of triples $(\mathit{to}, \mathit{from},
88−\mathit{message})$ of messages that have been sent but not yet processed. The
89−blacklist is a set of pairs $(\mathit{to}, \mathit{from})$. Once a pair
90−$(\mathit{to}, \mathit{from})$ has been blacklisted messages from
91−$\mathit{from}$ to $\mathit{to}$ will never be delivered ($\mathit{to}$ and
92−$\mathit{from}$ are node or process identifiers).
93−
94−\section{Semantics}
95−
96−\subsection{Contexts}
97−
98−We define an evaluation context as usual (TODO: catch?)
99−
100−\begin{equation*}
101−\sCtxt{E} ::= [] \OR \sBind{\sCtxt{E}}{M}
102−\end{equation*}
103−
104−A process context, parametrized by a \sPid, identifies a process within a set
105−of nodes.
106−
107−\begin{equation*}
108−\sCtxt{P}_\sPid ::= \sNode{\sProc{\sCtxt{E}}{pid} \sParP \sProcesses}{\sLinks}{\sNid} \sParN \sNodes
109−\end{equation*}
110−
111−We also find it useful to have a process context with two holes, one for a
112−process identified by \sPid{} and one for the set of processes on node \sNid.
113−This set of processes may or may not live on the same node as \sPid.
114−
115−\begin{equation*}
116−\begin{array}{rl}
117−\sCtxt{P}_{\sPid,\sNid} ::= &
118− \sNode{\sProc{\sCtxt{E}}{pid} \sParP []}{\sLinks}{\sNid} \sParN \sNodes \\[1em]
119−\OR &
120− \sNode{\sProc{\sCtxt{E}}{pid} \sParP \sProcesses}{\sLinks}{\sNid'} \sParN \sNode{[]}{\sLinks}{\sNid} \sParN \sNodes
121− \qquad
122− (\sNid \neq \sNid')
123−\end{array}
124−\end{equation*}
125−
126−\subsection{System Rules}
127−
128−\begin{equation*}
129−\frac{
130−}{
131− \sSystem{\sNodes}{\sQueue}{\sBlacklist}
132−\rightarrow
133− \sSystem{\sNodes}{\sQueue}{\sBlacklist, (\mathit{to}, \mathit{from})}
134−} \textsc{Disconnect}
135−\end{equation*}
136−
137−\subsection{Process rules}
138−
139−\subsubsection{Sending}
140−
141−If the communication is blacklisted the send is a no-op.
142−
143−\begin{equation*}
144−\frac{
145−(\mathit{to}, \mathit{from}) \notin \sBlacklist
146−}{
147− \sSystem{\sCtxt{P}[ \sSend \; \mathit{to} \; V ]_\mathit{from}}
148− {\sQueue}
149− {\sBlacklist}
150−\rightarrow
151− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\mathit{from}}
152− {\sQueue, (\mathit{to}, \mathit{from}, V)}
153− {\sBlacklist}
154−} \textsc{Send-Ok}
155−\end{equation*}
156−
157−\begin{equation*}
158−\frac{
159−(\mathit{to}, \mathit{from}) \in \sBlacklist
160−}{
161− \sSystem{\sCtxt{P}[ \sSend \; \mathit{to} \; V ]_\mathit{from}}
162− {\sQueue}
163− {\sBlacklist}
164−\rightarrow
165− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\mathit{from}}
166− {\sQueue}
167− {\sBlacklist}
168−} \textsc{Send-No}
169−\end{equation*}
170−
171−TODO: this allows to send functions
172−
173−\subsubsection{Receiving}
174−
175−We return the \emph{first} message of a randomly chosen sender.
176−
177−\begin{equation*}
178−\frac{
179− \mathit{from} \notin \sSenders(\sQueue)
180−}{
181− \sSystem{\sCtxt{P}[ \sExpect ]_\mathit{from}}
182− {\sQueue, (\mathit{to}, \mathit{from}, V), \sQueue'}
183− {\sBlacklist}
184−\rightarrow
185− \sSystem{\sCtxt{P}[ \sReturn \; V ]_\mathit{from}}
186− {\sQueue, \sQueue'}
187− {\sBlacklist}
188−} \textsc{Expect}
189−\end{equation*}
190−
191−\subsubsection{Spawning}
192−
193−\begin{equation*}
194−\frac{
195− \sPid' \text{ fresh} \qquad
196− (\sNid, \sPid) \notin \sBlacklist
197−}{
198− \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid[\sProcesses]_\sNid}
199− {\sQueue}
200− {\sBlacklist}
201−\rightarrow
202− \sSystem{\sCtxt{P}[ \sReturn \; (\sJust{\sPid'}) ]_\sPid[\sProcesses \sParP M_{\sPid'}]_\sNid}
203− {\sQueue}
204− {\sBlacklist}
205−} \textsc{Spawn-Ok}
206−\end{equation*}
207−
208−\begin{equation*}
209−\frac{
210− (\sNid, \sPid) \in \sBlacklist
211−}{
212− \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
213− {\sQueue}
214− {\sBlacklist}
215−\rightarrow
216− \sSystem{\sCtxt{P}[ \sReturn \; \sNothing ]_\sPid}
217− {\sQueue}
218− {\sBlacklist}
219−} \textsc{Spawn-No}
220−\end{equation*}
221−
222−\subsubsection{Reconnect}
223−
224−\begin{equation*}
225−\frac{
226−}{
227− \sSystem{\sCtxt{P}[ \sReconnect \; \mathit{id} ]_\sPid}
228− {\sQueue}
229− {\sBlacklist, (\mathit{id}, \sPid), \sBlacklist'}
230−\rightarrow
231− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
232− {\sQueue}
233− {\sBlacklist, \sBlacklist'}
234−} \textsc{Reconnect-Ok}
235−\end{equation*}
236−
237−\begin{equation*}
238−\frac{
239− (\mathit{id}, \sPid) \notin \sBlacklist
240−}{
241− \sSystem{\sCtxt{P}[ \sReconnect \; \mathit{id} ]_\sPid}
242− {\sQueue}
243− {\sBlacklist}
244−\rightarrow
245− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
246− {\sQueue}
247− {\sBlacklist}
248−} \textsc{Reconnect-No}
249−\end{equation*}
250−
251−\subsubsection{Administration}
252−
253−TODO: bind, pure evaluation, maybe exception handling
254−
255−\end{document}
doc/reconnect/reconnect.texdeleted−409
@@ -1,409 +0,0 @@
1−\documentclass[10pt]{article}
2−\usepackage[margin=2.5cm]{geometry}
3−\usepackage{listings}
4−\usepackage{amsmath,amssymb,stmaryrd}
5−\usepackage{mathpazo,times}
6−
7−\begin{document}
8−
9−\newcommand{\semNs}{\mathit{ns}}
10−\newcommand{\semEth}{\mathit{eth}}
11−\newcommand{\semPg}{\mathit{pg}}
12−\newcommand{\semNid}{\mathit{nid}}
13−\newcommand{\semNc}{\mathit{nc}}
14−\newcommand{\semRecon}{\mathrm{reconnect}}
15−\newcommand{\semDisconnect}{\mathrm{disconnect}}
16−\newcommand{\semDropped}{\mathrm{dropped}}
17−\newcommand{\semMessage}{\mathrm{message}}
18−\newcommand{\semPid}{\mathit{pid}}
19−
20−\newcommand{\semSystem}[2]{\llbracket #1, #2 \rrbracket}
21−\newcommand{\semNode}[3]{[ #1, #2, #3 ]}
22−\newcommand{\semStdNode}[1]{\semNode{\semPg_{#1}}{\semNid_{#1}}{\semNc_{#1}}}
23−\newcommand{\semProc}[3]{\langle #1, #2, #3 \rangle}
24−\newcommand{\semStdProc}[1]{\semProc{e}{\semPid}{q}}
25−
26−\newcommand{\semDied}[2]{\mathrm{died}(#1, #2)}
27−\newcommand{\semParN}{\mathrel{{\parallel}_N}}
28−\newcommand{\semParP}{\mathrel{{\parallel}_P}}
29−\newcommand{\semEthMatch}[3]{\mathrm{ethMatch}(#1, #2, #3)}
30−
31−\lstset{basicstyle=\ttfamily\small}
32−
33−\title{An Explicit $\semRecon$ Primitive for Cloud Haskell \\ (or a Future Erlang)}
34−\author{\small \begin{tabular}{ll}
35−Edsko de Vries & Duncan Coutts \\
36−Well-Typed LLP & Well-Typed LLP \\
37−\texttt{edsko@well-typed.com} & \texttt{duncan@well-typed.com}
38−\end{tabular}}
39−\maketitle
40−
41−\section*{Introduction}
42−
43−The original Cloud Haskell paper stipulates that messages are ``asynchronous,
44−reliable, and buffered'', but does not describe how this can be achieved.
45−Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),
46−the reliability of message delivery comes from the reliability of the
47−underlying network protocol---up to a point.
48−
49−The problem is that the underlying network protocol is connection-oriented, but
50−Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a
51−reliable-ordered connection from $P$ to $Q$. Reliability of message delivery
52−now follows from reliability of the network protocol, until $P$ somehow gets
53−disconnected from $Q$. If $P$ now sends another message to $Q$, the
54−implementation cannot simply reconnect: after all, some messages that were sent
55−on the first connection might not have been delivered. This means that $P$
56−might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1, m_3$.
57−
58−One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and
59−remove messages from this buffer only when $Q$ acknowledges that it received
60−them. On a reconnect $P$ must ask which message $Q$ last received, and
61−retransmit the rest. This means that when $P$ gets disconnected from $Q$, it
62−must infinitely buffer all messages sent to $Q$ (until a connection is
63−reestablished). However, infinite buffering is too strong a requirement;
64−moreover, this is unsatisfactory because it means implementing a reliable
65−protocol on top of the underlying reliable network protocol. We would like a
66−different solution.
67−
68−But even more important than the exact solution we adopt is a precise
69−semantics of Cloud Haskell message delivery. A good starting point (one that
70−has been used in the new implementation of Cloud Haskell) is \textit{A
71−Unified Semantics for Future Erlang} by Hans Svensson, Lars-\AA{}ke Fredlund
72−and Clara Benac Earle (Erlang '10)---although this semantics leaves the issue
73−of reconnect open.
74−
75−Here we give an overview of the relevant aspects of the Unified semantics,
76−discuss where reconnect comes into the picture, and then propose a new
77−primitive for Cloud Haskell called $\semRecon$, which essentially gives the
78−programmer the ability to explicitly accept message loss.
79−
80−\section*{Overview of the original semantics}
81−
82−The top-level semantics is a labelled transition relation between
83−\textit{systems}
84−%
85−\begin{equation}
86−\semSystem{\semNs}{\semEth} \xrightarrow{\tilde{\mu}} \semSystem{\semNs'}{\semEth'}
87−\end{equation}
88−%
89−A system $\semSystem{\semNs}{\semEth}$ consists of a bunch of nodes $\semNs$
90−and an ``ether'' or system message queue $\semEth$. The ether models, globally,
91−all messages that have been sent but not yet delivered. The label $\tilde{\mu}$
92−is a list of actions, and is only used in the semantics to define fairness (see
93−below).
94−
95−A node is a triplet $\semStdNode{}$ consisting of a bunch of processes
96−$\semPg$, a node ID $\semNid$ and a node controller $\semNc$. The node
97−controller is responsible for all administrative actions on a node (spawning
98−new processes, establishing links, etc.).
99−A process $\semStdProc{}$ consists of an expression $e$, process ID $\semPid$
100−and message queue (mailbox) $q$. Finally, $(\semParN)$ is used for the parallel
101−composition of nodes, and $(\semParP)$ is used for the parallel composition of
102−processes.
103−
104−\subsubsection*{Ordering}
105−
106−The ether contains messages of the form
107−%
108−\begin{equation*}
109−(\mathit{recipient}, \mathit{sender}, \mathit{message})
110−\end{equation*}
111−%
112−where $\mathit{recipient}$ and $\mathit{sender}$ are process IDs or node IDs
113−(for messages to or from node controllers). Ordering of message delivery in
114−the semantics is embodied by a function
115−%
116−\begin{equation*}
117−\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}}
118−\end{equation*}
119−%
120−(Def.~11, p.~25) which selects the \emph{first} message in $\semEth$ from
121−$\mathit{from}$ to $\mathit{to}$. Many of the semantic rules look like
122−%
123−\begin{equation*}
124−\frac{%
125−\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}} = \mathit{sig}
126−}{%
127−\semSystem{\semNs}{\semEth} \rightarrow \text{(do something with $\mathit{sig}$)}
128−}
129−\end{equation*}
130−
131−where $\mathit{to}$ and $\mathit{from}$ are universally quantified over the
132−rule. This means that messages between pairs of processes (or nodes) are
133−ordered, but there is no global ordering guarantee.
134−
135−\subsubsection*{Disconnects}
136−
137−Although the semantics is not connection oriented, it includes a
138−non-deterministic rule $\mathit{node}_\mathit{disconnect}$ which models
139−arbitrary disconnects (Table 9, p.~28):
140−%
141−{\small
142−\begin{equation*}
143−\frac{}{%
144− \begin{array}{l}
145− \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}{\semEth}
146−\xrightarrow{\semDisconnect(nid_1, nid_2)} \\[0.5em]
147− \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}
148− {\semEth \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})
149− \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})
150− }
151− \end{array}
152−}
153−\end{equation*}
154−}
155−%
156−So at any one point a node controller may receive a message that it got
157−disconnected from another node controller. These messages are handled by the
158−bottom rule in Table 12 (p.~30): local processes that link to (or monitor)
159−processes on the disconnected remote node are killed (or notified).
160−
161−\subsubsection*{Node or process failure}
162−
163−When a process dies (throws an exception) a message is sent to its local node
164−controller (rule $\mathit{exiting}$, Table~4, p.~27). Failure of an entire
165−node is handled by a non-deterministic rule like the one above (rule
166−$\mathit{node}_\mathit{failure}$, Table~9, p.~28). The resulting message is
167−handled in a similar way to a disconnect (Table~12, p.~30).
168−
169−When a process or a node \emph{dies} (but \emph{not} when it gets disconnected)
170−messages to that process (or node) can be removed from the ether (rules
171−$\mathit{missing}_\mathit{process}$ and $\mathit{missing}_\mathit{node}$,
172−Table~6, p.~28).
173−
174−\subsubsection*{Fairness}
175−
176−Since the semantic rules pick an (more or less) arbitrary message from the
177−ether to process, the rules do not guarantee that all messages are eventually
178−delivered. In the paper this is added ``on top'' of the semantic rules by Def.~20
179−(p.~29), which essentially states that all messages that have been sent must be
180−delivered (or explicitly removed by rules $\mathit{missing}_\mathit{process}$
181−and $\mathit{missing}_\mathit{node}$).
182−
183−\section*{Reconnect}
184−
185−\subsubsection*{In the Unified semantics}
186−
187−The original semantics state that
188−
189−\begin{enumerate}
190−\item all messages sent must eventually be delivered or explicitly removed from the ether (fairness)
191−\item only messages to died (not disconnected) processes or nodes can be removed from the ether
192−\end{enumerate}
193−
194−From a practical perspective this means that messages sent from process $P$ to
195−process $Q$ must be infinitely buffered when $P$ gets disconnected to $Q$, and
196−the system should keep retrying to connect to $Q$ until it receives evidence
197−(for instance, from $Q$'s node controller) that $Q$ has died.
198−
199−For messages sent to node controllers (such as attempts to spawn new processes)
200−this is even more problematic: when process $P$ gets disconnected from node
201−$N$, all messages from $P$ to $N$ must be infinitely buffered until a
202−reconnection is established, or dropped when $P$ learns $N$ has died. However,
203−process $P$ might never be able to distinguish a (temporary) disconnect from
204−$N$ from a crash of $N$.
205−
206−\subsubsection*{Permanent disconnects}
207−
208−The simplest solution to avoid infinite buffering is to drop the fairness
209−requirement from the semantics. Now the implementation is free to attempt to
210−reconnect only a finite number of times---or indeed never---and then simply
211−drop all subsequent messages and never reconnect again. This is a correct
212−implementation of the semantics, because without the fairness requirement
213−messages sent from $P$ to $Q$ can be left in the ether forever.\footnote{From a
214−purely formal perspective, the semantics without the fairness guarantee is too
215−permissive: it would allow a message never to be sent even when no disconnect
216−occurs. If we wanted to fix this, we would have to remove messages from the
217−ether on a disconnect, so that fairness can be satisfied, and keep an explicit
218−history of disconnects.}
219−
220−\subsubsection*{Implicit reconnect with potential message loss (Erlang-style)}
221−
222−The solution adopted by Erlang is an implicit reconnect but without
223−buffering. As described in the introduction, this means that it is possible for
224−$P$ to send messages $m_1, m_2, m_3$ to $Q$ and for $Q$ to receive messages
225−$m_1$ and $m_3$, but not $m_2$. We could model this in the semantics by
226−modifying the rule for disconnect so that it removes messages from the ether.
227−
228−\subsubsection*{Explicit Reconnects}
229−
230−Erlang-style implicit reconnects are not very satisfying semantically because
231−it means we cannot really make any claims about the reliability of message
232−delivery. Permanent disconnects are nicer semantically, but might be too
233−limiting (some musings on that below). The solution we propose is to introduce
234−a new primitive called $\semRecon$. Here's the rule:
235−%
236−\begin{equation*}
237−\frac{%
238−e \xrightarrow{\semRecon(i)} e' \qquad
239−(\semEth_0, \semEth_1) = \mathrm{partition} \; (\lambda (\mathit{to}, \mathit{from}, \_) \rightarrow \mathit{to} = i \wedge \mathit{from} = \semPid) \; \semEth
240−}{%
241− \semSystem{\semNode{\semProc{e}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth}
242−\xrightarrow{\semDropped(\semEth_0)}
243− \semSystem{\semNode{\semProc{e'}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth_1}
244−}
245−\end{equation*}
246−%
247−Semantically, when process $P$ calls $\semRecon(Q)$ it explicitly accepts that
248−some the messages it sent to $Q$ might be lost. Note that this is the only
249−change we need to make the Unified semantics. In particular, the fairness
250−requirement stays: since the rule explicitly records that some messages have
251−been dropped, fairness now means:
252−
253−\begin{quote}
254−All messages sent must eventually be delivered, removed from the ether because
255−a process or a node died, or removed from the ether by an explicit $\semRecon$.
256−\end{quote}
257−
258−From an implementation point of view, once $P$'s connection to $Q$ breaks we do
259−not implicitly reconnect (because doing so would mean losing the reliability
260−guarantee). When $P$ calls $\semRecon(Q)$, however, the implementation is
261−free to reestablish a connection from $P$ to $Q$, either immediately or when
262−$P$ sends its next message to $Q$.
263−
264−\section*{Example}
265−
266−Suppose we start with two nodes, both of which run a single process. The system
267−ether and both process queues are empty ($\epsilon$):
268−%
269−\begin{equation*}
270−\semSystem
271− {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}
272− \semParN
273− \underbrace{\semNode{\semProc{p_2}{\semPid_2}{\epsilon}}{\semNid_2}{\semNc_2}}_{N_2}
274− }
275− {\epsilon}
276−\end{equation*}
277−%
278−Now $p_1$ sends a message to $p_2$ (Rule $\mathit{output}$, Table~5, p.~28):
279−%
280−\begin{equation*}
281−\frac{%
282− p_1 \xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)} p_1'
283−}{%
284−\semSystem
285− {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}
286− \semParN
287− N_2
288− }
289− {\epsilon}
290−\xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)}
291−\semSystem
292− {\underbrace{\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}}_{N_1'}
293− \semParN
294− N_2
295− }
296− {\underbrace{(\semPid_2, \semPid_1, \semMessage(v))}_{M_1}}
297−}
298−\end{equation*}
299−%
300−Note that the message has been sent but not yet delivered (i.e., it is in the
301−ether, not in $p_2$'s queue). Now suppose that node $\semNid_1$ gets
302−disconnected from node $\semNid_2$ (Table~9, p.~28):
303−%
304−\begin{equation*}
305−\frac{%
306−}{%
307−\begin{array}{l}
308−\semSystem{N_1' \semParN N_2}{M_1}
309−\xrightarrow{\semDisconnect(\semNid_1, \semNid_2)} \\
310−\semSystem{N_1' \semParN N_2}{M_1 \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})
311− \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})}
312−\end{array}
313−}
314−\end{equation*}
315−%
316−Assume that $p_1$ had previously set up monitoring for $p_2$. It gets notified of the disconnect (Table 12), and it receives the monitor message; at this point we're in a state
317−%
318−\begin{equation*}
319−\semSystem{N_1'' \semParN N_2}{M_1}
320−\end{equation*}
321−%
322−where the original message $M_1$ is still in the ether. If at this point $p_1$ sends another message to $p_2$ we end up with an ether
323−%
324−\begin{equation*}
325−M_1 \cdot \underbrace{(\semPid_2, \semPid_1, \semMessage(v_2))}_{M_2}
326−\end{equation*}
327−%
328−which implies that we must deliver $M_1$ before $M_2$. This is of course
329−precisely the ``ordered'' reliability guarantee. If however, $p_1$ calls
330−$\semRecon$ when it receives the monitor message, we remove $M_1$ from the ether;
331−when $p_1$ then sends the next message we can establish a new connection.
332−
333−\section*{The Need for Reconnect}
334−
335−Ordering guarantees are between pairs of processes/nodes. Thus, when $P$ gets
336−disconnected from $Q$, the easiest way to reestablish a connection is for $P$
337−to restart to become a new process $P'$. This will happen naturally when $P$
338−links to $Q$ and can be restarted by some supervisor process.
339−
340−However, if there are many processes connected to $P$, then $P$ might not want
341−to restart (breaking all connections with its own clients) simply in order to
342−be able to reconnect to Q. For instance, maybe $P$ is a webserver and $Q$ is a
343−domain name server; if $P$ gets temporarily disconnected from $Q$, it does not
344−make much sense to require $P$ to restart (and get a new process ID) before it
345−can send new domain name requests (indeed, in this particular example, lost
346−messages to a domain name server may not matter at all).
347−
348−The situation is even more severe for messages sent from processes to
349−\emph{nodes}. For instance, suppose process $P$ does
350−%
351−\begin{lstlisting}[mathescape,keywords={do}]
352−do spawnAsync nid p1 ; spawnAsync nid p2 ; spawnAsync nid p3
353−\end{lstlisting}
354−%
355−and receives a confirmation that $p_3$ was spawned successfully.\footnote{In
356−the unified paper spawn is asynchronous, which is why the new implementation of
357−Cloud Haskell offers \texttt{spawnAsync}; \texttt{spawn} is then implemented in
358−terms of \texttt{spawnAsync} and \texttt{expect}.} Intuitively this seems to
359−suggest that \emph{all} of $p_1$, $p_2$ and $p_3$ should have been spawned, and
360−this is guaranteed by the reliable-ordered guarantee for messages:
361−\texttt{spawnAsync} is nothing more than a message from the process to the node
362−controller of the node $\mathit{nid}$.
363−
364−But the same problem with reconnect occurs here, too. If the connection from
365−the process to the remote node controller is lost, we cannot guarantee ordered
366−delivery. Permanent disconnect would mean that the process would have to
367−restart before it can spawn new processes on this remote node; if the process
368−is some sort of supervisor process, then this might not be what we want to do.
369−Implicit reconnects means we lose the reliability guarantee; an explicit
370−reconnect (probably after a monitor notification about the disconnect from the
371−remote node) allows the process to reestablish a connection to the remote node
372−controller, and forces the programmer of the process to think about how to
373−handle the potential loss of messages.
374−
375−\section*{Alternative Solutions}
376−
377−\begin{itemize}
378−
379−\item A hybrid solution is possible, too. For instance, we might guarantee
380−reliable-ordered message passing for messages sent from process-to-process, but
381−not for process-to-node. In other words, no explicit call is necessary when
382−spawning a new process on a remote node after a disconnect from that remote
383−node. This might muddle the semantics (in particular, if processes don't
384−monitor remote nodes, programmers might get a false sense of security and rely
385−on non-existing ordering guarantees). On the other hand, requiring an explicit
386−reconnect to a remote node before a spawn (or similar primitive) might be
387−confusing.
388−
389−\item Another hybrid solution is to have an implicit reconnect when sending a
390−monitor notification. So, if $P$ monitors $Q$, and gets a monitor notification,
391−then it must expect potential message loss. If $P$ does not monitor $Q$ then
392−disconnects are permanent.
393−
394−\item Since Cloud Haskell supports typed channels as well as sending messages
395−directly to processes, we could decide not to offer any reliability guarantees
396−for messages sent directly to processes, but provide reliable-ordered message
397−delivery on typed channels. This is an attractive solution, because a typed
398−channel could be considered a connection. When $P$ wants to communicate with
399−$Q$, it sends a message to $Q$ requesting a send port. It then communicates
400−with $Q$ through this send port; when it gets disconnected, it could request a
401−\empty{new} typed channel. Importantly, the send port $P$ receives must indeed
402−be a \emph{new} channel (at least from $P$s perspective).
403−
404−\end{itemize}
405−
406−
407−
408−
409−\end{document}
doc/semantics/CloudHaskellSemantics.texnew file+706
@@ -0,0 +1,706 @@
1+\documentclass{article}
2+\usepackage[margin=2.5cm]{geometry}
3+\usepackage{amsmath, amssymb, stmaryrd}
4+\usepackage{mathpazo, times}
5+\usepackage{float}
6+\usepackage{listings}
7+
8+\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
9+\newcommand{\sApp}[2]{{#1} {#2}}
10+\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
11+\newcommand{\sReturn}{\mathtt{return}}
12+\newcommand{\sThrow}[1]{\mathtt{throw} \; {#1}}
13+\newcommand{\sCatch}[2]{\mathtt{catch} \; {#1} \; {#2}}
14+
15+\newcommand{\sExpect}{\mathtt{expect}}
16+\newcommand{\sSend}{\mathtt{send}}
17+\newcommand{\sSpawn}{\mathtt{spawn}}
18+\newcommand{\sLink}{\mathtt{link}}
19+\newcommand{\sReconnect}{\mathtt{reconnect}}
20+\newcommand{\sNewChan}{\mathtt{newChan}}
21+\newcommand{\sSendChan}{\mathtt{sendChan}}
22+\newcommand{\sReceiveChan}{\mathtt{receiveChan}}
23+\newcommand{\sMonitor}{\mathtt{monitor}}
24+
25+\DeclareMathOperator{\sNodeOf}{node}
26+\DeclareMathOperator{\sProcessOf}{process}
27+
28+\newcommand{\sSpawned}{\mathtt{spawned}}
29+
30+\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}}
31+
32+\newcommand{\sPar}{\mathrel{\parallel}}
33+\newcommand{\sProc}[2]{{#1}_{#2}}
34+
35+\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
36+\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
37+\newcommand{\sCid}{\ensuremath{\mathit{cid}}}
38+
39+\newcommand{\sId}{\ensuremath{\mathit{id}}}
40+\newcommand{\sRef}{\ensuremath{\mathit{ref}}}
41+
42+\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
43+\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
44+\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle}
45+\newcommand{\sNodes}{\mathcal{N}}
46+\newcommand{\sQueue}{\mathcal{Q}}
47+\newcommand{\sProcesses}{\mathcal{P}}
48+\newcommand{\sBlacklist}{\mathcal{B}}
49+\newcommand{\sMonitors}{\mathcal{M}}
50+
51+\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
52+\newcommand{\sNothing}{\mathtt{Nothing}}
53+
54+\newcommand{\sCtxt}[1]{\mathbb{#1}}
55+
56+\newcommand{\sSenders}{\mathit{senders}}
57+
58+\newcommand{\OR}{\mathrel{|}}
59+\newcommand{\where}{\mathrel{|}}
60+
61+\floatstyle{boxed}
62+\restylefloat{figure}
63+
64+\lstset{basicstyle=\ttfamily\small}
65+
66+\begin{document}
67+
68+\title{Cloud Haskell Semantics (DRAFT)}
69+\author{Well-Typed LLP}
70+\date{\today}
71+
72+\maketitle
73+
74+\section{Introduction}
75+
76+Cloud Haskell brings Erlang-style concurrency to Haskell in the form of a
77+library.\footnote{\texttt{http://hackage.haskell.org/package/distributed-process}}
78+The original publication \cite{cloudhaskell} is a good introduction to Cloud
79+Haskell, and is accompanied by an ever-growing number of resouces, collected on
80+the Haskell
81+Wiki.\footnote{\texttt{http://www.haskell.org/haskellwiki/Cloud\_Haskell}} The
82+current document augments the original publication about Cloud Haskell by
83+giving a precise semantics to the Cloud Haskell primitives. It is meant as a
84+reference, not an introduction.
85+
86+The original Cloud Haskell paper stipulates that messages are ``asynchronous,
87+reliable, and buffered'', but does not describe how this can be achieved.
88+Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),
89+the reliability of message delivery comes from the reliability of the
90+underlying network protocol---up to a point.
91+
92+The problem is that the underlying network protocol is connection-oriented, but
93+Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a
94+reliable-ordered connection from $P$ to $Q$. Reliability of message delivery
95+now follows from reliability of the network protocol, until $P$ somehow gets
96+disconnected from $Q$. If $P$ now sends another message to $Q$, the
97+implementation cannot simply reconnect: after all, some messages that were sent
98+on the first connection might not have been delivered. This means that $P$
99+might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1,
100+m_3$.\footnote{Indeed, message passing in Erlang is ordered but unreliable for
101+the same reason \cite{erlang}.}
102+
103+One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and
104+remove messages from this buffer only when $Q$ acknowledges that it received
105+them. On a reconnect $P$ must ask which message $Q$ last received, and
106+retransmit the rest. This means that when $P$ gets disconnected from $Q$, it
107+must infinitely buffer all messages sent to $Q$ (until a connection is
108+reestablished). However, infinite buffering is too strong a requirement;
109+moreover, this is unsatisfactory because it means implementing a reliable
110+protocol on top of the underlying reliable network protocol. We would like a
111+different solution.
112+
113+Instead, Cloud Haskell does \emph{not} attempt to reconnect automatically, but
114+provides a $\sReconnect$ primitive which gives programmers the option of
115+reconnecting manually. This is an explicit acknowledgement from the programmer
116+that message loss might occur, and forces them to consider how such loss might
117+be dealt with.
118+
119+The semantics we present is based on \cite{unified}, which we will refer to the
120+as the ``Unified'' semantics. However, we will present the semantics in a more
121+``Haskell'' style following the semantics for STM \cite{stm}. It differs from
122+the Unified semantics in that
123+%
124+\begin{enumerate}
125+\item We introduce an explicit notion of \textit{reconnecting} (with potential
126+message loss)
127+\item We simplify the semantics: we ``flatten'' sets of nodes of processes as
128+sets of processes (but assume a mapping from process identifiers to node
129+identifiers), do not have per-process mailboxes (but only the system queue or
130+``ether'') and do not have an explicit concept of node controllers
131+\end{enumerate}
132+%
133+Our semantics differs from the STM semantics in that we pretend that the Cloud
134+Haskell \texttt{Process} monad is the top-level monad, and do not consider the
135+\texttt{IO} monad at all. Current imprecisions with respect to the ``real''
136+Cloud Haskell are
137+%
138+\begin{enumerate}
139+\item We ignore the issue of serializability, other than to say that the
140+semantics will get stuck when trying to send a non-serializable payload;
141+consequently, we do not formalize $\mathtt{static}$
142+\item We do not formalize all Cloud Haskell primitives (merging of ports,
143+``advanced messaging'', and others)
144+\item Some of the concepts that we do formalize are lower-level concepts; for
145+instance, the primitive $\sSpawn$ that we formalize is asynchronous (following
146+the Unified semantics); a synchronous construct can be derived.
147+\end{enumerate}
148+
149+\section{Preliminaries}
150+
151+Cloud Haskell Processes run on \emph{nodes}. Processes communicate by sending
152+messages to each other (directly or using typed channels). Processes can also
153+send messages to nodes (for instance, a request to spawn or monitor a process).
154+
155+We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and
156+$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively,
157+and representing process identifiers, node identifiers, and (typed) channel
158+identifiers. We assume the existence of total functions
159+%
160+\begin{equation*}
161+\begin{array}{r@{\;:\;}l}
162+\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\
163+\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId}
164+\end{array}
165+\end{equation*}
166+%
167+and define
168+$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$
169+and let $\sId$ range over $\mathtt{Identifier}$.
170+
171+We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process
172+ID $\sPid$. We will denote a set of processes as
173+%
174+ $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$
175+%
176+A \emph{system}
177+ $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$
178+is a tuple containing a set $\sProcesses$ of processes, a \emph{system
179+queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors
180+$\sMonitors$.
181+The set of monitors $\sMonitors$ is a set of tuples
182+ $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$
183+which records that node \sNid{} knows that process $\sPid_\mathit{fr}$ is
184+monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor reference). The system
185+queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr},
186+\mathit{message})$ of messages that have been sent but not yet processed. The
187+blacklist records disconnections and is represented as a of pairs
188+$(\sId_\mathit{to}, \sId_\mathit{fr})$.
189+
190+\section{Semantics}
191+
192+We follow the STM semantics as closely as possible. The language is the same
193+except for the primitives considered, and we use the same concept of evaluation
194+contexts:
195+
196+\begin{equation*}
197+\begin{array}{llll}
198+\text{value} & V & ::= & \sId \OR
199+ \sLam{x}{M} \OR
200+ \sReturn \; M \OR
201+ \sBind{M}{N} \OR
202+ \sThrow{M} \OR \sCatch{M}{N} \OR \\
203+ &&& \sExpect \OR
204+ \sSend \; \sPid \; M \OR
205+ \sSpawn \; \sNid \; M \OR
206+ \sMonitor \; \sId
207+\\
208+\text{term} & M, N & ::= & x \OR
209+ V \OR
210+ \sApp{M}{N} \OR
211+ \cdots \\
212+\\
213+\text{Evaluation} & \sCtxt{E} & ::= & [] \OR \sBind{\sCtxt{E}}{M} \OR \sCatch{\sCtxt{E}}{M} \\
214+\text{context} & \sCtxt{P}_\sPid & ::= & \sCtxt{E}[]_\sPid \sPar \sProcesses
215+\end{array}
216+\end{equation*}
217+%
218+Indeed, the ``administrative'' transitions are identical
219+(Figure~\ref{fig:administrative}).
220+
221+\begin{figure}
222+\small
223+\begin{equation*}
224+\frac{
225+ \llbracket M \rrbracket = V \qquad
226+ M \neq V
227+}{
228+ M \rightarrow V
229+} \textsc{Eval}
230+\qquad
231+\frac{
232+ M \rightarrow N
233+}{
234+ \sSystem{\sCtxt{P}[M]_\sPid}
235+ {\sQueue}
236+ {\sBlacklist}
237+ {\sMonitors}
238+\rightarrow
239+ \sSystem{\sCtxt{P}[N]_\sPid}
240+ {\sQueue}
241+ {\sBlacklist}
242+ {\sMonitors}
243+} \textsc{Admin}
244+\end{equation*}
245+%
246+\begin{equation*}
247+\begin{array}{r@{\;\rightarrow\;}ll@{\hspace{2em}}r@{\;\rightarrow\;}ll}
248+\sBind{\sReturn \; N}{M} & M \; N & \textsc{Bind} & \sCatch{(\sReturn \; M)}{N} & \sReturn \; M & \textsc{Catch}_1 \\
249+\sBind{\sThrow{N}}{M} & \sThrow{N} & \textsc{Throw} & \sCatch{(\sThrow M)}{N} & N \; M & \textsc{Catch}_2 \\
250+\end{array}
251+\end{equation*}
252+%
253+\caption{\label{fig:administrative}Administrative Transitions}
254+\end{figure}
255+
256+\subsection{Disconnect and Reconnect}
257+
258+Figure~\ref{fig:disconnect} gives the semantics for disconnecting and
259+reconnecting. Rule \textsc{Disconnect} models random network disconnect
260+between nodes $\sNid_1$ and $\sNid_2$. We assume that entire \emph{nodes} get
261+disconnected from each other, not individual processes. \emph{Reconnecting}
262+however is on a per connection basis (\textsc{Recon-Ex}). Connections to and
263+from node controllers can be implicitly reconnected ($\textsc{Recon-Im}_1$ and
264+$\textsc{Recon-Im}_2$).
265+
266+\begin{figure}
267+\small
268+\begin{equation*}
269+\frac{
270+ \sNid_1 \neq \sNid_2
271+}{
272+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
273+\rightarrow
274+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors}
275+} \textsc{Disconnect}
276+\end{equation*}
277+%
278+\begin{equation*}
279+\frac{
280+}{
281+ \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
282+ {\sQueue}
283+ {\sBlacklist}
284+ {\sMonitors}
285+\rightarrow
286+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
287+ {\sQueue}
288+ {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})}
289+ {\sMonitors}
290+} \textsc{Recon-Ex}
291+\end{equation*}
292+%
293+\begin{equation*}
294+\frac{
295+}{
296+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors}
297+\rightarrow
298+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
299+} \textsc{Recon-Im}_1
300+\qquad
301+\frac{
302+}{
303+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors}
304+\rightarrow
305+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
306+} \textsc{Recon-Im}_2
307+\end{equation*}
308+%
309+where
310+%
311+\begin{equation*}
312+\overline{\sNid} \subset \mathtt{Identifier}
313+ = \{ \sNid \} \cup
314+ \{ \sPid \where \sNodeOf(\sPid) = \sNid \} \cup
315+ \{ \sCid \where \sNodeOf(\sCid) = \sNid \}
316+\end{equation*}
317+\caption{\label{fig:disconnect}Disconnect and Reconnect}
318+\end{figure}
319+
320+\subsection{Communication}
321+
322+The semantics for the basic primitives are listed in Figure~\ref{fig:basic}.
323+Once a connection has been blacklisted, no further messages can be sent across
324+that connection (until an explicit or implicit reconnect).
325+
326+Message passing is ordered but only for a given sender and receiver; no
327+ordering guarantees exist between messages sent by different processes. For
328+that reason rules \textsc{Expect}, \textsc{ReceiveChan} and \textsc{Spawn-Exec}
329+choose the \emph{first} message of a \emph{randomly chosen} sender.
330+
331+Since the semantics is not type-driven, we represent typed channels simply as
332+an identifier with an annotation whether it is the send-end ($\sCid^s$) or the
333+receive end ($\sCid^r$) of the channel (rules \textsc{NewChan},
334+\textsc{SendChan} and \textsc{ReceiveChan}).
335+
336+Spawning finally is asynchronous. When process $P$ spawns process $Q$ on node
337+$\sNid$ (rule \textsc{Spawn-Async}) a message is sent to node $\sNid$ (which
338+may, of course, never arrive). When the remote node receives the message and
339+actually spawns $Q$ (rule \textsc{Spawn-Exec}) it sends a message back to $P$
340+with $Q$'s process ID. In Cloud Haskell this primitive is called
341+\texttt{spawnAsync}, and the Cloud Haskell \texttt{spawn} primitive is defined
342+in terms of \texttt{spawnAsync} (we do not consider the synchronous version in
343+this document).
344+
345+\begin{figure}
346+\small
347+\begin{equation*}
348+\frac{
349+}{
350+ \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}}
351+ {\sQueue}
352+ {\sBlacklist}
353+ {\sMonitors}
354+\rightarrow
355+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
356+ {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)}
357+ {\sBlacklist}
358+ {\sMonitors}
359+} \textsc{Send}
360+\end{equation*}
361+%
362+\begin{equation*}
363+\frac{
364+ \sId_{\mathit{fr}} \notin \sSenders(\sQueue)
365+}{
366+ \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}}
367+ {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'}
368+ {\sBlacklist}
369+ {\sMonitors}
370+\rightarrow
371+ \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}}
372+ {\sQueue, \sQueue'}
373+ {\sBlacklist}
374+ {\sMonitors}
375+} \textsc{Expect}
376+\end{equation*}
377+%
378+\begin{equation*}
379+\frac{
380+ \sCid \text{ fresh}
381+\qquad
382+ \sProcessOf(\sCid) = \sPid
383+}{
384+ \sSystem{\sCtxt{P}[\sNewChan]_\sPid}
385+ {\sQueue}
386+ {\sBlacklist}
387+ {\sMonitors}
388+\rightarrow
389+ \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid}
390+ {\sQueue}
391+ {\sBlacklist}
392+ {\sMonitors}
393+} \textsc{NewChan}
394+\end{equation*}
395+
396+\begin{equation*}
397+\frac{
398+}{
399+ \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}}
400+ {\sQueue}
401+ {\sBlacklist}
402+ {\sMonitors}
403+\rightarrow
404+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
405+ {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)}
406+ {\sBlacklist}
407+ {\sMonitors}
408+} \textsc{SendChan}
409+\end{equation*}
410+
411+\begin{equation*}
412+\frac{
413+ \sPid_{\mathit{fr}} \notin \sSenders(\sQueue)
414+}{
415+ \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}}
416+ {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'}
417+ {\sBlacklist}
418+ {\sMonitors}
419+\rightarrow
420+ \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}}
421+ {\sQueue, \sQueue'}
422+ {\sBlacklist}
423+ {\sMonitors}
424+} \textsc{ReceiveChan}
425+\end{equation*}
426+%
427+\begin{equation*}
428+\frac{
429+ \sRef \text{ fresh}
430+}{
431+ \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
432+ {\sQueue}
433+ {\sBlacklist}
434+ {\sMonitors}
435+\rightarrow
436+ \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid}
437+ {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)}
438+ {\sBlacklist}
439+ {\sMonitors}
440+} \textsc{Spawn-Async}
441+\end{equation*}
442+%
443+\begin{equation*}
444+\frac{
445+ \sPid \notin \sSenders(\sQueue)
446+\qquad
447+ \sPid' \text{ fresh}
448+\qquad
449+ \sNodeOf(\sPid') = \sNid
450+}{
451+ \sSystem{\sProcesses}
452+ {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'}
453+ {\sBlacklist}
454+ {\sMonitors}
455+\rightarrow
456+ \sSystem{\sProcesses \sPar M_{\sPid'}}
457+ {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')}
458+ {\sBlacklist}
459+ {\sMonitors}
460+} \textsc{Spawn-Exec}
461+\end{equation*}
462+%
463+where
464+%
465+\begin{equation*}
466+\begin{array}{l@{\;=\;}l@{\hspace{3em}}l}
467+ \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
468+&
469+ \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M)
470+&
471+ \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist
472+\\
473+ \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
474+&
475+ \sQueue
476+&
477+ \text{otherwise}
478+\end{array}
479+\end{equation*}
480+%
481+$(\sExtend{\sBlacklist})$ is only defined for serializable payloads.
482+\caption{\label{fig:basic}Basic Primitives}
483+\end{figure}
484+
485+\subsection{Monitoring}
486+
487+When process $P$ on node $\sNid_P$ wants to monitor process $Q$ on node
488+$\sNid_Q$ \emph{both} nodes must be notified. The local node it notified
489+immediately, and a message is sent to to the remote node (rules
490+\textsc{Mon-Loc} and \textsc{Mon-Rem}). As with all messages, the
491+message to the remote node might be lost. When $P$ is disconnected from $Q$ it
492+is the responsibility of $P$'s local node $\sNid_P$ to notify $P$
493+(\textsc{Mon-Dis}); when $Q$ terminates (\textsc{Mon-Ret}) or crashes
494+(\textsc{Mon-Throw}) it is the responsibility of the remote node $\sNid_Q$ to
495+notify $P$.
496+
497+\begin{figure}
498+\small
499+\begin{equation*}
500+\frac{
501+ \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
502+\qquad
503+ \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to})
504+\qquad
505+ \sRef \text{ fresh}
506+}{
507+\sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
508+ {\sQueue}
509+ {\sBlacklist}
510+ {\sMonitors}
511+\rightarrow
512+ \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}}
513+ {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})}
514+ {\sBlacklist}
515+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
516+} \textsc{Mon-Loc}
517+\end{equation*}
518+%
519+\begin{equation*}
520+\frac{
521+ \sPid_\mathit{fr} \notin \sSenders(\sQueue)
522+}{
523+ \sSystem{\sProcesses}
524+ {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'}
525+ {\sBlacklist}
526+ {\sMonitors}
527+\rightarrow
528+ \sSystem{\sProcesses}
529+ {\sQueue, \sQueue'}
530+ {\sBlacklist}
531+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)}
532+} \textsc{Mon-Rem}
533+\end{equation*}
534+%
535+\begin{equation*}
536+\frac{
537+ \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
538+\qquad
539+ (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist
540+}{
541+ \sSystem{\sProcesses}
542+ {\sQueue}
543+ {\sBlacklist}
544+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
545+\rightarrow
546+ \sSystem{\sProcesses}
547+ {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)}
548+ {\sBlacklist}
549+ {\sMonitors}
550+} \textsc{Mon-Dis}
551+\end{equation*}
552+%
553+\begin{equation*}
554+\frac{
555+ \sNodeOf(\sPid) = \sNid
556+}{
557+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
558+ {\sQueue}
559+ {\sBlacklist}
560+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
561+\rightarrow
562+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
563+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{died} \; \sRef)}
564+ {\sBlacklist}
565+ {\sMonitors}
566+} \textsc{Mon-Ret}
567+\end{equation*}
568+%
569+\begin{equation*}
570+\frac{
571+ \sNodeOf(\sPid) = \sNid
572+}{
573+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
574+ {\sQueue}
575+ {\sBlacklist}
576+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
577+\rightarrow
578+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
579+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{exc} \; \sRef \; M)}
580+ {\sBlacklist}
581+ {\sMonitors}
582+} \textsc{Mon-Throw}
583+\end{equation*}
584+%
585+\begin{equation*}
586+\frac{
587+ \sNodeOf(\sPid) = \sNid
588+\qquad
589+ \sPid \notin \sProcesses
590+}{
591+ \sSystem{\sProcesses}
592+ {\sQueue}
593+ {\sBlacklist}
594+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
595+\rightarrow
596+ \sSystem{\sProcesses}
597+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{unknown} \; \sRef)}
598+ {\sBlacklist}
599+ {\sMonitors}
600+} \textsc{Mon-Unknown}
601+\end{equation*}
602+%
603+\caption{Monitoring}
604+\end{figure}
605+
606+\subsection{Process Termination}
607+
608+The rules for normal and abnormal process termination are defined in
609+Figure~\ref{fig:termination}. When a process crashes it dies
610+silently, unless monitors are setup.
611+
612+\begin{figure}
613+\small
614+%
615+\begin{equation*}
616+\frac{
617+ \sNodeOf(\sPid) = \sNid
618+\qquad
619+ \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
620+}{
621+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
622+ {\sQueue}
623+ {\sBlacklist}
624+ {\sMonitors}
625+\rightarrow
626+ \sSystem{\sProcesses}
627+ {\sQueue}
628+ {\sBlacklist}
629+ {\sMonitors}
630+} \textsc{TermRet}
631+\end{equation*}
632+%
633+\begin{equation*}
634+\frac{
635+ \sNodeOf(\sPid) = \sNid
636+\qquad
637+ \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
638+}{
639+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
640+ {\sQueue}
641+ {\sBlacklist}
642+ {\sMonitors}
643+\rightarrow
644+ \sSystem{\sProcesses}
645+ {\sQueue}
646+ {\sBlacklist}
647+ {\sMonitors}
648+} \textsc{TermThrow}
649+\end{equation*}
650+%
651+\caption{\label{fig:termination}Process Termination}
652+\end{figure}
653+
654+\section{Open Issues}
655+
656+\subsection{Ordering of Monitor/Link Notifications}
657+
658+The semantics as described above, like the original Unified semantics, does not
659+guarantee that messages send from process $P$ to process $Q$ (\textsc{Send})
660+are ordered with respect to the link or monitor notification sent when process
661+$P$ terminates normally or abnormally (\textsc{Mon-Ret}, \textsc{Mon-Throw}). This means that if process $P$ does
662+
663+\begin{lstlisting}
664+receiveWait [
665+ match $ \(Reply reply) -> ...
666+ , match $ \(ProcessMonitorNotification ..) -> ...
667+ ]
668+\end{lstlisting}
669+
670+and process $Q$ does
671+
672+\begin{lstlisting}
673+send pidA (Reply reply)
674+// terminate or indeed throw an exception
675+\end{lstlisting}
676+
677+then the semantics does not guarantee that the reply from process $Q$ will
678+arrive at process $P$ before the monitor notification; hence, this results in
679+an (artificial) race condition in process $P$.
680+
681+One possible solution is to regard such a link notification as a message from
682+process $Q$ to process $P$, which should be ordered along with the other
683+messages.
684+
685+\subsection{Ordering and Typed Channels}
686+
687+The situation is more tricky still than sketched above because we of typed
688+channels. The semantics does not provide ordering guarantees between messages
689+sent directly to the process and messages sent on typed channels. That means
690+that even if we consider a link or monitor notification as a message sent to
691+the process, to be ordered with other messages sent to that process, it is
692+still unordered with respect to messages sent on typed channels. This means
693+that we have similar race conditions\footnote{Even ignoring the fact that we
694+currently don't even provide a way to wait for a message on a typed channel
695+\emph{or} a direct message.}
696+
697+A possible solution is to insist that \emph{all} messages from process $P$ to
698+process $Q$ are ordered, no matter how they are sent. From a implementation
699+point of view, this would entail the use of a single ordered network connection
700+for all messages from $P$ to $Q$, rather than using an ordered connection per
701+typed channel plus one for direct messages.
702+
703+\bibliographystyle{apalike}
704+\bibliography{references}
705+
706+\end{document}
doc/semantics/Makefilenew file+11
@@ -0,0 +1,11 @@
1+CloudHaskellSemantics.pdf: *.tex *.bib
2+ pdflatex CloudHaskellSemantics
3+ bibtex CloudHaskellSemantics
4+ pdflatex CloudHaskellSemantics
5+ pdflatex CloudHaskellSemantics
6+
7+.PHONY: clean
8+clean:
9+ rm -f *.aux *.bbl *.blg *.log
10+
11+# vi:set noexpandtab:
doc/semantics/references.bibnew file+72
@@ -0,0 +1,72 @@
1+@inproceedings{cloudhaskell,
2+ author = {Epstein, Jeff and Black, Andrew P. and Peyton-Jones, Simon},
3+ title = {Towards {H}askell in the cloud},
4+ booktitle = {Proceedings of the 4th ACM symposium on Haskell},
5+ series = {Haskell '11},
6+ year = {2011},
7+ isbn = {978-1-4503-0860-1},
8+ location = {Tokyo, Japan},
9+ pages = {118--129},
10+ numpages = {12},
11+ url = {http://doi.acm.org/10.1145/2034675.2034690},
12+ doi = {10.1145/2034675.2034690},
13+ acmid = {2034690},
14+ publisher = {ACM},
15+ address = {New York, NY, USA},
16+ keywords = {erlang, haskell, message-passing},
17+}
18+
19+@inproceedings{unified,
20+ author = {Svensson, Hans and Fredlund, Lars-{\AA}ke and Benac Earle, Clara},
21+ title = {A unified semantics for future {E}rlang},
22+ booktitle = {Proceedings of the 9th ACM SIGPLAN workshop on Erlang},
23+ series = {Erlang '10},
24+ year = {2010},
25+ isbn = {978-1-4503-0253-1},
26+ location = {Baltimore, Maryland, USA},
27+ pages = {23--32},
28+ numpages = {10},
29+ url = {http://doi.acm.org/10.1145/1863509.1863514},
30+ doi = {10.1145/1863509.1863514},
31+ acmid = {1863514},
32+ publisher = {ACM},
33+ address = {New York, NY, USA},
34+ keywords = {erlang, semantics},
35+}
36+
37+@article{stm,
38+ author = {Harris, Tim and Marlow, Simon and Jones, Simon Peyton and Herlihy, Maurice},
39+ title = {Composable memory transactions},
40+ journal = {Commun. ACM},
41+ issue_date = {August 2008},
42+ volume = {51},
43+ number = {8},
44+ month = aug,
45+ year = {2008},
46+ issn = {0001-0782},
47+ pages = {91--100},
48+ numpages = {10},
49+ url = {http://doi.acm.org/10.1145/1378704.1378725},
50+ doi = {10.1145/1378704.1378725},
51+ acmid = {1378725},
52+ publisher = {ACM},
53+ address = {New York, NY, USA},
54+}
55+
56+@inproceedings{erlang,
57+ author = {Svensson, Hans and Fredlund, Lars-\AAke},
58+ title = {A more accurate semantics for distributed erlang},
59+ booktitle = {Proceedings of the 2007 SIGPLAN workshop on ERLANG Workshop},
60+ series = {ERLANG '07},
61+ year = {2007},
62+ isbn = {978-1-59593-675-2},
63+ location = {Freiburg, Germany},
64+ pages = {43--54},
65+ numpages = {12},
66+ url = {http://doi.acm.org/10.1145/1292520.1292528},
67+ doi = {10.1145/1292520.1292528},
68+ acmid = {1292528},
69+ publisher = {ACM},
70+ address = {New York, NY, USA},
71+ keywords = {distributed systems, erlang, model checking, semantics, verification},
72+}
doc/tutorial/tutorial-client.hsdeleted−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
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-tcp/ChangeLogdeleted−12
@@ -1,12 +0,0 @@
1−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2
2−
3−* Base 4.6 compatibility
4−* Relax package contraints on bytestring and containers
5−
6−2012-07-12 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
7−
8−* Fix bug in recvExact
9−
10−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
11−
12−* 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−59
@@ -1,59 +0,0 @@
1−Name: network-transport-tcp
2−Version: 0.2.0.2
3−Cabal-Version: >=1.8
4−Build-Type: Simple
5−License: BSD3
6−License-file: LICENSE
7−Copyright: Well-Typed LLP
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10−Stability: experimental
11−Homepage: http://github.com/haskell-distributed/distributed-process
12−Bug-Reports: mailto:edsko@well-typed.com
13−Synopsis: 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.6,
28− bytestring >= 0.9 && < 0.11,
29− network >= 2.3 && < 2.4
30− Exposed-modules: Network.Transport.TCP,
31− Network.Transport.TCP.Internal
32− Extensions: CPP
33− ghc-options: -Wall -fno-warn-unused-do-bind
34− HS-Source-Dirs: src
35−
36−Test-Suite TestTCP
37− Type: exitcode-stdio-1.0
38− Main-Is: TestTCP.hs
39− Build-Depends: base >= 4.3 && < 5,
40− network-transport >= 0.2 && < 0.3,
41− data-accessor >= 0.2 && < 0.3,
42− containers >= 0.4 && < 0.6,
43− bytestring >= 0.9 && < 0.11,
44− network >= 2.3 && < 2.4,
45− random >= 1.0 && < 1.1,
46− ansi-terminal >= 0.5 && < 0.6,
47− mtl >= 2.0 && < 2.2
48− Other-modules: TestAuxiliary,
49− TestTransport,
50− Traced
51− ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
52− Extensions: ExistentialQuantification,
53− FlexibleInstances,
54− DeriveDataTypeable,
55− RankNTypes,
56− OverlappingInstances,
57− OverloadedStrings,
58− CPP
59− HS-Source-Dirs: tests src
network-transport-tcp/src/Network/Transport/TCP.hsdeleted−1655
@@ -1,1655 +0,0 @@
1−-- | TCP implementation of the transport layer.
2−--
3−-- The TCP implementation guarantees that only a single TCP connection (socket)
4−-- will be used between endpoints, provided that the addresses specified are
5−-- canonical. If /A/ connects to /B/ and reports its address as
6−-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as
7−-- @client1.local:http-alt@ then the transport layer will not realize that the
8−-- TCP connection can be reused.
9−--
10−-- Applications that use the TCP transport should use
11−-- 'Network.Socket.withSocketsDo' in their main function for Windows
12−-- compatibility (see "Network.Socket").
13−module Network.Transport.TCP ( -- * Main API
14− createTransport
15− , TCPParameters(..)
16− , defaultTCPParameters
17− -- * Internals (exposed for unit tests)
18− , createTransportExposeInternals
19− , TransportInternals(..)
20− , EndPointId
21− , encodeEndPointAddress
22− , decodeEndPointAddress
23− , ControlHeader(..)
24− , ConnectionRequestResponse(..)
25− , firstNonReservedConnectionId
26− , socketToEndPoint
27− -- * Design notes
28− -- $design
29− ) where
30−
31−import Prelude hiding
32− ( mapM_
33−#if ! MIN_VERSION_base(4,6,0)
34− , catch
35−#endif
36− )
37−
38−import Network.Transport
39−import Network.Transport.TCP.Internal ( forkServer
40− , recvWithLength
41− , recvInt32
42− , tryCloseSocket
43− )
44−import Network.Transport.Internal ( encodeInt32
45− , decodeInt32
46− , prependLength
47− , mapIOException
48− , tryIO
49− , tryToEnum
50− , void
51− , timeoutMaybe
52− , asyncWhenCancelled
53− )
54−import qualified Network.Socket as N ( HostName
55− , ServiceName
56− , Socket
57− , getAddrInfo
58− , socket
59− , addrFamily
60− , addrAddress
61− , SocketType(Stream)
62− , defaultProtocol
63− , setSocketOption
64− , SocketOption(ReuseAddr)
65− , connect
66− , sOMAXCONN
67− , AddrInfo
68− )
69−import Network.Socket.ByteString (sendMany)
70−import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
71−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
72−import Control.Concurrent.MVar ( MVar
73− , newMVar
74− , modifyMVar
75− , modifyMVar_
76− , readMVar
77− , takeMVar
78− , putMVar
79− , newEmptyMVar
80− , withMVar
81− )
82−import Control.Category ((>>>))
83−import Control.Applicative ((<$>))
84−import Control.Monad (when, unless)
85−import Control.Exception ( IOException
86− , SomeException
87− , AsyncException
88− , handle
89− , throw
90− , throwIO
91− , try
92− , bracketOnError
93− , mask
94− , onException
95− , fromException
96− )
97−import Data.IORef (IORef, newIORef, writeIORef, readIORef)
98−import Data.ByteString (ByteString)
99−import qualified Data.ByteString as BS (concat)
100−import qualified Data.ByteString.Char8 as BSC (pack, unpack, split)
101−import Data.Int (Int32)
102−import Data.IntMap (IntMap)
103−import qualified Data.IntMap as IntMap (empty)
104−import Data.IntSet (IntSet)
105−import qualified Data.IntSet as IntSet ( empty
106− , insert
107− , elems
108− , singleton
109− , null
110− , delete
111− , member
112− )
113−import Data.Map (Map)
114−import qualified Data.Map as Map (empty)
115−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
116−import qualified Data.Accessor.Container as DAC (mapMaybe, intMapMaybe)
117−import Data.Foldable (forM_, mapM_)
118−
119−-- $design
120−--
121−-- [Goals]
122−--
123−-- The TCP transport maps multiple logical connections between /A/ and /B/ (in
124−-- either direction) to a single TCP connection:
125−--
126−-- > +-------+ +-------+
127−-- > | A |==========================| B |
128−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
129−-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q |
130−-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
131−-- > | |==========================| |
132−-- > +-------+ +-------+
133−--
134−-- Ignoring the complications detailed below, the TCP connection is set up is
135−-- when the first lightweight connection is created (in either direction), and
136−-- torn down when the last lightweight connection (in either direction) is
137−-- closed.
138−--
139−-- [Connecting]
140−--
141−-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to
142−-- connect to /B/, it locally records that it is trying to connect to /B/ and
143−-- sends a request to /B/. As part of the request /A/ sends its own endpoint
144−-- address to /B/ (so that /B/ can reuse the connection in the other direction).
145−--
146−-- When /B/ receives the connection request it first checks if it did not
147−-- already initiate a connection request to /A/. If not it will acknowledge the
148−-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record
149−-- that it has a TCP connection to /A/.
150−--
151−-- The tricky case arises when /A/ sends a connection request to /B/ and /B/
152−-- finds that it had already sent a connection request to /A/. In this case /B/
153−-- will accept the connection request from /A/ if /A/s endpoint address is
154−-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects
155−-- it, it sends a 'ConnectionRequestCrossed' message to /A/. (The
156−-- lexicographical ordering is an arbitrary but convenient way to break the
157−-- tie.)
158−--
159−-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that
160−-- initiated the request just needs to wait until the /A/ thread that is dealing
161−-- with /B/'s connection request completes.
162−--
163−-- [Disconnecting]
164−--
165−-- The TCP connection is created as soon as the first logical connection from
166−-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
167−-- spawned that listens for incoming connections from /B/:
168−--
169−-- > +-------+ +-------+
170−-- > | A |==========================| B |
171−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
172−-- > | | | Q |
173−-- > | #| | |
174−-- > | |==========================| |
175−-- > +-------+ +-------+
176−--
177−-- The question is when the TCP connection can be closed again. Conceptually,
178−-- we want to do reference counting: when there are no logical connections left
179−-- between /A/ and /B/ we want to close the socket (possibly after some
180−-- timeout).
181−--
182−-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
183−-- might happen that /B/ sends a connection request over the existing socket at
184−-- the same time that /A/ closes its logical connection to /B/ and closes the
185−-- socket. This will cause a failure in /B/ (which will have to retry) which is
186−-- not caused by a network failure, which is unfortunate. (Note that the
187−-- connection request from /B/ might succeed even if /A/ closes the socket.)
188−--
189−-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
190−-- request to /B/ and records that its connection to /B/ is closing. If /A/
191−-- receives a new connection request from /B/ after having sent the
192−-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
193−-- and increments the reference count of the connection again.
194−--
195−-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
196−-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
197−-- and then actually close the socket. /A/ meanwhile will not send any more
198−-- requests to /B/ after having sent a 'CloseSocket' request, and will actually
199−-- close its end of the socket only when receiving the 'CloseSocket' message
200−-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
201−-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
202−-- reciprocal 'CloseSocket' message.)
203−--
204−-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
205−-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
206−-- whether to reuse the old socket (if /B/ sends a new connection request
207−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
208−
209−--------------------------------------------------------------------------------
210−-- Internal datatypes --
211−--------------------------------------------------------------------------------
212−
213−-- We use underscores for fields that we might update (using accessors)
214−--
215−-- All data types follow the same structure:
216−--
217−-- * A top-level data type describing static properties (TCPTransport,
218−-- LocalEndPoint, RemoteEndPoint)
219−-- * The 'static' properties include an MVar containing a data structure for
220−-- the dynamic properties (TransportState, LocalEndPointState,
221−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
222−-- * For the case of "valid" we use third data structure to give more details
223−-- about the state (ValidTransportState, ValidLocalEndPointState,
224−-- ValidRemoteEndPointState).
225−
226−data TCPTransport = TCPTransport
227− { transportHost :: N.HostName
228− , transportPort :: N.ServiceName
229− , transportState :: MVar TransportState
230− , transportParams :: TCPParameters
231− }
232−
233−data TransportState =
234− TransportValid ValidTransportState
235− | TransportClosed
236−
237−data ValidTransportState = ValidTransportState
238− { _localEndPoints :: Map EndPointAddress LocalEndPoint
239− , _nextEndPointId :: EndPointId
240− }
241−
242−data LocalEndPoint = LocalEndPoint
243− { localAddress :: EndPointAddress
244− , localChannel :: Chan Event
245− , localState :: MVar LocalEndPointState
246− }
247−
248−data LocalEndPointState =
249− LocalEndPointValid ValidLocalEndPointState
250− | LocalEndPointClosed
251−
252−data ValidLocalEndPointState = ValidLocalEndPointState
253− { _nextConnectionId :: !ConnectionId
254− , _localConnections :: Map EndPointAddress RemoteEndPoint
255− , _nextRemoteId :: !Int
256− }
257−
258−-- REMOTE ENDPOINTS
259−--
260−-- Remote endpoints (basically, TCP connections) have the following lifecycle:
261−--
262−-- Init ---+---> Invalid
263−-- |
264−-- +-------------------------------\
265−-- | |
266−-- | /----------\ |
267−-- | | | |
268−-- | v | v
269−-- +---> Valid ---> Closing ---> Closed
270−-- | | | |
271−-- | | | v
272−-- \-------+----------+--------> Failed
273−--
274−-- Init: There are two places where we create new remote endpoints: in
275−-- requestConnectionTo (in response to an API 'connect' call) and in
276−-- handleConnectionRequest (when a remote node tries to connect to us).
277−-- 'Init' carries an MVar () 'resolved' which concurrent threads can use to
278−-- wait for the remote endpoint to finish initialization. We record who
279−-- requested the connection (the local endpoint or the remote endpoint).
280−--
281−-- Invalid: We put the remote endpoint in invalid state only during
282−-- requestConnectionTo when we fail to connect.
283−--
284−-- Valid: This is the "normal" state for a working remote endpoint.
285−--
286−-- Closing: When we detect that a remote endpoint is no longer used, we send a
287−-- CloseSocket request across the connection and put the remote endpoint in
288−-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which
289−-- concurrent threads can use to wait for the remote endpoint to either be
290−-- closed fully (if the communication parnet responds with another
291−-- CloseSocket) or be put back in 'Valid' state if the remote endpoint denies
292−-- the request.
293−--
294−-- We also put the endpoint in Closed state, directly from Init, if we our
295−-- outbound connection request crossed an inbound connection request and we
296−-- decide to keep the inbound (i.e., the remote endpoint sent us a
297−-- ConnectionRequestCrossed message).
298−--
299−-- Closed: The endpoint is put in Closed state after a successful garbage
300−-- collection.
301−--
302−-- Failed: If the connection to the remote endpoint is lost, or the local
303−-- endpoint (or the whole transport) is closed manually, the remote endpoint is
304−-- put in Failed state, and we record the reason.
305−--
306−-- Invariants for dealing with remote endpoints:
307−--
308−-- INV-SEND: Whenever we send data the remote endpoint must be locked (to avoid
309−-- interleaving bits of payload).
310−--
311−-- INV-CLOSE: Local endpoints should never point to remote endpoint in closed
312−-- state. Whenever we put an endpoint in Closed state we remove that
313−-- endpoint from localConnections first, so that if a concurrent thread reads
314−-- the MVar, finds RemoteEndPointClosed, and then looks up the endpoint in
315−-- localConnections it is guaranteed to either find a different remote
316−-- endpoint, or else none at all (if we don't insist in this order some
317−-- threads might start spinning).
318−--
319−-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is
320−-- locked, and the remote endpoint must be in Valid or Closed state once
321−-- unlocked. This guarantees that there will not be two threads attempting to
322−-- both signal on 'resolved'.
323−--
324−-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we
325−-- first put the remote endpoint in Closed state, and then send a
326−-- EventConnectionLost event. This guarantees that we only send this event
327−-- once.
328−--
329−-- INV-CLOSING: An endpoint in closing state is for all intents and purposes
330−-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
331−-- acceptable, of course -- as we are waiting for the remote endpoint to
332−-- confirm or deny the request).
333−--
334−-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints.
335−-- In other words: it is okay to call modifyMVar on a local endpoint inside a
336−-- modifyMVar on a remote endpoint, but not the other way around. In
337−-- particular, it is okay to call removeRemoteEndPoint inside
338−-- modifyRemoteState.
339−
340−data RemoteEndPoint = RemoteEndPoint
341− { remoteAddress :: EndPointAddress
342− , remoteState :: MVar RemoteState
343− , remoteId :: Int
344− }
345−
346−data RequestedBy = RequestedByUs | RequestedByThem
347− deriving (Eq, Show)
348−
349−data RemoteState =
350− -- | Invalid remote endpoint (for example, invalid address)
351− RemoteEndPointInvalid (TransportError ConnectErrorCode)
352− -- | The remote endpoint is being initialized
353− | RemoteEndPointInit (MVar ()) RequestedBy
354− -- | "Normal" working endpoint
355− | RemoteEndPointValid ValidRemoteEndPointState
356− -- | The remote endpoint is being closed (garbage collected)
357− | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
358− -- | The remote endpoint has been closed (garbage collected)
359− | RemoteEndPointClosed
360− -- | The remote endpoint has failed, or has been forcefully shutdown
361− -- using a closeTransport or closeEndPoint API call
362− | RemoteEndPointFailed IOException
363−
364−data ValidRemoteEndPointState = ValidRemoteEndPointState
365− { _remoteOutgoing :: !Int
366− , _remoteIncoming :: IntSet
367− , remoteSocket :: N.Socket
368− , sendOn :: [ByteString] -> IO ()
369− , _pendingCtrlRequests :: IntMap (MVar (Either IOException [ByteString]))
370− , _nextCtrlRequestId :: !ControlRequestId
371− }
372−
373−-- | Local identifier for an endpoint within this transport
374−type EndPointId = Int32
375−
376−-- | Control request ID
377−--
378−-- Control requests are asynchronous; the request ID makes it possible to match
379−-- requests and replies
380−type ControlRequestId = Int32
381−
382−-- | Pair of local and a remote endpoint (for conciseness in signatures)
383−type EndPointPair = (LocalEndPoint, RemoteEndPoint)
384−
385−-- | Control headers
386−data ControlHeader =
387− -- | Request a new connection ID from the remote endpoint
388− RequestConnectionId
389− -- | Tell the remote endpoint we will no longer be using a connection
390− | CloseConnection
391− -- | Respond to a control request /from/ the remote endpoint
392− | ControlResponse
393− -- | Request to close the connection (see module description)
394− | CloseSocket
395− deriving (Enum, Bounded, Show)
396−
397−-- | Response sent by /B/ to /A/ when /A/ tries to connect
398−data ConnectionRequestResponse =
399− -- | /B/ accepts the connection
400− ConnectionRequestAccepted
401− -- | /A/ requested an invalid endpoint
402− | ConnectionRequestInvalid
403− -- | /A/s request crossed with a request from /B/ (see protocols)
404− | ConnectionRequestCrossed
405− deriving (Enum, Bounded, Show)
406−
407−-- | Parameters for setting up the TCP transport
408−data TCPParameters = TCPParameters {
409− -- | Backlog for 'listen'.
410− -- Defaults to SOMAXCONN.
411− tcpBacklog :: Int
412− -- | Should we set SO_REUSEADDR on the server socket?
413− -- Defaults to True.
414− , tcpReuseServerAddr :: Bool
415− -- | Should we set SO_REUSEADDR on client sockets?
416− -- Defaults to True.
417− , tcpReuseClientAddr :: Bool
418− }
419−
420−-- | Internal functionality we expose for unit testing
421−data TransportInternals = TransportInternals
422− { -- | The ID of the thread that listens for new incoming connections
423− transportThread :: ThreadId
424− -- | Find the socket between a local and a remote endpoint
425− , socketBetween :: EndPointAddress
426− -> EndPointAddress
427− -> IO N.Socket
428− }
429−
430−--------------------------------------------------------------------------------
431−-- Top-level functionality --
432−--------------------------------------------------------------------------------
433−
434−-- | Create a TCP transport
435−createTransport :: N.HostName
436− -> N.ServiceName
437− -> TCPParameters
438− -> IO (Either IOException Transport)
439−createTransport host port params =
440− either Left (Right . fst) <$> createTransportExposeInternals host port params
441−
442−-- | You should probably not use this function (used for unit testing only)
443−createTransportExposeInternals
444− :: N.HostName
445− -> N.ServiceName
446− -> TCPParameters
447− -> IO (Either IOException (Transport, TransportInternals))
448−createTransportExposeInternals host port params = do
449− state <- newMVar . TransportValid $ ValidTransportState
450− { _localEndPoints = Map.empty
451− , _nextEndPointId = 0
452− }
453− let transport = TCPTransport { transportState = state
454− , transportHost = host
455− , transportPort = port
456− , transportParams = params
457− }
458− tryIO $ bracketOnError (forkServer
459− host
460− port
461− (tcpBacklog params)
462− (tcpReuseServerAddr params)
463− (terminationHandler transport)
464− (handleConnectionRequest transport))
465− killThread
466− (mkTransport transport)
467− where
468− mkTransport :: TCPTransport
469− -> ThreadId
470− -> IO (Transport, TransportInternals)
471− mkTransport transport tid = return
472− ( Transport
473− { newEndPoint = apiNewEndPoint transport
474− , closeTransport = let evs = [ EndPointClosed
475− , throw $ userError "Transport closed"
476− ] in
477− apiCloseTransport transport (Just tid) evs
478− }
479− , TransportInternals
480− { transportThread = tid
481− , socketBetween = internalSocketBetween transport
482− }
483− )
484−
485− terminationHandler :: TCPTransport -> SomeException -> IO ()
486− terminationHandler transport ex = do
487− let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))
488− , throw $ userError "Transport closed"
489− ]
490− apiCloseTransport transport Nothing evs
491−
492−-- | Default TCP parameters
493−defaultTCPParameters :: TCPParameters
494−defaultTCPParameters = TCPParameters {
495− tcpBacklog = N.sOMAXCONN
496− , tcpReuseServerAddr = True
497− , tcpReuseClientAddr = True
498− }
499−
500−--------------------------------------------------------------------------------
501−-- API functions --
502−--------------------------------------------------------------------------------
503−
504−-- | Close the transport
505−apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()
506−apiCloseTransport transport mTransportThread evs =
507− asyncWhenCancelled return $ do
508− mTSt <- modifyMVar (transportState transport) $ \st -> case st of
509− TransportValid vst -> return (TransportClosed, Just vst)
510− TransportClosed -> return (TransportClosed, Nothing)
511− forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
512− -- This will invoke the termination handler, which in turn will call
513− -- apiCloseTransport again, but then the transport will already be closed
514− -- and we won't be passed a transport thread, so we terminate immmediate
515− forM_ mTransportThread killThread
516−
517−-- | Create a new endpoint
518−apiNewEndPoint :: TCPTransport
519− -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
520−apiNewEndPoint transport =
521− try . asyncWhenCancelled closeEndPoint $ do
522− ourEndPoint <- createLocalEndPoint transport
523− return EndPoint
524− { receive = readChan (localChannel ourEndPoint)
525− , address = localAddress ourEndPoint
526− , connect = apiConnect (transportParams transport) ourEndPoint
527− , closeEndPoint = let evs = [ EndPointClosed
528− , throw $ userError "Endpoint closed"
529− ] in
530− apiCloseEndPoint transport evs ourEndPoint
531− , newMulticastGroup = return . Left $ newMulticastGroupError
532− , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
533− }
534− where
535− newMulticastGroupError =
536− TransportError NewMulticastGroupUnsupported "Multicast not supported"
537− resolveMulticastGroupError =
538− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
539−
540−-- | Connnect to an endpoint
541−apiConnect :: TCPParameters -- ^ Parameters
542− -> LocalEndPoint -- ^ Local end point
543− -> EndPointAddress -- ^ Remote address
544− -> Reliability -- ^ Reliability (ignored)
545− -> ConnectHints -- ^ Hints
546− -> IO (Either (TransportError ConnectErrorCode) Connection)
547−apiConnect params ourEndPoint theirAddress _reliability hints =
548− try . asyncWhenCancelled close $
549− if localAddress ourEndPoint == theirAddress
550− then connectToSelf ourEndPoint
551− else do
552− resetIfBroken ourEndPoint theirAddress
553− (theirEndPoint, connId) <-
554− requestConnectionTo params ourEndPoint theirAddress hints
555− -- connAlive can be an IORef rather than an MVar because it is protected
556− -- by the remoteState MVar. We don't need the overhead of locking twice.
557− connAlive <- newIORef True
558− return Connection
559− { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
560− , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
561− }
562−
563−-- | Close a connection
564−apiClose :: EndPointPair -> ConnectionId -> IORef Bool -> IO ()
565−apiClose (ourEndPoint, theirEndPoint) connId connAlive =
566− void . tryIO . asyncWhenCancelled return $ do
567− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
568− { caseValid = \vst -> do
569− alive <- readIORef connAlive
570− if alive
571− then do
572− writeIORef connAlive False
573− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
574− return ( RemoteEndPointValid
575− . (remoteOutgoing ^: (\x -> x - 1))
576− $ vst
577− )
578− else
579− return (RemoteEndPointValid vst)
580− }
581− closeIfUnused (ourEndPoint, theirEndPoint)
582−
583−-- | Send data across a connection
584−apiSend :: EndPointPair -- ^ Local and remote endpoint
585− -> ConnectionId -- ^ Connection ID (supplied by remote endpoint)
586− -> IORef Bool -- ^ Is the connection still alive?
587− -> [ByteString] -- ^ Payload
588− -> IO (Either (TransportError SendErrorCode) ())
589−apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
590− -- We don't need the overhead of asyncWhenCancelled here
591− try . mapIOException sendFailed $
592− withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
593− { caseInvalid = \_ ->
594− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
595− , caseInit = \_ _ ->
596− relyViolation (ourEndPoint, theirEndPoint) "apiSend"
597− , caseValid = \vst -> do
598− alive <- readIORef connAlive
599− if alive
600− then sendOn vst (encodeInt32 connId : prependLength payload)
601− else throwIO $ TransportError SendClosed "Connection closed"
602− , caseClosing = \_ _ -> do
603− alive <- readIORef connAlive
604− if alive
605− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
606− else throwIO $ TransportError SendClosed "Connection closed"
607− , caseClosed = do
608− alive <- readIORef connAlive
609− if alive
610− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
611− else throwIO $ TransportError SendClosed "Connection closed"
612− , caseFailed = \err -> do
613− alive <- readIORef connAlive
614− if alive
615− then throwIO $ TransportError SendFailed (show err)
616− else throwIO $ TransportError SendClosed "Connection closed"
617− }
618− where
619− sendFailed = TransportError SendFailed . show
620−
621−-- | Force-close the endpoint
622−apiCloseEndPoint :: TCPTransport -- ^ Transport
623− -> [Event] -- ^ Events used to report closure
624− -> LocalEndPoint -- ^ Local endpoint
625− -> IO ()
626−apiCloseEndPoint transport evs ourEndPoint =
627− asyncWhenCancelled return $ do
628− -- Remove the reference from the transport state
629− removeLocalEndPoint transport ourEndPoint
630− -- Close the local endpoint
631− mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
632− case st of
633− LocalEndPointValid vst ->
634− return (LocalEndPointClosed, Just vst)
635− LocalEndPointClosed ->
636− return (LocalEndPointClosed, Nothing)
637− forM_ mOurState $ \vst -> do
638− forM_ (vst ^. localConnections) tryCloseRemoteSocket
639− forM_ evs $ writeChan (localChannel ourEndPoint)
640− where
641− -- Close the remote socket and return the set of all incoming connections
642− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
643− tryCloseRemoteSocket theirEndPoint = do
644− -- We make an attempt to close the connection nicely
645− -- (by sending a CloseSocket first)
646− let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"
647− modifyMVar_ (remoteState theirEndPoint) $ \st ->
648− case st of
649− RemoteEndPointInvalid _ ->
650− return st
651− RemoteEndPointInit resolved _ -> do
652− putMVar resolved ()
653− return closed
654− RemoteEndPointValid conn -> do
655− tryIO $ sendOn conn [encodeInt32 CloseSocket]
656− tryCloseSocket (remoteSocket conn)
657− return closed
658− RemoteEndPointClosing resolved conn -> do
659− putMVar resolved ()
660− tryCloseSocket (remoteSocket conn)
661− return closed
662− RemoteEndPointClosed ->
663− return st
664− RemoteEndPointFailed err ->
665− return $ RemoteEndPointFailed err
666−
667−--------------------------------------------------------------------------------
668−-- As soon as a remote connection fails, we want to put notify our endpoint --
669−-- and put it into a closed state. Since this may happen in many places, we --
670−-- provide some abstractions. --
671−--------------------------------------------------------------------------------
672−
673−data RemoteStatePatternMatch a = RemoteStatePatternMatch
674− { caseInvalid :: TransportError ConnectErrorCode -> IO a
675− , caseInit :: MVar () -> RequestedBy -> IO a
676− , caseValid :: ValidRemoteEndPointState -> IO a
677− , caseClosing :: MVar () -> ValidRemoteEndPointState -> IO a
678− , caseClosed :: IO a
679− , caseFailed :: IOException -> IO a
680− }
681−
682−remoteStateIdentity :: RemoteStatePatternMatch RemoteState
683−remoteStateIdentity =
684− RemoteStatePatternMatch
685− { caseInvalid = return . RemoteEndPointInvalid
686− , caseInit = (return .) . RemoteEndPointInit
687− , caseValid = return . RemoteEndPointValid
688− , caseClosing = (return .) . RemoteEndPointClosing
689− , caseClosed = return RemoteEndPointClosed
690− , caseFailed = return . RemoteEndPointFailed
691− }
692−
693−-- | Like modifyMVar, but if an I/O exception occurs don't restore the remote
694−-- endpoint to its original value but close it instead
695−modifyRemoteState :: EndPointPair
696− -> RemoteStatePatternMatch (RemoteState, a)
697− -> IO a
698−modifyRemoteState (ourEndPoint, theirEndPoint) match =
699− mask $ \restore -> do
700− st <- takeMVar theirState
701− case st of
702− RemoteEndPointValid vst -> do
703− mResult <- try $ restore (caseValid match vst)
704− case mResult of
705− Right (st', a) -> do
706− putMVar theirState st'
707− return a
708− Left ex -> do
709− case fromException ex of
710− Just ioEx -> handleIOException ioEx vst
711− Nothing -> putMVar theirState st
712− throwIO ex
713− -- The other cases are less interesting, because unless the endpoint is
714− -- in Valid state we're not supposed to do any IO on it
715− RemoteEndPointInit resolved origin -> do
716− (st', a) <- onException (restore $ caseInit match resolved origin)
717− (putMVar theirState st)
718− putMVar theirState st'
719− return a
720− RemoteEndPointClosing resolved vst -> do
721− (st', a) <- onException (restore $ caseClosing match resolved vst)
722− (putMVar theirState st)
723− putMVar theirState st'
724− return a
725− RemoteEndPointInvalid err -> do
726− (st', a) <- onException (restore $ caseInvalid match err)
727− (putMVar theirState st)
728− putMVar theirState st'
729− return a
730− RemoteEndPointClosed -> do
731− (st', a) <- onException (restore $ caseClosed match)
732− (putMVar theirState st)
733− putMVar theirState st'
734− return a
735− RemoteEndPointFailed err -> do
736− (st', a) <- onException (restore $ caseFailed match err)
737− (putMVar theirState st)
738− putMVar theirState st'
739− return a
740− where
741− theirState :: MVar RemoteState
742− theirState = remoteState theirEndPoint
743−
744− handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()
745− handleIOException ex vst = do
746− tryCloseSocket (remoteSocket vst)
747− putMVar theirState (RemoteEndPointFailed ex)
748− let incoming = IntSet.elems $ vst ^. remoteIncoming
749− code = EventConnectionLost (Just $ remoteAddress theirEndPoint) incoming
750− err = TransportError code (show ex)
751− writeChan (localChannel ourEndPoint) $ ErrorEvent err
752−
753−-- | Like 'modifyRemoteState' but without a return value
754−modifyRemoteState_ :: EndPointPair
755− -> RemoteStatePatternMatch RemoteState
756− -> IO ()
757−modifyRemoteState_ (ourEndPoint, theirEndPoint) match =
758− modifyRemoteState (ourEndPoint, theirEndPoint)
759− RemoteStatePatternMatch
760− { caseInvalid = u . caseInvalid match
761− , caseInit = \resolved origin -> u $ caseInit match resolved origin
762− , caseValid = u . caseValid match
763− , caseClosing = \resolved vst -> u $ caseClosing match resolved vst
764− , caseClosed = u $ caseClosed match
765− , caseFailed = u . caseFailed match
766− }
767− where
768− u :: IO a -> IO (a, ())
769− u p = p >>= \a -> return (a, ())
770−
771−-- | Like 'modifyRemoteState' but without the ability to change the state
772−withRemoteState :: EndPointPair
773− -> RemoteStatePatternMatch a
774− -> IO a
775−withRemoteState (ourEndPoint, theirEndPoint) match =
776− modifyRemoteState (ourEndPoint, theirEndPoint)
777− RemoteStatePatternMatch
778− { caseInvalid = \err -> do
779− a <- caseInvalid match err
780− return (RemoteEndPointInvalid err, a)
781− , caseInit = \resolved origin -> do
782− a <- caseInit match resolved origin
783− return (RemoteEndPointInit resolved origin, a)
784− , caseValid = \vst -> do
785− a <- caseValid match vst
786− return (RemoteEndPointValid vst, a)
787− , caseClosing = \resolved vst -> do
788− a <- caseClosing match resolved vst
789− return (RemoteEndPointClosing resolved vst, a)
790− , caseClosed = do
791− a <- caseClosed match
792− return (RemoteEndPointClosed, a)
793− , caseFailed = \err -> do
794− a <- caseFailed match err
795− return (RemoteEndPointFailed err, a)
796− }
797−
798−--------------------------------------------------------------------------------
799−-- Incoming requests --
800−--------------------------------------------------------------------------------
801−
802−-- | Handle a connection request (that is, a remote endpoint that is trying to
803−-- establish a TCP connection with us)
804−--
805−-- 'handleConnectionRequest' runs in the context of the transport thread, which
806−-- can be killed asynchronously by 'closeTransport'. We fork a separate thread
807−-- as soon as we have located the lcoal endpoint that the remote endpoint is
808−-- interested in. We cannot fork any sooner because then we have no way of
809−-- storing the thread ID and hence no way of killing the thread when we take
810−-- the transport down. We must be careful to close the socket when a (possibly
811−-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
812−-- handleConnectionRequest the transport will be shut down.)
813−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
814−handleConnectionRequest transport sock = handle handleException $ do
815− ourEndPointId <- recvInt32 sock
816− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
817− let ourAddress = encodeEndPointAddress (transportHost transport)
818− (transportPort transport)
819− ourEndPointId
820− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
821− TransportValid vst ->
822− case vst ^. localEndPointAt ourAddress of
823− Nothing -> do
824− sendMany sock [encodeInt32 ConnectionRequestInvalid]
825− throwIO $ userError "handleConnectionRequest: Invalid endpoint"
826− Just ourEndPoint ->
827− return ourEndPoint
828− TransportClosed ->
829− throwIO $ userError "Transport closed"
830− void . forkIO $ go ourEndPoint theirAddress
831− where
832− go :: LocalEndPoint -> EndPointAddress -> IO ()
833− go ourEndPoint theirAddress = do
834− -- This runs in a thread that will never be killed
835− mEndPoint <- handle ((>> return Nothing) . handleException) $ do
836− resetIfBroken ourEndPoint theirAddress
837− (theirEndPoint, isNew) <-
838− findRemoteEndPoint ourEndPoint theirAddress RequestedByThem
839−
840− if not isNew
841− then do
842− tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
843− tryCloseSocket sock
844− return Nothing
845− else do
846− let vst = ValidRemoteEndPointState
847− { remoteSocket = sock
848− , _remoteOutgoing = 0
849− , _remoteIncoming = IntSet.empty
850− , sendOn = sendMany sock
851− , _pendingCtrlRequests = IntMap.empty
852− , _nextCtrlRequestId = 0
853− }
854− sendMany sock [encodeInt32 ConnectionRequestAccepted]
855− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
856− return (Just theirEndPoint)
857− -- If we left the scope of the exception handler with a return value of
858− -- Nothing then the socket is already closed; otherwise, the socket has
859− -- been recorded as part of the remote endpoint. Either way, we no longer
860− -- have to worry about closing the socket on receiving an asynchronous
861− -- exception from this point forward.
862− forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
863−
864− handleException :: SomeException -> IO ()
865− handleException ex = do
866− tryCloseSocket sock
867− rethrowIfAsync (fromException ex)
868−
869− rethrowIfAsync :: Maybe AsyncException -> IO ()
870− rethrowIfAsync = mapM_ throwIO
871−
872−-- | Handle requests from a remote endpoint.
873−--
874−-- Returns only if the remote party closes the socket or if an error occurs.
875−-- This runs in a thread that will never be killed.
876−handleIncomingMessages :: EndPointPair -> IO ()
877−handleIncomingMessages (ourEndPoint, theirEndPoint) = do
878− mSock <- withMVar theirState $ \st ->
879− case st of
880− RemoteEndPointInvalid _ ->
881− relyViolation (ourEndPoint, theirEndPoint)
882− "handleIncomingMessages (invalid)"
883− RemoteEndPointInit _ _ ->
884− relyViolation (ourEndPoint, theirEndPoint)
885− "handleIncomingMessages (init)"
886− RemoteEndPointValid ep ->
887− return . Just $ remoteSocket ep
888− RemoteEndPointClosing _ ep ->
889− return . Just $ remoteSocket ep
890− RemoteEndPointClosed ->
891− return Nothing
892− RemoteEndPointFailed _ ->
893− return Nothing
894−
895− forM_ mSock $ \sock ->
896− tryIO (go sock) >>= either (prematureExit sock) return
897− where
898− -- Dispatch
899− --
900− -- If a recv throws an exception this will be caught top-level and
901− -- 'prematureExit' will be invoked. The same will happen if the remote
902− -- endpoint is put into a Closed (or Closing) state by a concurrent thread
903− -- (because a 'send' failed) -- the individual handlers below will throw a
904− -- user exception which is then caught and handled the same way as an
905− -- exception thrown by 'recv'.
906− go :: N.Socket -> IO ()
907− go sock = do
908− connId <- recvInt32 sock
909− if connId >= firstNonReservedConnectionId
910− then do
911− readMessage sock connId
912− go sock
913− else
914− case tryToEnum (fromIntegral connId) of
915− Just RequestConnectionId -> do
916− recvInt32 sock >>= createNewConnection
917− go sock
918− Just ControlResponse -> do
919− recvInt32 sock >>= readControlResponse sock
920− go sock
921− Just CloseConnection -> do
922− recvInt32 sock >>= closeConnection
923− go sock
924− Just CloseSocket -> do
925− didClose <- closeSocket sock
926− unless didClose $ go sock
927− Nothing ->
928− throwIO $ userError "Invalid control request"
929−
930− -- Create a new connection
931− createNewConnection :: ControlRequestId -> IO ()
932− createNewConnection reqId = do
933− newId <- getNextConnectionId ourEndPoint
934− modifyMVar_ theirState $ \st -> do
935− vst <- case st of
936− RemoteEndPointInvalid _ ->
937− relyViolation (ourEndPoint, theirEndPoint)
938− "handleIncomingMessages:createNewConnection (invalid)"
939− RemoteEndPointInit _ _ ->
940− relyViolation (ourEndPoint, theirEndPoint)
941− "handleIncomingMessages:createNewConnection (init)"
942− RemoteEndPointValid vst ->
943− return (remoteIncoming ^: IntSet.insert newId $ vst)
944− RemoteEndPointClosing resolved vst -> do
945− -- If the endpoint is in closing state that means we send a
946− -- CloseSocket request to the remote endpoint. If the remote
947− -- endpoint replies with the request to create a new connection, it
948− -- either ignored our request or it sent the request before it got
949− -- ours. Either way, at this point we simply restore the endpoint
950− -- to RemoteEndPointValid
951− putMVar resolved ()
952− return (remoteIncoming ^= IntSet.singleton newId $ vst)
953− RemoteEndPointFailed err ->
954− throwIO err
955− RemoteEndPointClosed ->
956− relyViolation (ourEndPoint, theirEndPoint)
957− "createNewConnection (closed)"
958− sendOn vst ( encodeInt32 ControlResponse
959− : encodeInt32 reqId
960− : prependLength [encodeInt32 newId]
961− )
962− return (RemoteEndPointValid vst)
963− writeChan ourChannel (ConnectionOpened newId ReliableOrdered theirAddr)
964−
965− -- Read a control response
966− readControlResponse :: N.Socket -> ControlRequestId -> IO ()
967− readControlResponse sock reqId = do
968− response <- recvWithLength sock
969− mmvar <- modifyMVar theirState $ \st -> case st of
970− RemoteEndPointInvalid _ ->
971− relyViolation (ourEndPoint, theirEndPoint)
972− "readControlResponse (invalid)"
973− RemoteEndPointInit _ _ ->
974− relyViolation (ourEndPoint, theirEndPoint)
975− "readControlResponse (init)"
976− RemoteEndPointValid vst ->
977− return ( RemoteEndPointValid
978− . (pendingCtrlRequestsAt reqId ^= Nothing)
979− $ vst
980− , vst ^. pendingCtrlRequestsAt reqId
981− )
982− RemoteEndPointClosing _ _ ->
983− throwIO $ userError "Invalid control response"
984− RemoteEndPointFailed err ->
985− throwIO err
986− RemoteEndPointClosed ->
987− relyViolation (ourEndPoint, theirEndPoint)
988− "readControlResponse (closed)"
989− case mmvar of
990− Nothing ->
991− throwIO $ userError "Invalid request ID"
992− Just mvar ->
993− putMVar mvar (Right response)
994−
995− -- Close a connection
996− -- It is important that we verify that the connection is in fact open,
997− -- because otherwise we should not decrement the reference count
998− closeConnection :: ConnectionId -> IO ()
999− closeConnection cid = do
1000− modifyMVar_ theirState $ \st -> case st of
1001− RemoteEndPointInvalid _ ->
1002− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"
1003− RemoteEndPointInit _ _ ->
1004− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"
1005− RemoteEndPointValid vst -> do
1006− unless (IntSet.member cid (vst ^. remoteIncoming)) $
1007− throwIO $ userError "Invalid CloseConnection"
1008− return ( RemoteEndPointValid
1009− . (remoteIncoming ^: IntSet.delete cid)
1010− $ vst
1011− )
1012− RemoteEndPointClosing _ _ ->
1013− -- If the remote endpoint is in Closing state, that means that are as
1014− -- far as we are concerned there are no incoming connections. This
1015− -- means that a CloseConnection request at this point is invalid.
1016− throwIO $ userError "Invalid CloseConnection request"
1017− RemoteEndPointFailed err ->
1018− throwIO err
1019− RemoteEndPointClosed ->
1020− relyViolation (ourEndPoint, theirEndPoint) "closeConnection (closed)"
1021− writeChan ourChannel (ConnectionClosed cid)
1022− closeIfUnused (ourEndPoint, theirEndPoint)
1023−
1024− -- Close the socket (if we don't have any outgoing connections)
1025− closeSocket :: N.Socket -> IO Bool
1026− closeSocket sock =
1027− modifyMVar theirState $ \st ->
1028− case st of
1029− RemoteEndPointInvalid _ ->
1030− relyViolation (ourEndPoint, theirEndPoint)
1031− "handleIncomingMessages:closeSocket (invalid)"
1032− RemoteEndPointInit _ _ ->
1033− relyViolation (ourEndPoint, theirEndPoint)
1034− "handleIncomingMessages:closeSocket (init)"
1035− RemoteEndPointValid vst -> do
1036− -- We regard a CloseSocket message as an (optimized) way for the
1037− -- remote endpoint to indicate that all its connections to us are
1038− -- now properly closed
1039− forM_ (IntSet.elems $ vst ^. remoteIncoming) $
1040− writeChan ourChannel . ConnectionClosed
1041− let vst' = remoteIncoming ^= IntSet.empty $ vst
1042− -- Check if we agree that the connection should be closed
1043− if vst' ^. remoteOutgoing == 0
1044− then do
1045− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1046− -- Attempt to reply (but don't insist)
1047− tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1048− tryCloseSocket sock
1049− return (RemoteEndPointClosed, True)
1050− else
1051− return (RemoteEndPointValid vst', False)
1052− RemoteEndPointClosing resolved _ -> do
1053− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1054− tryCloseSocket sock
1055− putMVar resolved ()
1056− return (RemoteEndPointClosed, True)
1057− RemoteEndPointFailed err ->
1058− throwIO err
1059− RemoteEndPointClosed ->
1060− relyViolation (ourEndPoint, theirEndPoint)
1061− "handleIncomingMessages:closeSocket (closed)"
1062−
1063− -- Read a message and output it on the endPoint's channel. By rights we
1064− -- should verify that the connection ID is valid, but this is unnecessary
1065− -- overhead
1066− readMessage :: N.Socket -> ConnectionId -> IO ()
1067− readMessage sock connId =
1068− recvWithLength sock >>= writeChan ourChannel . Received connId
1069−
1070− -- Arguments
1071− ourChannel = localChannel ourEndPoint
1072− theirState = remoteState theirEndPoint
1073− theirAddr = remoteAddress theirEndPoint
1074−
1075− -- Deal with a premature exit
1076− prematureExit :: N.Socket -> IOException -> IO ()
1077− prematureExit sock err = do
1078− tryCloseSocket sock
1079− modifyMVar_ theirState $ \st ->
1080− case st of
1081− RemoteEndPointInvalid _ ->
1082− relyViolation (ourEndPoint, theirEndPoint)
1083− "handleIncomingMessages:prematureExit"
1084− RemoteEndPointInit _ _ ->
1085− relyViolation (ourEndPoint, theirEndPoint)
1086− "handleIncomingMessages:prematureExit"
1087− RemoteEndPointValid vst -> do
1088− let code = EventConnectionLost
1089− (Just $ remoteAddress theirEndPoint)
1090− (IntSet.elems $ vst ^. remoteIncoming)
1091− writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1092− forM_ (vst ^. pendingCtrlRequests) $ flip putMVar (Left err)
1093− return (RemoteEndPointFailed err)
1094− RemoteEndPointClosing resolved _ -> do
1095− putMVar resolved ()
1096− return (RemoteEndPointFailed err)
1097− RemoteEndPointClosed ->
1098− relyViolation (ourEndPoint, theirEndPoint)
1099− "handleIncomingMessages:prematureExit"
1100− RemoteEndPointFailed err' ->
1101− return (RemoteEndPointFailed err')
1102−
1103−--------------------------------------------------------------------------------
1104−-- Uninterruptable auxiliary functions --
1105−-- --
1106−-- All these functions assume they are running in a thread which will never --
1107−-- be killed.
1108−--------------------------------------------------------------------------------
1109−
1110−-- | Request a connection to a remote endpoint
1111−--
1112−-- This will block until we get a connection ID from the remote endpoint; if
1113−-- the remote endpoint was in 'RemoteEndPointClosing' state then we will
1114−-- additionally block until that is resolved.
1115−--
1116−-- May throw a TransportError ConnectErrorCode exception.
1117−requestConnectionTo :: TCPParameters
1118− -> LocalEndPoint
1119− -> EndPointAddress
1120− -> ConnectHints
1121− -> IO (RemoteEndPoint, ConnectionId)
1122−requestConnectionTo params ourEndPoint theirAddress hints = go
1123− where
1124− go = do
1125− (theirEndPoint, isNew) <- mapIOException connectFailed $
1126− findRemoteEndPoint ourEndPoint theirAddress RequestedByUs
1127−
1128− if isNew
1129− then do
1130− forkIO . handle absorbAllExceptions $
1131− setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
1132− go
1133− else do
1134− reply <- mapIOException connectFailed $
1135− doRemoteRequest (ourEndPoint, theirEndPoint) RequestConnectionId
1136− return (theirEndPoint, decodeInt32 . BS.concat $ reply)
1137−
1138− connectFailed :: IOException -> TransportError ConnectErrorCode
1139− connectFailed = TransportError ConnectFailed . show
1140−
1141− absorbAllExceptions :: SomeException -> IO ()
1142− absorbAllExceptions _ex =
1143− return ()
1144−
1145−-- | Set up a remote endpoint
1146−setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
1147−setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
1148− result <- socketToEndPoint ourAddress
1149− theirAddress
1150− (tcpReuseClientAddr params)
1151− (connectTimeout hints)
1152− didAccept <- case result of
1153− Right (sock, ConnectionRequestAccepted) -> do
1154− let vst = ValidRemoteEndPointState
1155− { remoteSocket = sock
1156− , _remoteOutgoing = 0
1157− , _remoteIncoming = IntSet.empty
1158− , sendOn = sendMany sock
1159− , _pendingCtrlRequests = IntMap.empty
1160− , _nextCtrlRequestId = 0
1161− }
1162− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
1163− return True
1164− Right (sock, ConnectionRequestInvalid) -> do
1165− let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"
1166− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1167− tryCloseSocket sock
1168− return False
1169− Right (sock, ConnectionRequestCrossed) -> do
1170− resolveInit (ourEndPoint, theirEndPoint) RemoteEndPointClosed
1171− tryCloseSocket sock
1172− return False
1173− Left err -> do
1174− resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1175− return False
1176−
1177− when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
1178− where
1179− ourAddress = localAddress ourEndPoint
1180− theirAddress = remoteAddress theirEndPoint
1181− invalidAddress = TransportError ConnectNotFound
1182−
1183−-- | Do a (blocking) remote request
1184−--
1185−-- May throw IO (user) exception if the local or the remote endpoint is closed,
1186−-- if the send fails, or if the remote endpoint fails before it replies.
1187−doRemoteRequest :: EndPointPair -> ControlHeader -> IO [ByteString]
1188−doRemoteRequest (ourEndPoint, theirEndPoint) header = do
1189− replyMVar <- newEmptyMVar
1190− modifyRemoteState_ (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
1191− { caseValid = \vst -> do
1192− let reqId = vst ^. nextCtrlRequestId
1193− sendOn vst [encodeInt32 header, encodeInt32 reqId]
1194− return ( RemoteEndPointValid
1195− . (nextCtrlRequestId ^: (+ 1))
1196− . (pendingCtrlRequestsAt reqId ^= Just replyMVar)
1197− $ vst
1198− )
1199− -- Error cases
1200− , caseInvalid =
1201− throwIO
1202− , caseInit = \_ _ ->
1203− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (init)"
1204− , caseClosing = \_ _ ->
1205− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closing)"
1206− , caseClosed =
1207− relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closed)"
1208− , caseFailed =
1209− throwIO
1210− }
1211− mReply <- takeMVar replyMVar
1212− case mReply of
1213− Left err -> throwIO err
1214− Right reply -> return reply
1215−
1216−-- | Send a CloseSocket request if the remote endpoint is unused
1217−closeIfUnused :: EndPointPair -> IO ()
1218−closeIfUnused (ourEndPoint, theirEndPoint) =
1219− modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
1220− { caseValid = \vst ->
1221− if vst ^. remoteOutgoing == 0 && IntSet.null (vst ^. remoteIncoming)
1222− then do
1223− sendOn vst [encodeInt32 CloseSocket]
1224− resolved <- newEmptyMVar
1225− return $ RemoteEndPointClosing resolved vst
1226− else
1227− return $ RemoteEndPointValid vst
1228− }
1229−
1230−-- | Reset a remote endpoint if it is in Invalid mode
1231−--
1232−-- If the remote endpoint is currently in broken state, and
1233−--
1234−-- - a user calls the API function 'connect', or and the remote endpoint is
1235−-- - an inbound connection request comes in from this remote address
1236−--
1237−-- we remove the remote endpoint first.
1238−--
1239−-- Throws a TransportError ConnectFailed exception if the local endpoint is
1240−-- closed.
1241−resetIfBroken :: LocalEndPoint -> EndPointAddress -> IO ()
1242−resetIfBroken ourEndPoint theirAddress = do
1243− mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1244− LocalEndPointValid vst ->
1245− return (vst ^. localConnectionTo theirAddress)
1246− LocalEndPointClosed ->
1247− throwIO $ TransportError ConnectFailed "Endpoint closed"
1248− forM_ mTheirEndPoint $ \theirEndPoint ->
1249− withMVar (remoteState theirEndPoint) $ \st -> case st of
1250− RemoteEndPointInvalid _ ->
1251− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1252− RemoteEndPointFailed _ ->
1253− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1254− _ ->
1255− return ()
1256−
1257−-- | Special case of 'apiConnect': connect an endpoint to itself
1258−--
1259−-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)
1260−connectToSelf :: LocalEndPoint
1261− -> IO Connection
1262−connectToSelf ourEndPoint = do
1263− connAlive <- newIORef True -- Protected by the local endpoint lock
1264− connId <- mapIOException connectFailed $ getNextConnectionId ourEndPoint
1265− writeChan ourChan $
1266− ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)
1267− return Connection
1268− { send = selfSend connAlive connId
1269− , close = selfClose connAlive connId
1270− }
1271− where
1272− selfSend :: IORef Bool
1273− -> ConnectionId
1274− -> [ByteString]
1275− -> IO (Either (TransportError SendErrorCode) ())
1276− selfSend connAlive connId msg =
1277− try . withMVar ourState $ \st -> case st of
1278− LocalEndPointValid _ -> do
1279− alive <- readIORef connAlive
1280− if alive
1281− then writeChan ourChan (Received connId msg)
1282− else throwIO $ TransportError SendClosed "Connection closed"
1283− LocalEndPointClosed ->
1284− throwIO $ TransportError SendFailed "Endpoint closed"
1285−
1286− selfClose :: IORef Bool -> ConnectionId -> IO ()
1287− selfClose connAlive connId =
1288− withMVar ourState $ \st -> case st of
1289− LocalEndPointValid _ -> do
1290− alive <- readIORef connAlive
1291− when alive $ do
1292− writeChan ourChan (ConnectionClosed connId)
1293− writeIORef connAlive False
1294− LocalEndPointClosed ->
1295− return ()
1296−
1297− ourChan = localChannel ourEndPoint
1298− ourState = localState ourEndPoint
1299− connectFailed = TransportError ConnectFailed . show
1300−
1301−-- | Resolve an endpoint currently in 'Init' state
1302−resolveInit :: EndPointPair -> RemoteState -> IO ()
1303−resolveInit (ourEndPoint, theirEndPoint) newState =
1304− modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
1305− RemoteEndPointInit resolved _ -> do
1306− putMVar resolved ()
1307− case newState of
1308− RemoteEndPointClosed ->
1309− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1310− _ ->
1311− return ()
1312− return newState
1313− RemoteEndPointFailed ex ->
1314− throwIO ex
1315− _ ->
1316− relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
1317−
1318−-- | Get the next connection ID
1319−--
1320−-- Throws an IO exception when the endpoint is closed.
1321−getNextConnectionId :: LocalEndPoint -> IO ConnectionId
1322−getNextConnectionId ourEndpoint =
1323− modifyMVar (localState ourEndpoint) $ \st -> case st of
1324− LocalEndPointValid vst -> do
1325− let connId = vst ^. nextConnectionId
1326− return ( LocalEndPointValid
1327− . (nextConnectionId ^= connId + 1)
1328− $ vst
1329− , connId)
1330− LocalEndPointClosed ->
1331− throwIO $ userError "Local endpoint closed"
1332−
1333−-- | Create a new local endpoint
1334−--
1335−-- May throw a TransportError NewEndPointErrorCode exception if the transport
1336−-- is closed.
1337−createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
1338−createLocalEndPoint transport = do
1339− chan <- newChan
1340− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
1341− { _nextConnectionId = firstNonReservedConnectionId
1342− , _localConnections = Map.empty
1343− , _nextRemoteId = 0
1344− }
1345− modifyMVar (transportState transport) $ \st -> case st of
1346− TransportValid vst -> do
1347− let ix = vst ^. nextEndPointId
1348− let addr = encodeEndPointAddress (transportHost transport)
1349− (transportPort transport)
1350− ix
1351− let localEndPoint = LocalEndPoint { localAddress = addr
1352− , localChannel = chan
1353− , localState = state
1354− }
1355− return ( TransportValid
1356− . (localEndPointAt addr ^= Just localEndPoint)
1357− . (nextEndPointId ^= ix + 1)
1358− $ vst
1359− , localEndPoint
1360− )
1361− TransportClosed ->
1362− throwIO (TransportError NewEndPointFailed "Transport closed")
1363−
1364−
1365−-- | Remove reference to a remote endpoint from a local endpoint
1366−--
1367−-- If the local endpoint is closed, do nothing
1368−removeRemoteEndPoint :: EndPointPair -> IO ()
1369−removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
1370− modifyMVar_ ourState $ \st -> case st of
1371− LocalEndPointValid vst ->
1372− case vst ^. localConnectionTo theirAddress of
1373− Nothing ->
1374− return st
1375− Just remoteEndPoint' ->
1376− if remoteId remoteEndPoint' == remoteId theirEndPoint
1377− then return
1378− ( LocalEndPointValid
1379− . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
1380− $ vst
1381− )
1382− else return st
1383− LocalEndPointClosed ->
1384− return LocalEndPointClosed
1385− where
1386− ourState = localState ourEndPoint
1387− theirAddress = remoteAddress theirEndPoint
1388−
1389−-- | Remove reference to a local endpoint from the transport state
1390−--
1391−-- Does nothing if the transport is closed
1392−removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
1393−removeLocalEndPoint transport ourEndPoint =
1394− modifyMVar_ (transportState transport) $ \st -> case st of
1395− TransportValid vst ->
1396− return ( TransportValid
1397− . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
1398− $ vst
1399− )
1400− TransportClosed ->
1401− return TransportClosed
1402−
1403−-- | Find a remote endpoint. If the remote endpoint does not yet exist we
1404−-- create it in Init state. Returns if the endpoint was new.
1405−findRemoteEndPoint
1406− :: LocalEndPoint
1407− -> EndPointAddress
1408− -> RequestedBy
1409− -> IO (RemoteEndPoint, Bool)
1410−findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
1411− where
1412− go = do
1413− (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of
1414− LocalEndPointValid vst -> case vst ^. localConnectionTo theirAddress of
1415− Just theirEndPoint ->
1416− return (st, (theirEndPoint, False))
1417− Nothing -> do
1418− resolved <- newEmptyMVar
1419− theirState <- newMVar (RemoteEndPointInit resolved findOrigin)
1420− let theirEndPoint = RemoteEndPoint
1421− { remoteAddress = theirAddress
1422− , remoteState = theirState
1423− , remoteId = vst ^. nextRemoteId
1424− }
1425− return ( LocalEndPointValid
1426− . (localConnectionTo theirAddress ^= Just theirEndPoint)
1427− . (nextRemoteId ^: (+ 1))
1428− $ vst
1429− , (theirEndPoint, True)
1430− )
1431− LocalEndPointClosed ->
1432− throwIO $ userError "Local endpoint closed"
1433−
1434− if isNew
1435− then
1436− return (theirEndPoint, True)
1437− else do
1438− let theirState = remoteState theirEndPoint
1439− snapshot <- modifyMVar theirState $ \st -> case st of
1440− RemoteEndPointValid vst ->
1441− case findOrigin of
1442− RequestedByUs -> do
1443− let st' = RemoteEndPointValid
1444− . (remoteOutgoing ^: (+ 1))
1445− $ vst
1446− return (st', st')
1447− RequestedByThem ->
1448− return (st, st)
1449− _ ->
1450− return (st, st)
1451− -- The snapshot may no longer be up to date at this point, but if we
1452− -- increased the refcount then it can only either be Valid or Failed
1453− -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
1454− case snapshot of
1455− RemoteEndPointInvalid err ->
1456− throwIO err
1457− RemoteEndPointInit resolved initOrigin ->
1458− case (findOrigin, initOrigin) of
1459− (RequestedByUs, RequestedByUs) ->
1460− readMVar resolved >> go
1461− (RequestedByUs, RequestedByThem) ->
1462− readMVar resolved >> go
1463− (RequestedByThem, RequestedByUs) ->
1464− if ourAddress > theirAddress
1465− then
1466− -- Wait for the Crossed message
1467− readMVar resolved >> go
1468− else
1469− return (theirEndPoint, False)
1470− (RequestedByThem, RequestedByThem) ->
1471− throwIO $ userError "Already connected"
1472− RemoteEndPointValid _ ->
1473− -- We assume that the request crossed if we find the endpoint in
1474− -- Valid state. It is possible that this is really an invalid
1475− -- request, but only in the case of a broken client (we don't
1476− -- maintain enough history to be able to tell the difference).
1477− return (theirEndPoint, False)
1478− RemoteEndPointClosing resolved _ ->
1479− readMVar resolved >> go
1480− RemoteEndPointClosed ->
1481− go
1482− RemoteEndPointFailed err ->
1483− throwIO err
1484−
1485− ourState = localState ourEndPoint
1486− ourAddress = localAddress ourEndPoint
1487−
1488−--------------------------------------------------------------------------------
1489−-- "Stateless" (MVar free) functions --
1490−--------------------------------------------------------------------------------
1491−
1492−-- | Establish a connection to a remote endpoint
1493−--
1494−-- Maybe throw a TransportError
1495−socketToEndPoint :: EndPointAddress -- ^ Our address
1496− -> EndPointAddress -- ^ Their address
1497− -> Bool -- ^ Use SO_REUSEADDR?
1498− -> Maybe Int -- ^ Timeout for connect
1499− -> IO (Either (TransportError ConnectErrorCode)
1500− (N.Socket, ConnectionRequestResponse))
1501−socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1502− try $ do
1503− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
1504− Nothing -> throwIO (failed . userError $ "Could not parse")
1505− Just dec -> return dec
1506− addr:_ <- mapIOException invalidAddress $
1507− N.getAddrInfo Nothing (Just host) (Just port)
1508− bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
1509− when reuseAddr $
1510− mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
1511− mapIOException invalidAddress $
1512− timeoutMaybe timeout timeoutError $
1513− N.connect sock (N.addrAddress addr)
1514− response <- mapIOException failed $ do
1515− sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
1516− recvInt32 sock
1517− case tryToEnum response of
1518− Nothing -> throwIO (failed . userError $ "Unexpected response")
1519− Just r -> return (sock, r)
1520− where
1521− createSocket :: N.AddrInfo -> IO N.Socket
1522− createSocket addr = mapIOException insufficientResources $
1523− N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
1524−
1525− invalidAddress = TransportError ConnectNotFound . show
1526− insufficientResources = TransportError ConnectInsufficientResources . show
1527− failed = TransportError ConnectFailed . show
1528− timeoutError = TransportError ConnectTimeout "Timed out"
1529−
1530−-- | Encode end point address
1531−encodeEndPointAddress :: N.HostName
1532− -> N.ServiceName
1533− -> EndPointId
1534− -> EndPointAddress
1535−encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
1536− host ++ ":" ++ port ++ ":" ++ show ix
1537−
1538−-- | Decode end point address
1539−decodeEndPointAddress :: EndPointAddress
1540− -> Maybe (N.HostName, N.ServiceName, EndPointId)
1541−decodeEndPointAddress (EndPointAddress bs) =
1542− case map BSC.unpack $ BSC.split ':' bs of
1543− [host, port, endPointIdStr] ->
1544− case reads endPointIdStr of
1545− [(endPointId, "")] -> Just (host, port, endPointId)
1546− _ -> Nothing
1547− _ ->
1548− Nothing
1549−
1550−--------------------------------------------------------------------------------
1551−-- Functions from TransportInternals --
1552−--------------------------------------------------------------------------------
1553−
1554−-- Find a socket between two endpoints
1555−--
1556−-- Throws an IO exception if the socket could not be found.
1557−internalSocketBetween :: TCPTransport -- ^ Transport
1558− -> EndPointAddress -- ^ Local endpoint
1559− -> EndPointAddress -- ^ Remote endpoint
1560− -> IO N.Socket
1561−internalSocketBetween transport ourAddress theirAddress = do
1562− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
1563− TransportClosed ->
1564− throwIO $ userError "Transport closed"
1565− TransportValid vst ->
1566− case vst ^. localEndPointAt ourAddress of
1567− Nothing -> throwIO $ userError "Local endpoint not found"
1568− Just ep -> return ep
1569− theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1570− LocalEndPointClosed ->
1571− throwIO $ userError "Local endpoint closed"
1572− LocalEndPointValid vst ->
1573− case vst ^. localConnectionTo theirAddress of
1574− Nothing -> throwIO $ userError "Remote endpoint not found"
1575− Just ep -> return ep
1576− withMVar (remoteState theirEndPoint) $ \st -> case st of
1577− RemoteEndPointInit _ _ ->
1578− throwIO $ userError "Remote endpoint not yet initialized"
1579− RemoteEndPointValid vst ->
1580− return $ remoteSocket vst
1581− RemoteEndPointClosing _ vst ->
1582− return $ remoteSocket vst
1583− RemoteEndPointClosed ->
1584− throwIO $ userError "Remote endpoint closed"
1585− RemoteEndPointInvalid err ->
1586− throwIO err
1587− RemoteEndPointFailed err ->
1588− throwIO err
1589−
1590−--------------------------------------------------------------------------------
1591−-- Constants --
1592−--------------------------------------------------------------------------------
1593−
1594−-- | We reserve a bunch of connection IDs for control messages
1595−firstNonReservedConnectionId :: ConnectionId
1596−firstNonReservedConnectionId = 1024
1597−
1598−--------------------------------------------------------------------------------
1599−-- Accessor definitions --
1600−--------------------------------------------------------------------------------
1601−
1602−localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
1603−localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es })
1604−
1605−nextEndPointId :: Accessor ValidTransportState EndPointId
1606−nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid })
1607−
1608−nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
1609−nextConnectionId = accessor _nextConnectionId (\cix st -> st { _nextConnectionId = cix })
1610−
1611−localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
1612−localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
1613−
1614−nextRemoteId :: Accessor ValidLocalEndPointState Int
1615−nextRemoteId = accessor _nextRemoteId (\rid st -> st { _nextRemoteId = rid })
1616−
1617−remoteOutgoing :: Accessor ValidRemoteEndPointState Int
1618−remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs })
1619−
1620−remoteIncoming :: Accessor ValidRemoteEndPointState IntSet
1621−remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs })
1622−
1623−pendingCtrlRequests :: Accessor ValidRemoteEndPointState (IntMap (MVar (Either IOException [ByteString])))
1624−pendingCtrlRequests = accessor _pendingCtrlRequests (\rep st -> st { _pendingCtrlRequests = rep })
1625−
1626−nextCtrlRequestId :: Accessor ValidRemoteEndPointState ControlRequestId
1627−nextCtrlRequestId = accessor _nextCtrlRequestId (\cid st -> st { _nextCtrlRequestId = cid })
1628−
1629−localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1630−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1631−
1632−pendingCtrlRequestsAt :: ControlRequestId -> Accessor ValidRemoteEndPointState (Maybe (MVar (Either IOException [ByteString])))
1633−pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral ix)
1634−
1635−localConnectionTo :: EndPointAddress
1636− -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1637−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1638−
1639−-------------------------------------------------------------------------------
1640−-- Debugging --
1641−-------------------------------------------------------------------------------
1642−
1643−relyViolation :: EndPointPair -> String -> IO a
1644−relyViolation (ourEndPoint, theirEndPoint) str = do
1645− elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1646− fail (str ++ " RELY violation")
1647−
1648−elog :: EndPointPair -> String -> IO ()
1649−elog (ourEndPoint, theirEndPoint) msg = do
1650− tid <- myThreadId
1651− putStrLn $ show (localAddress ourEndPoint)
1652− ++ "/" ++ show (remoteAddress theirEndPoint)
1653− ++ "(" ++ show (remoteId theirEndPoint) ++ ")"
1654− ++ "/" ++ show tid
1655− ++ ": " ++ msg
network-transport-tcp/src/Network/Transport/TCP/Internal.hsdeleted−119
@@ -1,119 +0,0 @@
1−-- | Utility functions for TCP sockets
2−module Network.Transport.TCP.Internal ( forkServer
3− , recvWithLength
4− , recvExact
5− , recvInt32
6− , tryCloseSocket
7− ) where
8−
9−#if ! MIN_VERSION_base(4,6,0)
10−import Prelude hiding (catch)
11−#endif
12−
13−import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)
14−import qualified Network.Socket as N ( HostName
15− , ServiceName
16− , Socket
17− , SocketType(Stream)
18− , SocketOption(ReuseAddr)
19− , getAddrInfo
20− , defaultHints
21− , socket
22− , bindSocket
23− , listen
24− , addrFamily
25− , addrAddress
26− , defaultProtocol
27− , setSocketOption
28− , accept
29− , sClose
30− )
31−import qualified Network.Socket.ByteString as NBS (recv)
32−import Control.Concurrent (ThreadId)
33−import Control.Monad (forever, when)
34−import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_)
35−import Control.Applicative ((<$>))
36−import Data.ByteString (ByteString)
37−import qualified Data.ByteString as BS (length, concat, null)
38−import Data.Int (Int32)
39−
40−-- | Start a server at the specified address.
41−--
42−-- This sets up a server socket for the specified host and port. Exceptions
43−-- thrown during setup are not caught.
44−--
45−-- Once the socket is created we spawn a new thread which repeatedly accepts
46−-- incoming connections and executes the given request handler. If any
47−-- exception occurs the thread terminates and calls the terminationHandler.
48−-- This exception may occur because of a call to 'N.accept', because the thread
49−-- was explicitly killed, or because of a synchronous exception thrown by the
50−-- request handler. Typically, you should avoid the last case by catching any
51−-- relevant exceptions in the request handler.
52−--
53−-- The request handler should spawn threads to handle each individual request
54−-- or the server will block. Once a thread has been spawned it will be the
55−-- responsibility of the new thread to close the socket when an exception
56−-- occurs.
57−forkServer :: N.HostName -- ^ Host
58− -> N.ServiceName -- ^ Port
59− -> Int -- ^ Backlog (maximum number of queued connections)
60− -> Bool -- ^ Set ReuseAddr option?
61− -> (SomeException -> IO ()) -- ^ Termination handler
62− -> (N.Socket -> IO ()) -- ^ Request handler
63− -> IO ThreadId
64−forkServer host port backlog reuseAddr terminationHandler requestHandler = do
65− -- Resolve the specified address. By specification, getAddrInfo will never
66− -- return an empty list (but will throw an exception instead) and will return
67− -- the "best" address first, whatever that means
68− addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
69− bracketOnError (N.socket (N.addrFamily addr) N.Stream N.defaultProtocol)
70− tryCloseSocket $ \sock -> do
71− when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1
72− N.bindSocket sock (N.addrAddress addr)
73− N.listen sock backlog
74− -- We start listening for incoming requests in a separate thread. When
75− -- that thread is killed, we close the server socket and the termination
76− -- handler. We have to make sure that the exception handler is installed
77− -- /before/ any asynchronous exception occurs. So we mask_, then fork
78− -- (the child thread inherits the masked state from the parent), then
79− -- unmask only inside the catch.
80− mask_ $ forkIOWithUnmask $ \unmask ->
81− catch (unmask (forever $ acceptRequest sock)) $ \ex -> do
82− tryCloseSocket sock
83− terminationHandler ex
84− where
85− acceptRequest :: N.Socket -> IO ()
86− acceptRequest sock = bracketOnError (N.accept sock)
87− (tryCloseSocket . fst)
88− (requestHandler . fst)
89−
90−-- | Read a length and then a payload of that length
91−recvWithLength :: N.Socket -> IO [ByteString]
92−recvWithLength sock = recvInt32 sock >>= recvExact sock
93−
94−-- | Receive a 32-bit integer
95−recvInt32 :: Num a => N.Socket -> IO a
96−recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
97−
98−-- | Close a socket, ignoring I/O exceptions
99−tryCloseSocket :: N.Socket -> IO ()
100−tryCloseSocket sock = void . tryIO $
101− N.sClose sock
102−
103−-- | Read an exact number of bytes from a socket
104−--
105−-- Throws an I/O exception if the socket closes before the specified
106−-- number of bytes could be read
107−recvExact :: N.Socket -- ^ Socket to read from
108− -> Int32 -- ^ Number of bytes to read
109− -> IO [ByteString]
110−recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")
111−recvExact sock len = go [] len
112− where
113− go :: [ByteString] -> Int32 -> IO [ByteString]
114− go acc 0 = return (reverse acc)
115− go acc l = do
116− bs <- NBS.recv sock (fromIntegral l `min` 4096)
117− if BS.null bs
118− then throwIO (userError "recvExact: Socket closed")
119− else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport-tcp/tests/TestAuxiliary.hsdeleted−111
@@ -1,111 +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−#if ! MIN_VERSION_base(4,6,0)
12−import Prelude hiding (catch)
13−#endif
14−
15−import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
16−import Control.Concurrent.Chan (Chan)
17−import Control.Monad (liftM2, unless)
18−import Control.Exception (SomeException, try, catch)
19−import System.Timeout (timeout)
20−import System.IO (stdout, hFlush)
21−import System.Console.ANSI ( SGR(SetColor, Reset)
22− , Color(Red, Green)
23− , ConsoleLayer(Foreground)
24− , ColorIntensity(Vivid)
25− , setSGR
26− )
27−import System.Random (randomIO)
28−import Network.Transport
29−import Traced (Traceable(..), traceShow)
30−
31−-- | Like fork, but throw exceptions in the child thread to the parent
32−forkTry :: IO () -> IO ThreadId
33−forkTry p = do
34− tid <- myThreadId
35− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
36−
37−-- | Like try, but specialized to SomeException
38−trySome :: IO a -> IO (Either SomeException a)
39−trySome = try
40−
41−-- | Run the given test, catching timeouts and exceptions
42−runTest :: String -> IO () -> IO Bool
43−runTest description test = do
44− putStr $ "Running " ++ show description ++ ": "
45− hFlush stdout
46− done <- try . timeout 60000000 $ test -- 60 seconds
47− case done of
48− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
49− Right Nothing -> failed $ "(timeout)"
50− Right (Just ()) -> ok
51− where
52− failed :: String -> IO Bool
53− failed err = do
54− setSGR [SetColor Foreground Vivid Red]
55− putStr "failed "
56− setSGR [Reset]
57− putStrLn err
58− return False
59−
60− ok :: IO Bool
61− ok = do
62− setSGR [SetColor Foreground Vivid Green]
63− putStrLn "ok"
64− setSGR [Reset]
65− return True
66−
67−-- | Run a bunch of tests and throw an exception if any fails
68−runTests :: [(String, IO ())] -> IO ()
69−runTests tests = do
70− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
71− unless success $ fail "Some tests failed"
72−
73−-- | Random thread delay between 0 and the specified max
74−randomThreadDelay :: Int -> IO ()
75−randomThreadDelay maxDelay = do
76− delay <- randomIO :: IO Int
77− threadDelay (delay `mod` maxDelay)
78−
79−--------------------------------------------------------------------------------
80−-- traceShow instances --
81−--------------------------------------------------------------------------------
82−
83−instance Traceable EndPoint where
84− trace = const Nothing
85−
86−instance Traceable Transport where
87− trace = const Nothing
88−
89−instance Traceable Connection where
90− trace = const Nothing
91−
92−instance Traceable Event where
93− trace = traceShow
94−
95−instance Show err => Traceable (TransportError err) where
96− trace = traceShow
97−
98−instance Traceable EndPointAddress where
99− trace = traceShow . endPointAddressToByteString
100−
101−instance Traceable SomeException where
102− trace = traceShow
103−
104−instance Traceable ThreadId where
105− trace = const Nothing
106−
107−instance Traceable (Chan a) where
108− trace = const Nothing
109−
110−instance Traceable Float where
111− trace = traceShow
network-transport-tcp/tests/TestTCP.hsdeleted−794
@@ -1,794 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Main where
4−
5−import Prelude hiding
6− ( (>>=)
7− , return
8− , fail
9− , (>>)
10−#if ! MIN_VERSION_base(4,6,0)
11− , catch
12−#endif
13− )
14−import TestTransport (testTransport)
15−import TestAuxiliary (forkTry, runTests)
16−import Network.Transport
17−import Network.Transport.TCP ( createTransport
18− , createTransportExposeInternals
19− , TransportInternals(..)
20− , encodeEndPointAddress
21− , defaultTCPParameters
22− )
23−import Data.Int (Int32)
24−import Control.Concurrent (threadDelay, killThread)
25−import Control.Concurrent.MVar ( MVar
26− , newEmptyMVar
27− , putMVar
28− , takeMVar
29− , readMVar
30− , isEmptyMVar
31− , newMVar
32− , modifyMVar
33− )
34−import Control.Monad (replicateM, guard, forM_, replicateM_, when)
35−import Control.Applicative ((<$>))
36−import Control.Exception (throwIO, try, SomeException)
37−import Network.Transport.TCP ( ControlHeader(..)
38− , ConnectionRequestResponse(..)
39− , socketToEndPoint
40− )
41−import Network.Transport.Internal ( encodeInt32
42− , prependLength
43− , tlog
44− , tryIO
45− , void
46− )
47−import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)
48−import qualified Network.Socket as N ( sClose
49− , ServiceName
50− , Socket
51− , AddrInfo
52− , shutdown
53− , ShutdownCmd(ShutdownSend)
54− )
55−import Network.Socket.ByteString (sendMany)
56−import Data.String (fromString)
57−import Traced
58−import GHC.IO.Exception (ioe_errno)
59−import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)
60−import System.Timeout (timeout)
61−
62−instance Traceable ControlHeader where
63− trace = traceShow
64−
65−instance Traceable ConnectionRequestResponse where
66− trace = traceShow
67−
68−instance Traceable N.Socket where
69− trace = traceShow
70−
71−instance Traceable N.AddrInfo where
72− trace = traceShow
73−
74−instance Traceable TransportInternals where
75− trace = const Nothing
76−
77−-- Test that the server gets a ConnectionClosed message when the client closes
78−-- the socket without sending an explicit control message to the server first
79−testEarlyDisconnect :: IO N.ServiceName -> IO ()
80−testEarlyDisconnect nextPort = do
81− clientAddr <- newEmptyMVar
82− serverAddr <- newEmptyMVar
83− serverDone <- newEmptyMVar
84−
85− tlog "testEarlyDisconnect"
86− forkTry $ server serverAddr clientAddr serverDone
87− forkTry $ client serverAddr clientAddr
88−
89− takeMVar serverDone
90− where
91− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
92− server serverAddr clientAddr serverDone = do
93− tlog "Server"
94− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
95− Right endpoint <- newEndPoint transport
96− putMVar serverAddr (address endpoint)
97− theirAddr <- readMVar clientAddr
98−
99− -- TEST 1: they connect to us, then drop the connection
100− do
101− ConnectionOpened cid _ addr <- receive endpoint
102− True <- return $ addr == theirAddr
103−
104− ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid']) _) <- receive endpoint
105− True <- return $ addr' == theirAddr && cid' == cid
106−
107− return ()
108−
109− -- TEST 2: after they dropped their connection to us, we now try to
110− -- establish a connection to them. This should re-establish the broken
111− -- TCP connection.
112− tlog "Trying to connect to client"
113− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
114−
115− -- TEST 3: To test the connection, we do a simple ping test; as before,
116− -- however, the remote client won't close the connection nicely but just
117− -- closes the socket
118− do
119− Right () <- send conn ["ping"]
120−
121− ConnectionOpened cid _ addr <- receive endpoint
122− True <- return $ addr == theirAddr
123−
124− Received cid' ["pong"] <- receive endpoint
125− True <- return $ cid == cid'
126−
127− ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid'']) _) <- receive endpoint
128− True <- return $ addr' == theirAddr && cid'' == cid
129−
130− return ()
131−
132− -- TEST 4: A subsequent send on an already-open connection will now break
133− Left (TransportError SendFailed _) <- send conn ["ping2"]
134−
135− -- *Pfew*
136− putMVar serverDone ()
137−
138− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
139− client serverAddr clientAddr = do
140− tlog "Client"
141− clientPort <- nextPort
142− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
143− putMVar clientAddr ourAddress
144−
145− -- Listen for incoming messages
146− forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
147− -- Initial setup
148− 0 <- recvInt32 sock :: IO Int
149− _ <- recvWithLength sock
150− sendMany sock [encodeInt32 ConnectionRequestAccepted]
151−
152− -- Server requests a logical connection
153− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
154− reqId <- recvInt32 sock :: IO Int
155− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
156−
157− -- Server sends a message
158− 10001 <- recvInt32 sock :: IO Int
159− ["ping"] <- recvWithLength sock
160−
161− -- Reply
162− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
163− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
164− 10002 <- recvInt32 sock :: IO Int
165− [cid] <- recvWithLength sock
166− sendMany sock (cid : prependLength ["pong"])
167−
168− -- Close the socket
169− N.sClose sock
170−
171− -- Connect to the server
172− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
173−
174− -- Request a new connection, but don't wait for the response
175− let reqId = 0 :: Int32
176− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
177−
178− -- Close the socket without closing the connection explicitly
179− -- The server should receive an error event
180− N.sClose sock
181−
182−-- | Test the behaviour of a premature CloseSocket request
183−testEarlyCloseSocket :: IO N.ServiceName -> IO ()
184−testEarlyCloseSocket nextPort = do
185− clientAddr <- newEmptyMVar
186− serverAddr <- newEmptyMVar
187− serverDone <- newEmptyMVar
188−
189− tlog "testEarlyDisconnect"
190− forkTry $ server serverAddr clientAddr serverDone
191− forkTry $ client serverAddr clientAddr
192−
193− takeMVar serverDone
194− where
195− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
196− server serverAddr clientAddr serverDone = do
197− tlog "Server"
198− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
199− Right endpoint <- newEndPoint transport
200− putMVar serverAddr (address endpoint)
201− theirAddr <- readMVar clientAddr
202−
203− -- TEST 1: they connect to us, then send a CloseSocket. Since we don't
204− -- have any outgoing connections, this means we will agree to close the
205− -- socket
206− do
207− ConnectionOpened cid _ addr <- receive endpoint
208− True <- return $ addr == theirAddr
209−
210− ConnectionClosed cid' <- receive endpoint
211− True <- return $ cid' == cid
212−
213− return ()
214−
215− -- TEST 2: after they dropped their connection to us, we now try to
216− -- establish a connection to them. This should re-establish the broken
217− -- TCP connection.
218− tlog "Trying to connect to client"
219− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
220−
221− -- TEST 3: To test the connection, we do a simple ping test; as before,
222− -- however, the remote client won't close the connection nicely but just
223− -- sends a CloseSocket -- except that now we *do* have outgoing
224− -- connections, so we won't agree and hence will receive an error when
225− -- the socket gets closed
226− do
227− Right () <- send conn ["ping"]
228−
229− ConnectionOpened cid _ addr <- receive endpoint
230− True <- return $ addr == theirAddr
231−
232− Received cid' ["pong"] <- receive endpoint
233− True <- return $ cid' == cid
234−
235− ConnectionClosed cid'' <- receive endpoint
236− True <- return $ cid'' == cid
237−
238− ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint
239− True <- return $ addr' == theirAddr
240−
241− return ()
242−
243− -- TEST 4: A subsequent send on an already-open connection will now break
244− Left (TransportError SendFailed _) <- send conn ["ping2"]
245−
246− -- *Pfew*
247− putMVar serverDone ()
248−
249− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
250− client serverAddr clientAddr = do
251− tlog "Client"
252− clientPort <- nextPort
253− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
254− putMVar clientAddr ourAddress
255−
256− -- Listen for incoming messages
257− forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
258− -- Initial setup
259− 0 <- recvInt32 sock :: IO Int
260− _ <- recvWithLength sock
261− sendMany sock [encodeInt32 ConnectionRequestAccepted]
262−
263− -- Server requests a logical connection
264− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
265− reqId <- recvInt32 sock :: IO Int
266− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
267−
268− -- Server sends a message
269− 10001 <- recvInt32 sock :: IO Int
270− ["ping"] <- recvWithLength sock
271−
272− -- Reply
273− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
274− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
275− 10002 <- recvInt32 sock :: IO Int
276− [cid] <- recvWithLength sock
277− sendMany sock (cid : prependLength ["pong"])
278−
279− -- Send a CloseSocket even though there are still connections *in both
280− -- directions*
281− sendMany sock [encodeInt32 CloseSocket]
282− N.sClose sock
283−
284− -- Connect to the server
285− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
286−
287− -- Request a new connection, but don't wait for the response
288− let reqId = 0 :: Int32
289− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
290−
291− -- Send a CloseSocket without sending a closeconnecton
292− -- The server should still receive a ConnectionClosed message
293− sendMany sock [encodeInt32 CloseSocket]
294− N.sClose sock
295−
296−-- | Test the creation of a transport with an invalid address
297−testInvalidAddress :: IO N.ServiceName -> IO ()
298−testInvalidAddress nextPort = do
299− Left _ <- nextPort >>= \port -> createTransport "invalidHostName" port defaultTCPParameters
300− return ()
301−
302−-- | Test connecting to invalid or non-existing endpoints
303−testInvalidConnect :: IO N.ServiceName -> IO ()
304−testInvalidConnect nextPort = do
305− port <- nextPort
306− Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
307− Right endpoint <- newEndPoint transport
308−
309− -- Syntax error in the endpoint address
310− Left (TransportError ConnectFailed _) <-
311− connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints
312−
313− -- Syntax connect, but invalid hostname (TCP address lookup failure)
314− Left (TransportError ConnectNotFound _) <-
315− connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints
316−
317− -- TCP address correct, but nobody home at that address
318− Left (TransportError ConnectNotFound _) <-
319− connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints
320−
321− -- Valid TCP address but invalid endpoint number
322− Left (TransportError ConnectNotFound _) <-
323− connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered defaultConnectHints
324−
325− return ()
326−
327−-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
328−-- would happen when the endpoint sends a new connection request before
329−-- receiving an (already underway) CloseSocket request)
330−testIgnoreCloseSocket :: IO N.ServiceName -> IO ()
331−testIgnoreCloseSocket nextPort = do
332− serverAddr <- newEmptyMVar
333− clientDone <- newEmptyMVar
334− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
335−
336− forkTry $ server transport serverAddr
337− forkTry $ client transport serverAddr clientDone
338−
339− takeMVar clientDone
340−
341− where
342− server :: Transport -> MVar EndPointAddress -> IO ()
343− server transport serverAddr = do
344− tlog "Server"
345− Right endpoint <- newEndPoint transport
346− putMVar serverAddr (address endpoint)
347−
348− -- Wait for the client to connect and disconnect
349− tlog "Waiting for ConnectionOpened"
350− ConnectionOpened _ _ _ <- receive endpoint
351− tlog "Waiting for ConnectionClosed"
352− ConnectionClosed _ <- receive endpoint
353−
354− -- At this point the server will have sent a CloseSocket request to the
355− -- client, which however ignores it, instead it requests and closes
356− -- another connection
357− tlog "Waiting for ConnectionOpened"
358− ConnectionOpened _ _ _ <- receive endpoint
359− tlog "Waiting for ConnectionClosed"
360− ConnectionClosed _ <- receive endpoint
361−
362−
363− tlog "Server waiting.."
364−
365− client :: Transport -> MVar EndPointAddress -> MVar () -> IO ()
366− client transport serverAddr clientDone = do
367− tlog "Client"
368− Right endpoint <- newEndPoint transport
369− let ourAddress = address endpoint
370−
371− -- Connect to the server
372− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
373−
374− -- Request a new connection
375− tlog "Requesting connection"
376− let reqId = 0 :: Int32
377− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
378− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
379−
380− -- Close the connection again
381− tlog "Closing connection"
382− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
383−
384− -- Server will now send a CloseSocket request as its refcount reached 0
385− tlog "Waiting for CloseSocket request"
386− CloseSocket <- toEnum <$> recvInt32 sock
387−
388− -- But we ignore it and request another connection
389− tlog "Ignoring it, requesting another connection"
390− let reqId' = 1 :: Int32
391− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
392− response' <- replicateM 4 $ recvInt32 sock :: IO [Int32]
393−
394− -- Close it again
395− tlog "Closing connection"
396− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response' !! 3)]
397−
398− -- We now get a CloseSocket again, and this time we heed it
399− tlog "Waiting for second CloseSocket request"
400− CloseSocket <- toEnum <$> recvInt32 sock
401−
402− tlog "Closing socket"
403− sendMany sock [encodeInt32 CloseSocket]
404− N.sClose sock
405−
406− putMVar clientDone ()
407−
408−-- | Like 'testIgnoreSocket', but now the server requests a connection after the
409−-- client closed their connection. In the meantime, the server will have sent a
410−-- CloseSocket request to the client, and must block until the client responds.
411−testBlockAfterCloseSocket :: IO N.ServiceName -> IO ()
412−testBlockAfterCloseSocket nextPort = do
413− serverAddr <- newEmptyMVar
414− clientAddr <- newEmptyMVar
415− clientDone <- newEmptyMVar
416− port <- nextPort
417− Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
418−
419− forkTry $ server transport serverAddr clientAddr
420− forkTry $ client transport serverAddr clientAddr clientDone
421−
422− takeMVar clientDone
423−
424− where
425− server :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> IO ()
426− server transport serverAddr clientAddr = do
427− tlog "Server"
428− Right endpoint <- newEndPoint transport
429− putMVar serverAddr (address endpoint)
430−
431− -- Wait for the client to connect and disconnect
432− tlog "Waiting for ConnectionOpened"
433− ConnectionOpened _ _ _ <- receive endpoint
434− tlog "Waiting for ConnectionClosed"
435− ConnectionClosed _ <- receive endpoint
436−
437− -- At this point the server will have sent a CloseSocket request to the
438− -- client, and must block until the client responds
439− tlog "Server waiting to connect to the client.."
440− Right _ <- readMVar clientAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
441−
442− tlog "Server waiting.."
443−
444− client :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
445− client transport serverAddr clientAddr clientDone = do
446− tlog "Client"
447− Right endpoint <- newEndPoint transport
448− putMVar clientAddr (address endpoint)
449− let ourAddress = address endpoint
450−
451− -- Connect to the server
452− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
453−
454− -- Request a new connection
455− tlog "Requesting connection"
456− let reqId = 0 :: Int32
457− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
458− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
459−
460− -- Close the connection again
461− tlog "Closing connection"
462− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
463−
464− -- Server will now send a CloseSocket request as its refcount reached 0
465− tlog "Waiting for CloseSocket request"
466− CloseSocket <- toEnum <$> recvInt32 sock
467−
468− unblocked <- newEmptyMVar
469−
470− -- We should not hear from the server until we unblock him by
471− -- responding to the CloseSocket request (in this case, we
472− -- respond by sending a ConnectionRequest)
473− forkTry $ do
474− recvInt32 sock :: IO Int32
475− isEmptyMVar unblocked >>= (guard . not)
476− putMVar clientDone ()
477−
478− threadDelay 1000000
479−
480− tlog "Client ignores close socket and sends connection request"
481− tlog "This should unblock the server"
482− putMVar unblocked ()
483− let reqId' = 1 :: Int32
484− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
485−
486−-- | Test what happens when a remote endpoint sends a connection request to our
487−-- transport for an endpoint it already has a connection to
488−testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()
489−testUnnecessaryConnect nextPort numThreads = do
490− clientDone <- newEmptyMVar
491− serverAddr <- newEmptyMVar
492−
493− forkTry $ do
494− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
495− Right endpoint <- newEndPoint transport
496− putMVar serverAddr (address endpoint)
497−
498− forkTry $ do
499− -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check
500− let ourAddress = EndPointAddress "126.0.0.1"
501−
502− -- We should only get a single 'Accepted' reply
503− gotAccepted <- newEmptyMVar
504− dones <- replicateM numThreads $ do
505− done <- newEmptyMVar
506− forkTry $ do
507− -- It is possible that the remote endpoint just rejects the request by closing the socket
508− -- immediately (depending on far the remote endpoint got with the initialization)
509− response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
510− case response of
511− Right (_, ConnectionRequestAccepted) ->
512− -- We don't close this socket because we want to keep this connection open
513− putMVar gotAccepted ()
514− -- We might get either Invalid or Crossed (the transport does not
515− -- maintain enough history to be able to tell)
516− Right (sock, ConnectionRequestInvalid) ->
517− N.sClose sock
518− Right (sock, ConnectionRequestCrossed) ->
519− N.sClose sock
520− Left _ ->
521− return ()
522− putMVar done ()
523− return done
524−
525− mapM_ readMVar (gotAccepted : dones)
526− putMVar clientDone ()
527−
528− takeMVar clientDone
529−
530−-- | Test that we can create "many" transport instances
531−testMany :: IO N.ServiceName -> IO ()
532−testMany nextPort = do
533− Right masterTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
534− Right masterEndPoint <- newEndPoint masterTransport
535−
536− replicateM_ 10 $ do
537− mTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
538− case mTransport of
539− Left ex -> do
540− putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)
541− case (ioe_errno ex) of
542− Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"
543− _ -> return ()
544− throwIO ex
545− Right transport ->
546− replicateM_ 2 $ do
547− Right endpoint <- newEndPoint transport
548− Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered defaultConnectHints
549− return ()
550−
551−-- | Test what happens when the transport breaks completely
552−testBreakTransport :: IO N.ServiceName -> IO ()
553−testBreakTransport nextPort = do
554− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
555− Right endpoint <- newEndPoint transport
556−
557− killThread (transportThread internals) -- Uh oh
558−
559− ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint
560−
561− return ()
562−
563−-- | Test that a second call to 'connect' might succeed even if the first
564−-- failed. This is a TCP specific test rather than an endpoint specific test
565−-- because we must manually create the endpoint address to match an endpoint we
566−-- have yet to set up.
567−-- Then test that we get a connection lost message after the remote endpoint
568−-- suddenly closes the socket, and that a subsequent 'connect' allows us to
569−-- re-establish a connection to the same endpoint
570−testReconnect :: IO N.ServiceName -> IO ()
571−testReconnect nextPort = do
572− serverPort <- nextPort
573− serverDone <- newEmptyMVar
574− firstAttempt <- newEmptyMVar
575− endpointCreated <- newEmptyMVar
576−
577− -- Server
578− forkTry $ do
579− -- Wait for the client to do its first attempt
580− readMVar firstAttempt
581−
582− counter <- newMVar (0 :: Int)
583−
584− forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
585− -- Accept the connection
586− Right 0 <- tryIO $ (recvInt32 sock :: IO Int)
587− Right _ <- tryIO $ recvWithLength sock
588− Right () <- tryIO $ sendMany sock [encodeInt32 ConnectionRequestAccepted]
589−
590− -- The first time we close the socket before accepting the logical connection
591− count <- modifyMVar counter $ \i -> return (i + 1, i)
592−
593− when (count > 0) $ do
594− -- Client requests a logical connection
595− Right RequestConnectionId <- tryIO $ toEnum <$> (recvInt32 sock :: IO Int)
596− Right reqId <- tryIO $ (recvInt32 sock :: IO Int)
597− Right () <- tryIO $ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
598− return ()
599−
600− when (count > 1) $ do
601− -- Client sends a message
602− Right 10001 <- tryIO $ (recvInt32 sock :: IO Int)
603− Right ["ping"] <- tryIO $ recvWithLength sock
604− putMVar serverDone ()
605−
606− Right () <- tryIO $ N.sClose sock
607− return ()
608−
609− putMVar endpointCreated ()
610−
611− -- Client
612− forkTry $ do
613− Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
614− Right endpoint <- newEndPoint transport
615− let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
616−
617− -- The first attempt will fail because no endpoint is yet set up
618− -- Left (TransportError ConnectNotFound _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
619− putMVar firstAttempt ()
620−
621− -- The second attempt will fail because the server closes the socket before we can request a connection
622− takeMVar endpointCreated
623− -- This might time out or not, depending on whether the server closes the
624− -- socket before or after we can send the RequestConnectionId request
625− resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints
626− case resultConnect of
627− Nothing -> return ()
628− Just (Left (TransportError ConnectFailed _)) -> return ()
629− Just (Left err) -> throwIO err
630− Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
631−
632− -- The third attempt succeeds
633− Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
634−
635− -- But a send will fail because the server has closed the connection again
636− Left (TransportError SendFailed _) <- send conn1 ["ping"]
637− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
638−
639− -- But a subsequent call to connect should reestablish the connection
640− Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
641−
642− -- Send should now succeed
643− Right () <- send conn2 ["ping"]
644− return ()
645−
646− takeMVar serverDone
647−
648−-- Test what happens if we close the socket one way only. This means that the
649−-- 'recv' in 'handleIncomingMessages' will not fail, but a 'send' or 'connect'
650−-- *will* fail. We are testing that error handling everywhere does the right
651−-- thing.
652−testUnidirectionalError :: IO N.ServiceName -> IO ()
653−testUnidirectionalError nextPort = do
654− clientDone <- newEmptyMVar
655− serverPort <- nextPort
656− serverGotPing <- newEmptyMVar
657−
658− -- Server
659− forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
660− -- We accept connections, but when an exception occurs we don't do
661− -- anything (in particular, we don't close the socket). This is important
662− -- because when we shutdown one direction of the socket a recv here will
663− -- fail, but we don't want to close that socket at that point (which
664− -- would shutdown the socket in the other direction)
665− void . (try :: IO () -> IO (Either SomeException ())) $ do
666− 0 <- recvInt32 sock :: IO Int
667− _ <- recvWithLength sock
668− () <- sendMany sock [encodeInt32 ConnectionRequestAccepted]
669−
670− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
671− reqId <- recvInt32 sock :: IO Int
672− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
673−
674− 10001 <- recvInt32 sock :: IO Int
675− ["ping"] <- recvWithLength sock
676− putMVar serverGotPing ()
677−
678− -- Client
679− forkTry $ do
680− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
681− Right endpoint <- newEndPoint transport
682− let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
683−
684− -- Establish a connection to the server
685− Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
686− send conn1 ["ping"]
687− takeMVar serverGotPing
688−
689− -- Close the *outgoing* part of the socket only
690− sock <- socketBetween internals (address endpoint) theirAddr
691− N.shutdown sock N.ShutdownSend
692−
693− -- At this point we cannot notice the problem yet so we shouldn't receive an event yet
694− Nothing <- timeout 500000 $ receive endpoint
695−
696− -- But when we send we find the error
697− Left (TransportError SendFailed _) <- send conn1 ["ping"]
698− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
699−
700− -- A call to connect should now re-establish the connection
701− Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
702− send conn2 ["ping"]
703− takeMVar serverGotPing
704−
705− -- Again, close the outgoing part of the socket
706− sock' <- socketBetween internals (address endpoint) theirAddr
707− N.shutdown sock' N.ShutdownSend
708−
709− -- We now find the error when we attempt to close the connection
710− Nothing <- timeout 500000 $ receive endpoint
711− close conn2
712− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
713− Right conn3 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
714− send conn3 ["ping"]
715− takeMVar serverGotPing
716−
717− -- We repeat once more.
718− sock'' <- socketBetween internals (address endpoint) theirAddr
719− N.shutdown sock'' N.ShutdownSend
720−
721− -- Now we notice the problem when we try to connect
722− Nothing <- timeout 500000 $ receive endpoint
723− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
724− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
725− Right conn4 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
726− send conn4 ["ping"]
727− takeMVar serverGotPing
728−
729− putMVar clientDone ()
730−
731− takeMVar clientDone
732−
733−testInvalidCloseConnection :: IO N.ServiceName -> IO ()
734−testInvalidCloseConnection nextPort = do
735− Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
736− serverAddr <- newEmptyMVar
737− clientDone <- newEmptyMVar
738− serverDone <- newEmptyMVar
739−
740− -- Server
741− forkTry $ do
742− Right endpoint <- newEndPoint transport
743− putMVar serverAddr (address endpoint)
744−
745− ConnectionOpened _ _ _ <- receive endpoint
746−
747− -- At this point the client sends an invalid request, so we terminate the
748− -- connection
749− ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint
750−
751− putMVar serverDone ()
752−
753− -- Client
754− forkTry $ do
755− Right endpoint <- newEndPoint transport
756− let ourAddr = address endpoint
757−
758− -- Connect so that we have a TCP connection
759− theirAddr <- readMVar serverAddr
760− Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
761−
762− -- Get a handle on the TCP connection and manually send an invalid CloseConnection request
763− sock <- socketBetween internals ourAddr theirAddr
764− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (12345 :: Int)]
765−
766− putMVar clientDone ()
767−
768− mapM_ takeMVar [clientDone, serverDone]
769−
770−main :: IO ()
771−main = do
772− portMVar <- newEmptyMVar
773− forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
774− let nextPort = takeMVar portMVar
775− tcpResult <- tryIO $ runTests
776− [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
777− , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
778− , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
779− , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)
780− , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort 10)
781− , ("InvalidAddress", testInvalidAddress nextPort)
782− , ("InvalidConnect", testInvalidConnect nextPort)
783− , ("Many", testMany nextPort)
784− , ("BreakTransport", testBreakTransport nextPort)
785− , ("Reconnect", testReconnect nextPort)
786− , ("UnidirectionalError", testUnidirectionalError nextPort)
787− , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)
788− ]
789− -- Run the generic tests even if the TCP specific tests failed..
790− testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)
791− -- ..but if the generic tests pass, still fail if the specific tests did not
792− case tcpResult of
793− Left err -> throwIO err
794− Right () -> return ()
network-transport-tcp/tests/TestTransport.hsdeleted−964
@@ -1,964 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−module TestTransport where
3−
4−import Prelude hiding
5− ( (>>=)
6− , return
7− , fail
8− , (>>)
9−#if ! MIN_VERSION_base(4,6,0)
10− , catch
11−#endif
12− )
13−import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)
14−import Control.Concurrent (forkIO, killThread, yield)
15−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar, modifyMVar_, newMVar)
16−import Control.Exception (evaluate, throw, throwIO, bracket)
17−import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless)
18−import Control.Monad.Error ()
19−import Control.Applicative ((<$>))
20−import Network.Transport
21−import Network.Transport.Internal (tlog, tryIO, timeoutMaybe)
22−import Network.Transport.Util (spawn)
23−import System.Random (randomIO)
24−import Data.ByteString (ByteString)
25−import Data.ByteString.Char8 (pack)
26−import Data.Map (Map)
27−import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
28−import Data.String (fromString)
29−import Data.List (permutations)
30−import Traced
31−
32−-- | Server that echoes messages straight back to the origin endpoint.
33−echoServer :: EndPoint -> IO ()
34−echoServer endpoint = do
35− go Map.empty
36− where
37− go :: Map ConnectionId Connection -> IO ()
38− go cs = do
39− event <- receive endpoint
40− case event of
41− ConnectionOpened cid rel addr -> do
42− tlog $ "Opened new connection " ++ show cid
43− Right conn <- connect endpoint addr rel defaultConnectHints
44− go (Map.insert cid conn cs)
45− Received cid payload -> do
46− send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
47− go cs
48− ConnectionClosed cid -> do
49− tlog $ "Close connection " ++ show cid
50− close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
51− go (Map.delete cid cs)
52− ReceivedMulticast _ _ ->
53− -- Ignore
54− go cs
55− ErrorEvent _ ->
56− putStrLn $ "Echo server received error event: " ++ show event
57− EndPointClosed ->
58− return ()
59−
60−-- | Ping client used in a few tests
61−ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
62−ping endpoint server numPings msg = do
63− -- Open connection to the server
64− tlog "Connect to echo server"
65− Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
66−
67− -- Wait for the server to open reply connection
68− tlog "Wait for ConnectionOpened message"
69− ConnectionOpened cid _ _ <- receive endpoint
70−
71− -- Send pings and wait for reply
72− tlog "Send ping and wait for reply"
73− replicateM_ numPings $ do
74− send conn [msg]
75− Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg
76− return ()
77−
78− -- Close the connection
79− tlog "Close the connection"
80− close conn
81−
82− -- Wait for the server to close its connection to us
83− tlog "Wait for ConnectionClosed message"
84− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
85−
86− -- Done
87− tlog "Ping client done"
88−
89−-- | Basic ping test
90−testPingPong :: Transport -> Int -> IO ()
91−testPingPong transport numPings = do
92− tlog "Starting ping pong test"
93− server <- spawn transport echoServer
94− result <- newEmptyMVar
95−
96− -- Client
97− forkTry $ do
98− tlog "Ping client"
99− Right endpoint <- newEndPoint transport
100− ping endpoint server numPings "ping"
101− putMVar result ()
102−
103− takeMVar result
104−
105−-- | Test that endpoints don't get confused
106−testEndPoints :: Transport -> Int -> IO ()
107−testEndPoints transport numPings = do
108− server <- spawn transport echoServer
109− dones <- replicateM 2 newEmptyMVar
110−
111− forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
112− let name' :: ByteString
113− name' = pack [name]
114− Right endpoint <- newEndPoint transport
115− tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)
116− ping endpoint server numPings name'
117− putMVar done ()
118−
119− forM_ dones takeMVar
120−
121−-- Test that connections don't get confused
122−testConnections :: Transport -> Int -> IO ()
123−testConnections transport numPings = do
124− server <- spawn transport echoServer
125− result <- newEmptyMVar
126−
127− -- Client
128− forkTry $ do
129− Right endpoint <- newEndPoint transport
130−
131− -- Open two connections to the server
132− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
133− ConnectionOpened serv1 _ _ <- receive endpoint
134−
135− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
136− ConnectionOpened serv2 _ _ <- receive endpoint
137−
138− -- One thread to send "pingA" on the first connection
139− forkTry $ replicateM_ numPings $ send conn1 ["pingA"]
140−
141− -- One thread to send "pingB" on the second connection
142− forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
143−
144− -- Verify server responses
145− let verifyResponse 0 = putMVar result ()
146− verifyResponse n = do
147− event <- receive endpoint
148− case event of
149− Received cid [payload] -> do
150− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
151− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
152− verifyResponse (n - 1)
153− _ ->
154− verifyResponse n
155− verifyResponse (2 * numPings)
156−
157− takeMVar result
158−
159−-- | Test that closing one connection does not close the other
160−testCloseOneConnection :: Transport -> Int -> IO ()
161−testCloseOneConnection transport numPings = do
162− server <- spawn transport echoServer
163− result <- newEmptyMVar
164−
165− -- Client
166− forkTry $ do
167− Right endpoint <- newEndPoint transport
168−
169− -- Open two connections to the server
170− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
171− ConnectionOpened serv1 _ _ <- receive endpoint
172−
173− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
174− ConnectionOpened serv2 _ _ <- receive endpoint
175−
176− -- One thread to send "pingA" on the first connection
177− forkTry $ do
178− replicateM_ numPings $ send conn1 ["pingA"]
179− close conn1
180−
181− -- One thread to send "pingB" on the second connection
182− forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
183−
184− -- Verify server responses
185− let verifyResponse 0 = putMVar result ()
186− verifyResponse n = do
187− event <- receive endpoint
188− case event of
189− Received cid [payload] -> do
190− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
191− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
192− verifyResponse (n - 1)
193− _ ->
194− verifyResponse n
195− verifyResponse (3 * numPings)
196−
197− takeMVar result
198−
199−-- | Test that if A connects to B and B connects to A, B can still send to A after
200−-- A closes its connection to B (for instance, in the TCP transport, the socket pair
201−-- connecting A and B should not yet be closed).
202−testCloseOneDirection :: Transport -> Int -> IO ()
203−testCloseOneDirection transport numPings = do
204− addrA <- newEmptyMVar
205− addrB <- newEmptyMVar
206− doneA <- newEmptyMVar
207− doneB <- newEmptyMVar
208−
209− -- A
210− forkTry $ do
211− tlog "A"
212− Right endpoint <- newEndPoint transport
213− tlog (show (address endpoint))
214− putMVar addrA (address endpoint)
215−
216− -- Connect to B
217− tlog "Connect to B"
218− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
219−
220− -- Wait for B to connect to us
221− tlog "Wait for B"
222− ConnectionOpened cid _ _ <- receive endpoint
223−
224− -- Send pings to B
225− tlog "Send pings to B"
226− replicateM_ numPings $ send conn ["ping"]
227−
228− -- Close our connection to B
229− tlog "Close connection"
230− close conn
231−
232− -- Wait for B's pongs
233− tlog "Wait for pongs from B"
234− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
235−
236− -- Wait for B to close it's connection to us
237− tlog "Wait for B to close connection"
238− ConnectionClosed cid' <- receive endpoint
239− guard (cid == cid')
240−
241− -- Done
242− tlog "Done"
243− putMVar doneA ()
244−
245− -- B
246− forkTry $ do
247− tlog "B"
248− Right endpoint <- newEndPoint transport
249− tlog (show (address endpoint))
250− putMVar addrB (address endpoint)
251−
252− -- Wait for A to connect
253− tlog "Wait for A to connect"
254− ConnectionOpened cid _ _ <- receive endpoint
255−
256− -- Connect to A
257− tlog "Connect to A"
258− Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
259−
260− -- Wait for A's pings
261− tlog "Wait for pings from A"
262− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
263−
264− -- Wait for A to close it's connection to us
265− tlog "Wait for A to close connection"
266− ConnectionClosed cid' <- receive endpoint
267− guard (cid == cid')
268−
269− -- Send pongs to A
270− tlog "Send pongs to A"
271− replicateM_ numPings $ send conn ["pong"]
272−
273− -- Close our connection to A
274− tlog "Close connection to A"
275− close conn
276−
277− -- Done
278− tlog "Done"
279− putMVar doneB ()
280−
281− mapM_ takeMVar [doneA, doneB]
282−
283−-- | Collect events and order them by connection ID
284−collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString]])]
285−collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
286− where
287− -- TODO: for more serious use of this function we'd need to make these arguments strict
288− go (Just 0) open closed = finish open closed
289− go n open closed = do
290− mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint
291− case mEvent of
292− Left _ -> finish open closed
293− Right event -> do
294− let n' = (\x -> x - 1) <$> n
295− case event of
296− ConnectionOpened cid _ _ ->
297− go n' (Map.insert cid [] open) closed
298− ConnectionClosed cid ->
299− let list = Map.findWithDefault (error "Invalid ConnectionClosed") cid open in
300− go n' (Map.delete cid open) (Map.insert cid list closed)
301− Received cid msg ->
302− go n' (Map.adjust (msg :) cid open) closed
303− ReceivedMulticast _ _ ->
304− fail "Unexpected multicast"
305− ErrorEvent _ ->
306− fail "Unexpected error"
307− EndPointClosed ->
308− fail "Unexpected endpoint closure"
309−
310− finish open closed =
311− if Map.null open
312− then return . Map.toList . Map.map reverse $ closed
313− else fail $ "Open connections: " ++ show (map fst . Map.toList $ open)
314−
315−-- | Open connection, close it, then reopen it
316−-- (In the TCP transport this means the socket will be closed, then reopened)
317−--
318−-- Note that B cannot expect to receive all of A's messages on the first connection
319−-- before receiving the messages on the second connection. What might (and sometimes
320−-- does) happen is that finishes sending all of its messages on the first connection
321−-- (in the TCP transport, the first socket pair) while B is behind on reading _from_
322−-- this connection (socket pair) -- the messages are "in transit" on the network
323−-- (these tests are done on localhost, so there are in some OS buffer). Then when
324−-- A opens the second connection (socket pair) B will spawn a new thread for this
325−-- connection, and hence might start interleaving messages from the first and second
326−-- connection.
327−--
328−-- This is correct behaviour, however: the transport API guarantees reliability and
329−-- ordering _per connection_, but not _across_ connections.
330−testCloseReopen :: Transport -> Int -> IO ()
331−testCloseReopen transport numPings = do
332− addrB <- newEmptyMVar
333− doneB <- newEmptyMVar
334−
335− let numRepeats = 2 :: Int
336−
337− -- A
338− forkTry $ do
339− Right endpoint <- newEndPoint transport
340−
341− forM_ [1 .. numRepeats] $ \i -> do
342− tlog "A connecting"
343− -- Connect to B
344− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
345−
346− tlog "A pinging"
347− -- Say hi
348− forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]
349−
350− tlog "A closing"
351− -- Disconnect again
352− close conn
353−
354− tlog "A finishing"
355−
356− -- B
357− forkTry $ do
358− Right endpoint <- newEndPoint transport
359− putMVar addrB (address endpoint)
360−
361− eventss <- collect endpoint (Just (numRepeats * (numPings + 2))) Nothing
362−
363− forM_ (zip [1 .. numRepeats] eventss) $ \(i, (_, events)) -> do
364− forM_ (zip [1 .. numPings] events) $ \(j, event) -> do
365− guard (event == [pack $ "ping" ++ show i ++ "/" ++ show j])
366−
367− putMVar doneB ()
368−
369− takeMVar doneB
370−
371−-- | Test lots of parallel connection attempts
372−testParallelConnects :: Transport -> Int -> IO ()
373−testParallelConnects transport numPings = do
374− server <- spawn transport echoServer
375− done <- newEmptyMVar
376−
377− Right endpoint <- newEndPoint transport
378−
379− -- Spawn lots of clients
380− forM_ [1 .. numPings] $ \i -> forkTry $ do
381− Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
382− send conn [pack $ "ping" ++ show i]
383− send conn [pack $ "ping" ++ show i]
384− close conn
385−
386− forkTry $ do
387− eventss <- collect endpoint (Just (numPings * 4)) Nothing
388− -- Check that no pings got sent to the wrong connection
389− forM_ eventss $ \(_, [[ping1], [ping2]]) ->
390− guard (ping1 == ping2)
391− putMVar done ()
392−
393− takeMVar done
394−
395−-- | Test that sending on a closed connection gives an error
396−testSendAfterClose :: Transport -> Int -> IO ()
397−testSendAfterClose transport numRepeats = do
398− server <- spawn transport echoServer
399− clientDone <- newEmptyMVar
400−
401− forkTry $ do
402− Right endpoint <- newEndPoint transport
403−
404− -- We request two lightweight connections
405− replicateM numRepeats $ do
406− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
407− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
408−
409− -- Close the second, but leave the first open; then output on the second
410− -- connection (i.e., on a closed connection while there is still another
411− -- connection open)
412− close conn2
413− Left (TransportError SendClosed _) <- send conn2 ["ping2"]
414−
415− -- Now close the first connection, and output on it (i.e., output while
416− -- there are no lightweight connection at all anymore)
417− close conn1
418− Left (TransportError SendClosed _) <- send conn2 ["ping2"]
419−
420− return ()
421−
422− putMVar clientDone ()
423−
424− takeMVar clientDone
425−
426−-- | Test that closing the same connection twice has no effect
427−testCloseTwice :: Transport -> Int -> IO ()
428−testCloseTwice transport numRepeats = do
429− server <- spawn transport echoServer
430− clientDone <- newEmptyMVar
431−
432− forkTry $ do
433− Right endpoint <- newEndPoint transport
434−
435− replicateM numRepeats $ do
436− -- We request two lightweight connections
437− Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
438− Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
439−
440− -- Close the second one twice
441− close conn2
442− close conn2
443−
444− -- Then send a message on the first and close that twice too
445− send conn1 ["ping"]
446− close conn1
447−
448− -- Verify expected response from the echo server
449− ConnectionOpened cid1 _ _ <- receive endpoint
450− ConnectionOpened cid2 _ _ <- receive endpoint
451− ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
452− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
453− ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
454−
455− return ()
456−
457− putMVar clientDone ()
458−
459− takeMVar clientDone
460−
461−-- | Test that we can connect an endpoint to itself
462−testConnectToSelf :: Transport -> Int -> IO ()
463−testConnectToSelf transport numPings = do
464− done <- newEmptyMVar
465− Right endpoint <- newEndPoint transport
466−
467− tlog "Creating self-connection"
468− Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
469−
470− tlog "Talk to myself"
471−
472− -- One thread to write to the endpoint
473− forkTry $ do
474− tlog $ "writing"
475−
476− tlog $ "Sending ping"
477− replicateM_ numPings $ send conn ["ping"]
478−
479− tlog $ "Closing connection"
480− close conn
481−
482− -- And one thread to read
483− forkTry $ do
484− tlog $ "reading"
485−
486− tlog "Waiting for ConnectionOpened"
487− ConnectionOpened cid _ addr <- receive endpoint ; True <- return $ addr == address endpoint
488−
489− tlog "Waiting for Received"
490− replicateM_ numPings $ do
491− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
492− return ()
493−
494− tlog "Waiting for ConnectionClosed"
495− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
496−
497− tlog "Done"
498− putMVar done ()
499−
500− takeMVar done
501−
502−-- | Test that we can connect an endpoint to itself multiple times
503−testConnectToSelfTwice :: Transport -> Int -> IO ()
504−testConnectToSelfTwice transport numPings = do
505− done <- newEmptyMVar
506− Right endpoint <- newEndPoint transport
507−
508− tlog "Creating self-connection"
509− Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
510− Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
511−
512− tlog "Talk to myself"
513−
514− -- One thread to write to the endpoint using the first connection
515− forkTry $ do
516− tlog $ "writing"
517−
518− tlog $ "Sending ping"
519− replicateM_ numPings $ send conn1 ["pingA"]
520−
521− tlog $ "Closing connection"
522− close conn1
523−
524− -- One thread to write to the endpoint using the second connection
525− forkTry $ do
526− tlog $ "writing"
527−
528− tlog $ "Sending ping"
529− replicateM_ numPings $ send conn2 ["pingB"]
530−
531− tlog $ "Closing connection"
532− close conn2
533−
534− -- And one thread to read
535− forkTry $ do
536− tlog $ "reading"
537−
538− [(_, events1), (_, events2)] <- collect endpoint (Just (2 * (numPings + 2))) Nothing
539− True <- return $ events1 == replicate numPings ["pingA"]
540− True <- return $ events2 == replicate numPings ["pingB"]
541−
542− tlog "Done"
543− putMVar done ()
544−
545− takeMVar done
546−
547−-- | Test that we self-connections no longer work once we close our endpoint
548−-- or our transport
549−testCloseSelf :: IO (Either String Transport) -> IO ()
550−testCloseSelf newTransport = do
551− Right transport <- newTransport
552− Right endpoint1 <- newEndPoint transport
553− Right endpoint2 <- newEndPoint transport
554− Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
555− Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
556− Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
557−
558− -- Close the conneciton and try to send
559− close conn1
560− Left (TransportError SendClosed _) <- send conn1 ["ping"]
561−
562− -- Close the first endpoint. We should not be able to use the first
563− -- connection anymore, or open more self connections, but the self connection
564− -- to the second endpoint should still be fine
565− closeEndPoint endpoint1
566− Left (TransportError SendFailed _) <- send conn2 ["ping"]
567− Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
568− Right () <- send conn3 ["ping"]
569−
570− -- Close the transport; now the second should no longer work
571− closeTransport transport
572− Left (TransportError SendFailed _) <- send conn3 ["ping"]
573− Left (TransportError ConnectFailed _) <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
574−
575− return ()
576−
577−-- | Test various aspects of 'closeEndPoint'
578−testCloseEndPoint :: Transport -> Int -> IO ()
579−testCloseEndPoint transport _ = do
580− serverDone <- newEmptyMVar
581− clientDone <- newEmptyMVar
582− clientAddr1 <- newEmptyMVar
583− clientAddr2 <- newEmptyMVar
584− serverAddr <- newEmptyMVar
585−
586− -- Server
587− forkTry $ do
588− Right endpoint <- newEndPoint transport
589− putMVar serverAddr (address endpoint)
590−
591− -- First test (see client)
592− do
593− theirAddr <- readMVar clientAddr1
594− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
595− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
596− return ()
597−
598− -- Second test
599− do
600− theirAddr <- readMVar clientAddr2
601−
602− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
603− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
604−
605− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
606− send conn ["pong"]
607−
608− ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''
609− ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint ; True <- return $ addr' == theirAddr
610−
611− Left (TransportError SendFailed _) <- send conn ["pong2"]
612−
613− return ()
614−
615− putMVar serverDone ()
616−
617− -- Client
618− forkTry $ do
619− theirAddr <- readMVar serverAddr
620−
621− -- First test: close endpoint with one outgoing but no incoming connections
622− do
623− Right endpoint <- newEndPoint transport
624− putMVar clientAddr1 (address endpoint)
625−
626− -- Connect to the server, then close the endpoint without disconnecting explicitly
627− Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
628− closeEndPoint endpoint
629− EndPointClosed <- receive endpoint
630− return ()
631−
632− -- Second test: close endpoint with one outgoing and one incoming connection
633− do
634− Right endpoint <- newEndPoint transport
635− putMVar clientAddr2 (address endpoint)
636−
637− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
638− send conn ["ping"]
639−
640− -- Reply from the server
641− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
642− Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'
643−
644− -- Close the endpoint
645− closeEndPoint endpoint
646− EndPointClosed <- receive endpoint
647−
648− -- Attempt to send should fail with connection closed
649− Left (TransportError SendFailed _) <- send conn ["ping2"]
650−
651− -- An attempt to close the already closed connection should just return
652− () <- close conn
653−
654− -- And so should an attempt to connect
655− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
656−
657− return ()
658−
659− putMVar clientDone ()
660−
661− mapM_ takeMVar [serverDone, clientDone]
662−
663−-- Test closeTransport
664−--
665−-- This tests many of the same things that testEndPoint does, and some more
666−testCloseTransport :: IO (Either String Transport) -> IO ()
667−testCloseTransport newTransport = do
668− serverDone <- newEmptyMVar
669− clientDone <- newEmptyMVar
670− clientAddr1 <- newEmptyMVar
671− clientAddr2 <- newEmptyMVar
672− serverAddr <- newEmptyMVar
673−
674− -- Server
675− forkTry $ do
676− Right transport <- newTransport
677− Right endpoint <- newEndPoint transport
678− putMVar serverAddr (address endpoint)
679−
680− -- Client sets up first endpoint
681− theirAddr1 <- readMVar clientAddr1
682− ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
683−
684− -- Client sets up second endpoint
685− theirAddr2 <- readMVar clientAddr2
686−
687− ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
688− Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
689−
690− Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints
691− send conn ["pong"]
692−
693− -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however)
694− evs <- replicateM 3 $ receive endpoint
695− let expected = [ ConnectionClosed cid1
696− , ConnectionClosed cid2
697− , ErrorEvent (TransportError (EventConnectionLost (Just theirAddr2) []) "")
698− ]
699− True <- return $ any (== expected) (permutations evs)
700−
701− -- An attempt to send to the endpoint should now fail
702− Left (TransportError SendFailed _) <- send conn ["pong2"]
703−
704− putMVar serverDone ()
705−
706− -- Client
707− forkTry $ do
708− Right transport <- newTransport
709− theirAddr <- readMVar serverAddr
710−
711− -- Set up endpoint with one outgoing but no incoming connections
712− Right endpoint1 <- newEndPoint transport
713− putMVar clientAddr1 (address endpoint1)
714−
715− -- Connect to the server, then close the endpoint without disconnecting explicitly
716− Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
717−
718− -- Set up an endpoint with one outgoing and out incoming connection
719− Right endpoint2 <- newEndPoint transport
720− putMVar clientAddr2 (address endpoint2)
721−
722− Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
723− send conn ["ping"]
724−
725− -- Reply from the server
726− ConnectionOpened cid ReliableOrdered addr <- receive endpoint2 ; True <- return $ addr == theirAddr
727− Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid'
728−
729− -- Now shut down the entire transport
730− closeTransport transport
731−
732− -- Both endpoints should report that they have been closed
733− EndPointClosed <- receive endpoint1
734− EndPointClosed <- receive endpoint2
735−
736− -- Attempt to send should fail with connection closed
737− Left (TransportError SendFailed _) <- send conn ["ping2"]
738−
739− -- An attempt to close the already closed connection should just return
740− () <- close conn
741−
742− -- And so should an attempt to connect on either endpoint
743− Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
744− Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
745−
746− -- And finally, so should an attempt to create a new endpoint
747− Left (TransportError NewEndPointFailed _) <- newEndPoint transport
748−
749− putMVar clientDone ()
750−
751− mapM_ takeMVar [serverDone, clientDone]
752−
753−-- | Remote node attempts to connect to a closed local endpoint
754−testConnectClosedEndPoint :: Transport -> IO ()
755−testConnectClosedEndPoint transport = do
756− serverAddr <- newEmptyMVar
757− serverClosed <- newEmptyMVar
758− clientDone <- newEmptyMVar
759−
760− -- Server
761− forkTry $ do
762− Right endpoint <- newEndPoint transport
763− putMVar serverAddr (address endpoint)
764−
765− closeEndPoint endpoint
766− putMVar serverClosed ()
767−
768− -- Client
769− forkTry $ do
770− Right endpoint <- newEndPoint transport
771− readMVar serverClosed
772−
773− Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
774−
775− putMVar clientDone ()
776−
777− takeMVar clientDone
778−
779−-- | We should receive an exception when doing a 'receive' after we have been
780−-- notified that an endpoint has been closed
781−testExceptionOnReceive :: IO (Either String Transport) -> IO ()
782−testExceptionOnReceive newTransport = do
783− Right transport <- newTransport
784−
785− -- Test one: when we close an endpoint specifically
786− Right endpoint1 <- newEndPoint transport
787− closeEndPoint endpoint1
788− EndPointClosed <- receive endpoint1
789− Left _ <- trySome (receive endpoint1 >>= evaluate)
790−
791− -- Test two: when we close the entire transport
792− Right endpoint2 <- newEndPoint transport
793− closeTransport transport
794− EndPointClosed <- receive endpoint2
795− Left _ <- trySome (receive endpoint2 >>= evaluate)
796−
797− return ()
798−
799−-- | Test what happens when the argument to 'send' is an exceptional value
800−testSendException :: IO (Either String Transport) -> IO ()
801−testSendException newTransport = do
802− Right transport <- newTransport
803− Right endpoint1 <- newEndPoint transport
804− Right endpoint2 <- newEndPoint transport
805−
806− -- Connect endpoint1 to endpoint2
807− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
808− ConnectionOpened _ _ _ <- receive endpoint2
809−
810− -- Send an exceptional value
811− Left (TransportError SendFailed _) <- send conn (throw $ userError "uhoh")
812−
813− -- This will have been as a failure to send by endpoint1, which will
814− -- therefore have closed the socket. In turn this will have caused endpoint2
815− -- to report that the connection was lost
816− ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint1
817− ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2
818−
819− -- A new connection will re-establish the connection
820− Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
821− send conn2 ["ping"]
822− close conn2
823−
824− ConnectionOpened _ _ _ <- receive endpoint2
825− Received _ ["ping"] <- receive endpoint2
826− ConnectionClosed _ <- receive endpoint2
827−
828− return ()
829−
830−-- | If threads get killed while executing a 'connect', 'send', or 'close', this
831−-- should not affect other threads.
832−--
833−-- The intention of this test is to see what happens when a asynchronous
834−-- exception happes _while executing a send_. This is exceedingly difficult to
835−-- guarantee, however. Hence we run a large number of tests and insert random
836−-- thread delays -- and even then it might not happen. Moreover, it will only
837−-- happen when we run on multiple cores.
838−testKill :: IO (Either String Transport) -> Int -> IO ()
839−testKill newTransport numThreads = do
840− Right transport1 <- newTransport
841− Right transport2 <- newTransport
842− Right endpoint1 <- newEndPoint transport1
843− Right endpoint2 <- newEndPoint transport2
844−
845− threads <- replicateM numThreads . forkIO $ do
846− randomThreadDelay 100
847− bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)
848− -- Note that we should not insert a randomThreadDelay into the
849− -- exception handler itself as this means that the exception handler
850− -- could be interrupted and we might not close
851− (\(Right conn) -> close conn)
852− (\(Right conn) -> do randomThreadDelay 100
853− Right () <- send conn ["ping"]
854− randomThreadDelay 100)
855−
856− numAlive <- newMVar (0 :: Int)
857−
858− -- Kill half of those threads
859− forkIO . forM_ threads $ \tid -> do
860− shouldKill <- randomIO
861− if shouldKill
862− then randomThreadDelay 600 >> killThread tid
863− else modifyMVar_ numAlive (return . (+ 1))
864−
865− -- Since it is impossible to predict when the kill exactly happens, we don't
866− -- know how many connects were opened and how many pings were sent. But we
867− -- should not have any open connections (if we do, collect will throw an
868− -- error) and we should have at least the number of pings equal to the number
869− -- of threads we did *not* kill
870− eventss <- collect endpoint2 Nothing (Just 1000000)
871− let actualPings = sum . map (length . snd) $ eventss
872− expectedPings <- takeMVar numAlive
873− unless (actualPings >= expectedPings) $
874− throwIO (userError "Missing pings")
875−
876−-- print (actualPings, expectedPings)
877−
878−
879−-- | Set up conditions with a high likelyhood of "crossing" (for transports
880−-- that multiplex lightweight connections across heavyweight connections)
881−testCrossing :: Transport -> Int -> IO ()
882−testCrossing transport numRepeats = do
883− [aAddr, bAddr] <- replicateM 2 newEmptyMVar
884− [aDone, bDone] <- replicateM 2 newEmptyMVar
885− [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar
886− go <- newEmptyMVar
887−
888− let hints = defaultConnectHints {
889− connectTimeout = Just 5000000
890− }
891−
892− -- A
893− forkTry $ do
894− Right endpoint <- newEndPoint transport
895− putMVar aAddr (address endpoint)
896− theirAddress <- readMVar bAddr
897−
898− replicateM_ numRepeats $ do
899− takeMVar go >> yield
900− -- Because we are creating lots of connections, it's possible that
901− -- connect times out (for instance, in the TCP transport,
902− -- Network.Socket.connect may time out). We shouldn't regard this as an
903− -- error in the Transport, though.
904− connectResult <- connect endpoint theirAddress ReliableOrdered hints
905− case connectResult of
906− Right conn -> close conn
907− Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()
908− Left (TransportError ConnectFailed _) -> readMVar bTimeout
909− Left err -> throwIO . userError $ "testCrossed: " ++ show err
910− putMVar aDone ()
911−
912− -- B
913− forkTry $ do
914− Right endpoint <- newEndPoint transport
915− putMVar bAddr (address endpoint)
916− theirAddress <- readMVar aAddr
917−
918− replicateM_ numRepeats $ do
919− takeMVar go >> yield
920− connectResult <- connect endpoint theirAddress ReliableOrdered hints
921− case connectResult of
922− Right conn -> close conn
923− Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
924− Left (TransportError ConnectFailed _) -> readMVar aTimeout
925− Left err -> throwIO . userError $ "testCrossed: " ++ show err
926− putMVar bDone ()
927−
928− -- Driver
929− forM_ [1 .. numRepeats] $ \_i -> do
930− -- putStrLn $ "Round " ++ show _i
931− tryTakeMVar aTimeout
932− tryTakeMVar bTimeout
933− putMVar go ()
934− putMVar go ()
935− takeMVar aDone
936− takeMVar bDone
937−
938−-- Transport tests
939−testTransport :: IO (Either String Transport) -> IO ()
940−testTransport newTransport = do
941− Right transport <- newTransport
942− runTests
943− [ ("PingPong", testPingPong transport numPings)
944− , ("EndPoints", testEndPoints transport numPings)
945− , ("Connections", testConnections transport numPings)
946− , ("CloseOneConnection", testCloseOneConnection transport numPings)
947− , ("CloseOneDirection", testCloseOneDirection transport numPings)
948− , ("CloseReopen", testCloseReopen transport numPings)
949− , ("ParallelConnects", testParallelConnects transport numPings)
950− , ("SendAfterClose", testSendAfterClose transport 100)
951− , ("Crossing", testCrossing transport 10)
952− , ("CloseTwice", testCloseTwice transport 100)
953− , ("ConnectToSelf", testConnectToSelf transport numPings)
954− , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
955− , ("CloseSelf", testCloseSelf newTransport)
956− , ("CloseEndPoint", testCloseEndPoint transport numPings)
957− , ("CloseTransport", testCloseTransport newTransport)
958− , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
959− , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
960− , ("SendException", testSendException newTransport)
961− , ("Kill", testKill newTransport 1000)
962− ]
963− where
964− numPings = 10000 :: Int
network-transport-tcp/tests/Traced.hsdeleted−199
@@ -1,199 +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
54− ( (>>=)
55− , return
56− , fail
57− , (>>)
58−#if ! MIN_VERSION_base(4,6,0)
59− , catch
60−#endif
61− )
62−import qualified Prelude
63−import Control.Exception (catches, Handler(..), SomeException, throwIO, Exception(..), IOException)
64−import Control.Applicative ((<$>))
65−import Data.Typeable (Typeable)
66−import Data.Maybe (catMaybes)
67−import Data.ByteString (ByteString)
68−import Data.Int (Int32)
69−import Control.Concurrent.MVar (MVar)
70−
71−--------------------------------------------------------------------------------
72−-- MonadS class --
73−--------------------------------------------------------------------------------
74−
75−-- | Like 'Monad' but bind is only defined for 'Trace'able instances
76−class MonadS m where
77− returnS :: a -> m a
78− bindS :: Traceable a => m a -> (a -> m b) -> m b
79− failS :: String -> m a
80− seqS :: m a -> m b -> m b
81−
82−-- | Redefinition of 'Prelude.>>='
83−(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
84−(>>=) = bindS
85−
86−-- | Redefinition of 'Prelude.>>'
87−(>>) :: MonadS m => m a -> m b -> m b
88−(>>) = seqS
89−
90−-- | Redefinition of 'Prelude.return'
91−return :: MonadS m => a -> m a
92−return = returnS
93−
94−-- | Redefinition of 'Prelude.fail'
95−fail :: MonadS m => String -> m a
96−fail = failS
97−
98−--------------------------------------------------------------------------------
99−-- Trace typeclass (for adding elements to a trace --
100−--------------------------------------------------------------------------------
101−
102−data Showable = forall a. Show a => Showable a
103−
104−instance Show Showable where
105− show (Showable x) = show x
106−
107−mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
108−mapShowable f (Showable x) = f x
109−
110−traceShow :: Show a => a -> Maybe Showable
111−traceShow = Just . Showable
112−
113−class Traceable a where
114− trace :: a -> Maybe Showable
115−
116−instance (Traceable a, Traceable b) => Traceable (Either a b) where
117− trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
118− trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
119−
120−instance (Traceable a, Traceable b) => Traceable (a, b) where
121− trace (x, y) = case (trace x, trace y) of
122− (Nothing, Nothing) -> Nothing
123− (Just t1, Nothing) -> traceShow t1
124− (Nothing, Just t2) -> traceShow t2
125− (Just t1, Just t2) -> traceShow (t1, t2)
126−
127−instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
128− trace (x, y, z) = case (trace x, trace y, trace z) of
129− (Nothing, Nothing, Nothing) -> Nothing
130− (Just t1, Nothing, Nothing) -> traceShow t1
131− (Nothing, Just t2, Nothing) -> traceShow t2
132− (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
133− (Nothing, Nothing, Just t3) -> traceShow t3
134− (Just t1, Nothing, Just t3) -> traceShow (t1, t3)
135− (Nothing, Just t2, Just t3) -> traceShow (t2, t3)
136− (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
137−
138−instance Traceable a => Traceable (Maybe a) where
139− trace Nothing = traceShow (Nothing :: Maybe ())
140− trace (Just x) = mapShowable (Showable . Just) <$> trace x
141−
142−instance Traceable a => Traceable [a] where
143− trace = traceShow . catMaybes . map trace
144−
145−instance Traceable () where
146− trace = const Nothing
147−
148−instance Traceable Int where
149− trace = traceShow
150−
151−instance Traceable Int32 where
152− trace = traceShow
153−
154−instance Traceable Bool where
155− trace = const Nothing
156−
157−instance Traceable ByteString where
158− trace = traceShow
159−
160−instance Traceable (MVar a) where
161− trace = const Nothing
162−
163−instance Traceable [Char] where
164− trace = traceShow
165−
166−instance Traceable IOException where
167− trace = traceShow
168−
169−--------------------------------------------------------------------------------
170−-- IO instance for MonadS --
171−--------------------------------------------------------------------------------
172−
173−data TracedException = TracedException [String] SomeException
174− deriving Typeable
175−
176−instance Exception TracedException
177−
178−-- | Add tracing to 'IO' (see examples)
179−instance MonadS IO where
180− returnS = Prelude.return
181− bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
182− failS = Prelude.fail
183− seqS = (Prelude.>>)
184−
185−instance Show TracedException where
186− show (TracedException ts ex) =
187− show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))
188−
189−traceHandlers :: Traceable a => a -> [Handler b]
190−traceHandlers a = case trace a of
191− Nothing -> [ Handler $ \ex -> throwIO (ex :: SomeException) ]
192− Just t -> [ Handler $ \(TracedException ts ex) -> throwIO $ TracedException (show t : ts) ex
193− , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)
194− ]
195−
196−-- | Definition of 'ifThenElse' for use with RebindableSyntax
197−ifThenElse :: Bool -> a -> a -> a
198−ifThenElse True x _ = x
199−ifThenElse False _ y = y
network-transport/ChangeLogdeleted−12
@@ -1,12 +0,0 @@
1−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2
2−
3−* Base 4.6 compatible test suites
4−* Relax package constraints for bytestring
5−
6−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
7−
8−* Hide catch only for base < 4.6
9−
10−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
11−
12−* Initial release.
network-transport/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
network-transport/network-transport.cabaldeleted−81
@@ -1,81 +0,0 @@
1−Name: network-transport
2−Version: 0.2.0.2
3−Cabal-Version: >=1.6
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: Network abstraction layer
14−Description: "Network.Transport" is a Network Abstraction Layer which provides
15− the following high-level concepts:
16− .
17− * Nodes in the network are represented by 'EndPoint's. These are
18− heavyweight stateful objects.
19− .
20− * Each 'EndPoint' has an 'EndPointAddress'.
21− .
22− * Connections can be established from one 'EndPoint' to another
23− using the 'EndPointAddress' of the remote end.
24− .
25− * The 'EndPointAddress' can be serialised and sent over the
26− network, where as 'EndPoint's and connections cannot.
27− .
28− * Connections between 'EndPoint's are unidirectional and lightweight.
29− .
30− * Outgoing messages are sent via a 'Connection' object that
31− represents the sending end of the connection.
32− .
33− * Incoming messages for /all/ of the incoming connections on
34− an 'EndPoint' are collected via a shared receive queue.
35− .
36− * In addition to incoming messages, 'EndPoint's are notified of
37− other 'Event's such as new connections or broken connections.
38− .
39− This design was heavily influenced by the design of the Common
40− Communication Interface
41− (<http://www.olcf.ornl.gov/center-projects/common-communication-interface>).
42− Important design goals are:
43− .
44− * Connections should be lightweight: it should be no problem to
45− create thousands of connections between endpoints.
46− .
47− * Error handling is explicit: every function declares as part of
48− its type which errors it can return (no exceptions are thrown)
49− .
50− * Error handling is "abstract": errors that originate from
51− implementation specific problems (such as "no more sockets" in
52− the TCP implementation) get mapped to generic errors
53− ("insufficient resources") at the Transport level.
54− .
55− This package provides the generic interface only; you will
56− probably also want to install at least one transport
57− implementation (network-transport-*).
58−Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
59−Category: Network
60−
61−Source-Repository head
62− Type: git
63− Location: https://github.com/haskell-distributed/distributed-process
64− SubDir: network-transport
65−
66−Library
67− Build-Depends: base >= 4.3 && < 5,
68− binary >= 0.5 && < 0.6,
69− bytestring >= 0.9 && < 0.11,
70− transformers >= 0.2 && < 0.4
71− Exposed-Modules: Network.Transport,
72− Network.Transport.Util
73− Network.Transport.Internal
74− Extensions: ForeignFunctionInterface,
75− RankNTypes,
76− ScopedTypeVariables,
77− DeriveDataTypeable,
78− GeneralizedNewtypeDeriving,
79− CPP
80− GHC-Options: -Wall -fno-warn-unused-do-bind
81− HS-Source-Dirs: src
network-transport/src/Network/Transport.hsdeleted−226
@@ -1,226 +0,0 @@
1−-- | Network Transport
2−module Network.Transport ( -- * Types
3− Transport(..)
4− , EndPoint(..)
5− , Connection(..)
6− , Event(..)
7− , ConnectionId
8− , Reliability(..)
9− , MulticastGroup(..)
10− , EndPointAddress(..)
11− , MulticastAddress(..)
12− -- * Hints
13− , ConnectHints(..)
14− , defaultConnectHints
15− -- * Error codes
16− , TransportError(..)
17− , NewEndPointErrorCode(..)
18− , ConnectErrorCode(..)
19− , NewMulticastGroupErrorCode(..)
20− , ResolveMulticastGroupErrorCode(..)
21− , SendErrorCode(..)
22− , EventErrorCode(..)
23− ) where
24−
25−import Data.ByteString (ByteString)
26−import qualified Data.ByteString.Char8 as BSC (unpack)
27−import Control.Exception (Exception)
28−import Data.Typeable (Typeable)
29−import Data.Binary (Binary)
30−
31−--------------------------------------------------------------------------------
32−-- Main API --
33−--------------------------------------------------------------------------------
34−
35−-- | To create a network abstraction layer, use one of the
36−-- @Network.Transport.*@ packages.
37−data Transport = Transport {
38− -- | Create a new end point (heavyweight operation)
39− newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint)
40− -- | Shutdown the transport completely
41− , closeTransport :: IO ()
42− }
43−
44−-- | Network endpoint.
45−data EndPoint = EndPoint {
46− -- | Endpoints have a single shared receive queue.
47− receive :: IO Event
48− -- | EndPointAddress of the endpoint.
49− , address :: EndPointAddress
50− -- | Create a new lightweight connection.
51− , connect :: EndPointAddress -> Reliability -> ConnectHints -> IO (Either (TransportError ConnectErrorCode) Connection)
52− -- | Create a new multicast group.
53− , newMulticastGroup :: IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
54− -- | Resolve an address to a multicast group.
55− , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
56− -- | Close the endpoint
57− , closeEndPoint :: IO ()
58− }
59−
60−-- | Lightweight connection to an endpoint.
61−data Connection = Connection {
62− -- | Send a message on this connection.
63− send :: [ByteString] -> IO (Either (TransportError SendErrorCode) ())
64− -- | Close the connection.
65− , close :: IO ()
66− }
67−
68−-- | Event on an endpoint.
69−data Event =
70− -- | Received a message
71− Received ConnectionId [ByteString]
72− -- | Connection closed
73− | ConnectionClosed ConnectionId
74− -- | Connection opened
75− | ConnectionOpened ConnectionId Reliability EndPointAddress
76− -- | Received multicast
77− | ReceivedMulticast MulticastAddress [ByteString]
78− -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport)
79− | EndPointClosed
80− -- | An error occurred
81− | ErrorEvent (TransportError EventErrorCode)
82− deriving (Show, Eq)
83−
84−-- | Connection data ConnectHintsIDs enable receivers to distinguish one connection from another.
85−type ConnectionId = Int
86−
87−-- | Reliability guarantees of a connection.
88−data Reliability =
89− ReliableOrdered
90− | ReliableUnordered
91− | Unreliable
92− deriving (Show, Eq)
93−
94−-- | Multicast group.
95−data MulticastGroup = MulticastGroup {
96− -- | EndPointAddress of the multicast group.
97− multicastAddress :: MulticastAddress
98− -- | Delete the multicast group completely.
99− , deleteMulticastGroup :: IO ()
100− -- | Maximum message size that we can send to this group.
101− , maxMsgSize :: Maybe Int
102− -- | Send a message to the group.
103− , multicastSend :: [ByteString] -> IO ()
104− -- | Subscribe to the given multicast group (to start receiving messages from the group).
105− , multicastSubscribe :: IO ()
106− -- | Unsubscribe from the given multicast group (to stop receiving messages from the group).
107− , multicastUnsubscribe :: IO ()
108− -- | Close the group (that is, indicate you no longer wish to send to the group).
109− , multicastClose :: IO ()
110− }
111−
112−-- | EndPointAddress of an endpoint.
113−newtype EndPointAddress = EndPointAddress { endPointAddressToByteString :: ByteString }
114− deriving (Eq, Ord, Typeable, Binary)
115−
116−instance Show EndPointAddress where
117− show = BSC.unpack . endPointAddressToByteString
118−
119−-- | EndPointAddress of a multicast group.
120−newtype MulticastAddress = MulticastAddress { multicastAddressToByteString :: ByteString }
121− deriving (Eq, Ord)
122−
123−instance Show MulticastAddress where
124− show = show . multicastAddressToByteString
125−
126−--------------------------------------------------------------------------------
127−-- Hints --
128−-- --
129−-- Hints provide transport-generic "suggestions". For now, these are --
130−-- placeholders only. --
131−--------------------------------------------------------------------------------
132−
133−-- | Hints used by 'connect'
134−data ConnectHints = ConnectHints {
135− -- Timeout
136− connectTimeout :: Maybe Int
137− }
138−
139−-- | Default hints for connecting
140−defaultConnectHints :: ConnectHints
141−defaultConnectHints = ConnectHints {
142− connectTimeout = Nothing
143− }
144−
145−--------------------------------------------------------------------------------
146−-- Error codes --
147−-- --
148−-- Errors should be transport-implementation independent. The deciding factor --
149−-- for distinguishing one kind of error from another should be: might --
150−-- application code have to take a different action depending on the kind of --
151−-- error? --
152−--------------------------------------------------------------------------------
153−
154−-- | Errors returned by Network.Transport API functions consist of an error
155−-- code and a human readable description of the problem
156−data TransportError error = TransportError error String
157− deriving (Show, Typeable)
158−
159−-- | Although the functions in the transport API never throw TransportErrors
160−-- (but return them explicitly), application code may want to turn these into
161−-- exceptions.
162−instance (Typeable err, Show err) => Exception (TransportError err)
163−
164−-- | When comparing errors we ignore the human-readable strings
165−instance Eq error => Eq (TransportError error) where
166− TransportError err1 _ == TransportError err2 _ = err1 == err2
167−
168−-- | Errors during the creation of an endpoint
169−data NewEndPointErrorCode =
170− -- | Not enough resources
171− NewEndPointInsufficientResources
172− -- | Failed for some other reason
173− | NewEndPointFailed
174− deriving (Show, Typeable, Eq)
175−
176−-- | Connection failure
177−data ConnectErrorCode =
178− -- | Could not resolve the address
179− ConnectNotFound
180− -- | Insufficient resources (for instance, no more sockets available)
181− | ConnectInsufficientResources
182− -- | Timeout
183− | ConnectTimeout
184− -- | Failed for other reasons (including syntax error)
185− | ConnectFailed
186− deriving (Show, Typeable, Eq)
187−
188−-- | Failure during the creation of a new multicast group
189−data NewMulticastGroupErrorCode =
190− -- | Insufficient resources
191− NewMulticastGroupInsufficientResources
192− -- | Failed for some other reason
193− | NewMulticastGroupFailed
194− -- | Not all transport implementations support multicast
195− | NewMulticastGroupUnsupported
196− deriving (Show, Typeable, Eq)
197−
198−-- | Failure during the resolution of a multicast group
199−data ResolveMulticastGroupErrorCode =
200− -- | Multicast group not found
201− ResolveMulticastGroupNotFound
202− -- | Failed for some other reason (including syntax error)
203− | ResolveMulticastGroupFailed
204− -- | Not all transport implementations support multicast
205− | ResolveMulticastGroupUnsupported
206− deriving (Show, Typeable, Eq)
207−
208−-- | Failure during sending a message
209−data SendErrorCode =
210− -- | Connection was closed
211− SendClosed
212− -- | Send failed for some other reason
213− | SendFailed
214− deriving (Show, Typeable, Eq)
215−
216−-- | Error codes used when reporting errors to endpoints (through receive)
217−data EventErrorCode =
218− -- | Failure of the entire endpoint
219− EventEndPointFailed
220− -- | Transport-wide fatal error
221− | EventTransportFailed
222− -- | Some incoming connections were closed abruptly.
223− -- If an endpoint address is specified, then all connections to and
224− -- from that endpoint are now lost
225− | EventConnectionLost (Maybe EndPointAddress) [ConnectionId]
226− deriving (Show, Typeable, Eq)
network-transport/src/Network/Transport/Internal.hsdeleted−153
@@ -1,153 +0,0 @@
1−-- | Internal functions
2−module Network.Transport.Internal ( -- * Encoders/decoders
3− encodeInt32
4− , decodeInt32
5− , encodeInt16
6− , decodeInt16
7− , prependLength
8− -- * Miscellaneous abstractions
9− , mapIOException
10− , tryIO
11− , tryToEnum
12− , timeoutMaybe
13− , asyncWhenCancelled
14− -- * Replicated functionality from "base"
15− , void
16− , forkIOWithUnmask
17− -- * Debugging
18− , tlog
19− ) where
20−
21−#if ! MIN_VERSION_base(4,6,0)
22−import Prelude hiding (catch)
23−#endif
24−
25−import Foreign.Storable (pokeByteOff, peekByteOff)
26−import Foreign.C (CInt(..), CShort(..))
27−import Foreign.ForeignPtr (withForeignPtr)
28−import Data.ByteString (ByteString)
29−import qualified Data.ByteString as BS (length)
30−import qualified Data.ByteString.Internal as BSI ( unsafeCreate
31− , toForeignPtr
32− , inlinePerformIO)
33−import Control.Monad.IO.Class (MonadIO, liftIO)
34−import Control.Exception ( IOException
35− , SomeException
36− , AsyncException
37− , Exception
38− , catch
39− , try
40− , throw
41− , throwIO
42− , mask_
43− )
44−import Control.Concurrent (ThreadId, forkIO)
45−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
46−import GHC.IO (unsafeUnmask)
47−import System.Timeout (timeout)
48−--import Control.Concurrent (myThreadId)
49−
50−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
51−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
52−foreign import ccall unsafe "htons" htons :: CShort -> CShort
53−foreign import ccall unsafe "ntohs" ntohs :: CShort -> CShort
54−
55−-- | Serialize 32-bit to network byte order
56−encodeInt32 :: Enum a => a -> ByteString
57−encodeInt32 i32 =
58− BSI.unsafeCreate 4 $ \p ->
59− pokeByteOff p 0 (htonl . fromIntegral . fromEnum $ i32)
60−
61−-- | Deserialize 32-bit from network byte order
62−-- Throws an IO exception if this is not a valid integer.
63−decodeInt32 :: Num a => ByteString -> a
64−decodeInt32 bs
65− | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length"
66− | otherwise = BSI.inlinePerformIO $ do
67− let (fp, offset, _) = BSI.toForeignPtr bs
68− withForeignPtr fp $ \p -> do
69− w32 <- peekByteOff p offset
70− return (fromIntegral . ntohl $ w32)
71−
72−-- | Serialize 16-bit to network byte order
73−encodeInt16 :: Enum a => a -> ByteString
74−encodeInt16 i16 =
75− BSI.unsafeCreate 2 $ \p ->
76− pokeByteOff p 0 (htons . fromIntegral . fromEnum $ i16)
77−
78−-- | Deserialize 16-bit from network byte order
79−-- Throws an IO exception if this is not a valid integer
80−decodeInt16 :: Num a => ByteString -> a
81−decodeInt16 bs
82− | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length"
83− | otherwise = BSI.inlinePerformIO $ do
84− let (fp, offset, _) = BSI.toForeignPtr bs
85− withForeignPtr fp $ \p -> do
86− w16 <- peekByteOff p offset
87− return (fromIntegral . ntohs $ w16)
88−
89−-- | Prepend a list of bytestrings with their total length
90−prependLength :: [ByteString] -> [ByteString]
91−prependLength bss = encodeInt32 (sum . map BS.length $ bss) : bss
92−
93−-- | Translate exceptions that arise in IO computations
94−mapIOException :: Exception e => (IOException -> e) -> IO a -> IO a
95−mapIOException f p = catch p (throwIO . f)
96−
97−-- | Like 'try', but lifted and specialized to IOExceptions
98−tryIO :: MonadIO m => IO a -> m (Either IOException a)
99−tryIO = liftIO . try
100−
101−-- | Logging (for debugging)
102−tlog :: MonadIO m => String -> m ()
103−tlog _ = return ()
104−{-
105−tlog msg = liftIO $ do
106− tid <- myThreadId
107− putStrLn $ show tid ++ ": " ++ msg
108−-}
109−
110−-- | Not all versions of "base" export 'void'
111−void :: Monad m => m a -> m ()
112−void p = p >> return ()
113−
114−-- | This was introduced in "base" some time after 7.0.4
115−forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
116−forkIOWithUnmask io = forkIO (io unsafeUnmask)
117−
118−-- | Safe version of 'toEnum'
119−tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a
120−tryToEnum = go minBound maxBound
121− where
122− go :: Enum b => b -> b -> Int -> Maybe b
123− go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing
124−
125−-- | If the timeout value is not Nothing, wrap the given computation with a
126−-- timeout and it if times out throw the specified exception. Identity
127−-- otherwise.
128−timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a
129−timeoutMaybe Nothing _ f = f
130−timeoutMaybe (Just n) e f = do
131− ma <- timeout n f
132− case ma of
133− Nothing -> throwIO e
134− Just a -> return a
135−
136−-- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it
137−-- to complete. If f throws an exception we catch it and rethrow it in the
138−-- current thread. If the current thread is interrupted before f completes,
139−-- we run the specified clean up handler (if f throws an exception we assume
140−-- that no cleanup is necessary).
141−asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a
142−asyncWhenCancelled g f = mask_ $ do
143− mvar <- newEmptyMVar
144− forkIO $ try f >>= putMVar mvar
145− -- takeMVar is interruptible (even inside a mask_)
146− catch (takeMVar mvar) (exceptionHandler mvar) >>= either throwIO return
147− where
148− exceptionHandler :: MVar (Either SomeException a)
149− -> AsyncException
150− -> IO (Either SomeException a)
151− exceptionHandler mvar ex = do
152− forkIO $ takeMVar mvar >>= either (const $ return ()) g
153− throwIO ex
network-transport/src/Network/Transport/Util.hsdeleted−24
@@ -1,24 +0,0 @@
1−-- | Utility functions
2−--
3−-- Note: this module is bound to change even more than the rest of the API :)
4−module Network.Transport.Util (spawn) where
5−
6−import Network.Transport ( Transport
7− , EndPoint(..)
8− , EndPointAddress
9− , newEndPoint
10− )
11−import Control.Concurrent (forkIO)
12−import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
13−
14−-- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread.
15−--
16−-- Returns the address of the new end point.
17−spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress
18−spawn transport proc = do
19− addr <- newEmptyMVar
20− forkIO $ do
21− Right endpoint <- newEndPoint transport
22− putMVar addr (address endpoint)
23− proc endpoint
24− takeMVar addr
network-transport/tests/chat/ChatClient.hsdeleted−107
@@ -1,107 +0,0 @@
1−import System.Environment (getArgs)
2−import Network.Transport
3−import Network.Transport.TCP (createTransport)
4−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, modifyMVar_, modifyMVar)
5−import Control.Concurrent (forkIO)
6−import Control.Monad (forever, forM, unless, when)
7−import qualified Data.ByteString as BS (concat, null)
8−import qualified Data.ByteString.Char8 as BSC (pack, unpack, getLine)
9−import Data.Map (Map)
10−import qualified Data.Map as Map (fromList, elems, insert, member, empty, size, delete, (!))
11−
12−chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO ()
13−chatClient done endpoint serverAddr = do
14− connect endpoint serverAddr ReliableOrdered
15− cOut <- getPeers >>= connectToPeers
16− cIn <- newMVar Map.empty
17−
18− -- Listen for incoming messages
19− forkIO . forever $ do
20− event <- receive endpoint
21− case event of
22− Received _ msg ->
23− putStrLn . BSC.unpack . BS.concat $ msg
24− ConnectionOpened cid _ addr -> do
25− modifyMVar_ cIn $ return . Map.insert cid addr
26− didAdd <- modifyMVar cOut $ \conns ->
27− if not (Map.member addr conns)
28− then do
29− Right conn <- connect endpoint addr ReliableOrdered
30− return (Map.insert addr conn conns, True)
31− else
32− return (conns, False)
33− when didAdd $ showNumPeers cOut
34− ConnectionClosed cid -> do
35− addr <- modifyMVar cIn $ \conns ->
36− return (Map.delete cid conns, conns Map.! cid)
37− modifyMVar_ cOut $ \conns -> do
38− close (conns Map.! addr)
39− return (Map.delete addr conns)
40− showNumPeers cOut
41−
42−
43−
44−{-
45− chatState <- newMVar (Map.fromList peerConns)
46−
47− -- Thread to listen to incoming messages
48− forkIO . forever $ do
49− event <- receive endpoint
50− case event of
51− ConnectionOpened _ _ (EndPointAddress addr) -> do
52− modifyMVar_ chatState $ \peers ->
53− if not (Map.member addr peers)
54− then do
55− Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered
56− return (Map.insert addr conn peers)
57− else
58− return peers
59− Received _ msg ->
60− putStrLn . BSC.unpack . BS.concat $ msg
61− ConnectionClosed _ ->
62− return ()
63−
64−-}
65− -- Thread to interact with the user
66− showNumPeers cOut
67− let go = do
68− msg <- BSC.getLine
69− unless (BS.null msg) $ do
70− readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg]
71− go
72− go
73− putMVar done ()
74−
75− where
76− getPeers :: IO [EndPointAddress]
77− getPeers = do
78− ConnectionOpened _ _ _ <- receive endpoint
79− Received _ msg <- receive endpoint
80− ConnectionClosed _ <- receive endpoint
81− return . map EndPointAddress . read . BSC.unpack . BS.concat $ msg
82−
83− connectToPeers :: [EndPointAddress] -> IO (MVar (Map EndPointAddress Connection))
84− connectToPeers addrs = do
85− conns <- forM addrs $ \addr -> do
86− Right conn <- connect endpoint addr ReliableOrdered
87− return (addr, conn)
88− newMVar (Map.fromList conns)
89−
90− showNumPeers :: MVar (Map EndPointAddress Connection) -> IO ()
91− showNumPeers cOut =
92− readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers"
93−
94−
95−
96−
97−main :: IO ()
98−main = do
99− host:port:server:_ <- getArgs
100− Right transport <- createTransport host port
101− Right endpoint <- newEndPoint transport
102− clientDone <- newEmptyMVar
103−
104− forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server)
105−
106− takeMVar clientDone
107−
network-transport/tests/chat/ChatServer.hsdeleted−28
@@ -1,28 +0,0 @@
1−import System.Environment (getArgs)
2−import Network.Transport
3−import Network.Transport.TCP (createTransport)
4−import Control.Monad.State (evalStateT, modify, get)
5−import Control.Monad (forever)
6−import Control.Monad.IO.Class (liftIO)
7−import qualified Data.IntMap as IntMap (empty, insert, delete, elems)
8−import qualified Data.ByteString.Char8 as BSC (pack)
9−
10−main :: IO ()
11−main = do
12− host:port:_ <- getArgs
13− Right transport <- createTransport host port
14− Right endpoint <- newEndPoint transport
15−
16− putStrLn $ "Chat server ready at " ++ (show . endPointAddressToByteString . address $ endpoint)
17−
18− flip evalStateT IntMap.empty . forever $ do
19− event <- liftIO $ receive endpoint
20− case event of
21− ConnectionOpened cid _ addr -> do
22− get >>= \clients -> liftIO $ do
23− Right conn <- connect endpoint addr ReliableOrdered
24− send conn [BSC.pack . show . IntMap.elems $ clients]
25− close conn
26− modify $ IntMap.insert cid (endPointAddressToByteString addr)
27− ConnectionClosed cid ->
28− modify $ IntMap.delete cid
network-transport/tests/sumeuler/SumEulerMaster.hsdeleted−44
@@ -1,44 +0,0 @@
1−import System.Environment (getArgs)
2−import Network.Transport
3−import Network.Transport.TCP (createTransport)
4−import Control.Concurrent (forkIO)
5−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
6−import Control.Monad (forM, forM_, replicateM_)
7−import qualified Data.ByteString as BS (concat)
8−import qualified Data.ByteString.Char8 as BSC (pack, unpack)
9−import Control.Monad.Trans.Writer (execWriterT, tell)
10−import Control.Monad.IO.Class (liftIO)
11−
12−master :: MVar () -> EndPoint -> [String] -> IO ()
13−master done endpoint workers = do
14− conns <- forM workers $ \worker -> do
15− Right conn <- connect endpoint (EndPointAddress $ BSC.pack worker) ReliableOrdered
16− return conn
17− -- Send out requests
18− forM_ conns $ \conn -> do
19− send conn [BSC.pack $ show 5300]
20− close conn
21− -- Print all replies
22− replies <- execWriterT $ replicateM_ (length workers * 3) $ do
23− event <- liftIO $ receive endpoint
24− case event of
25− Received _ msg ->
26− tell [read . BSC.unpack . BS.concat $ msg]
27− _ ->
28− return ()
29− putStrLn $ "Replies: " ++ show (replies :: [Int])
30− putMVar done ()
31−
32−main :: IO ()
33−main = do
34− host:port:workers <- getArgs
35− Right transport <- createTransport host port
36− Right endpoint <- newEndPoint transport
37− masterDone <- newEmptyMVar
38−
39− putStrLn $ "Master using workers " ++ show workers
40−
41− forkIO $ master masterDone endpoint workers
42−
43− takeMVar masterDone
44−
network-transport/tests/sumeuler/SumEulerWorker.hsdeleted−52
@@ -1,52 +0,0 @@
1−import System.Environment (getArgs)
2−import Network.Transport
3−import Network.Transport.TCP (createTransport)
4−import qualified Data.ByteString.Char8 as BSC (putStrLn, pack, unpack)
5−import qualified Data.ByteString as BS (concat)
6−import Control.Concurrent (forkIO)
7−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
8−import System.IO (hFlush, stdout, stderr, hPutStrLn)
9−
10−mkList :: Int -> [Int]
11−mkList n = [1 .. n - 1]
12−
13−relPrime :: Int -> Int -> Bool
14−relPrime x y = gcd x y == 1
15−
16−euler :: Int -> Int
17−euler n = length (filter (relPrime n) (mkList n))
18−
19−sumEuler :: Int -> Int
20−sumEuler = sum . (map euler) . mkList
21−
22−worker :: String -> MVar () -> EndPoint -> IO ()
23−worker id done endpoint = do
24− ConnectionOpened _ _ theirAddr <- receive endpoint
25− Right replyChan <- connect endpoint theirAddr ReliableOrdered
26− go replyChan
27− where
28− go replyChan = do
29− event <- receive endpoint
30− case event of
31− ConnectionClosed _ -> do
32− close replyChan
33− putMVar done ()
34− Received _ msg -> do
35− let i :: Int
36− i = read . BSC.unpack . BS.concat $ msg
37− send replyChan [BSC.pack . show $ sumEuler i]
38− go replyChan
39−
40−main :: IO ()
41−main = do
42− (id:host:port:_) <- getArgs
43− Right transport <- createTransport host port
44− Right endpoint <- newEndPoint transport
45− workerDone <- newEmptyMVar
46−
47− BSC.putStrLn (endPointAddressToByteString (address endpoint))
48− hFlush stdout
49−
50− forkIO $ worker id workerDone endpoint
51−
52− takeMVar workerDone
network-transport/tests/sumeuler/sumeuler.shdeleted−20
@@ -1,20 +0,0 @@
1−#/bin/bash
2−
3−rm -f workers
4−killall -9 SumEulerWorker
5−
6−ghc -O2 -i../src -XScopedTypeVariables SumEulerWorker
7−ghc -O2 -i../src -XScopedTypeVariables SumEulerMaster
8−
9−./SumEulerWorker 1 127.0.0.1 8080 >> workers &
10−./SumEulerWorker 1 127.0.0.1 8081 >> workers &
11−./SumEulerWorker 1 127.0.0.1 8082 >> workers &
12−./SumEulerWorker 1 127.0.0.1 8083 >> workers &
13−./SumEulerWorker 1 127.0.0.1 8084 >> workers &
14−./SumEulerWorker 1 127.0.0.1 8085 >> workers &
15−./SumEulerWorker 1 127.0.0.1 8086 >> workers &
16−./SumEulerWorker 1 127.0.0.1 8087 >> workers &
17−
18−echo "Waiting for all workers to be ready"
19−sleep 1
20−cat workers | xargs ./SumEulerMaster 127.0.0.1 8090
distributed-process/src/Control/Distributed/Process.hs → src/Control/Distributed/Process.hsrenamed+236−174
@@ -1,24 +1,33 @@
1−-- | [Cloud Haskell]
2−--
3−-- This is an implementation of Cloud Haskell, as described in
4−-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon
5−-- Peyton Jones
6−-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
7−-- although some of the details are different. The precise message passing
8−-- semantics are based on /A unified semantics for future Erlang/ by Hans
9−-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.
10−module Control.Distributed.Process
11− ( -- * Basic types
1+{-# LANGUAGE CPP #-}
2+{- | [Cloud Haskell]
3+
4+This is an implementation of Cloud Haskell, as described in
5+/Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon
6+Peyton Jones (see
7+<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
8+although some of the details are different. The precise message passing
9+semantics are based on /A unified semantics for future Erlang/ by Hans
10+Svensson, Lars-Åke Fredlund and Clara Benac Earle.
11+
12+For a detailed description of the package and other reference materials,
13+please see the distributed-process wiki page on github:
14+<https://github.com/haskell-distributed/distributed-process/wiki>.
15+
16+-}
17+module Control.Distributed.Process
18+ ( -- * Basic types
1219 ProcessId
13− , NodeId
20+ , NodeId(..)
1421 , Process
1522 , SendPortId
1623 , processNodeId
1724 , sendPortProcessId
1825 , liftIO -- Reexported for convenience
1926 -- * Basic messaging
20− , send
27+ , send
28+ , usend
2129 , expect
30+ , expectTimeout
2231 -- * Channels
2332 , ReceivePort
2433 , SendPort
@@ -26,8 +35,16 @@ module Control.Distributed.Process
2635 , newChan
2736 , sendChan
2837 , receiveChan
38+ , receiveChanTimeout
2939 , mergePortsBiased
3040 , mergePortsRR
41+ -- * Unsafe messaging variants
42+ , unsafeSend
43+ , unsafeUSend
44+ , unsafeSendChan
45+ , unsafeNSend
46+ , unsafeNSendRemote
47+ , unsafeWrapMessage
3148 -- * Advanced messaging
3249 , Match
3350 , receiveWait
@@ -35,14 +52,44 @@ module Control.Distributed.Process
3552 , match
3653 , matchIf
3754 , matchUnknown
55+ , matchAny
56+ , matchAnyIf
57+ , matchChan
58+ , matchSTM
59+ , Message
60+ , matchMessage
61+ , matchMessageIf
62+ , isEncoded
63+ , wrapMessage
64+ , unwrapMessage
65+ , handleMessage
66+ , handleMessageIf
67+ , handleMessage_
68+ , handleMessageIf_
69+ , forward
70+ , uforward
71+ , delegate
72+ , relay
73+ , proxy
3874 -- * Process management
3975 , spawn
4076 , call
4177 , terminate
78+ , die
79+ , kill
80+ , exit
81+ , catchExit
82+ , catchesExit
4283 , ProcessTerminationException(..)
84+ , ProcessRegistrationException(..)
4385 , SpawnRef
4486 , getSelfPid
4587 , getSelfNode
88+ , ProcessInfo(..)
89+ , getProcessInfo
90+ , NodeStats(..)
91+ , getNodeStats
92+ , getLocalNodeStats
4693 -- * Monitoring and linking
4794 , link
4895 , linkNode
@@ -54,62 +101,85 @@ module Control.Distributed.Process
54101 , monitorNode
55102 , monitorPort
56103 , unmonitor
104+ , withMonitor
105+ , withMonitor_
106+ , MonitorRef -- opaque
57107 , ProcessLinkException(..)
58108 , NodeLinkException(..)
59109 , PortLinkException(..)
60− , MonitorRef -- opaque
61110 , ProcessMonitorNotification(..)
62111 , NodeMonitorNotification(..)
63112 , PortMonitorNotification(..)
64113 , DiedReason(..)
65114 -- * Closures
66115 , Closure
116+ , closure
67117 , Static
118+ , unStatic
68119 , unClosure
69120 , RemoteTable
70121 -- * Logging
71122 , say
72123 -- * Registry
73124 , register
125+ , reregister
74126 , unregister
75127 , whereis
76128 , nsend
77− , registerRemote
78− , unregisterRemote
79− , whereisRemote
129+ , registerRemoteAsync
130+ , reregisterRemoteAsync
131+ , unregisterRemoteAsync
80132 , whereisRemoteAsync
81133 , nsendRemote
82134 , WhereIsReply(..)
83− -- * Auxiliary API
135+ , RegisterReply(..)
136+ -- * Exception handling
84137 , catch
85− , expectTimeout
138+ , Handler(..)
139+ , catches
140+ , try
141+ , mask
142+ , mask_
143+ , onException
144+ , bracket
145+ , bracket_
146+ , finally
147+ -- * Auxiliary API
86148 , spawnAsync
87149 , spawnSupervised
88150 , spawnLink
89151 , spawnMonitor
90152 , spawnChannel
91153 , DidSpawn(..)
92− -- * Local versions of 'spawn'
154+ -- * Local versions of 'spawn'
93155 , spawnLocal
94156 , spawnChannelLocal
157+ , callLocal
158+ -- * Reconnecting
159+ , reconnect
160+ , reconnectPort
95161 ) where
96162
97−
98−#if ! MIN_VERSION_base(4,6,0)
99−import Prelude hiding (catch)
100−#endif
101−
102−import Data.Typeable (Typeable)
103163import Control.Monad.IO.Class (liftIO)
104−import Control.Applicative ((<$>))
164+import Control.Applicative
105165import Control.Monad.Reader (ask)
106−import Control.Distributed.Process.Internal.Types
107− ( RemoteTable
108− , NodeId(..)
166+import Control.Concurrent (killThread)
167+import Control.Concurrent.MVar
168+ ( MVar
169+ , newEmptyMVar
170+ , takeMVar
171+ , putMVar
172+ )
173+import Control.Distributed.Static
174+ ( Closure
175+ , closure
176+ , Static
177+ , RemoteTable
178+ )
179+import Control.Distributed.Process.Internal.Types
180+ ( NodeId(..)
109181 , ProcessId(..)
110182 , Process(..)
111− , Closure(..)
112− , Static(..)
113183 , MonitorRef(..)
114184 , ProcessMonitorNotification(..)
115185 , NodeMonitorNotification(..)
@@ -117,35 +187,24 @@ import Control.Distributed.Process.Internal.Types
117187 , ProcessLinkException(..)
118188 , NodeLinkException(..)
119189 , PortLinkException(..)
190+ , ProcessRegistrationException(..)
120191 , DiedReason(..)
121192 , SpawnRef(..)
122193 , DidSpawn(..)
123− , Closure(..)
124194 , SendPort(..)
125195 , ReceivePort(..)
126− , SerializableDict(..)
127196 , SendPortId(..)
128197 , WhereIsReply(..)
198+ , RegisterReply(..)
129199 , LocalProcess(processNode)
200+ , Message
201+ , localProcessWithId
130202 )
131−import Control.Distributed.Process.Internal.Closure.CP
132− ( cpSeq
133− , cpBind
134− , cpSend
135− , cpExpect
136− , cpLink
137− , cpUnlink
138− , cpNewChan
139− , cpCancelL
140− , cpSplit
141− )
142−import Control.Distributed.Process.Internal.Closure.Static
143− ( sdictUnit
144− , sdictSendPort
145− )
203+import Control.Distributed.Process.Serializable (Serializable)
146204import Control.Distributed.Process.Internal.Primitives
147205 ( -- Basic messaging
148− send
206+ send
207+ , usend
149208 , expect
150209 -- Channels
151210 , newChan
@@ -153,6 +212,11 @@ import Control.Distributed.Process.Internal.Primitives
153212 , receiveChan
154213 , mergePortsBiased
155214 , mergePortsRR
215+ , unsafeSend
216+ , unsafeUSend
217+ , unsafeSendChan
218+ , unsafeNSend
219+ , unsafeNSendRemote
156220 -- Advanced messaging
157221 , Match
158222 , receiveWait
@@ -160,11 +224,40 @@ import Control.Distributed.Process.Internal.Primitives
160224 , match
161225 , matchIf
162226 , matchUnknown
227+ , matchAny
228+ , matchAnyIf
229+ , matchChan
230+ , matchSTM
231+ , matchMessage
232+ , matchMessageIf
233+ , isEncoded
234+ , wrapMessage
235+ , unsafeWrapMessage
236+ , unwrapMessage
237+ , handleMessage
238+ , handleMessageIf
239+ , handleMessage_
240+ , handleMessageIf_
241+ , forward
242+ , uforward
243+ , delegate
244+ , relay
245+ , proxy
163246 -- Process management
164247 , terminate
165248 , ProcessTerminationException(..)
249+ , die
250+ , exit
251+ , catchExit
252+ , catchesExit
253+ , kill
166254 , getSelfPid
167255 , getSelfNode
256+ , ProcessInfo(..)
257+ , getProcessInfo
258+ , NodeStats(..)
259+ , getNodeStats
260+ , getLocalNodeStats
168261 -- Monitoring and linking
169262 , link
170263 , linkNode
@@ -176,30 +269,71 @@ import Control.Distributed.Process.Internal.Primitives
176269 , monitorNode
177270 , monitorPort
178271 , unmonitor
272+ , withMonitor
273+ , withMonitor_
179274 -- Logging
180275 , say
181276 -- Registry
182277 , register
278+ , reregister
183279 , unregister
184280 , whereis
185281 , nsend
186− , registerRemote
187− , unregisterRemote
188− , whereisRemote
282+ , registerRemoteAsync
283+ , reregisterRemoteAsync
284+ , unregisterRemoteAsync
189285 , whereisRemoteAsync
190286 , nsendRemote
191287 -- Closures
288+ , unStatic
192289 , unClosure
193− -- Auxiliary API
290+ -- Exception handling
194291 , catch
292+ , Handler(..)
293+ , catches
294+ , try
295+ , mask
296+ , mask_
297+ , onException
298+ , bracket
299+ , bracket_
300+ , finally
301+ -- Auxiliary API
195302 , expectTimeout
303+ , receiveChanTimeout
196304 , spawnAsync
305+ -- Reconnecting
306+ , reconnect
307+ , reconnectPort
197308 )
198−import Control.Distributed.Process.Serializable (Serializable)
199309import Control.Distributed.Process.Node (forkProcess)
310+import Control.Distributed.Process.Internal.Types
311+ ( processThread
312+ , withValidLocalState
313+ )
314+import Control.Distributed.Process.Internal.Spawn
315+ ( -- Spawning Processes/Channels
316+ spawn
317+ , spawnLink
318+ , spawnMonitor
319+ , spawnChannel
320+ , spawnSupervised
321+ , call
322+ )
323+import qualified Control.Monad.Catch as Catch
324+
325+#if MIN_VERSION_base(4,6,0)
326+import Prelude
327+#else
328+import Prelude hiding (catch)
329+#endif
330+import qualified Control.Exception as Exception (onException)
331+import Data.Accessor ((^.))
332+import Data.Foldable (forM_)
333+
200334
201335-- INTERNAL NOTES
202−--
336+--
203337-- 1. 'send' never fails. If you want to know that the remote process received
204338-- your message, you will need to send an explicit acknowledgement. If you
205339-- want to know when the remote process failed, you will need to monitor
@@ -208,7 +342,11 @@ import Control.Distributed.Process.Node (forkProcess)
208342-- 2. 'send' may block (when the system TCP buffers are full, while we are
209343-- trying to establish a connection to the remote endpoint, etc.) but its
210344-- return does not imply that the remote process received the message (much
211−-- less processed it)
345+-- less processed it). When 'send' targets a local process, it is dispatched
346+-- via the node controller however, in which cases it will /not/ block. This
347+-- isn't part of the semantics, so it should be ok. The ordering is maintained
348+-- because the ctrlChannel still has FIFO semantics with regards interactions
349+-- between two disparate forkIO threads.
212350--
213351-- 3. Message delivery is reliable and ordered. That means that if process A
214352-- sends messages m1, m2, m3 to process B, B will either arrive all three
@@ -237,17 +375,17 @@ import Control.Distributed.Process.Node (forkProcess)
237375-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
238376--
239377-- The precise semantics for message passing is based on
240−--
378+--
241379-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund
242380-- and Clara Benac Earle (not freely available online, unfortunately)
243381--
244382-- Some pointers to related documentation about Erlang, for comparison and
245−-- inspiration:
383+-- inspiration:
246384--
247385-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",
248−-- Hans Svensson and Lars-Ake Fredlund
386+-- Hans Svensson and Lars-Ake Fredlund
249387-- http://man.lupaworld.com/content/develop/p37-svensson.pdf
250−-- [4] The Erlang manual, sections "Message Sending" and "Send"
388+-- [4] The Erlang manual, sections "Message Sending" and "Send"
251389-- http://www.erlang.org/doc/reference_manual/processes.html#id82409
252390-- http://www.erlang.org/doc/reference_manual/expressions.html#send
253391-- [5] Questions "Is the order of message reception guaranteed?" and
@@ -257,112 +395,6 @@ import Control.Distributed.Process.Node (forkProcess)
257395-- [6] "Delivery of Messages", post on erlang-questions
258396-- http://erlang.org/pipermail/erlang-questions/2012-February/064767.html
259397
260−--------------------------------------------------------------------------------
261−-- Primitives are defined in a separate module; here we only define derived --
262−-- constructs --
263−--------------------------------------------------------------------------------
264−
265−-- | Spawn a process
266−--
267−-- For more information about 'Closure', see
268−-- "Control.Distributed.Process.Closure".
269−--
270−-- See also 'call'.
271−spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
272−spawn nid proc = do
273− us <- getSelfPid
274− -- Since we throw an exception when the remote node dies, we could use
275− -- linkNode instead. However, we don't have a way of "scoped" linking so if
276− -- we call linkNode here, and unlinkNode after, then we might remove a link
277− -- that was already set up
278− mRef <- monitorNode nid
279− sRef <- spawnAsync nid $ cpLink us
280− `cpSeq` cpExpect sdictUnit
281− `cpSeq` cpUnlink us
282− `cpSeq` proc
283− mPid <- receiveWait
284− [ matchIf (\(DidSpawn ref _) -> ref == sRef)
285− (\(DidSpawn _ pid) -> return $ Just pid)
286− , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)
287− (\_ -> return Nothing)
288− ]
289− unmonitor mRef
290− case mPid of
291− Nothing -> fail "spawn: remote node failed"
292− Just pid -> send pid () >> return pid
293−
294−-- | Spawn a process and link to it
295−--
296−-- Note that this is just the sequential composition of 'spawn' and 'link'.
297−-- (The "Unified" semantics that underlies Cloud Haskell does not even support
298−-- a synchronous link operation)
299−spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
300−spawnLink nid proc = do
301− pid <- spawn nid proc
302− link pid
303− return pid
304−
305−-- | Like 'spawnLink', but monitor the spawned process
306−spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
307−spawnMonitor nid proc = do
308− pid <- spawn nid proc
309− ref <- monitor pid
310− return (pid, ref)
311−
312−-- | Run a process remotely and wait for it to reply
313−--
314−-- We monitor the remote process: if it dies before it can send a reply, we die
315−-- too.
316−--
317−-- For more information about 'Static', 'SerializableDict', and 'Closure', see
318−-- "Control.Distributed.Process.Closure".
319−--
320−-- See also 'spawn'.
321−call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
322−call dict nid proc = do
323− us <- getSelfPid
324− (_, mRef) <- spawnMonitor nid (proc `cpBind` cpSend dict us)
325− -- We are guaranteed to receive the reply before the monitor notification
326− -- (if a reply is sent at all)
327− -- NOTE: This might not be true if we switch to unreliable delivery.
328− mResult <- receiveWait
329− [ match (return . Right)
330− , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
331− (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))
332− ]
333− case mResult of
334− Right a -> unmonitor mRef >> return a
335− Left err -> fail $ "call: remote process died: " ++ show err
336−
337−-- | Spawn a child process, have the child link to the parent and the parent
338−-- monitor the child
339−spawnSupervised :: NodeId
340− -> Closure (Process ())
341− -> Process (ProcessId, MonitorRef)
342−spawnSupervised nid proc = do
343− us <- getSelfPid
344− them <- spawn nid (cpLink us `cpSeq` proc)
345− ref <- monitor them
346− return (them, ref)
347−
348−-- | Spawn a new process, supplying it with a new 'ReceivePort' and return
349−-- the corresponding 'SendPort'.
350−spawnChannel :: forall a. Typeable a => Static (SerializableDict a)
351− -> NodeId
352− -> Closure (ReceivePort a -> Process ())
353− -> Process (SendPort a)
354−spawnChannel dict nid proc = do
355− us <- getSelfPid
356− spawn nid (go us)
357− expect
358− where
359− go :: ProcessId -> Closure (Process ())
360− go pid = cpNewChan dict
361− `cpBind`
362− (cpSend (sdictSendPort dict) pid `cpSplit` proc)
363− `cpBind`
364− cpCancelL
365−
366398--------------------------------------------------------------------------------
367399-- Local versions of spawn --
368400--------------------------------------------------------------------------------
@@ -370,16 +402,46 @@ spawnChannel dict nid proc = do
370402-- | Spawn a process on the local node
371403spawnLocal :: Process () -> Process ProcessId
372404spawnLocal proc = do
373− node <- processNode <$> ask
405+ node <- processNode <$> ask
374406 liftIO $ forkProcess node proc
375407
376408-- | Create a new typed channel, spawn a process on the local node, passing it
377409-- the receive port, and return the send port
378410spawnChannelLocal :: Serializable a
379− => (ReceivePort a -> Process ())
411+ => (ReceivePort a -> Process ())
380412 -> Process (SendPort a)
381−spawnChannelLocal proc = do
382− node <- processNode <$> ask
383− (sport, rport) <- newChan
384− _ <- liftIO $ forkProcess node (proc rport)
385− return sport
413+spawnChannelLocal proc = do
414+ node <- processNode <$> ask
415+ liftIO $ do
416+ mvar <- newEmptyMVar
417+ _ <- forkProcess node $ do
418+ -- It is important that we allocate the new channel in the new process,
419+ -- because otherwise it will be associated with the wrong process ID
420+ (sport, rport) <- newChan
421+ liftIO $ putMVar mvar sport
422+ proc rport
423+ takeMVar mvar
424+
425+-- | Local version of 'call'. Running a process in this way isolates it from
426+-- messages sent to the caller process, and also allows silently dropping late
427+-- or duplicate messages sent to the isolated process after it exits.
428+-- Silently dropping messages may not always be the best approach.
429+callLocal :: Process a -> Process a
430+callLocal proc = Catch.mask $ \release -> do
431+ mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))
432+ child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv
433+ lproc <- ask
434+ liftIO $ do
435+ rs <- Exception.onException (takeMVar mv) $ Catch.uninterruptibleMask_ $
436+ -- Exceptions need to be prevented from interrupting the clean up or
437+ -- the original exception which caused entering the handler could be
438+ -- forgotten. For instance, this could have a problematic effect
439+ -- when the original exception was meant to kill the thread and the
440+ -- second exception doesn't (like the exception thrown by
441+ -- 'System.Timeout.timeout').
442+ do mchildThreadId <- withValidLocalState (processNode lproc) $
443+ \vst -> return $ fmap processThread $
444+ vst ^. localProcessWithId (processLocalId child)
445+ forM_ mchildThreadId killThread
446+ takeMVar mv
447+ either Catch.throwM return rs
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.