git.iko.soy/distributed-process
on master help sign in
swap
660d5541026 ahead, 0 behind
127 files changed+14387−7851
since splitsnapshots
unifiedsplit
.gitignore+3−11 .travis.yml+43 CONTRIBUTING.md+1 ChangeLog+236 network-transport-pipes/LICENSE → LICENSE+2−1 README.md+10−108 distributed-process/Setup.hs → Setup.hs benchmarks/.gitignore−3 benchmarks/Channels.hs+43 benchmarks/Headers.gnuplot−16 benchmarks/Indirection.gnuplot−16 benchmarks/JustPingC.c−150 benchmarks/JustPingCacheHeader.hs−134 benchmarks/JustPingHaskell.hs−105 benchmarks/JustPingOneRecv.hs−131 benchmarks/JustPingThroughChan.hs−127 benchmarks/JustPingThroughMVar.hs−127 benchmarks/JustPingTransport.hs−95 benchmarks/JustPingTwoSocketPairs.hs−151 benchmarks/JustPingWithHeader.hs−131 benchmarks/Latency.hs+39 benchmarks/Makefile−72 benchmarks/Makefile.JustPing−48 benchmarks/PingPipes.hs−112 benchmarks/PingTCP.hs−133 benchmarks/PingTCPTransport.hs−128 benchmarks/ProcessRing.hs+117 benchmarks/SendTCP.hs−109 benchmarks/SendTransport.hs−117 benchmarks/Spawns.hs+49 benchmarks/Throughput.hs+74 benchmarks/erlang/latency.erl+35 benchmarks/erlang/ring.erl+62 benchmarks/erlang/throughput.erl+39 benchmarks/pingtest.c−183 benchmarks/remote/Latency.hs+32 benchmarks/remote/Throughput.hs+39 benchmarks/results_notes.md−111 distributed-process-tests/.gitignore+4 distributed-process-tests/CONTRIBUTING.md+1 distributed-process/LICENSE → distributed-process-tests/LICENSE+1−1 distributed-process-tests/README.md+14 network-transport/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/distributed-process.cabal−21 distributed-process/src/Control/Distributed/Process.hs−230 doc/InternalsTransportMulticast.txt−181 doc/InternalsTransportTCP.txt−81 doc/NetworkTCP.png doc/NetworkTCP.svg−630 doc/semantics/CloudHaskellSemantics.tex+706 doc/semantics/Makefile+11 doc/semantics/references.bib+72 doc/tutorial/tutorial-client.hs−20 doc/tutorial/tutorial-server.hs−52 examples/.gitignore−1 examples/DemoProcess.hs−36 examples/DemoTCP.hs−113 examples/DemoTransport.hs−192 examples/Makefile−20 install_all.sh−18 network-transport-pipes/network-transport-pipes.cabal−33 network-transport-pipes/src/Network/Transport/Pipes.hs−264 network-transport/LICENSE−31 network-transport/network-transport.cabal−71 network-transport/src/Network/Transport.hs−198 network-transport/src/Network/Transport/Chan.hs−150 network-transport/src/Network/Transport/Internal.hs−93 network-transport/src/Network/Transport/Internal/TCP.hs−102 network-transport/src/Network/Transport/TCP.hs−1138 network-transport/src/Network/Transport/Util.hs−24 network-transport/tests/TestAuxiliary.hs−82 network-transport/tests/TestInMemory.hs−8 network-transport/tests/TestMulticast.hs−72 network-transport/tests/TestMulticastInMemory.hs−7 network-transport/tests/TestTCP.hs−487 network-transport/tests/TestTransport.hs−734 network-transport/tests/Traced.hs−191 network-transport/tests/chat/ChatClient.hs−107 network-transport/tests/chat/ChatServer.hs−28 network-transport/tests/sumeuler/SumEulerMaster.hs−44 network-transport/tests/sumeuler/SumEulerWorker.hs−52 network-transport/tests/sumeuler/sumeuler.sh−20 src/Control/Distributed/Process.hs+447 src/Control/Distributed/Process/Closure.hs+244 src/Control/Distributed/Process/Debug.hs+288 src/Control/Distributed/Process/Internal/BiMultiMap.hs+135 src/Control/Distributed/Process/Internal/CQueue.hs+300 src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+320 src/Control/Distributed/Process/Internal/Closure/Explicit.hs+147 src/Control/Distributed/Process/Internal/Closure/TH.hs+330 src/Control/Distributed/Process/Internal/Messaging.hs+207 src/Control/Distributed/Process/Internal/Primitives.hs+1363 src/Control/Distributed/Process/Internal/Spawn.hs+165 src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs+21 src/Control/Distributed/Process/Internal/StrictList.hs+27 src/Control/Distributed/Process/Internal/StrictMVar.hs+93 src/Control/Distributed/Process/Internal/Types.hs+887 src/Control/Distributed/Process/Internal/WeakTQueue.hs+107 src/Control/Distributed/Process/Management.hs+509 src/Control/Distributed/Process/Management/Internal/Agent.hs+157 src/Control/Distributed/Process/Management/Internal/Bus.hs+21 src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+179 src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs+61 src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs+354 src/Control/Distributed/Process/Management/Internal/Trace/Types.hs+159 src/Control/Distributed/Process/Management/Internal/Types.hs+141 src/Control/Distributed/Process/Node.hs+1304 src/Control/Distributed/Process/Serializable.hs+73 src/Control/Distributed/Process/UnsafePrimitives.hs+200 stack-ghc-7.10.3.yaml+21 stack-ghc-8.0.2.yaml+23 stack-ghc-8.2.2.yaml+21 stack-ghc-8.4.4.yaml+20 stack-nightly.yaml+26 stack.yaml+22
.gitignore+3−11
@@ -1,12 +1,4 @@
1−tags
2−TAGS
31dist/
4−\#*#
5−*~
6−*.aux
7−*.hp
8−*.hi
9−*.o
10−*.prof
11−*.ps
12−*.swp
2+.cabal-sandbox
3+cabal.sandbox.config
4+.stack*
.travis.ymlnew file+43
@@ -0,0 +1,43 @@
1+language: c
2+
3+sudo: false
4+
5+matrix:
6+ include:
7+ - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"
8+ addons: {apt: {packages: [libgmp-dev]}}
9+ - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"
10+ addons: {apt: {packages: [libgmp-dev]}}
11+ - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"
12+ addons: {apt: {packages: [libgmp-dev]}}
13+ - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"
14+ addons: {apt: {packages: [libgmp-dev]}}
15+
16+cache:
17+ directories:
18+ - $HOME/.stack
19+
20+before_install:
21+- export PATH=$HOME/.local/bin:$PATH;
22+ mkdir -p ~/.local/bin;
23+ travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';
24+ stack --version
25+
26+install:
27+- stack $ARGS setup --no-terminal;
28+ stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;
29+
30+script:
31+- export ARG='--test-arguments'
32+ export TEST_PACKAGE="distributed-process-tests:"
33+- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory
34+- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP
35+- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure
36+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats
37+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory
38+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP
39+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory
40+
41+notifications:
42+ slack:
43+ secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=
CONTRIBUTING.mdnew file+1
@@ -0,0 +1 @@
1+See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
ChangeLognew file+236
@@ -0,0 +1,236 @@
1+[Unrealeased]
2+
3+*
4+
5+2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4
6+
7+* Added support for exceptions >= 0.10
8+
9+2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3
10+
11+* Drop support for ghc-7.8.* and earlier.
12+
13+2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2
14+
15+* Fixed build errors with ghc-8.2.1.
16+
17+2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1
18+
19+* Relax upper bounds in dependencies to build with ghc-8.2.1.
20+
21+2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0
22+
23+* Change type of message sent by `say` from a 3-tuple to a proper
24+type (`SayMessage`) with a proper `UTCTime`. (#291)
25+* Expose the MonitorRef in the withMonitor call.
26+* Have unmonitor remove the monitor message in the inbox. (#268)
27+* Remove Mx Data Tables. This API isn't used, is easy to replace with various
28+other packages. (#276)
29+* Add Ord instance to SpawnRef.
30+
31+2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6
32+
33+* Remove monitors from remote nodes when a process dies. (#295)
34+
35+2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5
36+
37+* Use only one connection to communicate between NCs. (#296, #297)
38+* Improve documentation of CQueue.
39+* Implement bidirectional multimaps for links and monitors. (#293, #294)
40+* Fix various warnings. (#292)
41+* Fix some of the intermittent failures in tests.
42+* Improve error messages when node controllers receive invalid requests.
43+(#290)
44+
45+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4
46+
47+* Fixup build errors.
48+
49+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3
50+
51+* Relax template-haskell upper bound.
52+
53+2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2
54+
55+* Provide compatibility with ghc-8.0.1
56+* Remove dependency on ghc-prim.
57+* Don't throw exceptions asynchronously.
58+* Bump upper bounds of dependencies.
59+* Fix exception handling in callLocal.
60+* Have spawnLocal inherit the masking state of the caller.
61+* Have nsend send unencoded messages to local processes.
62+
63+2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1
64+
65+* Implement MonadCatch, MonadThrow, MonadMask for Process.
66+
67+2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0
68+
69+* Have nsendRemote skip the transport for local communication.
70+* Unsafe primitives for usend and nsendRemote.
71+* Stop using the transport for local communication.
72+* Skip the transport for whereisRemoteAsync and registerRemoteAsync.
73+* Have nsendRemote skip the transport for local communication.
74+* Have runProcess forward exceptions.
75+* Reimport distributed-process-tests. d-p and d-p-test now can be kept in
76+sync.
77+* Add a stack.yaml file for building tests and d-p all at once conveniently.
78+* Implement unreliable forward (uforward).
79+* Add Functor instance for Match data type
80+* Have `spawnAsync` not use the transport in the local case.
81+* Fix monitor race in 'call'.
82+* Add compatibility with ghc-7.10: support new typeable, loosen deps, write
83+proper NFData instances, support new TH.
84+* Kill processes on a local node upon closeLocalNode.
85+* Fix getNodeStats function, see DP-97
86+* Return size of the queue in ProcessInfo.
87+* Implement unreliable send (usend).
88+* Implement MonadFix instance for Process.
89+* Introduce callLocal primitive.
90+* Prevent message loss due to timeouts in CQueue.
91+* More informative ProcessRegistrationException. Now includes the identifier
92+of the process that owns the name, if any.
93+* Avoid message loop between threads when tracing received messages.
94+
95+2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5
96+
97+* Fix dependencies.
98+* Add compatibility with GHC-7.10.
99+* Fix various race conditions (DP-99, DP-103).
100+
101+2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.5.2
102+
103+* Fix docstring for `register`
104+* Added Data instance to ProcessId, LocalProcessId and NodeId
105+* Add static serialiation dictionary for 'Static', for completeness
106+* Add Closure static serialization dictionary
107+* Replacement for modifyMVarMasked for GHC <= 7.4
108+* Document the use of built-in trace flags
109+* Make forkProcess exception-safe
110+* Make -Wall clean
111+
112+2014-08-13 Tim Watson <watson.timothy@gmail.com> 0.5.1
113+
114+* Fix cabal docs (thanks Markus Barenhoff)
115+* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)
116+
117+2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.5.0
118+
119+* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file
120+* Race condition in local monitoring when using call
121+* mask now works correctly if unmask is called by another process
122+* Improve efficiency of local message passing
123+* nsend uses local communication channels
124+* Link Node Controller and Network Listener
125+* Label spawned processes using labelThread
126+* Relaxed upper bound on syb in the cabal manifest
127+* Bump binary version to include 0.7.*
128+* Exposed process info
129+* Exposed node statistics
130+* Moved tests to https://github.com/haskell-distributed/distributed-process-tests
131+* Added "polymorphic expect"
132+* Exposed Message type and broaden scope of polymorphic expect
133+* Added Management API (for working with internal/system events)
134+* Tracing can no longer be disabled
135+* We now report node statistics for monitoring/management
136+* Node.runProcess now propagates exceptions to its caller
137+* Added simple micro benchmarks
138+
139+2013-01-27 Tim Watson <watson.timothy@gmail.com> 0.4.2
140+
141+* Improved exception handling for deferred type checked exit reasons
142+* Add matchChan primitive (thanks Simon Marlow)
143+* Expose deferred message handling/checking for AbstractMessage
144+* Add `getProcessInfo' API
145+* Add `trace' API backed by the GHC eventlog
146+
147+2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.4.1
148+
149+* Make behaviour of 'register' more Erlang-like (register will now fail if the
150+name is already registered). Patch by Jeff Epstein.
151+* Functor, Applicative, Alternative and Monad instances for ReceivePort
152+* Add support for receiveChanTimeout
153+* Improved documentation
154+* Avoid name clashes in the TH generation for closures
155+* Relax package bounds to allow for Binary 0.6
156+
157+2012-10-23 Edsko de Vries <edsko@well-typed.com> 0.4.0.2
158+
159+* Fix race condition in spawn
160+
161+2012-10-04 Edsko de Vries <edsko@well-typed.com> 0.4.0.1
162+
163+* Relax package boundaries
164+
165+2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.4.0
166+
167+* Improved treatment of network failure, using new failure semantics of
168+Network.Transport.
169+* Make NodeId Typeable
170+* Extend Template Haskell support with "remotableDec" so that you can refer to
171+$(mkClosure 'f) within the body of "f".
172+* Fix bug in spawnChannelLocal
173+* Numerous memory leaks plugged
174+* Relax upper bound on dependency on 'network'
175+* New primitive 'matchAny'
176+* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync')
177+
178+2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1
179+
180+* Fix memory leaks
181+* Make Template Haskell support optional
182+* Relax dependency constraints
183+
184+2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0
185+
186+* Extract 'static' into a separate package (C.D.Static)
187+* Use new package rank1dynamic to proper runtime checks for polymorphic values
188+
189+2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0
190+
191+* Expose the constructors of Closure
192+* Add instance (Typeable a => Serializable (Static a)) and make sure we only
193+use the internal representation of Static where really necessary
194+* Improved docs
195+
196+2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0
197+
198+* Add exception handling primitives
199+* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on
200+MVar' exception would be thrown.
201+
202+2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
203+
204+* Bugfix in the node controller
205+(one way this bug materialized: when using the SimpleLocalnet backend,
206+slave nodes could not be reused)
207+* Improved documentation in Control.Distributed.Process.Closure
208+
209+2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
210+
211+* Improve docs
212+* Local versions of spawn
213+
214+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
215+
216+* Base 4.6 compatibility
217+* Relax constraints on bytestring and containers
218+
219+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1
220+
221+* Relax upper bound on 'time' dependency
222+
223+2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1
224+
225+* Complete redesign of the underlying implementation of static values and
226+closures.
227+
228+* Add support for 'spawnChannel'
229+
230+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
231+
232+* Bugfix: Continue processing messages when a connection breaks.
233+
234+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
235+
236+* Initial release.
network-transport-pipes/LICENSE → LICENSErenamed+2−1
@@ -1,4 +1,5 @@
1−Copyright Ryan Newton, 2011
1+Copyright Well-Typed LLP, 2011-2012
2+Copyright Tweag I/O Limited, 2015
23
34All rights reserved.
45
README.md+10−108
@@ -1,114 +1,16 @@
1−Haskell Distributed Project
2−===========================
1+# distributed-process
2+[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)
3+[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)
34
4−This repository holds an implementation of [Cloud Haskell][1] based on the work
5−of Jeff Epstein, Andrew Black, and Simon Peyton-Jones.
5+This repository is part of Cloud Haskell.
66
7−At present, this repository hosts two packages:
7+See http://haskell-distributed.github.com for documentation, user guides,
8+tutorials and assistance.
89
9−* distributed-process
10−* network-transport
10+## Getting Help / Raising Issues
1111
12−For more detailed information about the interfaces provided by these packages,
13−please refer to the [distributed-process repository wiki][2].
12+Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.
1413
15−Examples
16−--------
14+## License
1715
18−Examples of the transport layer at work can be found in the `/examples` folder.
19−
20−### DemoTransport.hs
21−
22−The `DemoTransport.hs` file contains a number of different functions named
23−`demo#`. These functions demonstrate the use of the `Network.Transport` module.
24−
25−To try them out, launch `ghci`, including the appropriate sources:
26−
27− ghci -idistributed-process/src -inetwork-transport/src examples/DemoTransport.hs
28−
29−The first demo, `demo0` yields the following output when run with the TCP transport:
30−
31− *DemoTransport> tcp >>= demo0
32− logServer: [Chunk "hello 1" Empty]
33− logServer: [Chunk "hello 2" Empty]
34− logServer: [Chunk "hello 3" Empty]
35− logServer: [Chunk "hello 4" Empty]
36− logServer: [Chunk "hello 5" Empty]
37− logServer: [Chunk "hello 6" Empty]
38− logServer: [Chunk "hello 7" Empty]
39− logServer: [Chunk "hello 8" Empty]
40− logServer: [Chunk "hello 9" Empty]
41− logServer: [Chunk "hello 10" Empty]
42−
43−See the source code for more details.
44−
45−### DemoProcess.hs
46−
47−The `DemoProcess.hs` file shows a very basic example of how to use the
48−`Control.Distributed.Process` module in conjunction with `Network.Transport.TCP`.
49−This is demonstrated using the `demo1` function:
50−
51− ghci -idistributed-process/src -inetwork-transport/src examples/DemoProcess.hs
52−
53−The output of the example is as follows:
54−
55− *DemoProcess> demo1
56− "Starting node"
57− "Starting process"
58− 1: jim1 says: hi there
59− 2: bob1 says: hi there
60− 3: jim1 says: bye
61− 4: bob1 says: bye
62−
63−### DemoTCP.hs
64−
65−The `DemoTCP.hs` file demonstrates how a master can be connected to slaves
66−using the transport layer over TCP.
67−This example should be compiled in the usual fashion:
68−
69− ghc --make -idistributed-process/src -inetwork-transport/src examples/DemoTCP.hs
70−
71−After compiling, the following will initialize a new master that waits
72−for two clients to connect on the local machine:
73−
74− ./examples/DemoTCP 127.0.0.1 8080 sourceAddrFile 2
75−
76−Following this, two slaves should be created that will connect to the master:
77−
78− ./examples/DemoTCP 127.0.0.1 8081 sourceAddrFile
79− ./examples/DemoTCP 127.0.0.1 8082 sourceAddrFile
80−
81−Once the connection is established, the slaves will provide the master
82−with their `SourceAddr`. The master then decodes this, and sends a message
83−back. After processing this message, the slaves respond to the master,
84−which then outputs some data.
85−
86−Benchmarks
87−----------
88−
89−The `Transport.TCP` backend uses `Network.ByteString.Lazy` as its underlying
90−protocol, so we produce a benchmark that compares it directly with this.
91−Furthermore, the `Data.Binary` package is used for converting values
92−to `ByteStrings` for transmission.
93−
94−The benchmarking is performed on the client side using criterion:
95−the server must be set up before benching is performed.
96−
97−### Ping
98−
99−This benchmark measures how quickly a sequence of ping/pong messages
100−are sent between a server and client. Full details can be found in:
101−
102− ./benchmarks/PingTCP.hs
103− ./benchmarks/PingTransport.hs
104−
105−### Send
106−
107−This benchmark measures how quickly a number of bytes can be sent from
108−a client to a server. Full details can be found in the following files:
109−
110− ./benchmarks/SendTCP.hs
111− ./benchmarks/SendTransport.hs
112−
113−[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
114−[2]: https://github.com/haskell-distributed/distributed-process/wiki
16+This package is made available under a 3-clause BSD-style license.
distributed-process/Setup.hs → Setup.hsrenamed

The content is the same.

benchmarks/.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−*.swp
2−*.exe
3−*.data
benchmarks/Channels.hsnew file+43
@@ -0,0 +1,43 @@
1+-- | Like Latency, but creating lots of channels
2+import System.Environment
3+import Control.Monad
4+import Control.Applicative
5+import Control.Distributed.Process
6+import Control.Distributed.Process.Node
7+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
8+import Data.Binary (encode, decode)
9+import qualified Data.ByteString.Lazy as BSL
10+
11+pingServer :: Process ()
12+pingServer = forever $ do
13+ them <- expect
14+ sendChan them ()
15+ -- TODO: should this be automatic?
16+ reconnectPort them
17+
18+pingClient :: Int -> ProcessId -> Process ()
19+pingClient n them = do
20+ replicateM_ n $ do
21+ (sc, rc) <- newChan :: Process (SendPort (), ReceivePort ())
22+ send them sc
23+ receiveChan rc
24+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
25+
26+initialProcess :: String -> Process ()
27+initialProcess "SERVER" = do
28+ us <- getSelfPid
29+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
30+ pingServer
31+initialProcess "CLIENT" = do
32+ n <- liftIO $ getLine
33+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
34+ pingClient (read n) them
35+
36+main :: IO ()
37+main = do
38+ [role, host, port] <- getArgs
39+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
40+ case trans of
41+ Right transport -> do node <- newLocalNode transport initRemoteTable
42+ runProcess node $ initialProcess role
43+ Left other -> error $ show other
benchmarks/Headers.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
4− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
5− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
6− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
7− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
8− "JustPingC.data" smooth bezier with lines title "JustPingC"
9−set terminal postscript color
10−set output "Headers.ps"
11−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
12− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
13− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
14− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
15− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
16− "JustPingC.data" smooth bezier with lines title "JustPingC"
benchmarks/Indirection.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
4− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
5− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
6− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
7− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
8− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
9−set terminal postscript color
10−set output "Indirection.ps"
11−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
12− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
13− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
14− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
15− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
16− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
benchmarks/JustPingC.cdeleted−150
@@ -1,150 +0,0 @@
1−#include <stdio.h>
2−#include <stdlib.h>
3−#include <sys/types.h>
4−#include <sys/socket.h>
5−#include <netdb.h>
6−#include <string.h>
7−#include <unistd.h>
8−#include <signal.h>
9−#include <errno.h>
10−#include <time.h>
11−#include <sys/time.h>
12−#include <math.h>
13−
14−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
15−double timestamp() {
16− struct timeval tp;
17− gettimeofday(&tp, NULL);
18− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
19−}
20−
21−int server() {
22− printf("starting server\n");
23−
24− struct addrinfo hints, *res;
25− int error, server_socket;
26−
27− memset(&hints, 0, sizeof(hints));
28− hints.ai_family = PF_INET;
29− hints.ai_socktype = SOCK_STREAM;
30− hints.ai_flags = AI_PASSIVE;
31−
32− error = getaddrinfo(NULL, "8080", &hints, &res);
33− if(error) {
34− printf("server error: %s\n", gai_strerror(error));
35− return -1;
36− }
37−
38− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
39− if(server_socket < 0) {
40− printf("server error: could not create socket\n");
41− return -1;
42− }
43−
44− int yes = 1;
45− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
46− printf("server error: could not set socket options\n");
47− return -1;
48− }
49−
50− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
51− printf("server error: could not bind to socket\n");
52− return -1;
53− }
54−
55− listen(server_socket, 5);
56−
57− int client_socket;
58− struct sockaddr_storage client_addr;
59− socklen_t addr_size;
60− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
61−
62− for(;;) {
63− char* buf = malloc(8);
64− ssize_t read = recv(client_socket, buf, 8, 0);
65− if(read == 0) {
66− free(buf);
67− break;
68− }
69− // printf("server received '%s'\n", buf);
70− send(client_socket, buf, 8, 0);
71− free(buf);
72− }
73−
74− freeaddrinfo(res);
75− return 0;
76−}
77−
78−int client(int pings) {
79− printf("starting client\n");
80−
81− struct addrinfo hints, *res;
82− int error, client_socket;
83−
84− memset(&hints, 0, sizeof(hints));
85− hints.ai_family = PF_INET;
86− hints.ai_socktype = SOCK_STREAM;
87−
88− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
89− if(error) {
90− printf("client error: %s\n", gai_strerror(error));
91− return -1;
92− }
93−
94− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
95− if(client_socket < 0) {
96− printf("client error: could not create socket\n");
97− return -1;
98− }
99−
100− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
101− printf("client error: could not connect: %s\n", strerror(errno));
102− return -1;
103− }
104−
105− for(int i = 0; i < pings; i++) {
106− double timestamp_before = timestamp();
107−
108− send(client_socket, "ping123", 8, 0);
109−
110− char *buf = malloc(8);
111− ssize_t read = recv(client_socket, buf, 8, 0);
112−
113− if(read == 0) {
114− printf("server exited prematurely\n");
115− free(buf);
116− break;
117− }
118−
119− // printf("client received '%s'\n", buf);
120− free(buf);
121−
122− double timestamp_after = timestamp();
123− fprintf(stderr, "%i %lf\n", i, timestamp_after - timestamp_before);
124− }
125−
126− printf("client did %d pings\n", pings);
127−
128− freeaddrinfo(res);
129− return 0;
130−}
131−
132−int usage(int argc, char** argv) {
133− printf("usage: %s <number of pings>\n", argv[0]);
134− return -1;
135−}
136−
137−int main(int argc, char** argv) {
138− if(argc != 2) {
139− return usage(argc, argv);
140− }
141−
142− if(fork() == 0) {
143− // TODO: we should wait until we know the server is ready
144− int pings = 0;
145− sscanf(argv[1], "%d", &pings);
146− return client(pings);
147− } else {
148− return server();
149− }
150−}
benchmarks/JustPingCacheHeader.hsdeleted−134
@@ -1,134 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− -- Ignore header
111− return payload
112−
113−-- | Cached header
114−header :: ByteString
115−header = pack "fake"
116−
117−-- | Wrapper around NBS.send (for profiling)
118−send :: Socket -> ByteString -> IO ()
119−send sock bs = do
120− NBS.sendMany sock [header, bs]
121−
122−-- | Encode length (manual for now)
123−encodeLength :: Int32 -> IO ByteString
124−encodeLength i32 =
125− BSI.create 4 $ \p ->
126− pokeByteOff p 0 (htonl (fromIntegral i32))
127−
128−-- | Decode length (manual for now)
129−decodeLength :: ByteString -> IO Int32
130−decodeLength bs =
131− let (fp, _, _) = BSI.toForeignPtr bs in
132− withForeignPtr fp $ \p -> do
133− w32 <- peekByteOff p 0
134− return (fromIntegral (ntohl w32))
benchmarks/JustPingHaskell.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−
27−main :: IO ()
28−main = do
29− [pingsStr] <- getArgs
30− serverReady <- newEmptyMVar
31− clientDone <- newEmptyMVar
32−
33− -- Start the server
34− forkIO $ do
35− putStrLn "server: creating TCP connection"
36− serverAddrs <- getAddrInfo
37− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
38− Nothing
39− (Just "8080")
40− let serverAddr = head serverAddrs
41− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
42− setSocketOption sock ReuseAddr 1
43− bindSocket sock (addrAddress serverAddr)
44−
45− putStrLn "server: awaiting client connection"
46− putMVar serverReady ()
47− listen sock 1
48− (clientSock, clientAddr) <- accept sock
49−
50− putStrLn "server: listening for pings"
51− pong clientSock
52−
53− -- Start the client
54− forkIO $ do
55− takeMVar serverReady
56− let pings = read pingsStr
57− serverAddrs <- getAddrInfo
58− Nothing
59− (Just "127.0.0.1")
60− (Just "8080")
61− let serverAddr = head serverAddrs
62− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
63−
64− N.connect sock (addrAddress serverAddr)
65−
66− ping sock pings
67− putMVar clientDone ()
68−
69− -- Wait for the client to finish
70− takeMVar clientDone
71−
72−pingMessage :: ByteString
73−pingMessage = pack "ping123"
74−
75−ping :: Socket -> Int -> IO ()
76−ping sock pings = go pings
77− where
78− go :: Int -> IO ()
79− go 0 = do
80− putStrLn $ "client did " ++ show pings ++ " pings"
81− go !i = do
82− before <- getCurrentTime
83− send sock pingMessage
84− bs <- recv sock 8
85− after <- getCurrentTime
86− -- putStrLn $ "client received " ++ unpack bs
87− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
88− hPutStrLn stderr $ show i ++ " " ++ show latency
89− go (i - 1)
90−
91−pong :: Socket -> IO ()
92−pong sock = do
93− bs <- recv sock 8
94− -- putStrLn $ "server received " ++ unpack bs
95− when (BS.length bs > 0) $ do
96− send sock bs
97− pong sock
98−
99−-- | Wrapper around NBS.recv (for profiling)
100−recv :: Socket -> Int -> IO ByteString
101−recv = NBS.recv
102−
103−-- | Wrapper around NBS.send (for profiling)
104−send :: Socket -> ByteString -> IO Int
105−send = NBS.send
benchmarks/JustPingOneRecv.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− length <- decodeLength header -- Ignored
111− return payload
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
benchmarks/JustPingThroughChan.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexChannel <- newChan
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToChan clientSock multiplexChannel
59−
60− -- Reply to the client
61− forever $ readChan multiplexChannel >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToChan :: Socket -> Chan ByteString -> IO ()
76−socketToChan sock chan = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− writeChan chan bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
benchmarks/JustPingThroughMVar.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexMVar <- newEmptyMVar
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToMVar clientSock multiplexMVar
59−
60− -- Reply to the client
61− forever $ takeMVar multiplexMVar >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToMVar :: Socket -> MVar ByteString -> IO ()
76−socketToMVar sock mvar = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− putMVar mvar bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
benchmarks/JustPingTransport.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import System.Environment (getArgs, withArgs)
9−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
10−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
11−import Control.Concurrent (forkIO)
12−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
13−import qualified Network.Socket as N
14−import Debug.Trace
15−import Data.ByteString (ByteString)
16−import Data.ByteString.Char8 (pack, unpack)
17−import qualified Data.ByteString as BS
18−import qualified Network.Socket.ByteString as NBS
19−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
20−import Network.Transport (newConnection, receive, connect, send, defaultHints,
21− serialize, deserialize, SourceEnd, TargetEnd)
22−import Network.Transport.TCP (mkTransport, TCPConfig (..))
23−
24−main :: IO ()
25−main = do
26− [pingsStr] <- getArgs
27− serverAddr <- newEmptyMVar
28− clientAddr <- newEmptyMVar
29− clientDone <- newEmptyMVar
30−
31− -- Start the server
32− forkIO $ do
33− -- establish transport
34− putStrLn "server: creating TCP connection"
35− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
36−
37− -- create ping end
38− (sourceAddrPing, targetEndPing) <- newConnection transport
39− putMVar serverAddr sourceAddrPing
40−
41− -- create pong end
42− sourceAddrPong <- takeMVar clientAddr
43− sourceEndPong <- connect sourceAddrPong
44−
45− -- reply to pings with pongs
46− putStrLn "server: awaiting client connection"
47− pong targetEndPing sourceEndPong
48−
49− -- Start the client
50− forkIO $ do
51− sourceAddr <- takeMVar serverAddr
52− let pings = read pingsStr
53−
54− -- establish transport
55− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
56−
57− -- Create ping end
58− sourceEndPing <- connect sourceAddr
59−
60− -- Create pong end
61− (sourceAddrPong, targetEndPong) <- newConnection transport
62− putMVar clientAddr sourceAddrPong
63−
64− ping sourceEndPing targetEndPong pings
65− putMVar clientDone ()
66−
67− -- Wait for the client to finish
68− takeMVar clientDone
69−
70−pingMessage :: ByteString
71−pingMessage = pack "ping123"
72−
73−ping :: SourceEnd -> TargetEnd -> Int -> IO ()
74−ping sourceEndPing targetEndPong pings = go pings
75− where
76− go :: Int -> IO ()
77− go 0 = do
78− putStrLn $ "client did " ++ show pings ++ " pings"
79− go !i = do
80− before <- getCurrentTime
81− send sourceEndPing [pingMessage]
82− [bs] <- receive targetEndPong
83− after <- getCurrentTime
84− -- putStrLn $ "client received " ++ unpack bs
85− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
86− hPutStrLn stderr $ show i ++ " " ++ show latency
87− go (i - 1)
88−
89−pong :: TargetEnd -> SourceEnd -> IO ()
90−pong targetEndPing sourceEndPong = do
91− [bs] <- receive targetEndPing
92− -- putStrLn $ "server received " ++ unpack bs
93− when (BS.length bs > 0) $ do
94− send sourceEndPong [bs]
95− pong targetEndPing sourceEndPong
benchmarks/JustPingTwoSocketPairs.hsdeleted−151
@@ -1,151 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr, NoDelay)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− pingsStr:args <- getArgs
40− serverReady <- newEmptyMVar
41− clientReady <- newEmptyMVar
42− clientDone <- newEmptyMVar
43−
44− -- Start the server
45− forkIO $ do
46− -- Initialize the server
47− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51− listen sock 1
52−
53− -- Set up multiplexing channel
54− multiplexChannel <- newChan
55−
56− -- Connect to the client (to reply)
57− forkIO $ do
58− takeMVar clientReady
59− clientAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8081")
60− pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol
61− N.connect pongSock (addrAddress clientAddr)
62− when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1
63− forever $ readChan multiplexChannel >>= send pongSock
64−
65− -- Wait for incoming connections (pings from the client)
66− putMVar serverReady ()
67− (pingSock, pingAddr) <- accept sock
68− socketToChan pingSock multiplexChannel
69−
70− -- Start the client
71− forkIO $ do
72− clientAddr:_ <- getAddrInfo passive Nothing (Just "8081")
73− sock <- socket (addrFamily clientAddr) Stream defaultProtocol
74− setSocketOption sock ReuseAddr 1
75− bindSocket sock (addrAddress clientAddr)
76− listen sock 1
77−
78− -- Set up multiplexing channel
79− multiplexChannel <- newChan
80−
81− -- Connect to the server (to send pings)
82− forkIO $ do
83− takeMVar serverReady
84− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
85− pingSock <- socket (addrFamily serverAddr) Stream defaultProtocol
86− N.connect pingSock (addrAddress serverAddr)
87− when ("--NoDelay" `elem` args) $ setSocketOption pingSock NoDelay 1
88− ping pingSock multiplexChannel (read pingsStr)
89− putMVar clientDone ()
90−
91− -- Wait for incoming connections (pongs from the server)
92− putMVar clientReady ()
93− (pongSock, pongAddr) <- accept sock
94− socketToChan pongSock multiplexChannel
95−
96− -- Wait for the client to finish
97− takeMVar clientDone
98−
99−socketToChan :: Socket -> Chan ByteString -> IO ()
100−socketToChan sock chan = go
101− where
102− go = do bs <- recv sock
103− when (BS.length bs > 0) $ do
104− writeChan chan bs
105− go
106−
107−pingMessage :: ByteString
108−pingMessage = pack "ping123"
109−
110−ping :: Socket -> Chan ByteString -> Int -> IO ()
111−ping sock chan pings = go pings
112− where
113− go :: Int -> IO ()
114− go 0 = do
115− putStrLn $ "client did " ++ show pings ++ " pings"
116− go !i = do
117− before <- getCurrentTime
118− send sock pingMessage
119− bs <- readChan chan
120− after <- getCurrentTime
121− -- putStrLn $ "client received " ++ unpack bs
122− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
123− hPutStrLn stderr $ show i ++ " " ++ show latency
124− go (i - 1)
125−
126−-- | Receive a package
127−recv :: Socket -> IO ByteString
128−recv sock = do
129− header <- NBS.recv sock 4
130− length <- decodeLength header
131− NBS.recv sock (fromIntegral (length :: Int32))
132−
133−-- | Send a package
134−send :: Socket -> ByteString -> IO ()
135−send sock bs = do
136− length <- encodeLength (fromIntegral (BS.length bs))
137− NBS.sendMany sock [length, bs]
138−
139−-- | Encode length (manual for now)
140−encodeLength :: Int32 -> IO ByteString
141−encodeLength i32 =
142− BSI.create 4 $ \p ->
143− pokeByteOff p 0 (htonl (fromIntegral i32))
144−
145−-- | Decode length (manual for now)
146−decodeLength :: ByteString -> IO Int32
147−decodeLength bs =
148− let (fp, _, _) = BSI.toForeignPtr bs in
149− withForeignPtr fp $ \p -> do
150− w32 <- peekByteOff p 0
151− return (fromIntegral (ntohl w32))
benchmarks/JustPingWithHeader.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock _ = do
109− header <- NBS.recv sock 4
110− length <- decodeLength header
111− NBS.recv sock (fromIntegral (length :: Int32))
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
benchmarks/Latency.hsnew file+39
@@ -0,0 +1,39 @@
1+import System.Environment
2+import Control.Monad
3+import Control.Applicative
4+import Control.Distributed.Process
5+import Control.Distributed.Process.Node
6+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
7+import Data.Binary (encode, decode)
8+import qualified Data.ByteString.Lazy as BSL
9+
10+pingServer :: Process ()
11+pingServer = forever $ do
12+ them <- expect
13+ send them ()
14+
15+pingClient :: Int -> ProcessId -> Process ()
16+pingClient n them = do
17+ us <- getSelfPid
18+ replicateM_ n $ send them us >> (expect :: Process ())
19+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20+
21+initialProcess :: String -> Process ()
22+initialProcess "SERVER" = do
23+ us <- getSelfPid
24+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25+ pingServer
26+initialProcess "CLIENT" = do
27+ n <- liftIO $ getLine
28+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29+ pingClient (read n) them
30+
31+main :: IO ()
32+main = do
33+ [role, host, port] <- getArgs
34+ trans <- createTransport
35+ (defaultTCPAddr host port) defaultTCPParameters
36+ case trans of
37+ Right transport -> do node <- newLocalNode transport initRemoteTable
38+ runProcess node $ initialProcess role
39+ Left other -> error $ show other
benchmarks/Makefiledeleted−72
@@ -1,72 +0,0 @@
1−
2−# Run 100K ping-pongs, for one trial:
3−size = 100000
4−trials = 1
5−# You can run "make run1 size=1000 trials=100" for example.
6−
7−
8−# Disable this to test installed packages only:
9−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src
10−
11−# Enable for profiling
12−# PROFILING=-prof -fprof-auto
13−
14−ifeq ($(GHC),)
15− GHC=ghc
16−endif
17−
18−BENCHS= PingTCP.exe PingTCPTransport.exe PingPipes.exe SendTransport.exe
19−
20−all: $(BENCHS)
21−$(BENCHS): %.exe: %.hs
22− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $(PROFILING) $< -o $@
23−
24−#-------------------------------------------------------------------------------
25−# Shorthands for running benchmarks:
26−
27−run: run1 run2 run3 run4
28−
29−run1: runBaseline
30−runBaseline:
31− ./PingTCP.exe server 8080 &
32− sleep 1
33− time ./PingTCP.exe client 0.0.0.0 8080 $(size) $(trials)
34− # Kill the server:
35− killall PingTCP.exe
36−
37−run2: runTCP
38−runTCP:
39− ./PingTCPTransport.exe server 0.0.0.0 8080 sourceAddr &
40− sleep 1
41− # Run 100K ping-pongs, for one trial:
42− time ./PingTCPTransport.exe client 0.0.0.0 8081 sourceAddr $(size) $(trials)
43− # Kill the server:
44− killall PingTCPTransport.exe
45−
46−run3: runPipes
47−runPipes:
48− ./PingPipes.exe server sourceAddr &
49− sleep 1
50− time ./PingPipes.exe client sourceAddr $(size) $(trials)
51− # Kill the server:
52− killall PingPipes.exe
53−
54−# This benchmark measures throughput rather than latency
55−# Here 'size' means message size rather than number of pings:
56−run4: runTPT
57−runTPT:
58− ./SendTransport.exe server 0.0.0.0 8080 sourceAddr &
59− sleep 1
60− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr $(size)
61− killall SendTransport.exe
62−
63−# Run multiple sizes:
64−runTPTs:
65− $(MAKE) runTPT size=1000
66− $(MAKE) runTPT size=5000
67− $(MAKE) runTPT size=10000
68− $(MAKE) runTPT size=50000
69− $(MAKE) runTPT size=100000
70−
71−clean:
72− rm -f *.hi *.o *.exe
benchmarks/Makefile.JustPingdeleted−48
@@ -1,48 +0,0 @@
1−# The "Just Ping" tests measure ping latency with as little overhead as possible
2−
3−NUMPINGS=100000
4−INCLUDES=-i../network-transport/src -i../network-transport-pipes/src
5−
6−# Enable for profiling
7−# PROF_GHC=-prof -fprof-auto
8−# PROF_EXE=+RTS -pa -RTS
9−
10−GCC=gcc -std=c99
11−GHC=ghc -rtsopts
12−
13−Indirection.ps: JustPingWithHeader.data \
14− JustPingThroughChan.data \
15− JustPingThroughMVar.data \
16− JustPingTwoSocketPairs.data \
17− JustPingTwoSocketPairsND.data \
18− JustPingTransport.data
19− gnuplot ./Indirection.gnuplot
20−
21−Headers.ps: JustPingC.data \
22− JustPingHaskellNT.data \
23− JustPingHaskell.data \
24− JustPingWithHeader.data \
25− JustPingOneRecv.data \
26− JustPingCacheHeader.data
27− gnuplot ./Headers.gnuplot
28−
29−JustPingC.exe: JustPingC.c
30− $(GCC) -O2 -o JustPingC.exe JustPingC.c
31−
32−JustPingHaskellNT.exe: JustPingHaskell.hs
33− $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs
34−
35−JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe
36− time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@
37−
38−%.data : %.exe
39− time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@
40−
41−%.exe :: %.hs
42− $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES)
43−
44−.PHONY: clean
45−clean:
46− rm -f *.data *.ps *.pdf *.o *.hi *.exe
47−
48−# vi:set noexpandtab:
benchmarks/PingPipes.hsdeleted−112
@@ -1,112 +0,0 @@
1−module Main where
2−
3−-- TODO: Merge with PingTCPTransport and factor differences.
4−
5−import Network.Transport (newConnection, receive, connect, send,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.Pipes (mkTransport)
8−
9−import Control.Monad (forever, replicateM_)
10−import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
11−import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
12−-- import Data.Binary (encode,decode)
13−import Data.Serialize (encode,decode)
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−
18−-- import qualified Data.ByteString.Lazy.Char8 as LBS
19−import qualified Data.ByteString.Char8 as BS
20−
21−-- | This performs a ping benchmark on the TCP transport. This can be
22−-- compiled using:
23−--
24−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
25−--
26−-- To use the compiled binary, first set up a server:
27−--
28−-- ./benchmarks/PingPipes server sourceAddr
29−--
30−-- Once this is established, launch a client to perform the benchmark. The
31−-- following command sends 1000 pings per mark.
32−--
33−-- ./benchmarks/PingPipes client sourceAddr 1000
34−--
35−-- The server must be restarted between benchmarks.
36−main :: IO ()
37−main = do
38− args <- getArgs
39− case args of
40− "server" : sourceAddrFilePath : [] -> do
41− -- establish transport
42− transport <- mkTransport
43−
44− -- create ping end
45− putStrLn "server: creating ping end"
46− (sourceAddrPing, targetEndPing) <- newConnection transport
47− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
48−
49− -- create pong end
50− putStrLn "server: creating pong end"
51− [sourceAddrPongBS] <- receive targetEndPing
52− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
53−
54− -- always respond to a ping with a pong
55− putStrLn "server: awaiting pings"
56− forever $ pong targetEndPing sourceEndPong
57−
58−
59− "client" : sourceAddrFilePath : pingsStr : reps : args' -> do
60− let pings = read pingsStr
61− -- establish transport
62− transport <- mkTransport
63−
64− -- create ping end
65− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
66− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
67−
68− -- create pong end
69− (sourceAddrPong, targetEndPong) <- newConnection transport
70− send sourceEndPing [serialize sourceAddrPong]
71−
72− -- benchmark the pings
73− case (read reps) :: Int of
74− 0 -> error "What would zero reps mean?"
75− 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
76− replicateM_ pings (ping sourceEndPing targetEndPong)
77− n -> withArgs args' $ defaultMainWith
78− (defaultConfig{ cfgSamples = ljust n })
79− (return ()) -- Init action.
80− [ benchPing sourceEndPing targetEndPong (fromIntegral pings) ]
81− putStrLn "Done with all ping/pongs."
82−
83−
84−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
85−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
86−-- in reply down the `SourceEnd`, repeating whatever was sent.
87−pong :: TargetEnd -> SourceEnd -> IO ()
88−pong targetEndPing sourceEndPong = do
89− bs <- receive targetEndPing
90− send sourceEndPong bs
91−
92−-- | The effect of `ping sourceEndPing targetEndPong n` is to send the number
93−-- `n` using `sourceEndPing`, and to then receive the a number from
94−-- `targetEndPong`, which is then returned.
95−ping :: SourceEnd -> TargetEnd -> IO Int64
96−ping sourceEndPing targetEndPong = do
97− -- send sourceEndPing [BS.empty]
98− send sourceEndPing [encode (42 :: Int64)]
99−
100− [bs] <- receive targetEndPong
101−-- return $ decode bs
102− case decode bs of
103− Left err -> error$ "decode failure: " ++ err
104− Right x -> return x
105−
106−-- | The effect of `benchPing sourceEndPing targetEndPong n` is to send
107−-- `n` pings down `sourceEndPing` using the `ping` function. The time
108−-- taken is benchmarked.
109−benchPing :: SourceEnd -> TargetEnd -> Int64 -> Benchmark
110−benchPing sourceEndPing targetEndPong n = bench "PingTransport" $
111− nfIO (replicateM_ (fromIntegral n) (ping sourceEndPing targetEndPong))
112−
benchmarks/PingTCP.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
18−import System.IO (withFile, IOMode(..), hPutStrLn, Handle)
19−import Control.Concurrent (forkIO)
20−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
21−
22−import qualified Network.Socket as N
23−
24−import Debug.Trace
25−
26−#ifndef LAZY
27−import Data.ByteString (ByteString)
28−import Data.ByteString.Char8 (pack)
29−import qualified Data.ByteString as BS
30−import qualified Network.Socket.ByteString as NBS
31−encode = Ser.encode
32−decode = Ser.decode
33−#else
34−import Data.ByteString.Lazy (ByteString, pack)
35−import qualified Network.Socket.ByteString.Lazy as NBS
36−encode = Ser.encodeLazy
37−decode = Ser.decodeLazy
38−#endif
39−{-# INLINE encode #-}
40−{-# INLINE decode #-}
41−encode :: Ser.Serialize a => a -> ByteString
42−decode :: Ser.Serialize a => ByteString -> Either String a
43−
44−-- | This performs a ping benchmark on a TCP connection created by
45−-- Network.Socket. To compile this file, you might use:
46−--
47−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTCP.hs
48−--
49−-- To use the compiled binary, first set up the server on the current machine:
50−--
51−-- ./benchmarks/PingTCP server 8080
52−--
53−-- Next, perform the benchmark on a client using the server address, where
54−-- each mark is 1000 pings:
55−--
56−-- ./benchmarks/PingTCP client 0.0.0.0 8080 1000
57−--
58−-- The server must be restarted between benchmarks.
59−main :: IO ()
60−main = do
61− [pingsStr] <- getArgs
62− serverReady <- newEmptyMVar
63−
64− -- Start the server
65− forkIO $ do
66− putStrLn "server: creating TCP connection"
67− serverAddrs <- getAddrInfo
68− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
69− Nothing
70− (Just "8080")
71− let serverAddr = head serverAddrs
72− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
73− setSocketOption sock ReuseAddr 1
74− bindSocket sock (addrAddress serverAddr)
75−
76− putStrLn "server: awaiting client connection"
77− putMVar serverReady ()
78− listen sock 1
79− (clientSock, clientAddr) <- accept sock
80−
81− putStrLn "server: listening for pings"
82− pong clientSock
83−
84− -- Client
85− takeMVar serverReady
86− let pings = read pingsStr
87− serverAddrs <- getAddrInfo
88− Nothing
89− (Just "127.0.0.1")
90− (Just "8080")
91− let serverAddr = head serverAddrs
92− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
93−
94− N.connect sock (addrAddress serverAddr)
95−
96− ping sock pings
97−
98−pingMessage :: ByteString
99−pingMessage = pack "ping123"
100−
101−ping :: Socket -> Int -> IO ()
102−ping sock pings = go [] pings
103− where
104− go :: [Double] -> Int -> IO ()
105− go rtl 0 = do
106− withFile "round-trip-latency-tcp.data" WriteMode (writeData rtl)
107− putStrLn $ "client did " ++ show pings ++ " pings"
108− go rtl !i = do
109− before <- getCurrentTime
110− send sock pingMessage
111− bs <- recv sock 8
112− after <- getCurrentTime
113− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
114− latency `seq` go (latency : rtl) (i - 1)
115− writeData :: [Double] -> Handle -> IO ()
116− writeData rtl h = forM_ (zip [0..] rtl) (writeDataLine h)
117− writeDataLine :: Handle -> (Int, Double) -> IO ()
118− writeDataLine h (i, latency) = hPutStrLn h $ (show i) ++ " " ++ (show latency)
119−
120−pong :: Socket -> IO ()
121−pong sock = do
122− bs <- recv sock 8
123− when (BS.length bs > 0) $ do
124− send sock bs
125− pong sock
126−
127−-- | Wrapper around NBS.recv (for profiling)
128−recv :: Socket -> Int -> IO ByteString
129−recv = NBS.recv
130−
131−-- | Wrapper around NBS.send (for profiling)
132−send :: Socket -> ByteString -> IO Int
133−send = NBS.send
benchmarks/PingTCPTransport.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Network.Transport (newConnection, receive, connect, send, defaultHints,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Monad (forever, replicateM_, forM_)
10−
11−import qualified Data.Serialize as Ser
12−import Data.Maybe (fromJust)
13−import Data.Int
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−
20−#ifndef LAZY
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import qualified Data.ByteString.Lazy.Char8 as BS
27−import qualified Network.Socket.ByteString.Lazy as NBS
28−encode = Ser.encodeLazy
29−decode = Ser.decodeLazy
30−#endif
31−{-# INLINE encode #-}
32−{-# INLINE decode #-}
33−encode :: Ser.Serialize a => a -> BS.ByteString
34−decode :: Ser.Serialize a => BS.ByteString -> Either String a
35−
36−
37−
38−-- | This performs a ping benchmark on the TCP transport. This can be
39−-- compiled using:
40−--
41−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
42−--
43−-- To use the compiled binary, first set up a server:
44−--
45−-- ./benchmarks/PingTransport server 0.0.0.0 8080 sourceAddr
46−--
47−-- Once this is established, launch a client to perform the benchmark. The
48−-- following command sends 1000 pings per mark.
49−--
50−-- ./benchmarks/PingTransport client 0.0.0.0 8081 sourceAddr 1000
51−--
52−-- The server must be restarted between benchmarks.
53−main :: IO ()
54−main = do
55− [pingsStr] <- getArgs
56− serverAddr <- newEmptyMVar
57− clientAddr <- newEmptyMVar
58−
59− -- Start the server
60− forkIO $ do
61− -- establish transport
62− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
63−
64− -- create ping end
65− putStrLn "server: creating ping end"
66− (sourceAddrPing, targetEndPing) <- newConnection transport
67− putMVar serverAddr sourceAddrPing
68−
69− -- create pong end
70− putStrLn "server: creating pong end"
71− sourceAddrPong <- takeMVar clientAddr
72− sourceEndPong <- connect sourceAddrPong
73−
74− -- always respond to a ping with a pong
75− putStrLn "server: awaiting pings"
76− pong targetEndPing sourceEndPong
77−
78− -- Client
79− sourceAddr <- takeMVar serverAddr
80− let pings = read pingsStr
81− -- establish transport
82− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
83−
84− -- create ping end
85− sourceEndPing <- connect sourceAddr
86−
87− -- create pong end
88− (sourceAddrPong, targetEndPong) <- newConnection transport
89− putMVar clientAddr sourceAddrPong
90−
91− ping sourceEndPing targetEndPong pings
92− putStrLn "Done with all ping/pongs."
93−
94−-- | The message we use to ping (CAF so that we don't keep encoding it)
95−pingMessage :: BS.ByteString
96−pingMessage = BS.pack "ping123"
97−
98−-- | Keep replying to pings (send pongs)
99−pong :: TargetEnd -> SourceEnd -> IO ()
100−pong targetEndPing sourceEndPong = do
101− [bs] <- receive targetEndPing
102− -- putStrLn $ "server got " ++ BS.unpack bs
103− send sourceEndPong [bs]
104− pong targetEndPing sourceEndPong
105−
106−-- | Send a number of pings
107−ping :: SourceEnd -> TargetEnd -> Int -> IO ()
108−ping sourceEndPing targetEndPong pings = go [] pings
109− where
110− go :: [Double] -> Int -> IO ()
111− go rtl 0 = do
112− outputData rtl
113− putStrLn $ "client did " ++ show pings ++ " pings"
114− go rtl !i = do
115− before <- getCurrentTime
116− send sourceEndPing [pingMessage]
117− [bs] <- receive targetEndPong
118− -- putStrLn $ "client got " ++ BS.unpack bs
119− after <- getCurrentTime
120− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
121− latency `seq` go (latency : rtl) (i - 1)
122−
123−-- | Output latencies to a file to be plotted
124−outputData :: [Double] -> IO ()
125−outputData rtl = do
126− withFile "round-trip-latency-tcp-transport.data" WriteMode $ \h ->
127− forM_ (zip [0..] rtl) $ \(i, latency) ->
128− hPutStrLn h $ (show i) ++ " " ++ (show latency)
benchmarks/ProcessRing.hsnew file+117
@@ -0,0 +1,117 @@
1+{- ProcessRing benchmarks.
2+
3+To run the benchmarks, select a value for the ring size (sz) and
4+the number of times to send a message around the ring
5+
6+-}
7+
8+{-# LANGUAGE BangPatterns #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+
11+import Control.Monad
12+import Control.Distributed.Process hiding (catch)
13+import Control.Distributed.Process.Node
14+import Control.Exception (catch, SomeException)
15+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
16+import System.Environment
17+import System.Console.GetOpt
18+
19+data Options = Options
20+ { optRingSize :: Int
21+ , optIterations :: Int
22+ , optForward :: Bool
23+ , optParallel :: Bool
24+ , optUnsafe :: Bool
25+ } deriving Show
26+
27+initialProcess :: Options -> Process ()
28+initialProcess op =
29+ let ringSz = optRingSize op
30+ msgCnt = optIterations op
31+ fwd = optForward op
32+ unsafe = optUnsafe op
33+ msg = ("foobar", "baz")
34+ in do
35+ self <- getSelfPid
36+ ring <- makeRing fwd unsafe ringSz self
37+ forM_ [1..msgCnt] (\_ -> send ring msg)
38+ collect msgCnt
39+ where relay fsend pid = do
40+ msg <- expect :: Process (String, String)
41+ fsend pid msg
42+ relay fsend pid
43+
44+ forward' pid =
45+ receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid
46+
47+ makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId
48+ makeRing !f !u !n !pid
49+ | n == 0 = go f u pid
50+ | otherwise = go f u pid >>= makeRing f u (n - 1)
51+
52+ go :: Bool -> Bool -> ProcessId -> Process ProcessId
53+ go False False next = spawnLocal $ relay send next
54+ go False True next = spawnLocal $ relay unsafeSend next
55+ go True _ next = spawnLocal $ forward' next
56+
57+ collect :: Int -> Process ()
58+ collect !n
59+ | n == 0 = return ()
60+ | otherwise = do
61+ receiveWait [
62+ matchIf (\(a, b) -> a == "foobar" && b == "baz")
63+ (\_ -> return ())
64+ , matchAny (\_ -> error "unexpected input!")
65+ ]
66+ collect (n - 1)
67+
68+defaultOptions :: Options
69+defaultOptions = Options
70+ { optRingSize = 10
71+ , optIterations = 100
72+ , optForward = False
73+ , optParallel = False
74+ , optUnsafe = False
75+ }
76+
77+options :: [OptDescr (Options -> Options)]
78+options =
79+ [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"
80+ , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"
81+ , Option ['f'] ["forward"]
82+ (NoArg (\opts -> opts { optForward = True }))
83+ "use `forward' instead of send - default = False"
84+ , Option ['u'] ["unsafe-send"]
85+ (NoArg (\opts -> opts { optUnsafe = True }))
86+ "use 'unsafeSend' (ignored with -f) - default = False"
87+ , Option ['p'] ["parallel"]
88+ (NoArg (\opts -> opts { optParallel = True }))
89+ "send in parallel and consume sequentially - default = False"
90+ ]
91+
92+optMsgCnt :: Maybe String -> Options -> Options
93+optMsgCnt Nothing opts = opts
94+optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }
95+
96+optSz :: Maybe String -> Options -> Options
97+optSz Nothing opts = opts
98+optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }
99+
100+parseArgv :: [String] -> IO (Options, [String])
101+parseArgv argv = do
102+ pn <- getProgName
103+ case getOpt Permute options argv of
104+ (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
105+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))
106+ where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"
107+
108+main :: IO ()
109+main = do
110+ argv <- getArgs
111+ (opt, _) <- parseArgv argv
112+ putStrLn $ "options: " ++ (show opt)
113+ Right transport <- createTransport
114+ (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters
115+ node <- newLocalNode transport initRemoteTable
116+ catch (void $ runProcess node $ initialProcess opt)
117+ (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
benchmarks/SendTCP.hsdeleted−109
@@ -1,109 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Main where
4−
5−import Control.Monad
6−import Criterion.Main (Benchmark, bench, defaultMain, nfIO, bgroup)
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−
18−import qualified Network.Socket as N
19−
20−#ifdef LAZY
21−import Data.ByteString (ByteString)
22−import qualified Data.ByteString as BS
23−import qualified Network.Socket.ByteString as NBS
24−encode = Ser.encode
25−decode = Ser.decode
26−#else
27−import Data.ByteString.Lazy (ByteString)
28−import qualified Data.ByteString.Lazy as BS
29−import qualified Network.Socket.ByteString.Lazy as NBS
30−encode = Ser.encodeLazy
31−decode = Ser.decodeLazy
32−#endif
33−{-# INLINE encode #-}
34−{-# INLINE decode #-}
35−encode :: Ser.Serialize a => a -> ByteString
36−decode :: Ser.Serialize a => ByteString -> Either String a
37−
38−-- | This performs a benchmark on a TCP connection to measure how long it takes
39−-- to transfer a number of bytes.
40−-- To compile this file, you might use:
41−--
42−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTCP.hs
43−--
44−-- To use the compiled binary, first set up the server on the current machine,
45−-- such that it expects 1000 bytes:
46−--
47−-- ./benchmarks/SendTCP server 8080 1000
48−--
49−-- Next, perform the benchmark on a client using the server address, where
50−-- each mark is 1000 bytes:
51−--
52−-- ./benchmarks/SendTCP client 0.0.0.0 8080 1000
53−--
54−-- The server must be restarted between benchmarks.
55−main :: IO ()
56−main = do
57− args <- getArgs
58− case args of
59− "server" : service : sizeStr : [] -> withSocketsDo $ do
60− let size = read sizeStr
61− putStrLn "server: creating TCP connection"
62− serverAddrs <- getAddrInfo
63− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
64− Nothing
65− (Just service)
66− let serverAddr = head serverAddrs
67− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− setSocketOption sock ReuseAddr 1
69− bindSocket sock (addrAddress serverAddr)
70−
71− putStrLn "server: awaiting client connection"
72− listen sock 1
73− (clientSock, clientAddr) <- accept sock
74−
75− putStrLn "server: listening for data"
76−
77− forever $ pong clientSock size
78−
79− "client": host : service : sizeStr : args' -> withSocketsDo $ do
80− let size = read sizeStr
81− serverAddrs <- getAddrInfo
82− Nothing
83− (Just host)
84− (Just service)
85− let serverAddr = head serverAddrs
86− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
87−
88− N.connect sock (addrAddress serverAddr)
89−
90− -- benchmark the data
91− let bs = BS.replicate size 0
92− withArgs args' $ defaultMain [ benchSend sock bs ]
93−
94−-- | Each `ping` sends a `ByteString` and expects a byte in return.
95−ping :: Socket -> ByteString -> IO Word8
96−ping sock bs = do
97− NBS.send sock bs
98− bs' <- NBS.recv sock 1
99− either error return $ decode bs
100−
101−-- pong :: Socket -> Int64 -> IO ()
102−pong sock size = do
103− bs <- NBS.recv sock size
104− NBS.sendAll sock (encode (0 :: Word8))
105− return ()
106−
107−benchSend :: Socket -> ByteString -> Benchmark
108−benchSend sock bs = bench "SendTCP" $
109− nfIO (ping sock bs)
benchmarks/SendTransport.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoMonomorphismRestriction #-}
3−
4−module Main where
5−
6−import Network.Transport (newConnection, receive, connect, send, defaultHints,
7− serialize, deserialize, SourceEnd, TargetEnd)
8−import Network.Transport.TCP (mkTransport, TCPConfig (..))
9−
10−import Control.Applicative
11−import Control.Monad (forever, replicateM, replicateM_)
12−import Criterion.Main (Benchmark, bench, defaultMain, nfIO)
13−import qualified Data.Serialize as Ser
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−import System.Random
18−
19−#ifndef LAZY
20−import Data.ByteString (ByteString)
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import Data.ByteString.Lazy (ByteString)
27−import qualified Data.ByteString.Lazy.Char8 as BS
28−import qualified Network.Socket.ByteString.Lazy as NBS
29−encode = Ser.encodeLazy
30−decode = Ser.decodeLazy
31−#endif
32−{-# INLINE encode #-}
33−{-# INLINE decode #-}
34−encode :: Ser.Serialize a => a -> ByteString
35−decode :: Ser.Serialize a => ByteString -> Either String a
36−
37−-- | This performs a benchmark on the TCP transport to measure how long
38−-- it takes to transfer a number of bytes. This can be compiled using:
39−--
40−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTransport.hs
41−--
42−-- To use the compiled binary, first set up a server:
43−--
44−-- ./benchmarks/SendTransport server 0.0.0.0 8080 sourceAddr
45−--
46−-- Once this is established, launch a client to perform the benchmark. The
47−-- following command sends 1000 bytes per mark.
48−--
49−-- ./benchmarks/SendTransport client 0.0.0.0 8081 sourceAddr 1000
50−--
51−-- The server must be restarted between benchmarks.
52−main :: IO ()
53−main = do
54− args <- getArgs
55− case args of
56− "server" : host : service : sourceAddrFilePath : [] -> do
57−
58− -- establish transport
59− transport <- mkTransport $ TCPConfig defaultHints host service
60−
61− -- create ping end
62− putStrLn "server: creating ping end"
63− (sourceAddrPing, targetEndPing) <- newConnection transport
64− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
65−
66− -- create pong end
67− putStrLn "server: creating pong end"
68− [sourceAddrPongBS] <- receive targetEndPing
69− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
70−
71− -- always respond to a ping with a pong
72− putStrLn "server: awaiting pings"
73− forever $ pong targetEndPing sourceEndPong
74−
75−
76− "client" : host : service : sourceAddrFilePath : sizeStr : args' -> do
77− let size = read sizeStr
78−
79− -- establish transport
80− transport <- mkTransport $ TCPConfig defaultHints host service
81−
82− -- create ping end
83− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
84− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
85−
86− -- create pong end
87− (sourceAddrPong, targetEndPong) <- newConnection transport
88− send sourceEndPing [serialize sourceAddrPong]
89−
90− -- benchmark the data
91− bs <- BS.pack <$> replicateM size randomIO
92− withArgs args' $ defaultMain [ benchSend sourceEndPing targetEndPong bs ]
93−
94−-- | The effect of `ping sourceEndPing targetEndPong bs` is to send the
95−-- `ByteString` `bs` using `sourceEndPing`, and to then receive
96−-- that string back. Returns the length of the received message.
97−ping :: SourceEnd -> TargetEnd -> ByteString -> IO Int
98−ping sourceEndPing targetEndPong bs = do
99− send sourceEndPing [bs]
100− cs <- receive targetEndPong
101− return . fromIntegral $! sum (map BS.length cs)
102−
103−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
104−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
105−-- in reply down the `SourceEnd`, repeating whatever was sent.
106−pong :: TargetEnd -> SourceEnd -> IO ()
107−pong targetEndPing sourceEndPong = do
108− bs <- receive targetEndPing
109− send sourceEndPong bs
110−
111−-- | The effect of `benchSend sourceEndPing targetEndPong bs` is to send
112−-- `bs` pings down `sourceEndPing` using the `ping` function. The time
113−-- taken is benchmarked.
114−benchSend :: SourceEnd -> TargetEnd -> ByteString -> Benchmark
115−benchSend sourceEndPing targetEndPong bs = bench "SendTransport" $
116− nfIO (ping sourceEndPing targetEndPong bs)
117−
benchmarks/Spawns.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+-- | Like Throughput, but send every ping from a different process
4+-- (i.e., require a lightweight connection per ping)
5+import System.Environment
6+import Control.Monad
7+import Control.Applicative
8+import Control.Distributed.Process
9+import Control.Distributed.Process.Node
10+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
11+import Data.Binary (encode, decode)
12+import qualified Data.ByteString.Lazy as BSL
13+
14+counter :: Process ()
15+counter = go 0
16+ where
17+ go :: Int -> Process ()
18+ go !n = do
19+ b <- expect
20+ case b of
21+ Nothing -> go (n + 1)
22+ Just them -> send them n >> go 0
23+
24+count :: Int -> ProcessId -> Process ()
25+count n them = do
26+ us <- getSelfPid
27+ replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)
28+ send them (Just us)
29+ n' <- expect
30+ liftIO $ print (n == n')
31+
32+initialProcess :: String -> Process ()
33+initialProcess "SERVER" = do
34+ us <- getSelfPid
35+ liftIO $ BSL.writeFile "counter.pid" (encode us)
36+ counter
37+initialProcess "CLIENT" = do
38+ n <- liftIO $ getLine
39+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
40+ count (read n) them
41+
42+main :: IO ()
43+main = do
44+ [role, host, port] <- getArgs
45+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
46+ case trans of
47+ Right transport -> do node <- newLocalNode transport initRemoteTable
48+ runProcess node $ initialProcess role
49+ Left other -> error $ show other
benchmarks/Throughput.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+
4+import System.Environment
5+import Control.Monad
6+import Control.Applicative
7+import Control.Distributed.Process
8+import Control.Distributed.Process.Node
9+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)
10+import Data.Binary
11+import qualified Data.ByteString.Lazy as BSL
12+import Data.Typeable
13+
14+data SizedList a = SizedList { size :: Int , elems :: [a] }
15+ deriving (Typeable)
16+
17+instance Binary a => Binary (SizedList a) where
18+ put (SizedList sz xs) = put sz >> mapM_ put xs
19+ get = do
20+ sz <- get
21+ xs <- getMany sz
22+ return (SizedList sz xs)
23+
24+-- Copied from Data.Binary
25+getMany :: Binary a => Int -> Get [a]
26+getMany = go []
27+ where
28+ go xs 0 = return $! reverse xs
29+ go xs i = do x <- get
30+ x `seq` go (x:xs) (i-1)
31+{-# INLINE getMany #-}
32+
33+nats :: Int -> SizedList Int
34+nats = \n -> SizedList n (aux n)
35+ where
36+ aux 0 = []
37+ aux n = n : aux (n - 1)
38+
39+counter :: Process ()
40+counter = go 0
41+ where
42+ go :: Int -> Process ()
43+ go !n =
44+ receiveWait
45+ [ match $ \xs -> go (n + size (xs :: SizedList Int))
46+ , match $ \them -> send them n >> go 0
47+ ]
48+
49+count :: (Int, Int) -> ProcessId -> Process ()
50+count (packets, sz) them = do
51+ us <- getSelfPid
52+ replicateM_ packets $ send them (nats sz)
53+ send them us
54+ n' <- expect
55+ liftIO $ print (packets * sz, n' == packets * sz)
56+
57+initialProcess :: String -> Process ()
58+initialProcess "SERVER" = do
59+ us <- getSelfPid
60+ liftIO $ BSL.writeFile "counter.pid" (encode us)
61+ counter
62+initialProcess "CLIENT" = do
63+ n <- liftIO getLine
64+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
65+ count (read n) them
66+
67+main :: IO ()
68+main = do
69+ [role, host, port] <- getArgs
70+ trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
71+ case trans of
72+ Right transport -> do node <- newLocalNode transport initRemoteTable
73+ runProcess node $ initialProcess role
74+ Left other -> error $ show other
benchmarks/erlang/latency.erlnew file+35
@@ -0,0 +1,35 @@
1+-module(latency).
2+
3+-export([server/0, client/2, start_server/0, start_client/2]).
4+
5+forever(What) ->
6+ What(),
7+ forever(What).
8+
9+replicate(0, _) ->
10+ ok;
11+replicate(N, What) ->
12+ What(),
13+ replicate(N - 1, What).
14+
15+server() ->
16+ forever(fun () ->
17+ receive
18+ Them -> Them ! pong
19+ end
20+ end).
21+
22+client(N, Them) ->
23+ replicate(N, fun() ->
24+ {pingServer, Them} ! self(),
25+ receive
26+ pong -> ok
27+ end
28+ end),
29+ io:format("Did ~B pings", [N]).
30+
31+start_server() ->
32+ register(pingServer, spawn(latency, server, [])).
33+
34+start_client(N, Them) ->
35+ client(N, Them).
benchmarks/erlang/ring.erlnew file+62
@@ -0,0 +1,62 @@
1+%% can be run via escript if desired...
2+-module(ring).
3+
4+-export([main/1]).
5+
6+-record(opts, {
7+ ring_size = 1 :: non_neg_integer(),
8+ iterations = 1 :: non_neg_integer()
9+}).
10+
11+main(Argv) when is_list(Argv) ->
12+ Opts = parse_args(Argv),
13+ {Time, ok} = timer:tc(fun() -> run(Opts) end),
14+ io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).
15+
16+run(#opts{ ring_size=RingSize, iterations=SendCount }) ->
17+ Self = self(),
18+ Msg = {"foobar", "baz"},
19+ Pid = make_ring(RingSize, Self),
20+ [Pid ! Msg || _ <- lists:seq(1, SendCount)],
21+ collect(SendCount).
22+
23+collect(0) ->
24+ ok;
25+collect(N) ->
26+ receive
27+ {"foobar", "baz"} -> collect(N - 1);
28+ Other -> exit({unexpected_message, Other})
29+ end.
30+
31+-spec(make_ring(integer(), pid()) -> pid()).
32+make_ring(0, NextPid) ->
33+ go(NextPid);
34+make_ring(NumProcs, NextPid) ->
35+ make_ring(NumProcs - 1, go(NextPid)).
36+
37+-spec(go(pid()) -> pid()).
38+go(NextPid) ->
39+ spawn(fun() -> relay(NextPid) end).
40+
41+-spec(relay(pid()) -> no_return()).
42+relay(NextPid) ->
43+ receive
44+ {_, _}=Msg -> NextPid ! Msg, relay(NextPid)
45+ end.
46+
47+-spec(parse_args([string()]) -> #opts{}).
48+parse_args(Argv) ->
49+ lists:foldl(fun parse_args/2, #opts{}, Argv).
50+
51+parse_args(("-r" ++ Val), Opts) ->
52+ Sz = check_positive(ring_size, list_to_integer(Val)),
53+ Opts#opts{ ring_size = Sz };
54+parse_args(("-i" ++ Val), Opts) ->
55+ Iter = check_positive(iterations, list_to_integer(Val)),
56+ Opts#opts{ iterations = Iter }.
57+
58+check_positive(K, N) when N < 1 ->
59+ io:format("~p must be >= 1~n", [K]),
60+ error({K, N});
61+check_positive(_, N) ->
62+ N.
benchmarks/erlang/throughput.erlnew file+39
@@ -0,0 +1,39 @@
1+-module(throughput).
2+
3+-export([start_counter/0, start_count/3, counter/0, count/3, nats/1]).
4+
5+nats(0) ->
6+ [];
7+nats(N) ->
8+ [N | nats(N - 1)].
9+
10+counter() ->
11+ counter(0).
12+
13+counter(N) ->
14+ receive
15+ {count, List} ->
16+ counter(N + length(List));
17+ {get, Them} ->
18+ Them ! N,
19+ counter(0)
20+ end.
21+
22+replicate(0, _) ->
23+ ok;
24+replicate(N, What) ->
25+ What(),
26+ replicate(N - 1, What).
27+
28+count(Packets, Size, Them) ->
29+ replicate(Packets, fun() -> {counter, Them} ! {count, nats(Size)} end),
30+ {counter, Them} ! {get, self()},
31+ receive
32+ N -> io:format("Did ~B pings", [N])
33+ end.
34+
35+start_counter() ->
36+ register(counter, spawn(throughput, counter, [])).
37+
38+start_count(Packets, Size, Them) ->
39+ count(Packets, Size, Them).
benchmarks/pingtest.cdeleted−183
@@ -1,183 +0,0 @@
1−/**
2− * Compute baseline average and standard deviancy ping latency
3− *
4− * Compile using
5− *
6− * gcc -o pingtest -O2 -std=c99 pingtest.c
7− *
8− * Then start server
9− *
10− * ./pingtest server &
11− *
12− * And finally start the client
13− *
14− * ./pingtest client <number of pings; for instance, 10000>
15− *
16− * The server will terminate when the client does.
17− *
18− * Edsko de Vries <edsko@well-typed.com>
19− */
20−
21−#include <stdio.h>
22−#include <stdlib.h>
23−#include <sys/types.h>
24−#include <sys/socket.h>
25−#include <netdb.h>
26−#include <string.h>
27−#include <unistd.h>
28−#include <signal.h>
29−#include <errno.h>
30−#include <time.h>
31−#include <sys/time.h>
32−#include <math.h>
33−
34−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
35−double timestamp() {
36− struct timeval tp;
37− gettimeofday(&tp, NULL);
38− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
39−}
40−
41−int server() {
42− printf("starting server\n");
43−
44− struct addrinfo hints, *res;
45− int error, server_socket;
46−
47− memset(&hints, 0, sizeof(hints));
48− hints.ai_family = PF_INET;
49− hints.ai_socktype = SOCK_STREAM;
50− hints.ai_flags = AI_PASSIVE;
51−
52− error = getaddrinfo(NULL, "8080", &hints, &res);
53− if(error) {
54− printf("server error: %s\n", gai_strerror(error));
55− return -1;
56− }
57−
58− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
59− if(server_socket < 0) {
60− printf("server error: could not create socket\n");
61− return -1;
62− }
63−
64− int yes = 1;
65− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
66− printf("server error: could not set socket options\n");
67− return -1;
68− }
69−
70− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
71− printf("server error: could not bind to socket\n");
72− return -1;
73− }
74−
75− listen(server_socket, 5);
76−
77− int client_socket;
78− struct sockaddr_storage client_addr;
79− socklen_t addr_size;
80− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
81−
82− for(;;) {
83− char buf[8];
84− ssize_t read = recv(client_socket, &buf, 8, 0);
85− // printf("server received '%s'\n", buf);
86− send(client_socket, buf, 8, 0);
87− }
88−
89− freeaddrinfo(res);
90− return 0;
91−}
92−
93−int client(int pings) {
94− printf("starting client\n");
95−
96− struct addrinfo hints, *res;
97− int error, client_socket;
98−
99− memset(&hints, 0, sizeof(hints));
100− hints.ai_family = PF_INET;
101− hints.ai_socktype = SOCK_STREAM;
102−
103− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
104− if(error) {
105− printf("client error: %s\n", gai_strerror(error));
106− return -1;
107− }
108−
109− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
110− if(client_socket < 0) {
111− printf("client error: could not create socket\n");
112− return -1;
113− }
114−
115− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
116− printf("client error: could not connect: %s\n", strerror(errno));
117− return -1;
118− }
119−
120− double* round_trip_latency = (double*) calloc(pings, sizeof(double));
121−
122− for(int i = 0; i < pings; i++) {
123− double timestamp_before = timestamp();
124−
125− send(client_socket, "ping123", 8, 0);
126−
127− char buf[8];
128− ssize_t read = recv(client_socket, &buf, 8, 0);
129− // printf("client received '%s'\n", buf);
130−
131− double timestamp_after = timestamp();
132− round_trip_latency[i] = timestamp_after - timestamp_before;
133− }
134−
135− printf("client did %d pings\n", pings);
136−
137− // Write data to a file for plotting
138− FILE* data = fopen("round-trip-latency-c.data", "wt");
139− for(int i = 0; i < pings; i++) {
140− fprintf(data, "%i %lf\n", i, round_trip_latency[i]);
141− }
142− fclose(data);
143−
144− // compute average
145− double round_trip_latency_average = 0;
146− for(int i = 0; i < pings; i++) {
147− round_trip_latency_average += round_trip_latency[i];
148− };
149− round_trip_latency_average /= (double) pings;
150−
151−
152− // compute standard deviation
153− double round_trip_latency_stddev = 0;
154− for(int i = 0; i < pings; i++) {
155− round_trip_latency_stddev += pow(round_trip_latency[i] - round_trip_latency_average, 2);
156− }
157− round_trip_latency_stddev = sqrt(round_trip_latency_stddev / (double) (pings - 1));
158−
159− printf("average round-trip latency: %lf us (standard devitation %lf us)\n", round_trip_latency_average, round_trip_latency_stddev);
160−
161− freeaddrinfo(res);
162− return 0;
163−}
164−
165−int usage(int argc, char** argv) {
166− printf("usage: %s <number of pings>\n", argv[0]);
167− return -1;
168−}
169−
170−int main(int argc, char** argv) {
171− if(argc != 2) {
172− return usage(argc, argv);
173− }
174−
175− if(fork() == 0) {
176− // TODO: we should wait until we know the server is ready
177− int pings = 0;
178− sscanf(argv[1], "%d", &pings);
179− return client(pings);
180− } else {
181− return server();
182− }
183−}
benchmarks/remote/Latency.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2+
3+import Control.Monad
4+import Control.Applicative
5+import Control.Monad.IO.Class (liftIO)
6+import qualified Data.ByteString.Lazy as BSL
7+import Data.Binary (encode, decode)
8+import Remote
9+
10+pingServer :: ProcessM ()
11+pingServer = forever $ do
12+ them <- expect
13+ send them ()
14+
15+pingClient :: Int -> ProcessId -> ProcessM ()
16+pingClient n them = do
17+ us <- getSelfPid
18+ replicateM_ n $ send them us >> (expect :: ProcessM ())
19+ liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20+
21+initialProcess :: String -> ProcessM ()
22+initialProcess "SERVER" = do
23+ us <- getSelfPid
24+ liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25+ pingServer
26+initialProcess "CLIENT" = do
27+ n <- liftIO $ getLine
28+ them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29+ pingClient (read n) them
30+
31+main :: IO ()
32+main = remoteInit (Just "config") [] initialProcess
benchmarks/remote/Throughput.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2+
3+import Control.Monad
4+import Control.Applicative
5+import Control.Monad.IO.Class (liftIO)
6+import qualified Data.ByteString.Lazy as BSL
7+import Data.Binary (encode, decode)
8+import Remote
9+
10+counter :: ProcessM ()
11+counter = go 0
12+ where
13+ go :: Int -> ProcessM ()
14+ go !n = do
15+ b <- expect
16+ case b of
17+ Nothing -> go (n + 1)
18+ Just them -> send them n >> go 0
19+
20+count :: Int -> ProcessId -> ProcessM ()
21+count n them = do
22+ us <- getSelfPid
23+ replicateM_ n $ send them (Nothing :: Maybe ProcessId)
24+ send them (Just us)
25+ n' <- expect
26+ liftIO $ print (n == n')
27+
28+initialProcess :: String -> ProcessM ()
29+initialProcess "SERVER" = do
30+ us <- getSelfPid
31+ liftIO $ BSL.writeFile "counter.pid" (encode us)
32+ counter
33+initialProcess "CLIENT" = do
34+ n <- liftIO $ getLine
35+ them <- liftIO $ decode <$> BSL.readFile "counter.pid"
36+ count (read n) them
37+
38+main :: IO ()
39+main = remoteInit (Just "config") [] initialProcess
benchmarks/results_notes.mddeleted−111
@@ -1,111 +0,0 @@
1−
2−
3−[2012.02.22] {File for notes on results}
4−============================================================
5−
6−Here's a run of the PingTCP benchmark on a 3.1 ghz Intel Westmere running RHEL 6.2:
7−
8− ./PingTCP.exe server 8080 &
9− sleep 1
10− server: creating TCP connection
11− server: awaiting client connection
12− ./PingTCP.exe client 0.0.0.0 8080 1000
13− server: listening for pings
14− warming up
15− estimating clock resolution...
16− mean is 1.963031 us (320001 iterations)
17− found 38180 outliers among 319999 samples (11.9%)
18− 32741 (10.2%) low severe
19− 5439 (1.7%) high severe
20− estimating cost of a clock call...
21− mean is 43.17696 ns (15 iterations)
22− found 2 outliers among 15 samples (13.3%)
23− 1 (6.7%) high mild
24− 1 (6.7%) high severe
25−
26− benchmarking PingTCP
27− collecting 100 samples, 1 iterations each, in estimated 8.073997 s
28− mean: 77.01177 ms, lb 76.92822 ms, ub 77.14009 ms, ci 0.950
29− std dev: 526.1251 us, lb 366.2692 us, ub 803.1751 us, ci 0.950
30−
31−(That was without -O2)
32−
33− -----
34−
35−Running a C benchmark on the same machine it takes 5.6 seconds to do
36−200K ping pongs.
37−
38− => 28 us avg latency for C
39−
40−I got 72 us avg latency using PingTCP. The named pipes backend took
41−19.8s and was using 100% CPU. That's a 99 us latency.
42−
43−Pipes with unix-bytestring take 11.0 seconds, but still use 100% CPU.
44−
45− => 55 us latency for Pipes with unix-bytestring
46−
47−
48−
49−[2012.02.24] {After Adam's strictness refactoring.}
50−============================================================
51−
52−100K ping/pongs, 1 trial:
53−
54− PingTCP: 7.34s >80%CPU
55− PingTCPTransport: 19s ~60%CPU
56− PingPipes: 6.36s >=100%CPU
57−
58−Timing instead using 100 trials of 1000 pingpongs via criterion gives
59−results consistent with the above. Here are the mean latencies:
60−
61− PingTCP: 72 us
62− PingTCPTransport: 191 us
63− PingPipes: 65 us
64−
65−And here is my first attempt at running the SendTransport benchmark (TCP backend):
66−
67− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 1000
68− mean: 38.10901 ms, lb 35.92353 ms, ub 39.30006 ms, ci 0.950
69− std dev: 8.305210 ms, lb 4.935312 ms, ub 11.97144 ms, ci 0.950
70− found 5 outliers among 100 samples (5.0%)
71− 5 (5.0%) low severe
72− variance introduced by outliers: 94.703%
73− variance is severely inflated by outliers
74−
75− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 5000
76− mean: 32.87646 ms, lb 29.69947 ms, ub 35.62485 ms, ci 0.950
77− std dev: 15.21419 ms, lb 12.39949 ms, ub 17.39441 ms, ci 0.950
78− found 18 outliers among 100 samples (18.0%)
79− 18 (18.0%) low severe
80− variance introduced by outliers: 98.928%
81− variance is severely inflated by outliers
82−
83− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 10000
84− mean: 32.87737 ms, lb 29.34305 ms, ub 35.62680 ms, ci 0.950
85− std dev: 15.22060 ms, lb 12.40398 ms, ub 17.57401 ms, ci 0.950
86− found 18 outliers among 100 samples (18.0%)
87− 18 (18.0%) low severe
88− variance introduced by outliers: 98.929%
89− variance is severely inflated by outliers
90−
91− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 50000
92− mean: 1.351308 ms, lb 1.249680 ms, ub 1.548209 ms, ci 0.950
93− std dev: 696.6768 us, lb 448.3538 us, ub 1.314057 ms, ci 0.950
94− found 24 outliers among 100 samples (24.0%)
95− 3 (3.0%) high mild
96− 21 (21.0%) high severe
97− variance introduced by outliers: 98.942%
98− variance is severely inflated by outliers
99−
100− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 100000
101− mean: 2.184967 ms, lb 2.030858 ms, ub 2.641543 ms, ci 0.950
102− std dev: 1.235358 ms, lb 518.3995 us, ub 2.666540 ms, ci 0.950
103− found 15 outliers among 100 samples (15.0%)
104− 4 (4.0%) low severe
105− 9 (9.0%) high severe
106− variance introduced by outliers: 98.952%
107− variance is severely inflated by outliers
108−
109−This is quite odd. so in addition to the high variance it would seem
110−that messages of size 50K or 100K are much FASTER to send than smaller
111−massages?
distributed-process-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/LICENSE → distributed-process-tests/LICENSErenamed+1−1
@@ -1,4 +1,4 @@
1−Copyright Well-Typed LLP, 2011
1+Copyright Well-Typed LLP, 2011-2012
22
33All rights reserved.
44
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.
network-transport/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/distributed-process.cabaldeleted−21
@@ -1,21 +0,0 @@
1−Name: distributed-process
2−Version: 0.0.1
3−Description: Distributed processes for message based concurrency.
4−License: BSD3
5−License-file: LICENSE
6−Author: Duncan Coutts, Nicolas Wu
7−Maintainer: duncan@well-typed.com
8−Homepage: http://github.com/haskell-distributed/
9−Build-Type: Simple
10−Cabal-Version: >=1.2
11−
12−Library
13− Build-Depends: base >= 3 && < 5,
14− bytestring >= 0.9,
15− containers >= 0.4,
16− mtl >= 2.0,
17− network-transport >= 0.0
18− Exposed-modules: Control.Distributed.Process
19− Extensions: ExplicitForAll ScopedTypeVariables
20− ghc-options: -Wall
21− HS-Source-Dirs: src
distributed-process/src/Control/Distributed/Process.hsdeleted−230
@@ -1,230 +0,0 @@
1−{-# LANGUAGE CPP, ExplicitForAll, ScopedTypeVariables #-}
2−
3−module Control.Distributed.Process (
4− -- * Processes
5− Process,
6− liftIO,
7− ProcessId,
8−-- NodeId,
9−
10− -- * Basic messaging
11− send,
12− expect,
13−
14− -- * Process management
15− spawnLocal,
16− getSelfPid,
17−-- getSelfNode,
18−
19− -- * Initialisation
20− Transport,
21− LocalNode,
22− newLocalNode,
23− runProcess,
24−
25− ) where
26−
27−import qualified Network.Transport as Trans
28−import Network.Transport (Transport)
29−
30−import qualified Data.IntMap as IntMap
31−import Data.IntMap (IntMap)
32−import Control.Applicative
33−import Control.Monad
34−import Control.Monad.Trans
35−import Control.Concurrent.MVar
36−import Control.Concurrent.Chan
37−import Control.Concurrent
38−import Data.Typeable
39−
40−import Debug.Trace
41−
42−#ifndef LAZY
43−import qualified Data.ByteString.Char8 as BS
44−import Data.ByteString.Char8 (ByteString)
45−#else
46−import qualified Data.ByteString.Lazy.Char8 as BS
47−import Data.ByteString.Lazy.Char8 (ByteString)
48−#endif
49−
50−------------------------
51−-- Cloud Haskell layer
52−--
53−
54−data NodeId = NodeId -- !Trans.SourceEnd !Trans.SourceEnd
55−
56−data ProcessId = ProcessId !Trans.SourceEnd !NodeId !LocalProcessId
57−type LocalProcessId = Int
58−
59−newtype SourcePort a = SourcePort Trans.SourceEnd
60−
61−newtype Process a = Process { unProcess :: ProcessState -> IO a }
62−
63−instance Functor Process where
64− fmap f m = Process (\ps -> unProcess m ps >>= \x -> return (f x))
65−
66−instance Applicative Process where
67− pure = return
68− (<*>) = ap
69−
70−instance Monad Process where
71− m >>= k = Process (\ps -> unProcess m ps >>= \x -> unProcess (k x) ps)
72− return x = Process (\_ -> return x)
73−
74−instance MonadIO Process where
75− liftIO io = Process (\_ -> io)
76−
77−getProcessState :: Process ProcessState
78−getProcessState = Process (\ps -> return ps)
79−
80−getLocalNode :: Process LocalNode
81−getLocalNode = prNode <$> getProcessState
82−
83−getSelfPid :: Process ProcessId
84−getSelfPid = prPid <$> getProcessState
85−
86−-- State a process carries around and has local access to
87−--
88−data ProcessState = ProcessState {
89− prPid :: !ProcessId,
90− prChan :: !Trans.TargetEnd,
91− prQueue :: !(CQueue Message),
92− prNode :: !LocalNode
93− }
94−
95−data Message = Message String --string rep of TypeRep, sigh.
96− String
97−
98−-- Context for a local node, all processes running on a node have direct access to this
99−--
100−data LocalNode = LocalNode {
101− ndProcessTable :: !(MVar ProcessTable),
102− ndTransport :: !Transport
103− }
104−
105−data ProcessTable = ProcessTable
106− !LocalProcessId -- ^ Value of next ProcessTableEntry index
107− !(IntMap ProcessTableEntry) -- ^ Index from LocalProcessIds to ProcessTableEntry
108−data ProcessTableEntry = ProcessTableEntry {
109− pteThread :: !ThreadId
110− }
111−
112−newLocalNode :: Transport -> IO LocalNode
113−newLocalNode trans = do
114− processTableVar <- newMVar (ProcessTable 0 IntMap.empty)
115− return LocalNode {
116− ndProcessTable = processTableVar,
117− ndTransport = trans
118− }
119−
120−-- | `runProcess` executes a process on a given node, and waits for the process
121−-- to finish before returning.
122−runProcess :: LocalNode -> Process () -> IO ()
123−runProcess node proc = do
124− waitVar <- newEmptyMVar
125− _ <- forkProcess node (proc >> liftIO (putMVar waitVar ()))
126− --TODO: should use linking for waiting for the end
127− takeMVar waitVar
128−
129−-- | `forkProcess` forks and executes process on a given node. This
130−-- returns the ProcessId when the new process has been created.
131−forkProcess :: LocalNode -> Process () -> IO ProcessId
132−forkProcess node (Process action) = do
133− (sourceAddr, chan) <- Trans.newConnection (ndTransport node)
134− sourceEnd <- Trans.connect sourceAddr
135− processTable@(ProcessTable lpid _) <- takeMVar (ndProcessTable node)
136− let pid = ProcessId sourceEnd NodeId lpid
137− _ <- forkIO $ do
138− tid <- myThreadId
139− putMVar (ndProcessTable node) (insertProcess tid processTable)
140− queue <- newCQueue
141− _ <- forkIO $ receiverPump chan queue
142− action $ ProcessState pid chan queue node
143− return pid
144−
145− where
146− insertProcess :: ThreadId -> ProcessTable -> ProcessTable
147− insertProcess tid (ProcessTable nextPid table) =
148− let pte = ProcessTableEntry tid
149− in ProcessTable (nextPid+1) (IntMap.insert nextPid pte table)
150−
151− receiverPump :: Trans.TargetEnd -> CQueue Message -> IO ()
152− receiverPump chan queue = forever $ do
153− msgBlobs <- Trans.receive chan
154− readBlobs (concatMap BS.unpack msgBlobs)
155− where
156− readBlobs :: String -> IO ()
157− readBlobs [] = return ()
158− readBlobs bs = do
159− -- TODO: replace reads with something safer and faster.
160− let [((typerep, body), bs')] = reads bs
161− enqueue queue (Message typerep body)
162− readBlobs bs'
163−
164−send :: (Typeable a, Show a) => ProcessId -> a -> Process ()
165−send (ProcessId chan _ _) msg =
166− liftIO (Trans.send chan msgBlobs)
167− where
168− msgBlobs :: [ByteString]
169− msgBlobs = [BS.pack (show (show (typeOf msg), show msg))]
170−
171−expect :: forall a. (Typeable a, Read a) => Process a
172−expect = do
173− ProcessState { prQueue = queue } <- getProcessState
174− let typerepstr = show (typeOf (undefined :: a))
175− Message _ body <- liftIO $
176− dequeueMatching queue (\(Message typerepstr' _) -> typerepstr' == typerepstr)
177− return (read body)
178−
179−spawnLocal :: Process () -> Process ProcessId
180−spawnLocal proc = do
181− node <- getLocalNode
182− liftIO $ forkProcess node proc
183−
184−{-
185−send :: Serializable a -> ProcessId -> a -> Process ()
186−expect :: Serializable a -> Process a
187−
188−newChan :: Serializable a => Process (SourcePort a, TargetPort a)
189−sendChan :: Serializable a => SourcePort a -> a -> Process ()
190−receiveChan :: Serializable a => TargetPort a -> Process a
191−
192−spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
193−terminate :: ProcessM a
194−getSelfPid :: ProcessM ProcessId
195−getSelfNode :: ProcessM NodeId
196−
197−monitorProcess :: ProcessId -> ProcessId -> MonitorAction -> Process ()
198−
199−-}
200−
201−-- Concurrent queue for single reader, single writer
202−--
203−data CQueue a = CQueue (MVar [a]) -- arrived
204− (Chan a) -- incomming
205−
206−newCQueue :: IO (CQueue a)
207−newCQueue = do
208− arrived <- newMVar []
209− incomming <- newChan
210− return (CQueue arrived incomming)
211−
212−enqueue :: CQueue a -> a -> IO ()
213−enqueue (CQueue _arrived incomming) a = writeChan incomming a
214−
215−dequeueMatching :: forall a. CQueue a -> (a -> Bool) -> IO a
216−dequeueMatching (CQueue arrived incomming) matches = do
217− modifyMVar arrived (checkArrived [])
218− where
219− checkArrived :: [a] -> [a] -> IO ([a], a)
220− checkArrived xs' [] = checkIncomming xs'
221− checkArrived xs' (x:xs)
222− | matches x = return (reverse xs' ++ xs, x)
223− | otherwise = checkArrived (x:xs') xs
224−
225− checkIncomming :: [a] -> IO ([a], a)
226− checkIncomming xs' = do
227− x <- readChan incomming
228− if matches x
229− then return (reverse xs', x)
230− else checkIncomming (x:xs')
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−630
@@ -1,630 +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− <defs
20− id="defs4131">
21− <linearGradient
22− id="linearGradient4726">
23− <stop
24− style="stop-color:#800000;stop-opacity:1;"
25− offset="0"
26− id="stop4728" />
27− <stop
28− style="stop-color:#ffffff;stop-opacity:1;"
29− offset="1"
30− id="stop4730" />
31− </linearGradient>
32− <linearGradient
33− id="linearGradient4647">
34− <stop
35− style="stop-color:#008080;stop-opacity:1;"
36− offset="0"
37− id="stop4649" />
38− <stop
39− style="stop-color:#ffffff;stop-opacity:1;"
40− offset="1"
41− id="stop4651" />
42− </linearGradient>
43− <linearGradient
44− inkscape:collect="always"
45− xlink:href="#linearGradient4647"
46− id="linearGradient4655"
47− x1="-666.70703"
48− y1="18.113195"
49− x2="952.4931"
50− y2="345.05661"
51− gradientUnits="userSpaceOnUse"
52− gradientTransform="matrix(0.43409118,0,0,0.88792276,19.021275,3.9151406)" />
53− <linearGradient
54− inkscape:collect="always"
55− xlink:href="#linearGradient4647-0"
56− id="linearGradient4655-9"
57− x1="-666.70703"
58− y1="18.113195"
59− x2="952.4931"
60− y2="345.05661"
61− gradientUnits="userSpaceOnUse"
62− gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
63− <linearGradient
64− id="linearGradient4647-0">
65− <stop
66− style="stop-color:#008080;stop-opacity:1;"
67− offset="0"
68− id="stop4649-1" />
69− <stop
70− style="stop-color:#ffffff;stop-opacity:1;"
71− offset="1"
72− id="stop4651-0" />
73− </linearGradient>
74− <linearGradient
75− y2="345.05661"
76− x2="952.4931"
77− y1="18.113195"
78− x1="-666.70703"
79− gradientTransform="matrix(0.43409118,0,0,0.89091289,557.01803,3.5315903)"
80− gradientUnits="userSpaceOnUse"
81− id="linearGradient4680"
82− xlink:href="#linearGradient4647-0"
83− inkscape:collect="always" />
84− <linearGradient
85− inkscape:collect="always"
86− xlink:href="#linearGradient4647-9"
87− id="linearGradient4655-8"
88− x1="-666.70703"
89− y1="18.113195"
90− x2="952.4931"
91− y2="345.05661"
92− gradientUnits="userSpaceOnUse"
93− gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
94− <linearGradient
95− id="linearGradient4647-9">
96− <stop
97− style="stop-color:#008080;stop-opacity:1;"
98− offset="0"
99− id="stop4649-4" />
100− <stop
101− style="stop-color:#ffffff;stop-opacity:1;"
102− offset="1"
103− id="stop4651-7" />
104− </linearGradient>
105− <linearGradient
106− y2="345.05661"
107− x2="952.4931"
108− y1="18.113195"
109− x1="-666.70703"
110− gradientTransform="matrix(0.99936476,0,0,0.90055146,-0.79188555,417.08666)"
111− gradientUnits="userSpaceOnUse"
112− id="linearGradient4680-6"
113− xlink:href="#linearGradient4647-9"
114− inkscape:collect="always" />
115− <linearGradient
116− inkscape:collect="always"
117− xlink:href="#linearGradient4726"
118− id="linearGradient4732"
119− x1="484.52829"
120− y1="88.754707"
121− x2="18.113218"
122− y2="336.90564"
123− gradientUnits="userSpaceOnUse" />
124− <linearGradient
125− inkscape:collect="always"
126− xlink:href="#linearGradient4726-0"
127− id="linearGradient4732-1"
128− x1="484.52829"
129− y1="88.754707"
130− x2="18.113218"
131− y2="336.90564"
132− gradientUnits="userSpaceOnUse" />
133− <linearGradient
134− inkscape:collect="always"
135− id="linearGradient4726-0">
136− <stop
137− style="stop-color:#800000;stop-opacity:1;"
138− offset="0"
139− id="stop4728-2" />
140− <stop
141− style="stop-color:#800000;stop-opacity:0;"
142− offset="1"
143− id="stop4730-5" />
144− </linearGradient>
145− <linearGradient
146− gradientTransform="translate(539.26415,1.83019)"
147− y2="336.90564"
148− x2="18.113218"
149− y1="88.754707"
150− x1="484.52829"
151− gradientUnits="userSpaceOnUse"
152− id="linearGradient4755"
153− xlink:href="#linearGradient4726-0"
154− inkscape:collect="always" />
155− <linearGradient
156− inkscape:collect="always"
157− xlink:href="#linearGradient4726-6"
158− id="linearGradient4732-4"
159− x1="484.52829"
160− y1="88.754707"
161− x2="18.113218"
162− y2="336.90564"
163− gradientUnits="userSpaceOnUse" />
164− <linearGradient
165− id="linearGradient4726-6">
166− <stop
167− style="stop-color:#800000;stop-opacity:1;"
168− offset="0"
169− id="stop4728-4" />
170− <stop
171− style="stop-color:#ffffff;stop-opacity:1;"
172− offset="1"
173− id="stop4730-53" />
174− </linearGradient>
175− <linearGradient
176− gradientTransform="translate(543.26415,3.830193)"
177− y2="336.90564"
178− x2="18.113218"
179− y1="88.754707"
180− x1="484.52829"
181− gradientUnits="userSpaceOnUse"
182− id="linearGradient4795"
183− xlink:href="#linearGradient4726-6"
184− inkscape:collect="always" />
185− <linearGradient
186− inkscape:collect="always"
187− xlink:href="#linearGradient4726-4"
188− id="linearGradient4732-6"
189− x1="484.52829"
190− y1="88.754707"
191− x2="18.113218"
192− y2="336.90564"
193− gradientUnits="userSpaceOnUse" />
194− <linearGradient
195− id="linearGradient4726-4">
196− <stop
197− style="stop-color:#800000;stop-opacity:1;"
198− offset="0"
199− id="stop4728-40" />
200− <stop
201− style="stop-color:#ffffff;stop-opacity:1;"
202− offset="1"
203− id="stop4730-7" />
204− </linearGradient>
205− <linearGradient
206− gradientTransform="translate(-0.73585,416.83019)"
207− y2="336.90564"
208− x2="18.113218"
209− y1="88.754707"
210− x1="484.52829"
211− gradientUnits="userSpaceOnUse"
212− id="linearGradient4795-1"
213− xlink:href="#linearGradient4726-4"
214− inkscape:collect="always" />
215− <linearGradient
216− inkscape:collect="always"
217− xlink:href="#linearGradient4726-3"
218− id="linearGradient4732-2"
219− x1="484.52829"
220− y1="88.754707"
221− x2="18.113218"
222− y2="336.90564"
223− gradientUnits="userSpaceOnUse" />
224− <linearGradient
225− id="linearGradient4726-3">
226− <stop
227− style="stop-color:#800000;stop-opacity:1;"
228− offset="0"
229− id="stop4728-8" />
230− <stop
231− style="stop-color:#ffffff;stop-opacity:1;"
232− offset="1"
233− id="stop4730-1" />
234− </linearGradient>
235− <linearGradient
236− gradientTransform="translate(542.26415,415.83019)"
237− y2="336.90564"
238− x2="18.113218"
239− y1="88.754707"
240− x1="484.52829"
241− gradientUnits="userSpaceOnUse"
242− id="linearGradient4795-4"
243− xlink:href="#linearGradient4726-3"
244− inkscape:collect="always" />
245− </defs>
246− <sodipodi:namedview
247− id="base"
248− pagecolor="#ffffff"
249− bordercolor="#666666"
250− borderopacity="1.0"
251− inkscape:pageopacity="0.0"
252− inkscape:pageshadow="2"
253− inkscape:zoom="1"
254− inkscape:cx="512"
255− inkscape:cy="384"
256− inkscape:current-layer="layer1"
257− inkscape:document-units="px"
258− showgrid="false"
259− showguides="true"
260− inkscape:guide-bbox="true"
261− inkscape:window-width="1916"
262− inkscape:window-height="1036"
263− inkscape:window-x="4"
264− inkscape:window-y="22"
265− inkscape:window-maximized="0">
266− <sodipodi:guide
267− orientation="1,0"
268− position="984,175"
269− id="guide4870" />
270− </sodipodi:namedview>
271− <metadata
272− id="metadata4134">
273− <rdf:RDF>
274− <cc:Work
275− rdf:about="">
276− <dc:format>image/svg+xml</dc:format>
277− <dc:type
278− rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
279− <dc:title />
280− </cc:Work>
281− </rdf:RDF>
282− </metadata>
283− <g
284− id="layer1"
285− inkscape:label="Layer 1"
286− inkscape:groupmode="layer">
287− <rect
288− style="fill:url(#linearGradient4680);fill-opacity:1;stroke:#340000;stroke-width:1.24376428;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
289− id="rect4137-5"
290− width="412.79617"
291− height="287.24374"
292− x="571.56415"
293− y="34.192436" />
294− <rect
295− style="fill:url(#linearGradient4655);fill-opacity:1;stroke:#340000;stroke-width:1.24167538;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
296− id="rect4137"
297− width="412.79617"
298− height="286.27966"
299− x="33.567425"
300− y="34.473083" />
301− <rect
302− style="fill:url(#linearGradient4680-6);fill-opacity:1;stroke:#340000;stroke-width:1.89734483;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
303− id="rect4137-6"
304− width="950.33942"
305− height="290.35135"
306− x="32.696255"
307− y="448.07922" />
308− <rect
309− style="fill:none;stroke:#000000;stroke-width:11.57752419;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
310− id="rect4657-9"
311− width="582.76776"
312− height="149.16254"
313− x="109.61612"
314− y="-311.5813"
315− transform="matrix(0,1,-1,0,0,0)" />
316− <rect
317− style="fill:none;stroke:#000000;stroke-width:11.57752419000000010;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1;opacity:1"
318− id="rect4657"
319− width="582.76776"
320− height="149.16254"
321− x="256.99347"
322− y="124.76707" />
323− <text
324− xml:space="preserve"
325− 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"
326− x="36.887089"
327− y="73.584908"
328− id="text4659"
329− sodipodi:linespacing="125%"><tspan
330− sodipodi:role="line"
331− id="tspan4661"
332− x="36.887089"
333− y="73.584908">198.51.100.1:1080</tspan></text>
334− <text
335− xml:space="preserve"
336− 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"
337− x="574.88385"
338− y="73.30426"
339− id="text4659-2"
340− sodipodi:linespacing="125%"><tspan
341− sodipodi:role="line"
342− id="tspan4661-9"
343− x="574.88385"
344− y="73.30426">198.51.100.1:1081</tspan></text>
345− <rect
346− style="fill:none;stroke:#000000;stroke-width:11.57752419000000010;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
347− id="rect4657-7"
348− width="582.76776"
349− height="149.16254"
350− x="229.61612"
351− y="535.4187" />
352− <text
353− xml:space="preserve"
354− 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"
355− x="321.0159"
356− y="488.19104"
357− id="text4659-9"
358− sodipodi:linespacing="125%"><tspan
359− sodipodi:role="line"
360− id="tspan4661-90"
361− x="321.0159"
362− y="488.19104">198.51.100.2:1080</tspan></text>
363− <rect
364− style="fill:url(#linearGradient4732);stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1"
365− id="rect4724"
366− width="366.79245"
367− height="200.15094"
368− x="54.339622"
369− y="95.094337" />
370− <text
371− xml:space="preserve"
372− 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"
373− x="62.264153"
374− y="117.35849"
375− id="text4734"
376− sodipodi:linespacing="125%"><tspan
377− sodipodi:role="line"
378− id="tspan4736"
379− x="62.264153"
380− y="117.35849">198.51.100.1:1080:0</tspan></text>
381− <rect
382− style="fill:url(#linearGradient4795);fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
383− id="rect4724-0"
384− width="366.79245"
385− height="200.15094"
386− x="597.60376"
387− y="98.92453" />
388− <text
389− xml:space="preserve"
390− 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"
391− x="605.52832"
392− y="121.18868"
393− id="text4734-8"
394− sodipodi:linespacing="125%"><tspan
395− sodipodi:role="line"
396− id="tspan4736-8"
397− x="605.52832"
398− y="121.18868">198.51.100.1:1081:0</tspan></text>
399− <rect
400− style="fill:url(#linearGradient4795-1);fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
401− id="rect4724-6"
402− width="366.79245"
403− height="200.15094"
404− x="53.60376"
405− y="511.92453" />
406− <text
407− xml:space="preserve"
408− 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"
409− x="63.52832"
410− y="534.18872"
411− id="text4734-0"
412− sodipodi:linespacing="125%"><tspan
413− sodipodi:role="line"
414− id="tspan4736-9"
415− x="63.52832"
416− y="534.18872">198.51.100.2:1080:0</tspan></text>
417− <rect
418− style="fill:url(#linearGradient4795-4);fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
419− id="rect4724-06"
420− width="366.79245"
421− height="200.15094"
422− x="596.60376"
423− y="510.92456" />
424− <text
425− xml:space="preserve"
426− 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"
427− x="604.52832"
428− y="533.18872"
429− id="text4734-02"
430− sodipodi:linespacing="125%"><tspan
431− sodipodi:role="line"
432− id="tspan4736-4"
433− x="604.52832"
434− y="533.18872">198.51.100.2:1080:1</tspan></text>
435− <path
436− sodipodi:type="arc"
437− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
438− id="path5106"
439− sodipodi:cx="215.5"
440− sodipodi:cy="197.5"
441− sodipodi:rx="14.5"
442− sodipodi:ry="14.5"
443− 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"
444− transform="translate(22.235847,-2.3301926)" />
445− <path
446− sodipodi:type="arc"
447− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
448− id="path5106-0"
449− sodipodi:cx="215.5"
450− sodipodi:cy="197.5"
451− sodipodi:rx="14.5"
452− sodipodi:ry="14.5"
453− 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"
454− transform="translate(565.49998,1.5)" />
455− <path
456− sodipodi:type="arc"
457− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
458− id="path5106-7"
459− sodipodi:cx="215.5"
460− sodipodi:cy="197.5"
461− sodipodi:rx="14.5"
462− sodipodi:ry="14.5"
463− 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"
464− transform="translate(564.49998,413.50003)" />
465− <path
466− sodipodi:type="arc"
467− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
468− id="path5106-06"
469− sodipodi:cx="215.5"
470− sodipodi:cy="197.5"
471− sodipodi:rx="14.5"
472− sodipodi:ry="14.5"
473− 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"
474− transform="translate(21.499985,414.5)" />
475− <path
476− sodipodi:type="star"
477− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
478− id="path5217"
479− sodipodi:sides="3"
480− sodipodi:cx="-58"
481− sodipodi:cy="224"
482− sodipodi:r1="15.033296"
483− sodipodi:r2="7.5166483"
484− sodipodi:arg1="-1.5707963"
485− sodipodi:arg2="-0.52359878"
486− inkscape:flatsided="true"
487− inkscape:rounded="0"
488− inkscape:randomized="0"
489− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
490− inkscape:transform-center-y="-3.7583241"
491− transform="translate(250,279.48335)" />
492− <path
493− sodipodi:type="star"
494− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
495− id="path5217-1"
496− sodipodi:sides="3"
497− sodipodi:cx="-58"
498− sodipodi:cy="224"
499− sodipodi:r1="15.033296"
500− sodipodi:r2="7.5166483"
501− sodipodi:arg1="-1.5707963"
502− sodipodi:arg2="-0.52359878"
503− inkscape:flatsided="true"
504− inkscape:rounded="0"
505− inkscape:randomized="0"
506− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
507− inkscape:transform-center-y="-3.7583241"
508− transform="translate(336,278.75832)" />
509− <path
510− sodipodi:type="star"
511− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
512− id="path5217-0"
513− sodipodi:sides="3"
514− sodipodi:cx="-58"
515− sodipodi:cy="224"
516− sodipodi:r1="15.033296"
517− sodipodi:r2="7.5166483"
518− sodipodi:arg1="-1.5707963"
519− sodipodi:arg2="-0.52359878"
520− inkscape:flatsided="true"
521− inkscape:rounded="0"
522− inkscape:randomized="0"
523− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
524− inkscape:transform-center-y="-3.7583241"
525− transform="translate(292,278.75832)" />
526− <path
527− sodipodi:type="star"
528− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
529− id="path5217-7"
530− sodipodi:sides="3"
531− sodipodi:cx="-58"
532− sodipodi:cy="224"
533− sodipodi:r1="15.033296"
534− sodipodi:r2="7.5166483"
535− sodipodi:arg1="-1.5707963"
536− sodipodi:arg2="-0.52359878"
537− inkscape:flatsided="true"
538− inkscape:rounded="0"
539− inkscape:randomized="0"
540− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
541− transform="matrix(0,1,-1,0,654,214.75832)"
542− inkscape:transform-center-x="-3.7583239" />
543− <path
544− sodipodi:type="star"
545− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
546− id="path5217-4"
547− sodipodi:sides="3"
548− sodipodi:cx="-58"
549− sodipodi:cy="224"
550− sodipodi:r1="15.033296"
551− sodipodi:r2="7.5166483"
552− sodipodi:arg1="-1.5707963"
553− sodipodi:arg2="-0.52359878"
554− inkscape:flatsided="true"
555− inkscape:rounded="0"
556− inkscape:randomized="0"
557− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
558− transform="matrix(0,1,-1,0,653,299.75832)"
559− inkscape:transform-center-x="-3.7583239" />
560− <path
561− sodipodi:type="star"
562− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
563− id="path5217-49"
564− sodipodi:sides="3"
565− sodipodi:cx="-58"
566− sodipodi:cy="224"
567− sodipodi:r1="15.033296"
568− sodipodi:r2="7.5166483"
569− sodipodi:arg1="-1.5707963"
570− sodipodi:arg2="-0.52359878"
571− inkscape:flatsided="true"
572− inkscape:rounded="0"
573− inkscape:randomized="0"
574− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
575− transform="matrix(0,-1,1,0,365,140.75832)"
576− inkscape:transform-center-x="3.7583235" />
577− <path
578− sodipodi:type="star"
579− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
580− id="path5217-70"
581− sodipodi:sides="3"
582− sodipodi:cx="-58"
583− sodipodi:cy="224"
584− sodipodi:r1="15.033296"
585− sodipodi:r2="7.5166483"
586− sodipodi:arg1="-1.5707963"
587− sodipodi:arg2="-0.52359878"
588− inkscape:flatsided="true"
589− inkscape:rounded="0"
590− inkscape:randomized="0"
591− d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
592− transform="matrix(0,1,-1,0,653,665.75832)"
593− inkscape:transform-center-x="-3.7583239" />
594− <path
595− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
596− id="path5272"
597− 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"
598− inkscape:connector-curvature="0" />
599− <path
600− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
601− id="path5274"
602− 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"
603− inkscape:connector-curvature="0" />
604− <path
605− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
606− id="path5276"
607− 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"
608− inkscape:connector-curvature="0" />
609− <path
610− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
611− id="path5278"
612− 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"
613− inkscape:connector-curvature="0" />
614− <path
615− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
616− id="path5280"
617− 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"
618− inkscape:connector-curvature="0" />
619− <path
620− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
621− id="path5282"
622− 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"
623− inkscape:connector-curvature="0" />
624− <path
625− style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
626− id="path5288"
627− 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"
628− inkscape:connector-curvature="0" />
629− </g>
630−</svg>
doc/semantics/CloudHaskellSemantics.texnew file+706
@@ -0,0 +1,706 @@
1+\documentclass{article}
2+\usepackage[margin=2.5cm]{geometry}
3+\usepackage{amsmath, amssymb, stmaryrd}
4+\usepackage{mathpazo, times}
5+\usepackage{float}
6+\usepackage{listings}
7+
8+\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
9+\newcommand{\sApp}[2]{{#1} {#2}}
10+\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
11+\newcommand{\sReturn}{\mathtt{return}}
12+\newcommand{\sThrow}[1]{\mathtt{throw} \; {#1}}
13+\newcommand{\sCatch}[2]{\mathtt{catch} \; {#1} \; {#2}}
14+
15+\newcommand{\sExpect}{\mathtt{expect}}
16+\newcommand{\sSend}{\mathtt{send}}
17+\newcommand{\sSpawn}{\mathtt{spawn}}
18+\newcommand{\sLink}{\mathtt{link}}
19+\newcommand{\sReconnect}{\mathtt{reconnect}}
20+\newcommand{\sNewChan}{\mathtt{newChan}}
21+\newcommand{\sSendChan}{\mathtt{sendChan}}
22+\newcommand{\sReceiveChan}{\mathtt{receiveChan}}
23+\newcommand{\sMonitor}{\mathtt{monitor}}
24+
25+\DeclareMathOperator{\sNodeOf}{node}
26+\DeclareMathOperator{\sProcessOf}{process}
27+
28+\newcommand{\sSpawned}{\mathtt{spawned}}
29+
30+\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}}
31+
32+\newcommand{\sPar}{\mathrel{\parallel}}
33+\newcommand{\sProc}[2]{{#1}_{#2}}
34+
35+\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
36+\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
37+\newcommand{\sCid}{\ensuremath{\mathit{cid}}}
38+
39+\newcommand{\sId}{\ensuremath{\mathit{id}}}
40+\newcommand{\sRef}{\ensuremath{\mathit{ref}}}
41+
42+\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
43+\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
44+\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle}
45+\newcommand{\sNodes}{\mathcal{N}}
46+\newcommand{\sQueue}{\mathcal{Q}}
47+\newcommand{\sProcesses}{\mathcal{P}}
48+\newcommand{\sBlacklist}{\mathcal{B}}
49+\newcommand{\sMonitors}{\mathcal{M}}
50+
51+\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
52+\newcommand{\sNothing}{\mathtt{Nothing}}
53+
54+\newcommand{\sCtxt}[1]{\mathbb{#1}}
55+
56+\newcommand{\sSenders}{\mathit{senders}}
57+
58+\newcommand{\OR}{\mathrel{|}}
59+\newcommand{\where}{\mathrel{|}}
60+
61+\floatstyle{boxed}
62+\restylefloat{figure}
63+
64+\lstset{basicstyle=\ttfamily\small}
65+
66+\begin{document}
67+
68+\title{Cloud Haskell Semantics (DRAFT)}
69+\author{Well-Typed LLP}
70+\date{\today}
71+
72+\maketitle
73+
74+\section{Introduction}
75+
76+Cloud Haskell brings Erlang-style concurrency to Haskell in the form of a
77+library.\footnote{\texttt{http://hackage.haskell.org/package/distributed-process}}
78+The original publication \cite{cloudhaskell} is a good introduction to Cloud
79+Haskell, and is accompanied by an ever-growing number of resouces, collected on
80+the Haskell
81+Wiki.\footnote{\texttt{http://www.haskell.org/haskellwiki/Cloud\_Haskell}} The
82+current document augments the original publication about Cloud Haskell by
83+giving a precise semantics to the Cloud Haskell primitives. It is meant as a
84+reference, not an introduction.
85+
86+The original Cloud Haskell paper stipulates that messages are ``asynchronous,
87+reliable, and buffered'', but does not describe how this can be achieved.
88+Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),
89+the reliability of message delivery comes from the reliability of the
90+underlying network protocol---up to a point.
91+
92+The problem is that the underlying network protocol is connection-oriented, but
93+Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a
94+reliable-ordered connection from $P$ to $Q$. Reliability of message delivery
95+now follows from reliability of the network protocol, until $P$ somehow gets
96+disconnected from $Q$. If $P$ now sends another message to $Q$, the
97+implementation cannot simply reconnect: after all, some messages that were sent
98+on the first connection might not have been delivered. This means that $P$
99+might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1,
100+m_3$.\footnote{Indeed, message passing in Erlang is ordered but unreliable for
101+the same reason \cite{erlang}.}
102+
103+One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and
104+remove messages from this buffer only when $Q$ acknowledges that it received
105+them. On a reconnect $P$ must ask which message $Q$ last received, and
106+retransmit the rest. This means that when $P$ gets disconnected from $Q$, it
107+must infinitely buffer all messages sent to $Q$ (until a connection is
108+reestablished). However, infinite buffering is too strong a requirement;
109+moreover, this is unsatisfactory because it means implementing a reliable
110+protocol on top of the underlying reliable network protocol. We would like a
111+different solution.
112+
113+Instead, Cloud Haskell does \emph{not} attempt to reconnect automatically, but
114+provides a $\sReconnect$ primitive which gives programmers the option of
115+reconnecting manually. This is an explicit acknowledgement from the programmer
116+that message loss might occur, and forces them to consider how such loss might
117+be dealt with.
118+
119+The semantics we present is based on \cite{unified}, which we will refer to the
120+as the ``Unified'' semantics. However, we will present the semantics in a more
121+``Haskell'' style following the semantics for STM \cite{stm}. It differs from
122+the Unified semantics in that
123+%
124+\begin{enumerate}
125+\item We introduce an explicit notion of \textit{reconnecting} (with potential
126+message loss)
127+\item We simplify the semantics: we ``flatten'' sets of nodes of processes as
128+sets of processes (but assume a mapping from process identifiers to node
129+identifiers), do not have per-process mailboxes (but only the system queue or
130+``ether'') and do not have an explicit concept of node controllers
131+\end{enumerate}
132+%
133+Our semantics differs from the STM semantics in that we pretend that the Cloud
134+Haskell \texttt{Process} monad is the top-level monad, and do not consider the
135+\texttt{IO} monad at all. Current imprecisions with respect to the ``real''
136+Cloud Haskell are
137+%
138+\begin{enumerate}
139+\item We ignore the issue of serializability, other than to say that the
140+semantics will get stuck when trying to send a non-serializable payload;
141+consequently, we do not formalize $\mathtt{static}$
142+\item We do not formalize all Cloud Haskell primitives (merging of ports,
143+``advanced messaging'', and others)
144+\item Some of the concepts that we do formalize are lower-level concepts; for
145+instance, the primitive $\sSpawn$ that we formalize is asynchronous (following
146+the Unified semantics); a synchronous construct can be derived.
147+\end{enumerate}
148+
149+\section{Preliminaries}
150+
151+Cloud Haskell Processes run on \emph{nodes}. Processes communicate by sending
152+messages to each other (directly or using typed channels). Processes can also
153+send messages to nodes (for instance, a request to spawn or monitor a process).
154+
155+We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and
156+$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively,
157+and representing process identifiers, node identifiers, and (typed) channel
158+identifiers. We assume the existence of total functions
159+%
160+\begin{equation*}
161+\begin{array}{r@{\;:\;}l}
162+\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\
163+\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId}
164+\end{array}
165+\end{equation*}
166+%
167+and define
168+$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$
169+and let $\sId$ range over $\mathtt{Identifier}$.
170+
171+We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process
172+ID $\sPid$. We will denote a set of processes as
173+%
174+ $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$
175+%
176+A \emph{system}
177+ $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$
178+is a tuple containing a set $\sProcesses$ of processes, a \emph{system
179+queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors
180+$\sMonitors$.
181+The set of monitors $\sMonitors$ is a set of tuples
182+ $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$
183+which records that node \sNid{} knows that process $\sPid_\mathit{fr}$ is
184+monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor reference). The system
185+queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr},
186+\mathit{message})$ of messages that have been sent but not yet processed. The
187+blacklist records disconnections and is represented as a of pairs
188+$(\sId_\mathit{to}, \sId_\mathit{fr})$.
189+
190+\section{Semantics}
191+
192+We follow the STM semantics as closely as possible. The language is the same
193+except for the primitives considered, and we use the same concept of evaluation
194+contexts:
195+
196+\begin{equation*}
197+\begin{array}{llll}
198+\text{value} & V & ::= & \sId \OR
199+ \sLam{x}{M} \OR
200+ \sReturn \; M \OR
201+ \sBind{M}{N} \OR
202+ \sThrow{M} \OR \sCatch{M}{N} \OR \\
203+ &&& \sExpect \OR
204+ \sSend \; \sPid \; M \OR
205+ \sSpawn \; \sNid \; M \OR
206+ \sMonitor \; \sId
207+\\
208+\text{term} & M, N & ::= & x \OR
209+ V \OR
210+ \sApp{M}{N} \OR
211+ \cdots \\
212+\\
213+\text{Evaluation} & \sCtxt{E} & ::= & [] \OR \sBind{\sCtxt{E}}{M} \OR \sCatch{\sCtxt{E}}{M} \\
214+\text{context} & \sCtxt{P}_\sPid & ::= & \sCtxt{E}[]_\sPid \sPar \sProcesses
215+\end{array}
216+\end{equation*}
217+%
218+Indeed, the ``administrative'' transitions are identical
219+(Figure~\ref{fig:administrative}).
220+
221+\begin{figure}
222+\small
223+\begin{equation*}
224+\frac{
225+ \llbracket M \rrbracket = V \qquad
226+ M \neq V
227+}{
228+ M \rightarrow V
229+} \textsc{Eval}
230+\qquad
231+\frac{
232+ M \rightarrow N
233+}{
234+ \sSystem{\sCtxt{P}[M]_\sPid}
235+ {\sQueue}
236+ {\sBlacklist}
237+ {\sMonitors}
238+\rightarrow
239+ \sSystem{\sCtxt{P}[N]_\sPid}
240+ {\sQueue}
241+ {\sBlacklist}
242+ {\sMonitors}
243+} \textsc{Admin}
244+\end{equation*}
245+%
246+\begin{equation*}
247+\begin{array}{r@{\;\rightarrow\;}ll@{\hspace{2em}}r@{\;\rightarrow\;}ll}
248+\sBind{\sReturn \; N}{M} & M \; N & \textsc{Bind} & \sCatch{(\sReturn \; M)}{N} & \sReturn \; M & \textsc{Catch}_1 \\
249+\sBind{\sThrow{N}}{M} & \sThrow{N} & \textsc{Throw} & \sCatch{(\sThrow M)}{N} & N \; M & \textsc{Catch}_2 \\
250+\end{array}
251+\end{equation*}
252+%
253+\caption{\label{fig:administrative}Administrative Transitions}
254+\end{figure}
255+
256+\subsection{Disconnect and Reconnect}
257+
258+Figure~\ref{fig:disconnect} gives the semantics for disconnecting and
259+reconnecting. Rule \textsc{Disconnect} models random network disconnect
260+between nodes $\sNid_1$ and $\sNid_2$. We assume that entire \emph{nodes} get
261+disconnected from each other, not individual processes. \emph{Reconnecting}
262+however is on a per connection basis (\textsc{Recon-Ex}). Connections to and
263+from node controllers can be implicitly reconnected ($\textsc{Recon-Im}_1$ and
264+$\textsc{Recon-Im}_2$).
265+
266+\begin{figure}
267+\small
268+\begin{equation*}
269+\frac{
270+ \sNid_1 \neq \sNid_2
271+}{
272+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
273+\rightarrow
274+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors}
275+} \textsc{Disconnect}
276+\end{equation*}
277+%
278+\begin{equation*}
279+\frac{
280+}{
281+ \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
282+ {\sQueue}
283+ {\sBlacklist}
284+ {\sMonitors}
285+\rightarrow
286+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
287+ {\sQueue}
288+ {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})}
289+ {\sMonitors}
290+} \textsc{Recon-Ex}
291+\end{equation*}
292+%
293+\begin{equation*}
294+\frac{
295+}{
296+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors}
297+\rightarrow
298+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
299+} \textsc{Recon-Im}_1
300+\qquad
301+\frac{
302+}{
303+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors}
304+\rightarrow
305+ \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
306+} \textsc{Recon-Im}_2
307+\end{equation*}
308+%
309+where
310+%
311+\begin{equation*}
312+\overline{\sNid} \subset \mathtt{Identifier}
313+ = \{ \sNid \} \cup
314+ \{ \sPid \where \sNodeOf(\sPid) = \sNid \} \cup
315+ \{ \sCid \where \sNodeOf(\sCid) = \sNid \}
316+\end{equation*}
317+\caption{\label{fig:disconnect}Disconnect and Reconnect}
318+\end{figure}
319+
320+\subsection{Communication}
321+
322+The semantics for the basic primitives are listed in Figure~\ref{fig:basic}.
323+Once a connection has been blacklisted, no further messages can be sent across
324+that connection (until an explicit or implicit reconnect).
325+
326+Message passing is ordered but only for a given sender and receiver; no
327+ordering guarantees exist between messages sent by different processes. For
328+that reason rules \textsc{Expect}, \textsc{ReceiveChan} and \textsc{Spawn-Exec}
329+choose the \emph{first} message of a \emph{randomly chosen} sender.
330+
331+Since the semantics is not type-driven, we represent typed channels simply as
332+an identifier with an annotation whether it is the send-end ($\sCid^s$) or the
333+receive end ($\sCid^r$) of the channel (rules \textsc{NewChan},
334+\textsc{SendChan} and \textsc{ReceiveChan}).
335+
336+Spawning finally is asynchronous. When process $P$ spawns process $Q$ on node
337+$\sNid$ (rule \textsc{Spawn-Async}) a message is sent to node $\sNid$ (which
338+may, of course, never arrive). When the remote node receives the message and
339+actually spawns $Q$ (rule \textsc{Spawn-Exec}) it sends a message back to $P$
340+with $Q$'s process ID. In Cloud Haskell this primitive is called
341+\texttt{spawnAsync}, and the Cloud Haskell \texttt{spawn} primitive is defined
342+in terms of \texttt{spawnAsync} (we do not consider the synchronous version in
343+this document).
344+
345+\begin{figure}
346+\small
347+\begin{equation*}
348+\frac{
349+}{
350+ \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}}
351+ {\sQueue}
352+ {\sBlacklist}
353+ {\sMonitors}
354+\rightarrow
355+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
356+ {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)}
357+ {\sBlacklist}
358+ {\sMonitors}
359+} \textsc{Send}
360+\end{equation*}
361+%
362+\begin{equation*}
363+\frac{
364+ \sId_{\mathit{fr}} \notin \sSenders(\sQueue)
365+}{
366+ \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}}
367+ {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'}
368+ {\sBlacklist}
369+ {\sMonitors}
370+\rightarrow
371+ \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}}
372+ {\sQueue, \sQueue'}
373+ {\sBlacklist}
374+ {\sMonitors}
375+} \textsc{Expect}
376+\end{equation*}
377+%
378+\begin{equation*}
379+\frac{
380+ \sCid \text{ fresh}
381+\qquad
382+ \sProcessOf(\sCid) = \sPid
383+}{
384+ \sSystem{\sCtxt{P}[\sNewChan]_\sPid}
385+ {\sQueue}
386+ {\sBlacklist}
387+ {\sMonitors}
388+\rightarrow
389+ \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid}
390+ {\sQueue}
391+ {\sBlacklist}
392+ {\sMonitors}
393+} \textsc{NewChan}
394+\end{equation*}
395+
396+\begin{equation*}
397+\frac{
398+}{
399+ \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}}
400+ {\sQueue}
401+ {\sBlacklist}
402+ {\sMonitors}
403+\rightarrow
404+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
405+ {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)}
406+ {\sBlacklist}
407+ {\sMonitors}
408+} \textsc{SendChan}
409+\end{equation*}
410+
411+\begin{equation*}
412+\frac{
413+ \sPid_{\mathit{fr}} \notin \sSenders(\sQueue)
414+}{
415+ \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}}
416+ {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'}
417+ {\sBlacklist}
418+ {\sMonitors}
419+\rightarrow
420+ \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}}
421+ {\sQueue, \sQueue'}
422+ {\sBlacklist}
423+ {\sMonitors}
424+} \textsc{ReceiveChan}
425+\end{equation*}
426+%
427+\begin{equation*}
428+\frac{
429+ \sRef \text{ fresh}
430+}{
431+ \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
432+ {\sQueue}
433+ {\sBlacklist}
434+ {\sMonitors}
435+\rightarrow
436+ \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid}
437+ {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)}
438+ {\sBlacklist}
439+ {\sMonitors}
440+} \textsc{Spawn-Async}
441+\end{equation*}
442+%
443+\begin{equation*}
444+\frac{
445+ \sPid \notin \sSenders(\sQueue)
446+\qquad
447+ \sPid' \text{ fresh}
448+\qquad
449+ \sNodeOf(\sPid') = \sNid
450+}{
451+ \sSystem{\sProcesses}
452+ {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'}
453+ {\sBlacklist}
454+ {\sMonitors}
455+\rightarrow
456+ \sSystem{\sProcesses \sPar M_{\sPid'}}
457+ {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')}
458+ {\sBlacklist}
459+ {\sMonitors}
460+} \textsc{Spawn-Exec}
461+\end{equation*}
462+%
463+where
464+%
465+\begin{equation*}
466+\begin{array}{l@{\;=\;}l@{\hspace{3em}}l}
467+ \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
468+&
469+ \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M)
470+&
471+ \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist
472+\\
473+ \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
474+&
475+ \sQueue
476+&
477+ \text{otherwise}
478+\end{array}
479+\end{equation*}
480+%
481+$(\sExtend{\sBlacklist})$ is only defined for serializable payloads.
482+\caption{\label{fig:basic}Basic Primitives}
483+\end{figure}
484+
485+\subsection{Monitoring}
486+
487+When process $P$ on node $\sNid_P$ wants to monitor process $Q$ on node
488+$\sNid_Q$ \emph{both} nodes must be notified. The local node it notified
489+immediately, and a message is sent to to the remote node (rules
490+\textsc{Mon-Loc} and \textsc{Mon-Rem}). As with all messages, the
491+message to the remote node might be lost. When $P$ is disconnected from $Q$ it
492+is the responsibility of $P$'s local node $\sNid_P$ to notify $P$
493+(\textsc{Mon-Dis}); when $Q$ terminates (\textsc{Mon-Ret}) or crashes
494+(\textsc{Mon-Throw}) it is the responsibility of the remote node $\sNid_Q$ to
495+notify $P$.
496+
497+\begin{figure}
498+\small
499+\begin{equation*}
500+\frac{
501+ \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
502+\qquad
503+ \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to})
504+\qquad
505+ \sRef \text{ fresh}
506+}{
507+\sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
508+ {\sQueue}
509+ {\sBlacklist}
510+ {\sMonitors}
511+\rightarrow
512+ \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}}
513+ {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})}
514+ {\sBlacklist}
515+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
516+} \textsc{Mon-Loc}
517+\end{equation*}
518+%
519+\begin{equation*}
520+\frac{
521+ \sPid_\mathit{fr} \notin \sSenders(\sQueue)
522+}{
523+ \sSystem{\sProcesses}
524+ {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'}
525+ {\sBlacklist}
526+ {\sMonitors}
527+\rightarrow
528+ \sSystem{\sProcesses}
529+ {\sQueue, \sQueue'}
530+ {\sBlacklist}
531+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)}
532+} \textsc{Mon-Rem}
533+\end{equation*}
534+%
535+\begin{equation*}
536+\frac{
537+ \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
538+\qquad
539+ (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist
540+}{
541+ \sSystem{\sProcesses}
542+ {\sQueue}
543+ {\sBlacklist}
544+ {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
545+\rightarrow
546+ \sSystem{\sProcesses}
547+ {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)}
548+ {\sBlacklist}
549+ {\sMonitors}
550+} \textsc{Mon-Dis}
551+\end{equation*}
552+%
553+\begin{equation*}
554+\frac{
555+ \sNodeOf(\sPid) = \sNid
556+}{
557+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
558+ {\sQueue}
559+ {\sBlacklist}
560+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
561+\rightarrow
562+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
563+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{died} \; \sRef)}
564+ {\sBlacklist}
565+ {\sMonitors}
566+} \textsc{Mon-Ret}
567+\end{equation*}
568+%
569+\begin{equation*}
570+\frac{
571+ \sNodeOf(\sPid) = \sNid
572+}{
573+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
574+ {\sQueue}
575+ {\sBlacklist}
576+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
577+\rightarrow
578+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
579+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{exc} \; \sRef \; M)}
580+ {\sBlacklist}
581+ {\sMonitors}
582+} \textsc{Mon-Throw}
583+\end{equation*}
584+%
585+\begin{equation*}
586+\frac{
587+ \sNodeOf(\sPid) = \sNid
588+\qquad
589+ \sPid \notin \sProcesses
590+}{
591+ \sSystem{\sProcesses}
592+ {\sQueue}
593+ {\sBlacklist}
594+ {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
595+\rightarrow
596+ \sSystem{\sProcesses}
597+ {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{unknown} \; \sRef)}
598+ {\sBlacklist}
599+ {\sMonitors}
600+} \textsc{Mon-Unknown}
601+\end{equation*}
602+%
603+\caption{Monitoring}
604+\end{figure}
605+
606+\subsection{Process Termination}
607+
608+The rules for normal and abnormal process termination are defined in
609+Figure~\ref{fig:termination}. When a process crashes it dies
610+silently, unless monitors are setup.
611+
612+\begin{figure}
613+\small
614+%
615+\begin{equation*}
616+\frac{
617+ \sNodeOf(\sPid) = \sNid
618+\qquad
619+ \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
620+}{
621+ \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
622+ {\sQueue}
623+ {\sBlacklist}
624+ {\sMonitors}
625+\rightarrow
626+ \sSystem{\sProcesses}
627+ {\sQueue}
628+ {\sBlacklist}
629+ {\sMonitors}
630+} \textsc{TermRet}
631+\end{equation*}
632+%
633+\begin{equation*}
634+\frac{
635+ \sNodeOf(\sPid) = \sNid
636+\qquad
637+ \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
638+}{
639+ \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
640+ {\sQueue}
641+ {\sBlacklist}
642+ {\sMonitors}
643+\rightarrow
644+ \sSystem{\sProcesses}
645+ {\sQueue}
646+ {\sBlacklist}
647+ {\sMonitors}
648+} \textsc{TermThrow}
649+\end{equation*}
650+%
651+\caption{\label{fig:termination}Process Termination}
652+\end{figure}
653+
654+\section{Open Issues}
655+
656+\subsection{Ordering of Monitor/Link Notifications}
657+
658+The semantics as described above, like the original Unified semantics, does not
659+guarantee that messages send from process $P$ to process $Q$ (\textsc{Send})
660+are ordered with respect to the link or monitor notification sent when process
661+$P$ terminates normally or abnormally (\textsc{Mon-Ret}, \textsc{Mon-Throw}). This means that if process $P$ does
662+
663+\begin{lstlisting}
664+receiveWait [
665+ match $ \(Reply reply) -> ...
666+ , match $ \(ProcessMonitorNotification ..) -> ...
667+ ]
668+\end{lstlisting}
669+
670+and process $Q$ does
671+
672+\begin{lstlisting}
673+send pidA (Reply reply)
674+// terminate or indeed throw an exception
675+\end{lstlisting}
676+
677+then the semantics does not guarantee that the reply from process $Q$ will
678+arrive at process $P$ before the monitor notification; hence, this results in
679+an (artificial) race condition in process $P$.
680+
681+One possible solution is to regard such a link notification as a message from
682+process $Q$ to process $P$, which should be ordered along with the other
683+messages.
684+
685+\subsection{Ordering and Typed Channels}
686+
687+The situation is more tricky still than sketched above because we of typed
688+channels. The semantics does not provide ordering guarantees between messages
689+sent directly to the process and messages sent on typed channels. That means
690+that even if we consider a link or monitor notification as a message sent to
691+the process, to be ordered with other messages sent to that process, it is
692+still unordered with respect to messages sent on typed channels. This means
693+that we have similar race conditions\footnote{Even ignoring the fact that we
694+currently don't even provide a way to wait for a message on a typed channel
695+\emph{or} a direct message.}
696+
697+A possible solution is to insist that \emph{all} messages from process $P$ to
698+process $Q$ are ordered, no matter how they are sent. From a implementation
699+point of view, this would entail the use of a single ordered network connection
700+for all messages from $P$ to $Q$, rather than using an ordered connection per
701+typed channel plus one for direct messages.
702+
703+\bibliographystyle{apalike}
704+\bibliography{references}
705+
706+\end{document}
doc/semantics/Makefilenew file+11
@@ -0,0 +1,11 @@
1+CloudHaskellSemantics.pdf: *.tex *.bib
2+ pdflatex CloudHaskellSemantics
3+ bibtex CloudHaskellSemantics
4+ pdflatex CloudHaskellSemantics
5+ pdflatex CloudHaskellSemantics
6+
7+.PHONY: clean
8+clean:
9+ rm -f *.aux *.bbl *.blg *.log
10+
11+# vi:set noexpandtab:
doc/semantics/references.bibnew file+72
@@ -0,0 +1,72 @@
1+@inproceedings{cloudhaskell,
2+ author = {Epstein, Jeff and Black, Andrew P. and Peyton-Jones, Simon},
3+ title = {Towards {H}askell in the cloud},
4+ booktitle = {Proceedings of the 4th ACM symposium on Haskell},
5+ series = {Haskell '11},
6+ year = {2011},
7+ isbn = {978-1-4503-0860-1},
8+ location = {Tokyo, Japan},
9+ pages = {118--129},
10+ numpages = {12},
11+ url = {http://doi.acm.org/10.1145/2034675.2034690},
12+ doi = {10.1145/2034675.2034690},
13+ acmid = {2034690},
14+ publisher = {ACM},
15+ address = {New York, NY, USA},
16+ keywords = {erlang, haskell, message-passing},
17+}
18+
19+@inproceedings{unified,
20+ author = {Svensson, Hans and Fredlund, Lars-{\AA}ke and Benac Earle, Clara},
21+ title = {A unified semantics for future {E}rlang},
22+ booktitle = {Proceedings of the 9th ACM SIGPLAN workshop on Erlang},
23+ series = {Erlang '10},
24+ year = {2010},
25+ isbn = {978-1-4503-0253-1},
26+ location = {Baltimore, Maryland, USA},
27+ pages = {23--32},
28+ numpages = {10},
29+ url = {http://doi.acm.org/10.1145/1863509.1863514},
30+ doi = {10.1145/1863509.1863514},
31+ acmid = {1863514},
32+ publisher = {ACM},
33+ address = {New York, NY, USA},
34+ keywords = {erlang, semantics},
35+}
36+
37+@article{stm,
38+ author = {Harris, Tim and Marlow, Simon and Jones, Simon Peyton and Herlihy, Maurice},
39+ title = {Composable memory transactions},
40+ journal = {Commun. ACM},
41+ issue_date = {August 2008},
42+ volume = {51},
43+ number = {8},
44+ month = aug,
45+ year = {2008},
46+ issn = {0001-0782},
47+ pages = {91--100},
48+ numpages = {10},
49+ url = {http://doi.acm.org/10.1145/1378704.1378725},
50+ doi = {10.1145/1378704.1378725},
51+ acmid = {1378725},
52+ publisher = {ACM},
53+ address = {New York, NY, USA},
54+}
55+
56+@inproceedings{erlang,
57+ author = {Svensson, Hans and Fredlund, Lars-\AAke},
58+ title = {A more accurate semantics for distributed erlang},
59+ booktitle = {Proceedings of the 2007 SIGPLAN workshop on ERLANG Workshop},
60+ series = {ERLANG '07},
61+ year = {2007},
62+ isbn = {978-1-59593-675-2},
63+ location = {Freiburg, Germany},
64+ pages = {43--54},
65+ numpages = {12},
66+ url = {http://doi.acm.org/10.1145/1292520.1292528},
67+ doi = {10.1145/1292520.1292528},
68+ acmid = {1292528},
69+ publisher = {ACM},
70+ address = {New York, NY, USA},
71+ keywords = {distributed systems, erlang, model checking, semantics, verification},
72+}
doc/tutorial/tutorial-client.hsdeleted−20
@@ -1,20 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport)
3−import System.Environment
4−import Control.Monad
5−import Data.ByteString.Char8
6−
7−main :: IO ()
8−main = do
9− [host, port, serverAddr] <- getArgs
10− Right transport <- createTransport host port
11− Right endpoint <- newEndPoint transport
12−
13− let addr = EndPointAddress (pack serverAddr)
14− Right conn <- connect endpoint addr ReliableOrdered
15− send conn [pack "Hello world"]
16− close conn
17−
18− replicateM_ 3 $ receive endpoint >>= print
19−
20− closeTransport transport
doc/tutorial/tutorial-server.hsdeleted−52
@@ -1,52 +0,0 @@
1−import Network.Transport
2−import Network.Transport.TCP (createTransport)
3−import Control.Concurrent
4−import Data.Map
5−import Control.Exception
6−import System.Environment
7−
8−-- | Server that echoes messages straight back to the origin endpoint.
9−echoServer :: EndPoint -> MVar () -> IO ()
10−echoServer endpoint serverDone = go empty
11− where
12− go :: Map ConnectionId (MVar Connection) -> IO ()
13− go cs = do
14− event <- receive endpoint
15− case event of
16− ConnectionOpened cid rel addr -> do
17− connMVar <- newEmptyMVar
18− forkIO $ do
19− Right conn <- connect endpoint addr rel
20− putMVar connMVar conn
21− go (insert cid connMVar cs)
22− Received cid payload -> do
23− forkIO $ do
24− conn <- readMVar (cs ! cid)
25− send conn payload
26− return ()
27− go cs
28− ConnectionClosed cid -> do
29− forkIO $ do
30− conn <- readMVar (cs ! cid)
31− close conn
32− go (delete cid cs)
33− EndPointClosed -> do
34− putStrLn "Echo server exiting"
35− putMVar serverDone ()
36−
37−onCtrlC :: IO a -> IO () -> IO a
38−p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
39− where
40− isUserInterrupt :: AsyncException -> Maybe ()
41− isUserInterrupt UserInterrupt = Just ()
42− isUserInterrupt _ = Nothing
43−
44−main :: IO ()
45−main = do
46− [host, port] <- getArgs
47− serverDone <- newEmptyMVar
48− Right transport <- createTransport host port
49− Right endpoint <- newEndPoint transport
50− forkIO $ echoServer endpoint serverDone
51− putStrLn $ "Echo server started at " ++ show (address endpoint)
52− readMVar serverDone `onCtrlC` closeTransport transport
examples/.gitignoredeleted−1
@@ -1 +0,0 @@
1−*.exe
examples/DemoProcess.hsdeleted−36
@@ -1,36 +0,0 @@
1−module Main where
2−
3−import Control.Distributed.Process
4−import Control.Concurrent (threadDelay)
5−
6−import Network.Transport (closeTransport)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Debug.Trace
10−
11−demo1 = do
12− trans <- mkTransport $ TCPConfig undefined "127.0.0.1" "8080"
13− node <- newLocalNode trans
14− print "Starting node"
15− runProcess node $ do
16− liftIO $ print "Starting process"
17− lpid1 <- spawnLocal (logger 1)
18− spawnLocal (chatty "jim1" lpid1)
19− spawnLocal (chatty "bob1" lpid1)
20− return ()
21− threadDelay 600000
22− closeTransport trans
23−
24−chatty :: String -> ProcessId -> Process ()
25−chatty name target = do
26− send target (name ++ " says: hi there")
27− liftIO $ threadDelay 500000
28− send target (name ++ " says: bye")
29−
30−logger :: Int -> Process ()
31−logger n = do
32− str <- expect
33− liftIO . putStrLn $ show n ++ ": " ++ str
34− logger (n+1)
35−
36−main = demo1
examples/DemoTCP.hsdeleted−113
@@ -1,113 +0,0 @@
1−module Main where
2−
3−import Network.Transport
4−import Network.Transport.TCP
5−
6−import Control.Monad
7−import Data.Char
8−import Data.String
9−import Network.Socket (HostName, ServiceName)
10−import System.Environment
11−
12−import qualified Data.ByteString.Char8 as BS
13−
14−import Debug.Trace
15−
16−type ChanId = Int
17−
18−-- | This example demonstrates how a master can be connected to slaves using
19−-- the transport layer. After compiling, the following will initialize a new
20−-- master that waits for two clients to connect on the local machine:
21−--
22−-- ./DemoTCP 127.0.0.1 8080 sourceAddrFile 2
23−--
24−-- Following this, two slaves should be created that will connect to the master:
25−--
26−-- ./DemoTCP 127.0.0.1 8081 sourceAddrFile
27−-- ./DemoTCP 127.0.0.1 8082 sourceAddrFile
28−--
29−-- Once the connection is established, the slaves will provide the master
30−-- with their SourceAddr. The master then decodes this, and sends a message
31−-- back. After processing this message, the slaves respond to the master,
32−-- which then outputs some data.
33−main :: IO ()
34−main = do
35− args <- getArgs
36− case args of
37− -- Master:
38− -- The master only provides the host, service, and slaves to expect.
39− [host, service, sourceAddrFilePath, number] -> do
40− let numSlaves = read number
41− transport <- mkTransport $ TCPConfig defaultHints host service
42− (clientSourceEnds, masterTargetEnd) <- demoMaster transport sourceAddrFilePath numSlaves
43− zipWithM_
44− (\clientSourceEnd clientId ->
45− send clientSourceEnd [BS.pack . show $ clientId])
46− clientSourceEnds [0 .. numSlaves-1]
47− replicateM_ numSlaves $ do
48− [clientMessage] <- receive masterTargetEnd
49− print clientMessage
50−
51− closeTargetEnd masterTargetEnd
52− putStrLn "master: close connections"
53−
54− -- Slave:
55− -- Each slave provides its own host and service, as well as details of
56− -- the master it wishes to connect to.
57− [host, service, sourceAddrFilePath] -> do
58− transport <- mkTransport $ TCPConfig defaultHints host service
59− (masterSourceEnd, slaveTargetEnd) <- demoSlave transport sourceAddrFilePath
60− [clientId] <- receive slaveTargetEnd
61− putStrLn $ "slave: received clientId: " ++ show clientId
62− let message = "Connected to slave: " ++ (BS.unpack clientId)
63−
64− send masterSourceEnd [BS.pack message]
65− putStrLn "slave: sent message to master"
66−
67− closeSourceEnd masterSourceEnd
68− putStrLn "slave: close connection"
69−
70− _ -> error "Unexpected arguments"
71−
72−demoMaster :: Transport -- ^ Transport
73− -> FilePath -- ^ File to write SourceAddr
74− -> Int -- ^ Number of slaves to expect
75− -> IO ([SourceEnd], TargetEnd)
76−demoMaster transport sourceAddrFilePath numSlaves = do
77− -- Establish an initial transport
78− (sourceAddr, targetEnd) <- newConnection transport
79−
80− -- Write a file containing the sourceAddr
81− putStrLn $ "master: writing sourceAddr file:" ++ (show . serialize $ sourceAddr)
82− BS.writeFile sourceAddrFilePath $ serialize sourceAddr
83−
84− -- Deserialize each of the sourceEnds received by the slaves
85− sourceEnds <- replicateM numSlaves $ do
86− [bytes] <- receive targetEnd
87− putStrLn "master: received connection."
88− case deserialize transport bytes of
89− Nothing -> fail "Garbage message from slave!"
90− Just sourceAddr -> connect sourceAddr
91− return (sourceEnds, targetEnd)
92−
93−demoSlave :: Transport -- ^ Transport
94− -> FilePath -- ^ File to read SourceAddr
95− -> IO (SourceEnd, TargetEnd)
96−demoSlave transport masterSourceAddrFilePath = do
97− -- Create a new connection on the transport
98− (sourceAddr, targetEnd) <- newConnection transport
99−
100− -- Establish connection with the master
101− bytes <- BS.readFile masterSourceAddrFilePath
102− case deserialize transport bytes of
103− Just masterSourceAddr -> do
104− putStrLn $ "slave: connecting to sourceAddr: " ++ (show . serialize $ masterSourceAddr)
105− masterSourceEnd <- connect masterSourceAddr
106−
107− -- Source the serialized address of this slave
108− send masterSourceEnd [serialize sourceAddr]
109− putStrLn "slave: sent sourceAddr"
110− return (masterSourceEnd, targetEnd)
111−
112− Nothing -> error "slave: Unable to deserialize master SourceAddr!"
113−
examples/DemoTransport.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE CPP, NamedFieldPuns #-}
2−module Main where
3−
4−import Network.Transport
5−import qualified Network.Transport.MVar
6−import qualified Network.Transport.Pipes
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Concurrent
10−import Control.Monad
11−
12−#ifndef LAZY
13−import qualified Data.ByteString.Char8 as BS
14−#else
15−import qualified Data.ByteString.Lazy.Char8 as BS
16−#endif
17−
18−import Data.IORef
19−import Debug.Trace
20−
21−-------------------------------------------
22−
23−{- Run a demo above with one of these tranpsort shorthands like this:
24− tcp >>= demo0
25− -}
26−tcp = mkTCPOff 8080
27−mvar = return Network.Transport.MVar.mkTransport
28−pipes = return Network.Transport.Pipes.mkTransport
29−
30−tcp :: IO (IO Transport)
31−mvar :: IO (IO Transport)
32−pipes :: IO (IO Transport)
33−
34−-------------------------------------------
35−-- Example programs using backend directly
36−
37−
38−-- | Check if multiple messages can be sent on the same connection.
39−demo0 :: IO Transport -> IO ()
40−demo0 mktrans = do
41− trans <- mktrans
42−
43− (sourceAddr, targetEnd) <- newConnection trans
44−
45− forkIO $ logServer "logServer" targetEnd
46− threadDelay 100000
47−
48− sourceEnd <- connect sourceAddr
49−
50− mapM_ (\n -> send sourceEnd [BS.pack ("hello " ++ show n)]) [1 .. 10]
51− threadDelay 100000
52−
53− closeTransport trans
54−
55−
56−-- | Check endpoint serialization and deserialization.
57−demo1 :: IO Transport -> IO ()
58−demo1 mktrans = do
59− trans <- mktrans
60−
61− (sourceAddr, targetEnd) <- newConnection trans
62−
63− forkIO $ logServer "logServer" targetEnd
64− threadDelay 100000
65−
66− sourceEnd <- connect sourceAddr
67−
68− -- This use of Just is slightly naughty
69− let Just sourceAddr' = deserialize trans (serialize sourceAddr)
70− sourceEnd' <- connect sourceAddr'
71−
72− send sourceEnd [BS.pack "hello 1"]
73− send sourceEnd' [BS.pack "hello 2"]
74− threadDelay 100000
75− closeTransport trans
76−
77−
78−-- | Check that messages can be sent before receive is set up.
79−demo2 :: IO Transport -> IO ()
80−demo2 mktrans = do
81− trans <- mktrans
82−
83− (sourceAddr, targetEnd) <- newConnection trans
84− sourceEnd <- connect sourceAddr
85−
86− forkIO $ send sourceEnd [BS.pack "hello 1"]
87− threadDelay 100000
88−
89− forkIO $ logServer "logServer" targetEnd
90− threadDelay 100000
91− closeTransport trans
92−
93−
94−-- | Check that two different transports can be created.
95−demo3 :: IO Transport -> IO ()
96−demo3 mktrans = do
97− trans1 <- mktrans
98− trans2 <- mktrans
99−
100− (sourceAddr1, targetEnd1) <- newConnection trans1
101− (sourceAddr2, targetEnd2) <- newConnection trans2
102−
103− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
104− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
105−
106− sourceEnd1 <- connect sourceAddr1
107− sourceEnd2 <- connect sourceAddr2
108−
109− send sourceEnd1 [BS.pack "hello1"]
110− send sourceEnd2 [BS.pack "hello2"]
111−
112− threadDelay 100000
113− putStrLn "demo3: Time, up, killing threads & closing transports.."
114− killThread threadId1
115− killThread threadId2
116− putStrLn "demo3: Threads killed."
117− closeTransport trans1
118− closeTransport trans2
119− putStrLn "demo3: Done."
120−
121−
122−-- | Check that two different connections on the same transport can be created.
123−demo4 :: IO Transport -> IO ()
124−demo4 mktrans = do
125− trans <- mktrans
126−
127− (sourceAddr1, targetEnd1) <- newConnection trans
128− (sourceAddr2, targetEnd2) <- newConnection trans
129−
130− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
131− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
132−
133− sourceEnd1 <- connect sourceAddr1
134− sourceEnd2 <- connect sourceAddr2
135−
136− threadId3 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd1 [BS.pack ("A" ++ show i)]
137− threadId4 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd2 [BS.pack ("B" ++ show i)]
138−
139− threadDelay 1000000
140−
141− putStrLn "demo4: Time, up, killing threads & closing transports.."
142− killThread threadId1
143− killThread threadId2
144− killThread threadId3
145− killThread threadId4
146− putStrLn "demo4: Threads killed."
147− closeTransport trans
148− putStrLn "demo4: Done."
149−
150−
151−
152−--------------------------------------------------------------------------------
153−
154−logServer :: String -> TargetEnd -> IO ()
155−logServer name targetEnd = forever $ do
156− x <- receive targetEnd
157− trace (name ++ " rcvd: " ++ show x) $ return ()
158−
159−mkTCPOff off = do
160− cntr <- newIORef 0
161− return$ do cnt <- readIORef cntr
162− writeIORef cntr (cnt+1)
163− mkTransport (TCPConfig undefined "127.0.0.1" (show (off + cnt)))
164−
165−--------------------------------------------------------------------------------
166−
167−runWAllTranports :: (IO Transport -> IO ()) -> Int -> IO ()
168−runWAllTranports demo offset = do
169− putStrLn "------------------------------------------------------------"
170− putStrLn " MVAR transport:"
171− mvar >>= demo
172− putStrLn "\n TCP transport:"
173− tcp >>= demo
174− putStrLn "\n PIPES transport:"
175− pipes >>= demo
176− putStrLn "\n"
177−
178−
179−main = do
180− putStrLn "Demo0:"
181− runWAllTranports demo0 0
182− putStrLn "Demo1:"
183− runWAllTranports demo1 10
184− putStrLn "Demo2:"
185− runWAllTranports demo2 20
186− putStrLn "Demo3:"
187− runWAllTranports demo3 30
188− putStrLn "Demo4:"
189− runWAllTranports demo4 40
190−
191− threadDelay (300 * 1000)
192− putStrLn "Done with all demos!"
examples/Makefiledeleted−20
@@ -1,20 +0,0 @@
1−
2−
3−ifeq ($(GHC),)
4− GHC=ghc
5−endif
6−
7−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src -i../distributed-process/src
8−
9−EXMPLS= DemoTransport.exe DemoProcess.exe
10−
11−all: $(EXMPLS)
12−
13−$(EXMPLS): %.exe: %.hs
14− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $< -o $@
15−
16−# transport:
17−# $(GHC) -threaded --make -i../network-transport/src DemoTransport.hs -o DemoTransport.exe -fforce-recomp
18−
19−clean:
20− rm -f *.hi *.o $(EXMPLS)
install_all.shdeleted−18
@@ -1,18 +0,0 @@
1−#!/bin/bash
2−
3−set -e
4−
5−if [ "$GHC" == "" ]; then
6− GHC=ghc
7−fi
8−
9−cd network-transport/
10−cabal.par install --with-ghc=$GHC $*
11−
12−echo;echo
13−cd ../network-transport-pipes/
14−cabal.par install --with-ghc=$GHC $*
15−
16−echo;echo
17−cd ../distributed-process/
18−cabal.par install --with-ghc=$GHC $*
network-transport-pipes/network-transport-pipes.cabaldeleted−33
@@ -1,33 +0,0 @@
1−Name: network-transport-pipes
2−Version: 0.0.1.2
3−-- Version History:
4−-- 0.0.1.1 - Initial
5−
6−Description: Named Pipes backend for network-transport interface.
7−License: BSD3
8−License-file: LICENSE
9−Author: Ryan Newton
10−Maintainer: rrnewton@gmail.com
11−Homepage: http://github.com/haskell-distributed/
12−Build-Type: Simple
13−Cabal-Version: >=1.2
14−
15−Library
16− Build-Depends: base >= 3 && < 5,
17−-- binary >= 0.5,
18− cereal,
19− bytestring >= 0.9,
20− network-transport >= 0.0.1.1,
21−-- containers >= 0.4,
22− containers >= 0.3,
23−-- network >= 2.3,
24−-- safe >= 0.3,
25− unix >= 2.4,
26− random,
27− directory,
28− unix-bytestring >= 0.3.5.3,
29− time
30− Exposed-modules: Network.Transport.Pipes
31−-- Extensions: BangPatterns
32− ghc-options: -Wall
33− HS-Source-Dirs: src
network-transport-pipes/src/Network/Transport/Pipes.hsdeleted−264
@@ -1,264 +0,0 @@
1−{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, PackageImports #-}
2−
3−----------------------------------------------------------------------------------------------------
4−
5−-- WARNING -- This transport is not yet completed. TODO:
6−
7−-- * Add support for messages greater than 4096 bytes.
8−-- * debug ODD problem with CEREAL below
9−
10−----------------------------------------------------------------------------------------------------
11−
12−module Network.Transport.Pipes
13− ( mkTransport
14− ) where
15−
16−import Control.Monad (when, unless)
17−import Control.Exception (evaluate, throw, handle, fromException,
18− SomeException, IOException)
19−import Control.Concurrent.MVar
20−import Control.Concurrent (threadDelay, forkOS)
21−import Data.IntMap (IntMap)
22−-- import Data.ByteString.Char8 (ByteString)
23−import Data.Word
24−import Data.Int
25−import Data.IORef
26−import qualified Data.IntMap as IntMap
27−import qualified Data.ByteString.Char8 as BS
28−import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) -- Not in 6.10
29−
30−-- For some STRANGE reason this is not working with Data.Binary [2012.02.20]:
31−#define CEREAL
32−#ifdef CEREAL
33−import Data.Serialize (encode,decode) -- Uses strict BS
34−#else
35−import Data.Binary (encode,decode) -- Uses lazy BS
36−#endif
37−
38−import Data.List (foldl')
39−import Network.Transport
40−import System.Random (randomIO)
41−import System.IO (IOMode(ReadMode,AppendMode,WriteMode,ReadWriteMode),
42− openFile, hClose, hPutStrLn, hPutStr, stderr, stdout, hFlush)
43−import System.IO.Error (ioeGetHandle)
44−import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
45−import System.Posix.Types (Fd, ByteCount)
46−import System.Directory (doesFileExist, removeFile)
47−import System.Mem (performGC)
48−
49−#define USE_UNIX_BYTESTRING
50−#ifdef USE_UNIX_BYTESTRING
51−import qualified "unix-bytestring" System.Posix.IO.ByteString as PIO
52−-- import qualified "unix-bytestring" System.Posix.IO.ByteString.Lazy as PIO
53−import System.Posix.IO as PIO (openFd, closeFd, -- append, exclusive, noctty, nonBlock, trunc,
54− OpenFileFlags(..), OpenMode(ReadOnly, WriteOnly))
55−-- (fromS,toS) = (BS.pack, BS.unpack)
56−(fromS,toS) = (BS.pack, BS.unpack)
57−fromBS = id
58−readit fd n = PIO.fdRead fd n
59−#else
60−import qualified System.Posix.IO as PIO
61−(toS,fromS) = (id,id)
62−fromBS = BS.unpack
63−readit fd n = do (s,_) <- PIO.fdRead fd n
64− return (BS.pack s)
65−#endif
66−-- readit :: Fd -> Int -> IO BS.ByteString
67−readit :: Fd -> ByteCount -> IO BS.ByteString
68−
69−----------------------------------------------------------------------------------------------------
70−
71−-- The msg header consists of just a length field represented as a Word32
72−sizeof_header = 4
73−
74−fileFlags =
75− PIO.OpenFileFlags {
76− PIO.append = False,
77− PIO.exclusive = False,
78− PIO.noctty = False,
79− PIO.nonBlock = True,
80− -- In nonblocking mode opening for read will always succeed and
81− -- opening for write must happen second.
82− PIO.trunc = False
83− }
84−-- NOTE:
85−-- "The only open file status flags that can be meaningfully applied
86−-- to a pipe or FIFO are O_NONBLOCK and O_ASYNC. "
87−
88−
89−mkTransport :: IO Transport
90−mkTransport = do
91−-- uid <- randomIO :: IO Word64
92− -- For backwards compatibility we shouldn't assume a Random instance for Word64:
93− uid <- randomIO :: IO Int
94−
95− lock <- newMVar ()
96− let filename = "/tmp/pipe_"++show (abs uid)
97− createNamedPipe filename $ unionFileModes ownerReadMode ownerWriteMode
98−
99− return Transport
100− { newConnectionWith = \ _ -> do
101− -- Here we protect from blocking other threads by running on a separate (OS) thread:
102− -- Opening the file on the reader side should always succeed:
103− mv <- onOSThread$ tryUntilNoIOErr "open pipe for read" $
104−-- spinTillThere filename
105− PIO.openFd filename PIO.ReadOnly Nothing fileFlags
106−
107− return (mkSourceAddr filename,
108− mkTargetEnd mv lock)
109− , newMulticastWith = error "Pipes.hs: newMulticastWith not implemented yet"
110− , deserialize = \bs -> return$ mkSourceAddr (BS.unpack bs)
111− , closeTransport = removeFile filename
112− }
113− where
114− mkSourceAddr :: String -> SourceAddr
115− mkSourceAddr filename = SourceAddr
116− { connectWith = \_ -> mkSourceEnd filename
117− , serialize = BS.pack filename
118− }
119−
120− mkSourceEnd :: String -> IO SourceEnd
121− mkSourceEnd filename = do
122− -- Initiate but do not block on file opening:
123− mv <- onOSThread$ tryUntilNoIOErr "open pipe for write" $
124− -- The reader must connect first, the writer here spins with backoff.
125− PIO.openFd filename PIO.WriteOnly Nothing fileFlags
126−
127− return $
128− -- Write to the named pipe. If the message is less than
129− -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
130− -- we have to do something more sophisticated.
131− SourceEnd
132− { send = \bsls -> do
133− -- ThreadSafe: This may happen on multiple processes/threads:
134− -- We don't need to lock because the write is atomic (for <4096):
135− let msgsize :: Word32 = fromIntegral$ foldl' (\n s -> n + BS.length s) 0 bsls
136− when (msgsize > 4096)$ -- TODO, look up PIPE_BUF in foreign code
137− error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
138− -- Otherwise it's just a simple write:
139− -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
140−
141− let hdrbss :: BS.ByteString
142−#ifdef CEREAL
143− hdrbss = encode msgsize
144−#else
145−-- hdrbss = BS.fromChunks[encode msgsize]
146− [hdrbss] = BS.toChunks (encode msgsize)
147−#endif
148−
149−-- let finalmsg = BS.concat (encode msgsize : bss)
150− let finalmsg = BS.concat (hdrbss : bsls)
151−
152− fd <- readMVar mv -- Synchronize with file opening.
153− ----------------------------------------
154− cnt <- PIO.fdWrite fd (fromBS finalmsg) -- inefficient to use String here!
155− unless (fromIntegral cnt == BS.length finalmsg) $
156− error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
157− ----------------------------------------
158− return ()
159− , closeSourceEnd = do
160− fd <- readMVar mv
161− PIO.closeFd fd
162− }
163−
164− mkTargetEnd :: MVar Fd -> MVar () -> TargetEnd
165− mkTargetEnd mv lock = TargetEnd
166− { receive = do
167− fd <- readMVar mv -- Make sure Fd is there before
168−
169− -- This should only happen on a *single* process. But it may
170− -- happen on multiple threads so we grab a lock.
171−
172− -- If we don't lock, we cannot atomically read the length
173− -- and THEN read the payload. (A single read could be
174− -- atomic, but not two reads.)
175− takeMVar lock
176−
177− let spinread :: Int -> IO BS.ByteString
178− spinread desired = do
179−
180− bs <- tryUntilNoIOErr "read pipe file descriptor"$
181− readit fd (fromIntegral desired)
182−
183− case BS.length bs of
184− n | n == desired -> return bs
185− -- Because we're in non-blocking mode we deal with failed reads thusly:
186−-- 0 -> do threadDelay (10*1000)
187−-- spinread desired
188− 0 -> error$ "receive: read zero bytes from pipe. Even in non-blocking mode should have had an EAGAIN error instead."
189− l -> error$ "Inclomplete read expected either 0 bytes or complete msg ("++
190− show desired ++" bytes) got "++ show l ++ " bytes"
191−
192− hdr <- spinread sizeof_header
193− let
194−#ifdef CEREAL
195− decoded = decode hdr
196−#else
197− decoded = decode (BS.fromChunks [hdr])
198−#endif
199− payload <- case decoded of
200− Left err -> error$ "ERROR: "++ err
201− Right size -> spinread (fromIntegral (size::Word32))
202−
203− putMVar lock ()
204− return [payload] -- How terribly listy.
205− , closeTargetEnd = do
206− fd <- readMVar mv
207− PIO.closeFd fd
208− }
209−
210−-- | Wait untila file is present, with backoff.
211−spinTillThere :: String -> IO ()
212−spinTillThere filename = mkBackoff >>= loop
213− where
214− loop bkoff = do b <- doesFileExist filename
215− unless b $ do bkoff; loop bkoff
216−
217−-- | Create a backoff action that waits successively longer between attempts.
218−mkBackoff :: IO (IO ())
219−mkBackoff =
220− do tref <- newIORef 1
221− return$ do t <- readIORef tref
222− writeIORef tref (min maxwait (2 * t))
223− threadDelay t
224− where
225− maxwait = 50 * 1000
226−
227−-- | Try an IO action repeatedly (with backoff) until it succeeds without exception.
228−tryUntilNoIOErr :: String -> IO a -> IO a
229−tryUntilNoIOErr msg action =
230− do startTime <- getCurrentTime
231− bkoff <- mkBackoff
232− loop startTime startTime bkoff
233− where
234− loop start lastWarned bkoff =
235− handle (\ (e :: IOException) ->
236− do lw <- maybeWarn start lastWarned
237− bkoff
238−-- BSS.hPutStr stderr$ BSS.pack$ " got IO err: " ++ show e
239− -- case ioeGetHandle e of
240− -- Nothing -> BSS.hPutStrLn stderr$ BSS.pack$ " no hndl io err."
241− -- Just x -> BSS.hPutStrLn stderr$ BSS.pack$ " HNDL on io err!" ++ show x
242− loop start lw bkoff) $
243− action
244− -- After how many milleseconds should we start warning?
245− warn_lvl = 3000
246− maybeWarn :: UTCTime -> UTCTime -> IO UTCTime
247− maybeWarn start lastWarned = do
248− now <- getCurrentTime
249− let seconds :: Double = fromRational $ toRational $ diffUTCTime now start
250− sinceWarned :: Double = fromRational $ toRational $ diffUTCTime now lastWarned
251− if (seconds * 1000 >= warn_lvl &&
252− sinceWarned >= 1.0 ) then do
253− BS.hPutStrLn stderr$ BS.pack$ "WARNING: have been trying an IO action ("++msg++
254− ") for "++show seconds++ " seconds without success"
255− return now
256− else
257− return lastWarned
258−
259−-- Execute an action on its own OS thread. Return an MVar to synchronize on.
260−onOSThread :: IO a -> IO (MVar a)
261−onOSThread action = do
262− mv <- newEmptyMVar
263− forkOS (action >>= putMVar mv )
264− return mv
network-transport/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Well-Typed LLP, 2011
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of the owner nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31−
network-transport/network-transport.cabaldeleted−71
@@ -1,71 +0,0 @@
1−Name: network-transport
2−Version: 0.1.0
3−Description: Network Transport
4−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
5−Maintainer: dcoutts@well-typed.com
6−License: BSD3
7−License-file: LICENSE
8−Synopsis: Network abstraction layer
9−Category: Network
10−Homepage: http://github.com/haskell-distributed
11−Build-Type: Simple
12−Cabal-Version: >=1.9.2
13−
14−Library
15− Build-Depends: base >= 4 && < 5,
16− bytestring,
17− containers,
18− data-accessor,
19− network,
20− mtl,
21− transformers
22− Exposed-modules: Network.Transport,
23− Network.Transport.Chan,
24− Network.Transport.TCP,
25− Network.Transport.Util
26− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable
27− ghc-options: -Wall -fno-warn-unused-do-bind
28− HS-Source-Dirs: src
29−
30−Test-Suite TestTCP
31− Type: exitcode-stdio-1.0
32− Main-Is: TestTCP.hs
33− Build-Depends: base >= 4,
34− bytestring,
35− containers,
36− data-accessor,
37− network,
38− mtl,
39− transformers,
40− ansi-terminal
41− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, RankNTypes, OverlappingInstances
42− ghc-options: -Wall -fno-warn-unused-do-bind
43− HS-Source-Dirs: tests src
44−
45−Test-Suite TestMulticastInMemory
46− Type: exitcode-stdio-1.0
47− Main-Is: TestMulticastInMemory.hs
48− Build-Depends: base >= 4,
49− bytestring,
50− containers,
51− data-accessor,
52− mtl,
53− transformers,
54− ansi-terminal
55− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, RankNTypes, OverlappingInstances
56− ghc-options: -Wall -fno-warn-unused-do-bind
57− HS-Source-Dirs: tests src
58−
59−Test-Suite TestInMemory
60− Type: exitcode-stdio-1.0
61− Main-Is: TestInMemory.hs
62− Build-Depends: base >= 4,
63− bytestring,
64− containers,
65− data-accessor,
66− mtl,
67− transformers,
68− ansi-terminal
69− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, RankNTypes, OverlappingInstances
70− ghc-options: -Wall -fno-warn-unused-do-bind
71− HS-Source-Dirs: tests src
network-transport/src/Network/Transport.hsdeleted−198
@@ -1,198 +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− -- * Error codes
13− , TransportError(..)
14− , NewEndPointErrorCode(..)
15− , ConnectErrorCode(..)
16− , NewMulticastGroupErrorCode(..)
17− , ResolveMulticastGroupErrorCode(..)
18− , SendErrorCode(..)
19− , EventErrorCode(..)
20− ) where
21−
22−import Data.ByteString (ByteString)
23−import Control.Exception (Exception)
24−import Data.Typeable (Typeable)
25−
26−--------------------------------------------------------------------------------
27−-- Main API --
28−--------------------------------------------------------------------------------
29−
30−-- | To create a network abstraction layer, use one of the
31−-- @Network.Transport.*@ packages.
32−data Transport = Transport {
33− -- | Create a new end point (heavyweight operation)
34− newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint)
35− -- | Shutdown the transport completely
36− , closeTransport :: IO ()
37− }
38−
39−-- | Network endpoint.
40−data EndPoint = EndPoint {
41− -- | Endpoints have a single shared receive queue.
42− receive :: IO Event
43− -- | EndPointAddress of the endpoint.
44− , address :: EndPointAddress
45− -- | Create a new lightweight connection.
46− , connect :: EndPointAddress -> Reliability -> IO (Either (TransportError ConnectErrorCode) Connection)
47− -- | Create a new multicast group.
48− , newMulticastGroup :: IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
49− -- | Resolve an address to a multicast group.
50− , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
51− -- | Close the endpoint
52− , closeEndPoint :: IO ()
53− }
54−
55−-- | Lightweight connection to an endpoint.
56−data Connection = Connection {
57− -- | Send a message on this connection.
58− send :: [ByteString] -> IO (Either (TransportError SendErrorCode) ())
59− -- | Close the connection.
60− , close :: IO ()
61− }
62−
63−-- | Event on an endpoint.
64−data Event =
65− -- | Received a message
66− Received ConnectionId [ByteString]
67− -- | Connection closed
68− | ConnectionClosed ConnectionId
69− -- | Connection opened
70− | ConnectionOpened ConnectionId Reliability EndPointAddress
71− -- | Received multicast
72− | ReceivedMulticast MulticastAddress [ByteString]
73− -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport)
74− | EndPointClosed
75− -- | An error occurred
76− | ErrorEvent (TransportError EventErrorCode)
77− deriving Show
78−
79−-- | Connection IDs enable receivers to distinguish one connection from another.
80−type ConnectionId = Int
81−
82−-- | Reliability guarantees of a connection.
83−data Reliability =
84− ReliableOrdered
85− | ReliableUnordered
86− | Unreliable
87− deriving Show
88−
89−-- | Multicast group.
90−data MulticastGroup = MulticastGroup {
91− -- | EndPointAddress of the multicast group.
92− multicastAddress :: MulticastAddress
93− -- | Delete the multicast group completely.
94− , deleteMulticastGroup :: IO ()
95− -- | Maximum message size that we can send to this group.
96− , maxMsgSize :: Maybe Int
97− -- | Send a message to the group.
98− , multicastSend :: [ByteString] -> IO ()
99− -- | Subscribe to the given multicast group (to start receiving messages from the group).
100− , multicastSubscribe :: IO ()
101− -- | Unsubscribe from the given multicast group (to stop receiving messages from the group).
102− , multicastUnsubscribe :: IO ()
103− -- | Close the group (that is, indicate you no longer wish to send to the group).
104− , multicastClose :: IO ()
105− }
106−
107−-- | EndPointAddress of an endpoint.
108−newtype EndPointAddress = EndPointAddress { endPointAddressToByteString :: ByteString }
109− deriving (Eq, Ord)
110−
111−instance Show EndPointAddress where
112− show = show . endPointAddressToByteString
113−
114−-- | EndPointAddress of a multicast group.
115−newtype MulticastAddress = MulticastAddress { multicastAddressToByteString :: ByteString }
116− deriving (Eq, Ord)
117−
118−instance Show MulticastAddress where
119− show = show . multicastAddressToByteString
120−
121−--------------------------------------------------------------------------------
122−-- Error codes --
123−--------------------------------------------------------------------------------
124−
125−data TransportError error = TransportError error String
126− deriving (Show, Typeable)
127−
128−-- | Although the functions in the transport API never throw TransportErrors
129−-- (but return them explicitly), application code may want to turn these into
130−-- exceptions.
131−instance (Typeable err, Show err) => Exception (TransportError err)
132−
133−-- | Errors during the creation of an endpoint
134−data NewEndPointErrorCode =
135− -- | Not enough resources
136− -- (i.e., this could be a temporary local problem)
137− NewEndPointInsufficientResources
138− -- | Failed for some other reason
139− -- (i.e., there is probably no point trying again)
140− | NewEndPointFailed
141− deriving (Show, Typeable)
142−
143−-- | Connection failure
144−data ConnectErrorCode =
145− -- | Could not resolve the address
146− -- (i.e., this could be a temporary remote problem)
147− ConnectNotFound
148− -- | Insufficient resources (for instance, no more sockets available)
149− -- (i.e., this could be a temporary local problem)
150− | ConnectInsufficientResources
151− -- | Failed for other reasons (including syntax error)
152− -- (i.e., there is probably no point trying again).
153− | ConnectFailed
154− deriving (Show, Typeable)
155−
156−-- | Failure during the creation of a new multicast group
157−data NewMulticastGroupErrorCode =
158− -- | Insufficient resources
159− -- (i.e., this could be a temporary problem)
160− NewMulticastGroupInsufficientResources
161− -- | Failed for some other reason
162− -- (i.e., there is probably no point trying again)
163− | NewMulticastGroupFailed
164− -- | Not all transport implementations support multicast
165− | NewMulticastGroupUnsupported
166− deriving (Show, Typeable)
167−
168−-- | Failure during the resolution of a multicast group
169−data ResolveMulticastGroupErrorCode =
170− -- | Multicast group not found
171− -- (i.e., this could be a temporary problem)
172− ResolveMulticastGroupNotFound
173− -- | Failed for some other reason (including syntax error)
174− -- (i.e., there is probably no point trying again)
175− | ResolveMulticastGroupFailed
176− -- | Not all transport implementations support multicast
177− | ResolveMulticastGroupUnsupported
178− deriving (Show, Typeable)
179−
180−-- | Failure during sending a message
181−data SendErrorCode =
182− -- | Could not send this message
183− -- (but another attempt might succeed)
184− SendUnreachable
185− -- | Send failed for some other reason
186− -- (and retrying probably won't help)
187− | SendFailed
188− deriving (Show, Typeable)
189−
190−-- | Error codes used when reporting errors to endpoints (through receive)
191−data EventErrorCode =
192− -- | Failure of the entire endpoint
193− EventEndPointFailed
194− -- | Transport-wide fatal error
195− | EventTransportFailed
196− -- | Connection to a remote endpoint was lost
197− | EventConnectionLost EndPointAddress [ConnectionId]
198− deriving Show
network-transport/src/Network/Transport/Chan.hsdeleted−150
@@ -1,150 +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 (throw)
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 = throw (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 = throw (userError "closeEndPoint not implemented")
51− , newMulticastGroup = apiNewMulticastGroup state addr
52− , resolveMulticastGroup = apiResolveMulticastGroup state addr
53− }
54−
55−-- | Create a new connection
56−apiConnect :: EndPointAddress -> MVar TransportState -> EndPointAddress -> Reliability -> IO (Either (TransportError ConnectErrorCode) Connection)
57−apiConnect myAddress state theirAddress _ = do
58− (chan, conn) <- modifyMVar state $ \st -> do
59− let chan = st ^. channelAt theirAddress
60− let conn = st ^. nextConnectionIdAt theirAddress
61− return (nextConnectionIdAt theirAddress ^: (+ 1) $ st, (chan, conn))
62− writeChan chan $ ConnectionOpened conn ReliableOrdered myAddress
63− connAlive <- newMVar True
64− return . Right $ Connection { send = apiSend chan conn connAlive
65− , close = apiClose chan conn connAlive
66− }
67−
68−-- | Send a message over a connection
69−apiSend :: Chan Event -> ConnectionId -> MVar Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
70−apiSend chan conn connAlive msg =
71− modifyMVar connAlive $ \alive -> do
72− if alive
73− then do writeChan chan (Received conn msg)
74− return (alive, Right ())
75− else do return (alive, Left (TransportError SendFailed "Connection closed"))
76−
77−-- | Close a connection
78−apiClose :: Chan Event -> ConnectionId -> MVar Bool -> IO ()
79−apiClose chan conn connAlive =
80− modifyMVar_ connAlive $ \alive -> do
81− when alive . writeChan chan $ ConnectionClosed conn
82− return False
83−
84−-- | Create a new multicast group
85−apiNewMulticastGroup :: MVar TransportState -> EndPointAddress -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
86−apiNewMulticastGroup state ourAddress = do
87− group <- newMVar Set.empty
88− groupAddr <- modifyMVar state $ \st -> do
89− let addr = MulticastAddress . BSC.pack . show . Map.size $ st ^. multigroups
90− return (multigroupAt addr ^= group $ st, addr)
91− return . Right $ createMulticastGroup state ourAddress groupAddr group
92−
93−-- | Construct a multicast group
94−--
95−-- When the group is deleted some endpoints may still receive messages, but
96−-- subsequent calls to resolveMulticastGroup will fail. This mimicks the fact
97−-- that some multicast messages may still be in transit when the group is
98−-- deleted.
99−createMulticastGroup :: MVar TransportState -> EndPointAddress -> MulticastAddress -> MVar (Set EndPointAddress) -> MulticastGroup
100−createMulticastGroup state ourAddress groupAddress group =
101− MulticastGroup { multicastAddress = groupAddress
102− , deleteMulticastGroup = modifyMVar_ state $ return . (multigroups ^: Map.delete groupAddress)
103− , maxMsgSize = Nothing
104− , multicastSend = \payload -> do
105− cs <- (^. channels) <$> readMVar state
106− es <- readMVar group
107− forM_ (Set.elems es) $ \ep -> do
108− let ch = (cs ^. at ep "Invalid endpoint")
109− writeChan ch (ReceivedMulticast groupAddress payload)
110− , multicastSubscribe = modifyMVar_ group $ return . (Set.insert ourAddress)
111− , multicastUnsubscribe = modifyMVar_ group $ return . (Set.delete ourAddress)
112− , multicastClose = return ()
113− }
114−
115−-- | Resolve a multicast group
116−apiResolveMulticastGroup :: MVar TransportState
117− -> EndPointAddress
118− -> MulticastAddress
119− -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
120−apiResolveMulticastGroup state ourAddress groupAddress = do
121− group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state
122− case group of
123− Nothing -> return . Left $ TransportError ResolveMulticastGroupNotFound ("Group " ++ show groupAddress ++ " not found")
124− Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar
125−
126−--------------------------------------------------------------------------------
127−-- Lens definitions --
128−--------------------------------------------------------------------------------
129−
130−channels :: Accessor TransportState (Map EndPointAddress (Chan Event))
131−channels = accessor _channels (\ch st -> st { _channels = ch })
132−
133−nextConnectionId :: Accessor TransportState (Map EndPointAddress ConnectionId)
134−nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid })
135−
136−multigroups :: Accessor TransportState (Map MulticastAddress (MVar (Set EndPointAddress)))
137−multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })
138−
139−at :: Ord k => k -> String -> Accessor (Map k v) v
140−at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)
141−
142−channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)
143−channelAt addr = channels >>> at addr "Invalid channel"
144−
145−nextConnectionIdAt :: EndPointAddress -> Accessor TransportState ConnectionId
146−nextConnectionIdAt addr = nextConnectionId >>> at addr "Invalid connection ID"
147−
148−multigroupAt :: MulticastAddress -> Accessor TransportState (MVar (Set EndPointAddress))
149−multigroupAt addr = multigroups >>> at addr "Invalid multigroup"
150−
network-transport/src/Network/Transport/Internal.hsdeleted−93
@@ -1,93 +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− , mapExceptionIO
10− , tryIO
11− , tryToEnum
12− , void
13− -- * Debugging
14− , tlog
15− ) where
16−
17−import Prelude hiding (catch)
18−import Foreign.Storable (pokeByteOff, peekByteOff)
19−import Foreign.C (CInt(..), CShort(..))
20−import Foreign.ForeignPtr (withForeignPtr)
21−import Data.ByteString (ByteString)
22−import qualified Data.ByteString as BS (length)
23−import qualified Data.ByteString.Internal as BSI (unsafeCreate, toForeignPtr, inlinePerformIO)
24−import Control.Monad.IO.Class (MonadIO, liftIO)
25−import Control.Exception (IOException, Exception, catch, try, throw)
26−--import Control.Concurrent (myThreadId)
27−
28−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
29−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
30−foreign import ccall unsafe "htons" htons :: CShort -> CShort
31−foreign import ccall unsafe "ntohs" ntohs :: CShort -> CShort
32−
33−-- | Serialize 32-bit to network byte order
34−encodeInt32 :: Enum a => a -> ByteString
35−encodeInt32 i32 =
36− BSI.unsafeCreate 4 $ \p ->
37− pokeByteOff p 0 (htonl . fromIntegral . fromEnum $ i32)
38−
39−-- | Deserialize 32-bit from network byte order
40−decodeInt32 :: Num a => ByteString -> Maybe a
41−decodeInt32 bs | BS.length bs /= 4 = Nothing
42−decodeInt32 bs = Just . BSI.inlinePerformIO $ do
43− let (fp, _, _) = BSI.toForeignPtr bs
44− withForeignPtr fp $ \p -> do
45− w32 <- peekByteOff p 0
46− return (fromIntegral . ntohl $ w32)
47−
48−-- | Serialize 16-bit to network byte order
49−encodeInt16 :: Enum a => a -> ByteString
50−encodeInt16 i16 =
51− BSI.unsafeCreate 2 $ \p ->
52− pokeByteOff p 0 (htons . fromIntegral . fromEnum $ i16)
53−
54−-- | Deserialize 16-bit from network byte order
55−decodeInt16 :: Num a => ByteString -> Maybe a
56−decodeInt16 bs | BS.length bs /= 2 = Nothing
57−decodeInt16 bs = Just . BSI.inlinePerformIO $ do
58− let (fp, _, _) = BSI.toForeignPtr bs
59− withForeignPtr fp $ \p -> do
60− w16 <- peekByteOff p 0
61− return (fromIntegral . ntohs $ w16)
62−
63−-- | Prepend a list of bytestrings with their total length
64−prependLength :: [ByteString] -> [ByteString]
65−prependLength bss = encodeInt32 (sum . map BS.length $ bss) : bss
66−
67−-- | Translate exceptions that arise in IO computations
68−mapExceptionIO :: (Exception e1, Exception e2) => (e1 -> e2) -> IO a -> IO a
69−mapExceptionIO f p = catch p (throw . f)
70−
71−-- | Like 'try', but lifted and specialized to IOExceptions
72−tryIO :: MonadIO m => IO a -> m (Either IOException a)
73−tryIO = liftIO . try
74−
75−-- | Logging (for debugging)
76−tlog :: MonadIO m => String -> m ()
77−tlog _ = return ()
78−{-
79−tlog msg = liftIO $ do
80− tid <- myThreadId
81− putStrLn $ show tid ++ ": " ++ msg
82−-}
83−
84−-- | Not all versions of "base" export 'void'
85−void :: Monad m => m a -> m ()
86−void p = p >> return ()
87−
88−-- | Safe version of 'toEnum'
89−tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a
90−tryToEnum = go minBound maxBound
91− where
92− go :: Enum b => b -> b -> Int -> Maybe b
93− go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing
network-transport/src/Network/Transport/Internal/TCP.hsdeleted−102
@@ -1,102 +0,0 @@
1−-- | Utility functions for TCP sockets
2−module Network.Transport.Internal.TCP ( forkServer
3− , recvWithLength
4− , recvExact
5− , recvInt32
6− ) where
7−
8−import Prelude hiding (catch)
9−import Network.Transport.Internal (decodeInt32)
10−import qualified Network.Socket as N ( HostName
11− , ServiceName
12− , Socket
13− , SocketType(Stream)
14− , SocketOption(ReuseAddr)
15− , getAddrInfo
16− , defaultHints
17− , socket
18− , bindSocket
19− , listen
20− , addrFamily
21− , addrAddress
22− , defaultProtocol
23− , setSocketOption
24− , accept
25− , sClose
26− )
27−import qualified Network.Socket.ByteString as NBS (recv)
28−import Control.Concurrent (forkIO, ThreadId)
29−import Control.Monad (liftM, forever)
30−import Control.Exception (SomeException, handle, bracketOnError, throw)
31−import Data.ByteString (ByteString)
32−import qualified Data.ByteString as BS (length, concat, null)
33−import Data.Int (Int32)
34−
35−-- | Start a server at the specified address.
36−--
37−-- This sets up a server socket for the specified host and port. Exceptions
38−-- thrown during setup are not caught.
39−--
40−-- Once the socket is created we spawn a new thread which repeatedly accepts
41−-- incoming connections and executes the given request handler. If any
42−-- exception occurs the thread terminates and calls the terminationHandler.
43−-- This exception may occur because of a call to 'N.accept', because the thread
44−-- was explicitly killed, or because of a synchronous exception thrown by the
45−-- request handler. Typically, you should avoid the last case by catching any
46−-- relevant exceptions in the request handler.
47−--
48−-- The request handler should spawn threads to handle each individual request
49−-- or the server will block. Once a thread has been spawned it will be the
50−-- responsibility of the new thread to close the socket when an exception
51−-- occurs.
52−forkServer :: N.HostName -- ^ Host
53− -> N.ServiceName -- ^ Port
54− -> Int -- ^ Backlog (maximum number of queued connections)
55− -> (SomeException -> IO ()) -- ^ Termination handler
56− -> (N.Socket -> IO ()) -- ^ Request handler
57− -> IO ThreadId
58−forkServer host port backlog terminationHandler requestHandler = do
59− -- Resolve the specified address. By specification, getAddrInfo will never
60− -- return an empty list (but will throw an exception instead) and will return
61− -- the "best" address first, whatever that means
62− addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
63− sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
64− -- putStrLn $ "Created server socket " ++ show sock ++ " for address " ++ host ++ ":" ++ port
65− N.setSocketOption sock N.ReuseAddr 1
66− N.bindSocket sock (N.addrAddress addr)
67− N.listen sock backlog
68− -- TODO: when is this socket closed?
69− forkIO . handle terminationHandler . forever $
70− bracketOnError (N.accept sock)
71− (N.sClose . fst)
72− (requestHandler . fst)
73−
74−-- | Read a length and then a payload of that length
75−recvWithLength :: N.Socket -> IO [ByteString]
76−recvWithLength sock = recvInt32 sock >>= recvExact sock
77−
78−-- | Receive a 32-bit integer
79−recvInt32 :: Num a => N.Socket -> IO a
80−recvInt32 sock = do
81− mi <- liftM (decodeInt32 . BS.concat) $ recvExact sock 4
82− case mi of
83− Nothing -> throw (userError "Invalid integer")
84− Just i -> return i
85−
86−-- | Read an exact number of bytes from a socket
87−--
88−-- Throws an I/O exception if the socket closes before the specified
89−-- number of bytes could be read
90−recvExact :: N.Socket -- ^ Socket to read from
91− -> Int32 -- ^ Number of bytes to read
92− -> IO [ByteString]
93−recvExact _ len | len <= 0 = throw (userError "Negative length")
94−recvExact sock len = go [] len
95− where
96− go :: [ByteString] -> Int32 -> IO [ByteString]
97− go acc 0 = return (reverse acc)
98− go acc l = do
99− bs <- NBS.recv sock (fromIntegral l `min` 4096)
100− if BS.null bs
101− then throw (userError "Socket closed")
102− else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport/src/Network/Transport/TCP.hsdeleted−1138
@@ -1,1138 +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−--
14−-- TODOs:
15−-- * Output exception on channel after endpoint is closed
16−module Network.Transport.TCP ( -- * Main API
17− createTransport
18− , -- * TCP specific functionality (exported mostly for testing purposes_
19− EndPointId
20− , encodeEndPointAddress
21− , decodeEndPointAddress
22− , ControlHeader(..)
23− , ConnectionRequestResponse(..)
24− , firstNonReservedConnectionId
25− , socketToEndPoint
26− -- * Design notes
27− -- $design
28− ) where
29−
30−import Prelude hiding (catch)
31−import Network.Transport
32−import Network.Transport.Internal.TCP ( forkServer
33− , recvWithLength
34− , recvInt32
35− )
36−import Network.Transport.Internal ( encodeInt32
37− , decodeInt32
38− , prependLength
39− , mapExceptionIO
40− , tryIO
41− , tryToEnum
42− , void
43− )
44−import qualified Network.Socket as N ( HostName
45− , ServiceName
46− , Socket
47− , sClose
48− , getAddrInfo
49− , socket
50− , addrFamily
51− , addrAddress
52− , SocketType(Stream)
53− , defaultProtocol
54− , setSocketOption
55− , SocketOption(ReuseAddr)
56− , connect
57− , sOMAXCONN
58− , AddrInfo
59− )
60−import Network.Socket.ByteString (sendMany)
61−import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
62−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
63−import Control.Concurrent.MVar ( MVar
64− , newMVar
65− , modifyMVar
66− , modifyMVar_
67− , readMVar
68− , takeMVar
69− , putMVar
70− , newEmptyMVar
71− , withMVar
72− )
73−import Control.Category ((>>>))
74−import Control.Applicative ((<$>))
75−import Control.Monad (forM_, when, unless)
76−import Control.Exception (IOException, SomeException, handle, throw, try, bracketOnError)
77−import Data.IORef (IORef, newIORef, writeIORef, readIORef)
78−import Data.ByteString (ByteString)
79−import qualified Data.ByteString as BS (concat)
80−import qualified Data.ByteString.Char8 as BSC (pack, unpack, split)
81−import Data.Int (Int32)
82−import Data.IntMap (IntMap)
83−import qualified Data.IntMap as IntMap (empty)
84−import Data.IntSet (IntSet)
85−import qualified Data.IntSet as IntSet (empty, insert, elems, singleton, null, delete)
86−import Data.Map (Map)
87−import qualified Data.Map as Map (empty, elems, size)
88−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
89−import qualified Data.Accessor.Container as DAC (mapMaybe, intMapMaybe)
90−import System.IO (hPutStrLn, stderr)
91−
92−-- $design
93−--
94−-- [Goals]
95−--
96−-- The TCP transport maps multiple logical connections between /A/ and /B/ (in
97−-- either direction) to a single TCP connection:
98−--
99−-- > +-------+ +-------+
100−-- > | A |==========================| B |
101−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
102−-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q |
103−-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
104−-- > | |==========================| |
105−-- > +-------+ +-------+
106−--
107−-- Ignoring the complications detailed below, the TCP connection is set up is
108−-- when the first lightweight connection is created (in either direction), and
109−-- torn down when the last lightweight connection (in either direction) is
110−-- closed.
111−--
112−-- [Connecting]
113−--
114−-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to
115−-- connect to /B/, it locally records that it is trying to connect to /B/ and
116−-- sends a request to /B/. As part of the request /A/ sends its own endpoint
117−-- address to /B/ (so that /B/ can reuse the connection in the other direction).
118−--
119−-- When /B/ receives the connection request it first checks if it did not
120−-- already initiate a connection request to /A/. If not it will acknowledge the
121−-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record
122−-- that it has a TCP connection to /A/.
123−--
124−-- The tricky case arises when /A/ sends a connection request to /B/ and /B/
125−-- finds that it had already sent a connection request to /A/. In this case /B/
126−-- will accept the connection request from /A/ if /A/s endpoint address is
127−-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects
128−-- it, it sends a 'ConnectionRequestCrossed' message to /A/. (The
129−-- lexicographical ordering is an arbitrary but convenient way to break the
130−-- tie.)
131−--
132−-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that
133−-- initiated the request just needs to wait until the /A/ thread that is dealing
134−-- with /B/'s connection request completes.
135−--
136−-- [Disconnecting]
137−--
138−-- The TCP connection is created as soon as the first logical connection from
139−-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
140−-- spawned that listens for incoming connections from /B/:
141−--
142−-- > +-------+ +-------+
143−-- > | A |==========================| B |
144−-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
145−-- > | | | Q |
146−-- > | #| | |
147−-- > | |==========================| |
148−-- > +-------+ +-------+
149−--
150−-- The question is when the TCP connection can be closed again. Conceptually,
151−-- we want to do reference counting: when there are no logical connections left
152−-- between /A/ and /B/ we want to close the socket (possibly after some
153−-- timeout).
154−--
155−-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
156−-- might happen that /B/ sends a connection request over the existing socket at
157−-- the same time that /A/ closes its logical connection to /B/ and closes the
158−-- socket. This will cause a failure in /B/ (which will have to retry) which is
159−-- not caused by a network failure, which is unfortunate. (Note that the
160−-- connection request from /B/ might succeed even if /A/ closes the socket.)
161−--
162−-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
163−-- request to /B/ and records that its connection to /B/ is closing. If /A/
164−-- receives a new connection request from /B/ after having sent the
165−-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
166−-- and increments the reference count of the connection again.
167−--
168−-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
169−-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
170−-- and then actually close the socket. /A/ meanwhile will not send any more
171−-- requests to /B/ after having sent a 'CloseSocket' request, and will actually
172−-- close its end of the socket only when receiving the 'CloseSocket' message
173−-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
174−-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
175−-- reciprocal 'CloseSocket' message.)
176−--
177−-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
178−-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
179−-- whether to reuse the old socket (if /B/ sends a new connection request
180−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
181−
182−--------------------------------------------------------------------------------
183−-- Internal datatypes --
184−--------------------------------------------------------------------------------
185−
186−-- We use underscores for fields that we might update (using accessores)
187−--
188−-- All data types follow the same structure:
189−--
190−-- * A top-level data type describing static properties (TCPTransport,
191−-- LocalEndPoint, RemoteEndPoint)
192−-- * The 'static' properties include an MVar containing a data structure for
193−-- the dynamic properties (TransportState, LocalEndPointState,
194−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
195−-- * For the case of "valid" we use third data structure to give more details
196−-- about the state (ValidTransportState, ValidLocalEndPointState,
197−-- ValidRemoteEndPointState).
198−
199−data TCPTransport = TCPTransport
200− { transportHost :: N.HostName
201− , transportPort :: N.ServiceName
202− , transportState :: MVar TransportState
203− }
204−
205−data TransportState =
206− TransportValid ValidTransportState
207− | TransportClosed
208−
209−data ValidTransportState = ValidTransportState
210− { _localEndPoints :: Map EndPointAddress LocalEndPoint
211− }
212−
213−data LocalEndPoint = LocalEndPoint
214− { localAddress :: EndPointAddress
215− , localChannel :: Chan Event
216− , localState :: MVar LocalEndPointState
217− }
218−
219−data LocalEndPointState =
220− LocalEndPointValid ValidLocalEndPointState
221− | LocalEndPointClosed
222−
223−data ValidLocalEndPointState = ValidLocalEndPointState
224− { _nextConnectionId :: ConnectionId
225− , _pendingCtrlRequests :: IntMap (MVar [ByteString])
226− , _nextCtrlRequestId :: ControlRequestId
227− , _localConnections :: Map EndPointAddress RemoteEndPoint
228− , _internalThreads :: [ThreadId]
229− }
230−
231−-- A remote endpoint has incoming and outgoing connections, and when the total
232−-- number of connections (that is, the 'remoteRefCount') drops to zero we want
233−-- to close the TCP connection to the endpoint.
234−--
235−-- What we need to avoid, however, is a situation with two concurrent threads
236−-- where one closes the last (incoming or outgoing) connection, initiating the
237−-- process of closing the connection, while another requests (but does not yet
238−-- have) a new connection.
239−--
240−-- We therefore insist that:
241−--
242−-- 1. All operations that change the state of the endpoint (ask for a new
243−-- connection, close a connection, close the endpoint completely) are
244−-- serialized (that is, they take the contents of the MVar containing the
245−-- endpoint state before starting and don't put the updated contents back
246−-- until they have completed).
247−-- 2. Writing to ('apiSend') or reading from (in 'handleIncomingMessages') must
248−-- maintain the invariant that the connection they are writing to/reading
249−-- from *must* be "included" in the 'remoteRefCount'.
250−-- 3. Since every endpoint is associated with a single socket, we regard writes
251−-- that endpoint a state change too (i.e., we take the MVar before the write
252−-- and put it back after). The reason is that we don't want to "scramble" the
253−-- output of multiple concurrent writes (either from an explicit 'send' or
254−-- the writes for control messages).
255−--
256−-- Of course, "serialize" does not mean that we want for the remote endpoint to
257−-- reply. "Send" takes the mvar, sends to the endpoint (asynchronously), and
258−-- then puts the mvar back, without waiting for the endpoint to receive the
259−-- message. Similarly, when requesting a new connection, we take the mvar,
260−-- tentatively increment the reference count, send the control request, and
261−-- then put the mvar back. When the remote host responds to the new connection
262−-- request we might have to do another state change (reduce the refcount) if
263−-- the connection request was refused but we don't want to increment the ref
264−-- count only after the remote host acknowledges the request because then a
265−-- concurrent 'close' might actually attempt to close the socket.
266−--
267−-- Since we don't do concurrent reads from the same socket we don't need to
268−-- take the lock when reading from the socket.
269−--
270−-- Moreover, we insist on the invariant (INV-CLOSE) that whenever we put an
271−-- endpoint in closed state we remove that endpoint from localConnections
272−-- first, so that if a concurrent thread reads the mvar, finds EndPointClosed,
273−-- and then looks up the endpoint in localConnections it is guaranteed to
274−-- either find a different remote endpoint, or else none at all.
275−
276−data RemoteEndPoint = RemoteEndPoint
277− { remoteAddress :: EndPointAddress
278− , remoteState :: MVar RemoteState
279− }
280−
281−data RemoteState =
282− RemoteEndPointInvalid (TransportError ConnectErrorCode)
283− | RemoteEndPointValid ValidRemoteEndPointState
284− | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
285− | RemoteEndPointClosed
286−
287−data ValidRemoteEndPointState = ValidRemoteEndPointState
288− { _remoteOutgoing :: !Int
289− , _remoteIncoming :: IntSet
290− , remoteSocket :: N.Socket
291− , sendOn :: [ByteString] -> IO ()
292− }
293−
294−type EndPointId = Int32
295−type ControlRequestId = Int32
296−type EndPointPair = (LocalEndPoint, RemoteEndPoint)
297−
298−-- | Control headers
299−data ControlHeader =
300− RequestConnectionId -- ^ Request a new connection ID from the remote endpoint
301− | CloseConnection -- ^ Tell the remote endpoint we will no longer be using a connection
302− | ControlResponse -- ^ Respond to a control request /from/ the remote endpoint
303− | CloseSocket -- ^ Request to close the connection (see module description)
304− deriving (Enum, Bounded, Show)
305−
306−-- Response sent by /B/ to /A/ when /A/ tries to connect
307−data ConnectionRequestResponse =
308− ConnectionRequestAccepted -- ^ /B/ accepts the connection
309− | ConnectionRequestEndPointInvalid -- ^ /A/ requested an invalid endpoint
310− | ConnectionRequestCrossed -- ^ /A/s request crossed with a request from /B/ (see protocols)
311− deriving (Enum, Bounded, Show)
312−
313−--------------------------------------------------------------------------------
314−-- Top-level functionality --
315−--------------------------------------------------------------------------------
316−
317−-- | Create a TCP transport
318−--
319−-- TODOs: deal with hints
320−createTransport :: N.HostName -> N.ServiceName -> IO (Either IOException Transport)
321−createTransport host port = do
322− state <- newMVar . TransportValid $ ValidTransportState { _localEndPoints = Map.empty }
323− let transport = TCPTransport { transportState = state
324− , transportHost = host
325− , transportPort = port
326− }
327− tryIO $ do
328− -- For a discussion of the use of N.sOMAXCONN, see
329− -- http://tangentsoft.net/wskfaq/advanced.html#backlog
330− -- http://www.linuxjournal.com/files/linuxjournal.com/linuxjournal/articles/023/2333/2333s2.html
331− transportThread <- forkServer host port N.sOMAXCONN (terminationHandler transport) (handleConnectionRequest transport)
332− return Transport { newEndPoint = apiNewEndPoint transport
333− , closeTransport = killThread transportThread -- This will invoke the termination handler
334− }
335− where
336− terminationHandler :: TCPTransport -> SomeException -> IO ()
337− terminationHandler transport _ = do
338− -- TODO: we currently don't make a distinction between endpoint failure and manual closure
339− mTSt <- modifyMVar (transportState transport) $ \st -> case st of
340− TransportValid vst -> return (TransportClosed, Just vst)
341− TransportClosed -> return (TransportClosed, Nothing)
342− case mTSt of
343− Nothing ->
344− -- Transport already closed
345− return ()
346− Just tSt ->
347− mapM_ (apiCloseEndPoint transport) (Map.elems $ tSt ^. localEndPoints)
348−
349−--------------------------------------------------------------------------------
350−-- API functions --
351−--------------------------------------------------------------------------------
352−
353−-- | Create a new endpoint
354−apiNewEndPoint :: TCPTransport -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
355−apiNewEndPoint transport = try $ do
356− ourEndPoint <- createLocalEndPoint transport
357− return EndPoint
358− { receive = readChan (localChannel ourEndPoint)
359− , address = localAddress ourEndPoint
360− , connect = apiConnect ourEndPoint
361− , closeEndPoint = apiCloseEndPoint transport ourEndPoint
362− , newMulticastGroup = return . Left $ newMulticastGroupError
363− , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
364− }
365− where
366− newMulticastGroupError = TransportError NewMulticastGroupUnsupported "TCP does not support multicast"
367− resolveMulticastGroupError = TransportError ResolveMulticastGroupUnsupported "TCP does not support multicast"
368−
369−-- | Connnect to an endpoint
370−apiConnect :: LocalEndPoint -- ^ Local end point
371− -> EndPointAddress -- ^ Remote address
372− -> Reliability -- ^ Reliability (ignored)
373− -> IO (Either (TransportError ConnectErrorCode) Connection)
374−apiConnect ourEndPoint theirAddress _ | localAddress ourEndPoint == theirAddress =
375− connectToSelf ourEndPoint
376−apiConnect ourEndPoint theirAddress _ = try $ do
377− (theirEndPoint, connId) <- requestConnectionTo ourEndPoint theirAddress
378− -- connAlive can be an IORef rather than an MVar because it is protected by
379− -- the remoteState MVar. We don't need the overhead of locking twice.
380− connAlive <- newIORef True
381− return $ Connection { send = apiSend theirEndPoint connId connAlive
382− , close = apiClose theirEndPoint connId connAlive
383− }
384−
385−-- | Close a connection
386−--
387−-- RELY: The endpoint must not be invalid
388−-- GUARANTEE: If the connection is alive on entry then the remote endpoint will
389−-- either be RemoteEndPointValid or RemoteEndPointClosing. Otherwise, the state
390−-- of the remote endpoint will not be changed.
391−--
392−-- TODO: We ignore errors during a close. Is that right?
393−apiClose :: RemoteEndPoint -> ConnectionId -> IORef Bool -> IO ()
394−apiClose theirEndPoint connId connAlive = void . tryIO $ do
395− modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
396− RemoteEndPointValid vst -> do
397− alive <- readIORef connAlive
398− if alive
399− then do
400− writeIORef connAlive False
401− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
402− return (RemoteEndPointValid . (remoteOutgoing ^: (\x -> x - 1)) $ vst)
403− else
404− return (RemoteEndPointValid vst)
405− RemoteEndPointClosed -> do
406− return st
407− RemoteEndPointClosing _ _ ->
408− -- See discussion in apiSend why we must allow for this case
409− return st
410− RemoteEndPointInvalid _ ->
411− fail "apiClose RELY violation"
412− closeIfUnused theirEndPoint
413−
414−-- | Send data across a connection
415−--
416−-- RELY: The endpoint must not be in invalid state.
417−-- GUARANTEE: The state of the remote endpoint will not be changed.
418−apiSend :: RemoteEndPoint -> ConnectionId -> IORef Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
419−apiSend theirEndPoint connId connAlive payload = do
420− withMVar (remoteState theirEndPoint) $ \st -> case st of
421− RemoteEndPointValid vst -> do
422− alive <- readIORef connAlive
423− try $ if alive
424− then mapExceptionIO sendFailed $ sendOn vst (encodeInt32 connId : prependLength payload)
425− else throw $ TransportError SendFailed "Connection closed"
426− RemoteEndPointClosed -> do
427− return (Left $ TransportError SendFailed "Connection closed")
428− RemoteEndPointClosing _ _ ->
429− -- The only way for the endpoint to be in closing state, while a
430− -- connection is still active, is for the application to call 'close'
431− -- on the connection triggering "garbage collection" of the TCP channel
432− -- (CloseSocket request to the remote endpoint) which hasn't completed
433− -- yet. Even if the remote endpoint comes back with "please don't
434− -- close", this still means that our *outgoing* connection has been
435− -- closed
436− return (Left $ TransportError SendFailed "Connection closed")
437− RemoteEndPointInvalid _ ->
438− error "apiSend RELY violation"
439− where
440− sendFailed :: IOException -> TransportError SendErrorCode
441− sendFailed = TransportError SendFailed . show
442−
443−-- | Force-close the endpoint
444−apiCloseEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
445−apiCloseEndPoint transport ourEndPoint = do
446− -- Remove the reference from the transport state
447− removeLocalEndPoint transport ourEndPoint
448− -- Close the local endpoint
449− mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
450− case st of
451− LocalEndPointValid vst ->
452− return (LocalEndPointClosed, Just vst)
453− LocalEndPointClosed ->
454− return (LocalEndPointClosed, Nothing)
455− case mOurState of
456− Nothing -> -- Already closed
457− return ()
458− Just vst -> do
459− -- Close all endpoints and kill all threads
460− forM_ (Map.elems $ vst ^. localConnections) $ tryCloseRemoteSocket
461− forM_ (vst ^. internalThreads) killThread
462− -- We send a single message to the endpoint that it is closed. Subsequent
463− -- calls will block. We could change this so that all subsequent calls to
464− -- receive return an error, but this would mean checking for some state on
465− -- every call to receive, which is an unnecessary overhead.
466− writeChan (localChannel ourEndPoint) EndPointClosed
467− where
468− -- Close the remote socket and return the set of all incoming connections
469− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
470− tryCloseRemoteSocket theirEndPoint = do
471− -- We make an attempt to close the connection nicely (by sending a CloseSocket first)
472− modifyMVar_ (remoteState theirEndPoint) $ \st ->
473− case st of
474− RemoteEndPointInvalid _ ->
475− return st
476− RemoteEndPointValid conn -> do
477− -- Try to send a CloseSocket request
478− tryIO $ sendOn conn [encodeInt32 CloseSocket]
479− -- .. but even if it fails, close the socket anyway
480− -- (hence, two separate calls to tryIO)
481− tryIO $ N.sClose (remoteSocket conn)
482− return RemoteEndPointClosed
483− RemoteEndPointClosing _ conn -> do
484− tryIO $ N.sClose (remoteSocket conn)
485− return RemoteEndPointClosed
486− RemoteEndPointClosed ->
487− return RemoteEndPointClosed
488−
489−-- | Special case of 'apiConnect': connect an endpoint to itself
490−connectToSelf :: LocalEndPoint -> IO (Either (TransportError ConnectErrorCode) Connection)
491−connectToSelf ourEndPoint = do
492− -- Here connAlive must an MVar because it is not protected by another lock
493− connAlive <- newMVar True
494− -- TODO: catch exception
495− connId <- getNextConnectionId ourEndPoint
496− writeChan ourChan (ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint))
497− return . Right $ Connection { send = selfSend connAlive connId
498− , close = selfClose connAlive connId
499− }
500− where
501− ourChan :: Chan Event
502− ourChan = localChannel ourEndPoint
503−
504− selfSend :: MVar Bool -> ConnectionId -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
505− selfSend connAlive connId msg = do
506− modifyMVar connAlive $ \alive ->
507− if alive
508− then do
509− writeChan ourChan (Received connId msg)
510− return (alive, Right ())
511− else
512− return (alive, Left (TransportError SendFailed "Connection closed"))
513−
514− selfClose :: MVar Bool -> ConnectionId -> IO ()
515− selfClose connAlive connId = do
516− modifyMVar_ connAlive $ \alive -> do
517− when alive $ writeChan ourChan (ConnectionClosed connId)
518− return False
519−
520−--------------------------------------------------------------------------------
521−-- Lower level functionality --
522−--------------------------------------------------------------------------------
523−
524−-- | Create a new local endpoint
525−--
526−-- May throw a TransportError NewEndPointErrorCode exception if the transport is closed.
527−createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
528−createLocalEndPoint transport = do
529− chan <- newChan
530− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
531− { _nextConnectionId = firstNonReservedConnectionId
532− , _pendingCtrlRequests = IntMap.empty
533− , _nextCtrlRequestId = 0
534− , _localConnections = Map.empty
535− , _internalThreads = []
536− }
537− modifyMVar (transportState transport) $ \st -> case st of
538− TransportValid vst -> do
539− let ix = fromIntegral $ Map.size (vst ^. localEndPoints)
540− let addr = encodeEndPointAddress (transportHost transport) (transportPort transport) ix
541− let localEndPoint = LocalEndPoint { localAddress = addr
542− , localChannel = chan
543− , localState = state
544− }
545− return (TransportValid . (localEndPointAt addr ^= Just localEndPoint) $ vst, localEndPoint)
546− TransportClosed ->
547− throw (TransportError NewEndPointFailed "Transport closed")
548−
549−-- | Request a connection to a remote endpoint
550−--
551−-- This will block until we get a connection ID from the remote endpoint; if
552−-- the remote endpoint was in 'RemoteEndPointClosing' state then we will
553−-- additionally block until that is resolved.
554−--
555−-- May throw a TransportError ConnectErrorCode exception.
556−requestConnectionTo :: LocalEndPoint
557− -> EndPointAddress
558− -> IO (RemoteEndPoint, ConnectionId)
559−requestConnectionTo ourEndPoint theirAddress = go
560− where
561− go = do
562− -- Find the remote endpoint (create it if it doesn't yet exist)
563− theirEndPoint <- findTheirEndPoint
564− let theirState = remoteState theirEndPoint
565−
566− -- Before we initiate the new connection request we want to make sure that
567− -- refcount on the endpoint is incremented so that a concurrent thread will
568− -- not close the connection. Note that if IF we return RemoteEndPointValid
569− -- here then we can rely on the endpoint remaining in that state.
570− endPointStateSnapshot <- modifyMVar theirState $ \st ->
571− case st of
572− RemoteEndPointValid ep ->
573− return (RemoteEndPointValid . (remoteOutgoing ^: (+ 1)) $ ep, st)
574− _ ->
575− return (st, st)
576−
577− -- From this point on we are guaranteed the refcount is positive, provided
578− -- that the endpoint was valid. We still need to deal with the case where
579− -- it was not valid, however, which we didn't want to do while holding the
580− -- endpoint lock.
581− --
582− -- Although 'endPointStateSnapshot' here refers to a snapshot of the
583− -- endpoint state, and might have changed in the meantime, these changes
584− -- won't matter.
585− case endPointStateSnapshot of
586− RemoteEndPointInvalid err -> do
587− throw err
588−
589− RemoteEndPointClosing resolved _ ->
590− -- If the remote endpoint is closing, then we need to block until
591− -- this is resolved and we then try again
592− readMVar resolved >> go
593−
594− RemoteEndPointClosed -> do
595− -- EndPointClosed indicates that a concurrent thread was in the
596− -- process of closing the TCP connection to the remote endpoint when
597− -- we obtained a reference to it. The remote endpoint will now have
598− -- been removed from ourState, so we simply try again.
599− go
600−
601− RemoteEndPointValid _ -> do
602− -- On a failure we decrement the refcount again and return an error.
603− -- The only state the remote endpoint can be in at this point is
604− -- valid. As mentioned above, we can rely on the endpoint being in
605− -- valid state at this point.
606− let failureHandler :: IOException -> IO b
607− failureHandler err = do
608− modifyMVar_ theirState $ \(RemoteEndPointValid ep) ->
609− return (RemoteEndPointValid . (remoteOutgoing ^: (\x -> x - 1)) $ ep)
610− -- TODO: should we call closeIfUnused here?
611− throw $ TransportError ConnectFailed (show err)
612−
613− -- Do the actual connection request. This blocks until the remote
614− -- endpoint replies (but note that we don't hold any locks at this
615− -- point)
616− reply <- handle failureHandler $ doRemoteRequest (ourEndPoint, theirEndPoint) RequestConnectionId
617− case decodeInt32 . BS.concat $ reply of
618− Nothing -> failureHandler (userError "Invalid integer")
619− Just cid -> return (theirEndPoint, cid)
620−
621− -- If this is a new endpoint, fork a thread to listen for incoming
622− -- connections. We don't want to do this while we hold the lock, because
623− -- forkEndPointThread modifies the local state too (to record the thread
624− -- ID)
625− findTheirEndPoint :: IO RemoteEndPoint
626− findTheirEndPoint = do
627− (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of
628− LocalEndPointClosed ->
629− throw (TransportError ConnectFailed "Local endpoint closed")
630− LocalEndPointValid vst ->
631− case vst ^. localConnectionTo theirAddress of
632− Just theirEndPoint ->
633− return (st, (theirEndPoint, False))
634− Nothing -> do
635− theirState <- newEmptyMVar
636− let theirEndPoint = RemoteEndPoint { remoteAddress = theirAddress
637− , remoteState = theirState
638− }
639− return (LocalEndPointValid . (localConnectionTo theirAddress ^= Just theirEndPoint) $ vst, (theirEndPoint, True))
640−
641− -- The only way for forkEndPointThread to fail is if the local endpoint
642− -- gets closed. This error will be caught elsewhere, so we ignore it
643− -- here.
644− when isNew . void . forkEndPointThread ourEndPoint $
645− setupRemoteEndPoint (ourEndPoint, theirEndPoint)
646− return theirEndPoint
647−
648− ourState :: MVar LocalEndPointState
649− ourState = localState ourEndPoint
650−
651−-- | Set up a remote endpoint
652−--
653−-- RELY: The state of the remote endpoint must be uninitialized.
654−-- GUARANTEE: Will only change the state to RemoteEndPointValid or
655−-- RemoteEndPointInvalid.
656−setupRemoteEndPoint :: EndPointPair -> IO ()
657−setupRemoteEndPoint (ourEndPoint, theirEndPoint) = do
658− result <- socketToEndPoint (localAddress ourEndPoint) (remoteAddress theirEndPoint)
659− case result of
660− Right (sock, ConnectionRequestAccepted) -> do
661− let vst = ValidRemoteEndPointState
662− { remoteSocket = sock
663− , _remoteOutgoing = 0
664− , _remoteIncoming = IntSet.empty
665− , sendOn = sendMany sock
666− }
667− putMVar theirState (RemoteEndPointValid vst)
668− handleIncomingMessages (ourEndPoint, theirEndPoint)
669− Right (sock, ConnectionRequestEndPointInvalid) -> do
670− -- We remove the endpoint from our local state again because the next
671− -- call to 'connect' might give a different result. Threads that were
672− -- waiting on the result of this call to connect will get the
673− -- RemoteEndPointInvalid; subsequent threads will initiate a new
674− -- connection requests.
675− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
676− putMVar theirState (RemoteEndPointInvalid (invalidAddress "Invalid endpoint"))
677− N.sClose sock
678− Right (sock, ConnectionRequestCrossed) -> do
679− N.sClose sock
680− Left err -> do
681− -- See comment above
682− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
683− putMVar theirState (RemoteEndPointInvalid err)
684− where
685− theirState = remoteState theirEndPoint
686− invalidAddress = TransportError ConnectNotFound
687−
688−-- | Establish a connection to a remote endpoint
689−socketToEndPoint :: EndPointAddress -- ^ Our address
690− -> EndPointAddress -- ^ Their address
691− -> IO (Either (TransportError ConnectErrorCode) (N.Socket, ConnectionRequestResponse))
692−socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do
693− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
694− Nothing -> throw (failed . userError $ "Could not parse")
695− Just dec -> return dec
696− addr:_ <- mapExceptionIO invalidAddress $ N.getAddrInfo Nothing (Just host) (Just port)
697− bracketOnError (createSocket addr) N.sClose $ \sock -> do
698− mapExceptionIO failed $ N.setSocketOption sock N.ReuseAddr 1
699− mapExceptionIO invalidAddress $ N.connect sock (N.addrAddress addr)
700− response <- mapExceptionIO failed $ do
701− sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
702− recvInt32 sock
703− case tryToEnum response of
704− Nothing -> throw (failed . userError $ "Unexpected response")
705− Just r -> return (sock, r)
706− where
707− createSocket :: N.AddrInfo -> IO N.Socket
708− createSocket addr = mapExceptionIO insufficientResources $ do
709− sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
710− -- putStrLn $ "Created client socket " ++ show sock
711− return sock
712−
713− invalidAddress, insufficientResources, failed :: IOException -> TransportError ConnectErrorCode
714− invalidAddress = TransportError ConnectNotFound . show
715− insufficientResources = TransportError ConnectInsufficientResources . show
716− failed = TransportError ConnectFailed . show
717−
718−-- | Remove reference to a remote endpoint from a local endpoint
719−--
720−-- If the local endpoint is closed, do nothing
721−removeRemoteEndPoint :: EndPointPair -> IO ()
722−removeRemoteEndPoint (ourEndPoint, theirEndPoint) = do
723− modifyMVar_ (localState ourEndPoint) $ \st -> case st of
724− LocalEndPointValid vst ->
725− return (LocalEndPointValid . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing) $ vst)
726− LocalEndPointClosed ->
727− return LocalEndPointClosed
728−
729−-- | Remove reference to a local endpoint from the transport state
730−--
731−-- Does nothing if the transport is closed
732−removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
733−removeLocalEndPoint transport ourEndPoint = do
734− modifyMVar_ (transportState transport) $ \st -> case st of
735− TransportValid vst ->
736− return (TransportValid . (localEndPointAt (localAddress ourEndPoint) ^= Nothing) $ vst)
737− TransportClosed ->
738− return TransportClosed
739−
740−-- | Encode end point address
741−encodeEndPointAddress :: N.HostName -> N.ServiceName -> EndPointId -> EndPointAddress
742−encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
743− host ++ ":" ++ port ++ ":" ++ show ix
744−
745−-- | Decode end point address
746−decodeEndPointAddress :: EndPointAddress -> Maybe (N.HostName, N.ServiceName, EndPointId)
747−decodeEndPointAddress (EndPointAddress bs) = case map BSC.unpack $ BSC.split ':' bs of
748− [host, port, endPointIdStr] ->
749− case reads endPointIdStr of
750− [(endPointId, "")] -> Just (host, port, endPointId)
751− _ -> Nothing
752− _ ->
753− Nothing
754−
755−-- | Do a (blocking) remote request
756−--
757−-- RELY: Remote endpoint must be in valid state.
758−-- GUARANTEE: Will not change the state of the remote endpoint.
759−--
760−-- May throw IO (user) exception if the local endpoint is closed or if the send
761−-- fails.
762−doRemoteRequest :: EndPointPair -> ControlHeader -> IO [ByteString]
763−doRemoteRequest (ourEndPoint, theirEndPoint) header = do
764− reply <- newEmptyMVar
765− reqId <- modifyMVar (localState ourEndPoint) $ \st -> case st of
766− LocalEndPointValid vst -> do
767− let reqId = vst ^. nextCtrlRequestId
768− return (LocalEndPointValid . (nextCtrlRequestId ^: (+ 1)) . (pendingCtrlRequestsAt reqId ^= Just reply) $ vst, reqId)
769− LocalEndPointClosed ->
770− throw (userError "Local endpoint closed")
771− withMVar (remoteState theirEndPoint) $ \(RemoteEndPointValid vst) ->
772− sendOn vst [encodeInt32 header, encodeInt32 reqId]
773− takeMVar reply
774−
775−-- | Check if the remote endpoint is unused, and if so, send a CloseSocket request
776−closeIfUnused :: RemoteEndPoint -> IO ()
777−closeIfUnused theirEndPoint = modifyMVar_ (remoteState theirEndPoint) $ \st ->
778− case st of
779− RemoteEndPointValid vst -> do
780− if vst ^. remoteOutgoing == 0 && IntSet.null (vst ^. remoteIncoming)
781− then do
782− resolved <- newEmptyMVar
783− sendOn vst [encodeInt32 CloseSocket]
784− return (RemoteEndPointClosing resolved vst)
785− else
786− return st
787− _ -> do
788− return st
789−
790−-- | Fork a new thread and store its ID as part of the transport state
791−--
792−-- If the local end point is closed this function does nothing (no thread is
793−-- spawned). Returns whether or not a thread was spawned.
794−forkEndPointThread :: LocalEndPoint -> IO () -> IO Bool
795−forkEndPointThread ourEndPoint p =
796− modifyMVar ourState $ \st -> case st of
797− LocalEndPointValid vst -> do
798− tid <- forkIO (p >> removeThread)
799− return (LocalEndPointValid . (internalThreads ^: (tid :)) $ vst, True)
800− LocalEndPointClosed ->
801− return (LocalEndPointClosed, False)
802− where
803− removeThread :: IO ()
804− removeThread = do
805− tid <- myThreadId
806− modifyMVar_ ourState $ \st -> case st of
807− LocalEndPointValid vst ->
808− return (LocalEndPointValid . (internalThreads ^: filter (/= tid)) $ vst)
809− LocalEndPointClosed ->
810− return LocalEndPointClosed
811−
812− ourState :: MVar LocalEndPointState
813− ourState = localState ourEndPoint
814−
815−--------------------------------------------------------------------------------
816−-- Incoming requests --
817−--------------------------------------------------------------------------------
818−
819−-- | Handle a connection request (that is, a remote endpoint that is trying to
820−-- establish a TCP connection with us)
821−--
822−-- 'handleConnectionRequest' runs in the context of the transport thread, which
823−-- can be killed asynchronously by 'closeTransport'. We fork a separate thread
824−-- as soon as we have located the lcoal endpoint that the remote endpoint is
825−-- interested in. We cannot fork any sooner because then we have no way of
826−-- storing the thread ID and hence no way of killing the thread when we take
827−-- the transport down. We must be careful to close the socket when a (possibly
828−-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
829−-- handleConnectionRequest the transport will be shut down.)
830−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
831−handleConnectionRequest transport sock = handle tryCloseSocket $ do
832− ourEndPointId <- recvInt32 sock
833− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
834− let ourAddress = encodeEndPointAddress (transportHost transport) (transportPort transport) ourEndPointId
835− ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
836− TransportValid vst ->
837− case vst ^. localEndPointAt ourAddress of
838− Nothing -> do
839− sendMany sock [encodeInt32 ConnectionRequestEndPointInvalid]
840− fail "Invalid endpoint"
841− Just ourEndPoint ->
842− return ourEndPoint
843− TransportClosed -> do
844− fail "Transport closed"
845− void . forkEndPointThread ourEndPoint $ go ourEndPoint theirAddress
846− where
847− go :: LocalEndPoint -> EndPointAddress -> IO ()
848− go ourEndPoint theirAddress = do
849− mEndPoint <- handle (\e -> invalidEndPoint e >> return Nothing) $ do
850− (crossed, theirEndPoint) <- modifyMVar (localState ourEndPoint) $ \st -> case st of
851− LocalEndPointValid vst ->
852− case vst ^. localConnectionTo theirAddress of
853− Nothing -> do
854− theirState <- newEmptyMVar
855− let theirEndPoint = RemoteEndPoint { remoteAddress = theirAddress
856− , remoteState = theirState
857− }
858− return (LocalEndPointValid . (localConnectionTo theirAddress ^= Just theirEndPoint) $ vst, (False, theirEndPoint))
859− Just theirEndPoint ->
860− return (st, (localAddress ourEndPoint < theirAddress, theirEndPoint))
861− LocalEndPointClosed ->
862− fail "Local endpoint closed"
863− if crossed
864− then do
865− tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
866− tryIO $ N.sClose sock
867− return Nothing
868− else do
869− let vst = ValidRemoteEndPointState
870− { remoteSocket = sock
871− , _remoteOutgoing = 0
872− , _remoteIncoming = IntSet.empty
873− , sendOn = sendMany sock
874− }
875− sendMany sock [encodeInt32 ConnectionRequestAccepted]
876− -- TODO: this putMVar might block if the remote endpoint sends a
877− -- connection request for a local endpoint that it is already
878− -- connected to
879− putMVar (remoteState theirEndPoint) (RemoteEndPointValid vst)
880− return (Just theirEndPoint)
881− -- If we left the scope of the exception handler with a return value of
882− -- Nothing then the socket is already closed; otherwise, the socket has
883− -- been recorded as part of the remote endpoint. Either way, we no longer
884− -- have to worry about closing the socket on receiving an asynchronous
885− -- exception from this point forward.
886− case mEndPoint of
887− Nothing ->
888− return ()
889− Just theirEndPoint ->
890− handleIncomingMessages (ourEndPoint, theirEndPoint)
891−
892− tryCloseSocket :: IOException -> IO ()
893− tryCloseSocket _ = void . tryIO $ N.sClose sock
894−
895− invalidEndPoint :: IOException -> IO ()
896− invalidEndPoint ex = do
897− tryIO $ sendMany sock [encodeInt32 ConnectionRequestEndPointInvalid]
898− tryCloseSocket ex
899−
900−-- | Handle requests from a remote endpoint.
901−--
902−-- Returns only if the remote party closes the socket or if an error occurs.
903−--
904−-- RELY: The remote endpoint must be in RemoteEndPointValid or
905−-- RemoteEndPointClosing state. If the latter, then the 'resolved' MVar
906−-- associated with the closing state must be empty.
907−-- GUARANTEE: May change the remote endpoint to RemoteEndPointClosed state.
908−handleIncomingMessages :: EndPointPair -> IO ()
909−handleIncomingMessages (ourEndPoint, theirEndPoint) = do
910− -- For efficiency sake we get the socket once and for all
911− sock <- withMVar theirState $ \st ->
912− case st of
913− RemoteEndPointValid ep ->
914− return (remoteSocket ep)
915− RemoteEndPointClosing _ ep ->
916− return (remoteSocket ep)
917− _ ->
918− error "handleIncomingMessages RELY violation"
919−
920− mCleanExit <- tryIO $ go sock
921− case mCleanExit of
922− Right () -> return ()
923− Left err -> prematureExit sock err
924− where
925− -- Dispatch
926− go :: N.Socket -> IO ()
927− go sock = do
928− connId <- recvInt32 sock
929− if connId >= firstNonReservedConnectionId
930− then do
931− readMessage sock connId
932− go sock
933− else do
934− case tryToEnum (fromIntegral connId) of
935− Just RequestConnectionId -> do
936− recvInt32 sock >>= createNewConnection
937− go sock
938− Just ControlResponse -> do
939− recvInt32 sock >>= readControlResponse sock
940− go sock
941− Just CloseConnection -> do
942− recvInt32 sock >>= closeConnection
943− go sock
944− Just CloseSocket -> do
945− didClose <- closeSocket sock
946− unless didClose $ go sock
947− Nothing ->
948− -- Invalid control request, exit
949− hPutStrLn stderr "Warning: invalid control request"
950−
951− -- Create a new connection
952− createNewConnection :: ControlRequestId -> IO ()
953− createNewConnection reqId = do
954− newId <- getNextConnectionId ourEndPoint
955− modifyMVar_ theirState $ \st -> do
956− vst <- case st of
957− RemoteEndPointValid vst ->
958− return (remoteIncoming ^: IntSet.insert newId $ vst)
959− RemoteEndPointClosing resolved vst -> do
960− -- If the endpoint is in closing state that means we send a
961− -- CloseSocket request to the remote endpoint. If the remote
962− -- endpoint replies with the request to create a new connection, it
963− -- either ignored our request or it sent the request before it got
964− -- ours. Either way, at this point we simply restore the endpoint
965− -- to RemoteEndPointValid
966− putMVar resolved ()
967− return (remoteIncoming ^= IntSet.singleton newId $ vst)
968− _ ->
969− error "handleIncomingMessages RELY violation"
970− sendOn vst ( encodeInt32 ControlResponse
971− : encodeInt32 reqId
972− : prependLength [encodeInt32 newId]
973− )
974− -- We add the new connection ID to the list of open connections only once the
975− -- endpoint has been notified of the new connection (sendOn may fail)
976− return (RemoteEndPointValid vst)
977− writeChan ourChannel (ConnectionOpened newId ReliableOrdered theirAddr)
978−
979− -- Read a control response
980− readControlResponse :: N.Socket -> ControlRequestId -> IO ()
981− readControlResponse sock reqId = do
982− response <- recvWithLength sock
983− mmvar <- modifyMVar ourState $ \st -> case st of
984− LocalEndPointValid vst ->
985− return (LocalEndPointValid . (pendingCtrlRequestsAt reqId ^= Nothing) $ vst, vst ^. pendingCtrlRequestsAt reqId)
986− LocalEndPointClosed ->
987− fail "Local endpoint closed"
988− case mmvar of
989− Nothing -> do
990− hPutStrLn stderr $ "Warning: Invalid request ID"
991− return () -- Invalid request ID. TODO: We just ignore it?
992− Just mvar ->
993− putMVar mvar response
994−
995− -- Close a connection
996− closeConnection :: ConnectionId -> IO ()
997− closeConnection cid = do
998− -- TODO: we should check that this connection is in fact open
999− writeChan ourChannel (ConnectionClosed cid)
1000− modifyMVar_ theirState $ \(RemoteEndPointValid vst) ->
1001− return (RemoteEndPointValid . (remoteIncoming ^: IntSet.delete cid) $ vst)
1002− closeIfUnused theirEndPoint
1003−
1004− -- Close the socket (if we don't have any outgoing connections)
1005− closeSocket :: N.Socket -> IO Bool
1006− closeSocket sock = do
1007− -- We need to check if we can close the socket (that is, if we don't have
1008− -- any outgoing connections), and once we are sure that we can put the
1009− -- endpoint in Closed state. However, by INV-CLOSE we can only put the
1010− -- endpoint in Closed state once we remove the endpoint from our local
1011− -- connections. But we can do that only once we are sure that we can
1012− -- close the endpoint. Catch-22. We can resolve the catch-22 by locking
1013− -- /both/ our local state and the endpoint state, but at the cost of
1014− -- introducing a double lock and all the associated perils, or by putting
1015− -- the remote endpoint in Closing state first. We opt for the latter.
1016− canClose <- modifyMVar theirState $ \st ->
1017− case st of
1018− RemoteEndPointValid vst -> do
1019− -- We regard a CloseSocket message as an (optimized) way for the
1020− -- remote endpoint to indicate that all its connections to us are
1021− -- now properly closed
1022− forM_ (IntSet.elems $ vst ^. remoteIncoming) $ \cid ->
1023− writeChan ourChannel (ConnectionClosed cid)
1024− let vst' = remoteIncoming ^= IntSet.empty $ vst
1025− -- Check if we agree that the connection should be closed
1026− if vst' ^. remoteOutgoing == 0
1027− then do
1028− -- Attempt to reply (but don't insist)
1029− tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1030− resolved <- newEmptyMVar
1031− return (RemoteEndPointClosing resolved vst', Just resolved)
1032− else
1033− return (RemoteEndPointValid vst', Nothing)
1034− RemoteEndPointClosing resolved _ ->
1035− return (st, Just resolved)
1036− _ ->
1037− error "handleIncomingConnections RELY violation"
1038−
1039− case canClose of
1040− Nothing ->
1041− return False
1042− Just resolved -> do
1043− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1044− modifyMVar_ theirState $ return . const RemoteEndPointClosed
1045− N.sClose sock
1046− putMVar resolved ()
1047− return True
1048−
1049− -- Read a message and output it on the endPoint's channel
1050− readMessage :: N.Socket -> ConnectionId -> IO ()
1051− readMessage sock connId = recvWithLength sock >>= writeChan ourChannel . Received connId
1052−
1053− -- Arguments
1054− ourChannel = localChannel ourEndPoint
1055− ourState = localState ourEndPoint
1056− theirState = remoteState theirEndPoint
1057− theirAddr = remoteAddress theirEndPoint
1058−
1059− -- Deal with a premature exit
1060− prematureExit :: N.Socket -> IOException -> IO ()
1061− prematureExit sock err = do
1062− N.sClose sock
1063− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1064− mUnclosedConnections <- modifyMVar theirState $ \st ->
1065− case st of
1066− RemoteEndPointInvalid _ ->
1067− error "handleIncomingMessages RELY violation"
1068− RemoteEndPointValid vst ->
1069− return (RemoteEndPointClosed, Just $ vst ^. remoteIncoming)
1070− RemoteEndPointClosing _ _ ->
1071− return (RemoteEndPointClosed, Nothing)
1072− RemoteEndPointClosed ->
1073− return (st, Nothing)
1074−
1075− -- We send the connection lost message even if unclosedConnections is the
1076− -- empty set, because *outgoing* connections will be broken too now
1077− case mUnclosedConnections of
1078− Nothing ->
1079− return ()
1080− Just unclosedConnections -> writeChan ourChannel . ErrorEvent $
1081− TransportError (EventConnectionLost (remoteAddress theirEndPoint) (IntSet.elems unclosedConnections)) (show err)
1082−
1083−-- | Get the next connection ID
1084−--
1085−-- Throws an IO exception when the endpoint is closed.
1086−getNextConnectionId :: LocalEndPoint -> IO ConnectionId
1087−getNextConnectionId ourEndpoint =
1088− modifyMVar (localState ourEndpoint) $ \st -> case st of
1089− LocalEndPointValid vst -> do
1090− let connId = vst ^. nextConnectionId
1091− return (LocalEndPointValid . (nextConnectionId ^= connId + 1) $ vst, connId)
1092− LocalEndPointClosed ->
1093− fail "Local endpoint closed"
1094−
1095−--------------------------------------------------------------------------------
1096−-- Constants --
1097−--------------------------------------------------------------------------------
1098−
1099−-- | We reserve a bunch of connection IDs for control messages
1100−firstNonReservedConnectionId :: ConnectionId
1101−firstNonReservedConnectionId = 1024
1102−
1103−--------------------------------------------------------------------------------
1104−-- Accessor definitions --
1105−--------------------------------------------------------------------------------
1106−
1107−localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
1108−localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es })
1109−
1110−pendingCtrlRequests :: Accessor ValidLocalEndPointState (IntMap (MVar [ByteString]))
1111−pendingCtrlRequests = accessor _pendingCtrlRequests (\rep st -> st { _pendingCtrlRequests = rep })
1112−
1113−nextCtrlRequestId :: Accessor ValidLocalEndPointState ControlRequestId
1114−nextCtrlRequestId = accessor _nextCtrlRequestId (\cid st -> st { _nextCtrlRequestId = cid })
1115−
1116−nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
1117−nextConnectionId = accessor _nextConnectionId (\cix st -> st { _nextConnectionId = cix })
1118−
1119−localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
1120−localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
1121−
1122−internalThreads :: Accessor ValidLocalEndPointState [ThreadId]
1123−internalThreads = accessor _internalThreads (\ts st -> st { _internalThreads = ts })
1124−
1125−localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1126−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1127−
1128−pendingCtrlRequestsAt :: ControlRequestId -> Accessor ValidLocalEndPointState (Maybe (MVar [ByteString]))
1129−pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral ix)
1130−
1131−localConnectionTo :: EndPointAddress -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1132−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1133−
1134−remoteOutgoing :: Accessor ValidRemoteEndPointState Int
1135−remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs })
1136−
1137−remoteIncoming :: Accessor ValidRemoteEndPointState IntSet
1138−remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs })
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/TestAuxiliary.hsdeleted−82
@@ -1,82 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module TestAuxiliary ( -- Running tests
3− runTest
4− , runTests
5− -- Writing tests
6− , forkTry
7− ) where
8−
9−import Prelude hiding (catch)
10−import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo)
11−import Control.Monad (liftM2, unless)
12−import Control.Exception (SomeException, try, catch)
13−import System.Timeout (timeout)
14−import System.IO (stdout, hFlush)
15−import System.Console.ANSI ( SGR(SetColor, Reset)
16− , Color(Red, Green)
17− , ConsoleLayer(Foreground)
18− , ColorIntensity(Vivid)
19− , setSGR
20− )
21−import Network.Transport
22−import Traced (Traceable(..), traceShow)
23−
24−-- | Like fork, but throw exceptions in the child thread to the parent
25−forkTry :: IO () -> IO ThreadId
26−forkTry p = do
27− tid <- myThreadId
28− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
29−
30−-- | Run the given test, catching timeouts and exceptions
31−runTest :: String -> IO () -> IO Bool
32−runTest description test = do
33− putStr $ "Running " ++ show description ++ ": "
34− hFlush stdout
35− done <- try . timeout 20000000 $ test
36− case done of
37− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
38− Right Nothing -> failed $ "(timeout)"
39− Right (Just ()) -> ok
40− where
41− failed :: String -> IO Bool
42− failed err = do
43− setSGR [SetColor Foreground Vivid Red]
44− putStr "failed "
45− setSGR [Reset]
46− putStrLn err
47− return False
48−
49− ok :: IO Bool
50− ok = do
51− setSGR [SetColor Foreground Vivid Green]
52− putStrLn "ok"
53− setSGR [Reset]
54− return True
55−
56−-- | Run a bunch of tests and throw an exception if any fails
57−runTests :: [(String, IO ())] -> IO ()
58−runTests tests = do
59− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
60− unless success $ fail "Some tests failed"
61−
62−--------------------------------------------------------------------------------
63−-- traceShow instances --
64−--------------------------------------------------------------------------------
65−
66−instance Traceable EndPoint where
67− trace = const Nothing
68−
69−instance Traceable Transport where
70− trace = const Nothing
71−
72−instance Traceable Connection where
73− trace = const Nothing
74−
75−instance Traceable Event where
76− trace = traceShow
77−
78−instance Show err => Traceable (TransportError err) where
79− trace = traceShow
80−
81−instance Traceable EndPointAddress where
82− trace = traceShow . endPointAddressToByteString
network-transport/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/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/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/tests/TestTCP.hsdeleted−487
@@ -1,487 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Main where
4−
5−import Prelude hiding (catch, (>>=), (>>), return, fail)
6−import TestTransport (testTransport)
7−import TestAuxiliary (forkTry, runTests)
8−import Network.Transport
9−import Network.Transport.TCP (createTransport, encodeEndPointAddress)
10−import Data.Int (Int32)
11−import Control.Concurrent (threadDelay)
12−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar, isEmptyMVar)
13−import Control.Monad (replicateM, guard, forM_)
14−import Control.Applicative ((<$>))
15−import Control.Exception (throw)
16−import Network.Transport.TCP ( ControlHeader(..)
17− , ConnectionRequestResponse(..)
18− , socketToEndPoint
19− )
20−import Network.Transport.Internal (encodeInt32, prependLength, tlog, tryIO)
21−import Network.Transport.Internal.TCP (recvInt32, forkServer, recvWithLength)
22−import qualified Network.Socket as N ( sClose
23− , ServiceName
24− , Socket
25− , AddrInfo
26− )
27−import Network.Socket.ByteString (sendMany)
28−import Data.String (fromString)
29−import Traced
30−
31−instance Traceable ControlHeader where
32− trace = traceShow
33−
34−instance Traceable ConnectionRequestResponse where
35− trace = traceShow
36−
37−instance Traceable N.Socket where
38− trace = const Nothing
39−
40−instance Traceable N.AddrInfo where
41− trace = traceShow
42−
43−
44−-- Test that the server gets a ConnectionClosed message when the client closes
45−-- the socket without sending an explicit control message to the server first
46−testEarlyDisconnect :: IO N.ServiceName -> IO ()
47−testEarlyDisconnect nextPort = do
48− clientAddr <- newEmptyMVar
49− serverAddr <- newEmptyMVar
50− serverDone <- newEmptyMVar
51−
52− tlog "testEarlyDisconnect"
53− forkTry $ server serverAddr clientAddr serverDone
54− forkTry $ client serverAddr clientAddr
55−
56− takeMVar serverDone
57− where
58− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
59− server serverAddr clientAddr serverDone = do
60− tlog "Server"
61− Right transport <- nextPort >>= createTransport "127.0.0.1"
62− Right endpoint <- newEndPoint transport
63− putMVar serverAddr (address endpoint)
64− theirAddr <- readMVar clientAddr
65−
66− -- TEST 1: they connect to us, then drop the connection
67− do
68− ConnectionOpened cid _ addr <- receive endpoint
69− True <- return $ addr == theirAddr
70−
71− ErrorEvent (TransportError (EventConnectionLost addr' [cid']) _) <- receive endpoint
72− True <- return $ addr' == theirAddr && cid' == cid
73−
74− return ()
75−
76− -- TEST 2: after they dropped their connection to us, we now try to
77− -- establish a connection to them. This should re-establish the broken
78− -- TCP connection.
79− tlog "Trying to connect to client"
80− Right conn <- connect endpoint theirAddr ReliableOrdered
81−
82− -- TEST 3: To test the connection, we do a simple ping test; as before,
83− -- however, the remote client won't close the connection nicely but just
84− -- closes the socket
85− do
86− Right () <- send conn ["ping"]
87−
88− ConnectionOpened cid _ addr <- receive endpoint
89− True <- return $ addr == theirAddr
90−
91− Received cid' ["pong"] <- receive endpoint
92− True <- return $ cid == cid'
93−
94− ErrorEvent (TransportError (EventConnectionLost addr' [cid'']) _) <- receive endpoint
95− True <- return $ addr' == theirAddr && cid'' == cid
96−
97− return ()
98−
99− -- TEST 4: A subsequent send on an already-open connection will now break
100− Left (TransportError SendFailed _) <- send conn ["ping2"]
101−
102− -- *Pfew*
103− putMVar serverDone ()
104−
105− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
106− client serverAddr clientAddr = do
107− tlog "Client"
108− clientPort <- nextPort
109− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
110− putMVar clientAddr ourAddress
111−
112− -- Listen for incoming messages
113− forkServer "127.0.0.1" clientPort 5 throw $ \sock -> do
114− -- Initial setup
115− 0 <- recvInt32 sock :: IO Int
116− _ <- recvWithLength sock
117− sendMany sock [encodeInt32 ConnectionRequestAccepted]
118−
119− -- Server requests a logical connection
120− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
121− reqId <- recvInt32 sock :: IO Int
122− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
123−
124− -- Server sends a message
125− 10001 <- recvInt32 sock :: IO Int
126− ["ping"] <- recvWithLength sock
127−
128− -- Reply
129− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
130− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
131− 10002 <- recvInt32 sock :: IO Int
132− [cid] <- recvWithLength sock
133− sendMany sock (cid : prependLength ["pong"])
134−
135− -- Close the socket
136− N.sClose sock
137−
138− -- Connect to the server
139− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
140−
141− -- Request a new connection, but don't wait for the response
142− let reqId = 0 :: Int32
143− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
144−
145− -- Close the socket without closing the connection explicitly
146− -- The server should receive an error event
147− N.sClose sock
148−
149−-- | Test the behaviour of a premature CloseSocket request
150−testEarlyCloseSocket :: IO N.ServiceName -> IO ()
151−testEarlyCloseSocket nextPort = do
152− clientAddr <- newEmptyMVar
153− serverAddr <- newEmptyMVar
154− serverDone <- newEmptyMVar
155−
156− tlog "testEarlyDisconnect"
157− forkTry $ server serverAddr clientAddr serverDone
158− forkTry $ client serverAddr clientAddr
159−
160− takeMVar serverDone
161− where
162− server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
163− server serverAddr clientAddr serverDone = do
164− tlog "Server"
165− Right transport <- nextPort >>= createTransport "127.0.0.1"
166− Right endpoint <- newEndPoint transport
167− putMVar serverAddr (address endpoint)
168− theirAddr <- readMVar clientAddr
169−
170− -- TEST 1: they connect to us, then send a CloseSocket. Since we don't
171− -- have any outgoing connections, this means we will agree to close the
172− -- socket
173− do
174− ConnectionOpened cid _ addr <- receive endpoint
175− True <- return $ addr == theirAddr
176−
177− ConnectionClosed cid' <- receive endpoint
178− True <- return $ cid' == cid
179−
180− return ()
181−
182− -- TEST 2: after they dropped their connection to us, we now try to
183− -- establish a connection to them. This should re-establish the broken
184− -- TCP connection.
185− tlog "Trying to connect to client"
186− Right conn <- connect endpoint theirAddr ReliableOrdered
187−
188− -- TEST 3: To test the connection, we do a simple ping test; as before,
189− -- however, the remote client won't close the connection nicely but just
190− -- sends a CloseSocket -- except that now we *do* have outgoing
191− -- connections, so we won't agree and hence will receive an error when
192− -- the socket gets closed
193− do
194− Right () <- send conn ["ping"]
195−
196− ConnectionOpened cid _ addr <- receive endpoint
197− True <- return $ addr == theirAddr
198−
199− Received cid' ["pong"] <- receive endpoint
200− True <- return $ cid' == cid
201−
202− ConnectionClosed cid'' <- receive endpoint
203− True <- return $ cid'' == cid
204−
205− ErrorEvent (TransportError (EventConnectionLost addr' []) _) <- receive endpoint
206− True <- return $ addr' == theirAddr
207−
208− return ()
209−
210− -- TEST 4: A subsequent send on an already-open connection will now break
211− Left (TransportError SendFailed _) <- send conn ["ping2"]
212−
213− -- *Pfew*
214− putMVar serverDone ()
215−
216− client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
217− client serverAddr clientAddr = do
218− tlog "Client"
219− clientPort <- nextPort
220− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
221− putMVar clientAddr ourAddress
222−
223− -- Listen for incoming messages
224− forkServer "127.0.0.1" clientPort 5 throw $ \sock -> do
225− -- Initial setup
226− 0 <- recvInt32 sock :: IO Int
227− _ <- recvWithLength sock
228− sendMany sock [encodeInt32 ConnectionRequestAccepted]
229−
230− -- Server requests a logical connection
231− RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
232− reqId <- recvInt32 sock :: IO Int
233− sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
234−
235− -- Server sends a message
236− 10001 <- recvInt32 sock :: IO Int
237− ["ping"] <- recvWithLength sock
238−
239− -- Reply
240− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
241− ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
242− 10002 <- recvInt32 sock :: IO Int
243− [cid] <- recvWithLength sock
244− sendMany sock (cid : prependLength ["pong"])
245−
246− -- Send a CloseSocket even though there are still connections *in both
247− -- directions*
248− sendMany sock [encodeInt32 CloseSocket]
249− N.sClose sock
250−
251− -- Connect to the server
252− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
253−
254− -- Request a new connection, but don't wait for the response
255− let reqId = 0 :: Int32
256− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
257−
258− -- Send a CloseSocket without sending a closeconnecton
259− -- The server should still receive a ConnectionClosed message
260− sendMany sock [encodeInt32 CloseSocket]
261− N.sClose sock
262−
263−-- | Test the creation of a transport with an invalid address
264−testInvalidAddress :: IO N.ServiceName -> IO ()
265−testInvalidAddress nextPort = do
266− Left _ <- nextPort >>= createTransport "invalidHostName"
267− return ()
268−
269−-- | Test connecting to invalid or non-existing endpoints
270−testInvalidConnect :: IO N.ServiceName -> IO ()
271−testInvalidConnect nextPort = do
272− port <- nextPort
273− Right transport <- createTransport "127.0.0.1" port
274− Right endpoint <- newEndPoint transport
275−
276− -- Syntax error in the endpoint address
277− Left (TransportError ConnectFailed _) <-
278− connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered
279−
280− -- Syntax connect, but invalid hostname (TCP address lookup failure)
281− Left (TransportError ConnectNotFound _) <-
282− connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered
283−
284− -- TCP address correct, but nobody home at that address
285− Left (TransportError ConnectNotFound _) <-
286− connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered
287−
288− -- Valid TCP address but invalid endpoint number
289− Left (TransportError ConnectNotFound _) <-
290− connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered
291−
292− return ()
293−
294−-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
295−-- would happen when the endpoint sends a new connection request before
296−-- receiving an (already underway) CloseSocket request)
297−testIgnoreCloseSocket :: IO N.ServiceName -> IO ()
298−testIgnoreCloseSocket nextPort = do
299− serverAddr <- newEmptyMVar
300− clientDone <- newEmptyMVar
301− Right transport <- nextPort >>= createTransport "127.0.0.1"
302−
303− forkTry $ server transport serverAddr
304− forkTry $ client transport serverAddr clientDone
305−
306− takeMVar clientDone
307−
308− where
309− server :: Transport -> MVar EndPointAddress -> IO ()
310− server transport serverAddr = do
311− tlog "Server"
312− Right endpoint <- newEndPoint transport
313− putMVar serverAddr (address endpoint)
314−
315− -- Wait for the client to connect and disconnect
316− tlog "Waiting for ConnectionOpened"
317− ConnectionOpened _ _ _ <- receive endpoint
318− tlog "Waiting for ConnectionClosed"
319− ConnectionClosed _ <- receive endpoint
320−
321− -- At this point the server will have sent a CloseSocket request to the
322− -- client, which however ignores it, instead it requests and closes
323− -- another connection
324− tlog "Waiting for ConnectionOpened"
325− ConnectionOpened _ _ _ <- receive endpoint
326− tlog "Waiting for ConnectionClosed"
327− ConnectionClosed _ <- receive endpoint
328−
329−
330− tlog "Server waiting.."
331−
332− client :: Transport -> MVar EndPointAddress -> MVar () -> IO ()
333− client transport serverAddr clientDone = do
334− tlog "Client"
335− Right endpoint <- newEndPoint transport
336− let ourAddress = address endpoint
337−
338− -- Connect to the server
339− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
340−
341− -- Request a new connection
342− tlog "Requesting connection"
343− let reqId = 0 :: Int32
344− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
345− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
346−
347− -- Close the connection again
348− tlog "Closing connection"
349− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
350−
351− -- Server will now send a CloseSocket request as its refcount reached 0
352− tlog "Waiting for CloseSocket request"
353− CloseSocket <- toEnum <$> recvInt32 sock
354−
355− -- But we ignore it and request another connection
356− tlog "Ignoring it, requesting another connection"
357− let reqId' = 1 :: Int32
358− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
359− response' <- replicateM 4 $ recvInt32 sock :: IO [Int32]
360−
361− -- Close it again
362− tlog "Closing connection"
363− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response' !! 3)]
364−
365− -- We now get a CloseSocket again, and this time we heed it
366− tlog "Waiting for second CloseSocket request"
367− CloseSocket <- toEnum <$> recvInt32 sock
368−
369− tlog "Closing socket"
370− sendMany sock [encodeInt32 CloseSocket]
371− N.sClose sock
372−
373− putMVar clientDone ()
374−
375−-- | Like 'testIgnoreSocket', but now the server requests a connection after the
376−-- client closed their connection. In the meantime, the server will have sent a
377−-- CloseSocket request to the client, and must block until the client responds.
378−testBlockAfterCloseSocket :: IO N.ServiceName -> IO ()
379−testBlockAfterCloseSocket nextPort = do
380− serverAddr <- newEmptyMVar
381− clientAddr <- newEmptyMVar
382− clientDone <- newEmptyMVar
383− port <- nextPort
384− Right transport <- createTransport "127.0.0.1" port
385−
386− forkTry $ server transport serverAddr clientAddr
387− forkTry $ client transport serverAddr clientAddr clientDone
388−
389− takeMVar clientDone
390−
391− where
392− server :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> IO ()
393− server transport serverAddr clientAddr = do
394− tlog "Server"
395− Right endpoint <- newEndPoint transport
396− putMVar serverAddr (address endpoint)
397−
398− -- Wait for the client to connect and disconnect
399− tlog "Waiting for ConnectionOpened"
400− ConnectionOpened _ _ _ <- receive endpoint
401− tlog "Waiting for ConnectionClosed"
402− ConnectionClosed _ <- receive endpoint
403−
404− -- At this point the server will have sent a CloseSocket request to the
405− -- client, and must block until the client responds
406− tlog "Server waiting to connect to the client.."
407− Right _ <- readMVar clientAddr >>= \addr -> connect endpoint addr ReliableOrdered
408−
409− tlog "Server waiting.."
410−
411− client :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
412− client transport serverAddr clientAddr clientDone = do
413− tlog "Client"
414− Right endpoint <- newEndPoint transport
415− putMVar clientAddr (address endpoint)
416− let ourAddress = address endpoint
417−
418− -- Connect to the server
419− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
420−
421− -- Request a new connection
422− tlog "Requesting connection"
423− let reqId = 0 :: Int32
424− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
425− response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
426−
427− -- Close the connection again
428− tlog "Closing connection"
429− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
430−
431− -- Server will now send a CloseSocket request as its refcount reached 0
432− tlog "Waiting for CloseSocket request"
433− CloseSocket <- toEnum <$> recvInt32 sock
434−
435− unblocked <- newEmptyMVar
436−
437− -- We should not hear from the server until we unblock him by
438− -- responding to the CloseSocket request (in this case, we
439− -- respond by sending a ConnectionRequest)
440− forkTry $ do
441− recvInt32 sock :: IO Int32
442− isEmptyMVar unblocked >>= (guard . not)
443− putMVar clientDone ()
444−
445− threadDelay 1000000
446−
447− tlog "Client ignores close socket and sends connection request"
448− tlog "This should unblock the server"
449− putMVar unblocked ()
450− let reqId' = 1 :: Int32
451− sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
452−
453−-- | Test what happens when a remote endpoint sends a connection request to our
454−-- transport for an endpoint it already has a connection to
455−testUnnecessaryConnect :: IO N.ServiceName -> IO ()
456−testUnnecessaryConnect nextPort = do
457− clientDone <- newEmptyMVar
458− serverAddr <- newEmptyMVar
459−
460− forkTry $ do
461− Right transport <- nextPort >>= createTransport "127.0.0.1"
462− Right endpoint <- newEndPoint transport
463− putMVar serverAddr (address endpoint)
464−
465− forkTry $ do
466− let ourAddress = EndPointAddress "ourAddress"
467− Right (_, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
468− Right (_, ConnectionRequestEndPointInvalid) <- readMVar serverAddr >>= socketToEndPoint ourAddress
469− putMVar clientDone ()
470−
471− takeMVar clientDone
472−
473−main :: IO ()
474−main = do
475− portMVar <- newEmptyMVar
476− forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
477− let nextPort = takeMVar portMVar
478− tryIO $ runTests
479− [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
480− , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
481− , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
482− , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)
483− , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort)
484− , ("InvalidAddress", testInvalidAddress nextPort)
485− , ("InvalidConnect", testInvalidConnect nextPort)
486− ]
487− testTransport (either (Left . show) (Right) <$> nextPort >>= createTransport "127.0.0.1")
network-transport/tests/TestTransport.hsdeleted−734
@@ -1,734 +0,0 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−module TestTransport where
3−
4−import Prelude hiding (catch, (>>=), (>>), return, fail)
5−import TestAuxiliary (forkTry, runTests)
6−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
7−import Control.Monad (replicateM, replicateM_, when, guard, forM_)
8−import Control.Monad.Error ()
9−import Network.Transport
10−import Network.Transport.Internal (tlog)
11−import Network.Transport.Util (spawn)
12−import Data.ByteString (ByteString)
13−import Data.ByteString.Char8 (pack)
14−import Data.Map (Map)
15−import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
16−import Data.String (fromString)
17−import Traced
18−
19−-- | Server that echoes messages straight back to the origin endpoint.
20−echoServer :: EndPoint -> IO ()
21−echoServer endpoint = do
22− go Map.empty
23− where
24− go :: Map ConnectionId Connection -> IO ()
25− go cs = do
26− event <- receive endpoint
27− case event of
28− ConnectionOpened cid rel addr -> do
29− tlog $ "Opened new conncetion " ++ show cid
30− Right conn <- connect endpoint addr rel
31− go (Map.insert cid conn cs)
32− Received cid payload -> do
33− send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
34− go cs
35− ConnectionClosed cid -> do
36− tlog $ "Close connection " ++ show cid
37− close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
38− go (Map.delete cid cs)
39− ReceivedMulticast _ _ ->
40− -- Ignore
41− go cs
42− ErrorEvent _ ->
43− fail (show event)
44− EndPointClosed ->
45− return ()
46−
47−-- | Ping client used in a few tests
48−ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
49−ping endpoint server numPings msg = do
50− -- Open connection to the server
51− tlog "Connect to echo server"
52− Right conn <- connect endpoint server ReliableOrdered
53−
54− -- Wait for the server to open reply connection
55− tlog "Wait for ConnectionOpened message"
56− ConnectionOpened cid _ _ <- receive endpoint
57−
58− -- Send pings and wait for reply
59− tlog "Send ping and wait for reply"
60− replicateM_ numPings $ do
61− send conn [msg]
62− Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg
63− return ()
64−
65− -- Close the connection
66− tlog "Close the connection"
67− close conn
68−
69− -- Wait for the server to close its connection to us
70− tlog "Wait for ConnectionClosed message"
71− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
72−
73− -- Done
74− tlog "Ping client done"
75−
76−-- | Basic ping test
77−testPingPong :: Transport -> Int -> IO ()
78−testPingPong transport numPings = do
79− tlog "Starting ping pong test"
80− server <- spawn transport echoServer
81− result <- newEmptyMVar
82−
83− -- Client
84− forkTry $ do
85− tlog "Ping client"
86− Right endpoint <- newEndPoint transport
87− ping endpoint server numPings "ping"
88− putMVar result ()
89−
90− takeMVar result
91−
92−-- | Test that endpoints don't get confused
93−testEndPoints :: Transport -> Int -> IO ()
94−testEndPoints transport numPings = do
95− server <- spawn transport echoServer
96− dones <- replicateM 2 newEmptyMVar
97−
98− forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
99− let name' :: ByteString
100− name' = pack [name]
101− Right endpoint <- newEndPoint transport
102− tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)
103− ping endpoint server numPings name'
104− putMVar done ()
105−
106− forM_ dones takeMVar
107−
108−-- Test that connections don't get confused
109−testConnections :: Transport -> Int -> IO ()
110−testConnections transport numPings = do
111− server <- spawn transport echoServer
112− result <- newEmptyMVar
113−
114− -- Client
115− forkTry $ do
116− Right endpoint <- newEndPoint transport
117−
118− -- Open two connections to the server
119− Right conn1 <- connect endpoint server ReliableOrdered
120− ConnectionOpened serv1 _ _ <- receive endpoint
121−
122− Right conn2 <- connect endpoint server ReliableOrdered
123− ConnectionOpened serv2 _ _ <- receive endpoint
124−
125− -- One thread to send "pingA" on the first connection
126− forkTry $ replicateM_ numPings $ send conn1 ["pingA"]
127−
128− -- One thread to send "pingB" on the second connection
129− forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
130−
131− -- Verify server responses
132− let verifyResponse 0 = putMVar result ()
133− verifyResponse n = do
134− event <- receive endpoint
135− case event of
136− Received cid [payload] -> do
137− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
138− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
139− verifyResponse (n - 1)
140− _ ->
141− verifyResponse n
142− verifyResponse (2 * numPings)
143−
144− takeMVar result
145−
146−-- | Test that closing one connection does not close the other
147−testCloseOneConnection :: Transport -> Int -> IO ()
148−testCloseOneConnection transport numPings = do
149− server <- spawn transport echoServer
150− result <- newEmptyMVar
151−
152− -- Client
153− forkTry $ do
154− Right endpoint <- newEndPoint transport
155−
156− -- Open two connections to the server
157− Right conn1 <- connect endpoint server ReliableOrdered
158− ConnectionOpened serv1 _ _ <- receive endpoint
159−
160− Right conn2 <- connect endpoint server ReliableOrdered
161− ConnectionOpened serv2 _ _ <- receive endpoint
162−
163− -- One thread to send "pingA" on the first connection
164− forkTry $ do
165− replicateM_ numPings $ send conn1 ["pingA"]
166− close conn1
167−
168− -- One thread to send "pingB" on the second connection
169− forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
170−
171− -- Verify server responses
172− let verifyResponse 0 = putMVar result ()
173− verifyResponse n = do
174− event <- receive endpoint
175− case event of
176− Received cid [payload] -> do
177− when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
178− when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
179− verifyResponse (n - 1)
180− _ ->
181− verifyResponse n
182− verifyResponse (3 * numPings)
183−
184− takeMVar result
185−
186−-- | Test that if A connects to B and B connects to A, B can still send to A after
187−-- A closes its connection to B (for instance, in the TCP transport, the socket pair
188−-- connecting A and B should not yet be closed).
189−testCloseOneDirection :: Transport -> Int -> IO ()
190−testCloseOneDirection transport numPings = do
191− addrA <- newEmptyMVar
192− addrB <- newEmptyMVar
193− doneA <- newEmptyMVar
194− doneB <- newEmptyMVar
195−
196− -- A
197− forkTry $ do
198− tlog "A"
199− Right endpoint <- newEndPoint transport
200− tlog (show (address endpoint))
201− putMVar addrA (address endpoint)
202−
203− -- Connect to B
204− tlog "Connect to B"
205− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered
206−
207− -- Wait for B to connect to us
208− tlog "Wait for B"
209− ConnectionOpened cid _ _ <- receive endpoint
210−
211− -- Send pings to B
212− tlog "Send pings to B"
213− replicateM_ numPings $ send conn ["ping"]
214−
215− -- Close our connection to B
216− tlog "Close connection"
217− close conn
218−
219− -- Wait for B's pongs
220− tlog "Wait for pongs from B"
221− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
222−
223− -- Wait for B to close it's connection to us
224− tlog "Wait for B to close connection"
225− ConnectionClosed cid' <- receive endpoint
226− guard (cid == cid')
227−
228− -- Done
229− tlog "Done"
230− putMVar doneA ()
231−
232− -- B
233− forkTry $ do
234− tlog "B"
235− Right endpoint <- newEndPoint transport
236− tlog (show (address endpoint))
237− putMVar addrB (address endpoint)
238−
239− -- Wait for A to connect
240− tlog "Wait for A to connect"
241− ConnectionOpened cid _ _ <- receive endpoint
242−
243− -- Connect to A
244− tlog "Connect to A"
245− Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered
246−
247− -- Wait for A's pings
248− tlog "Wait for pings from A"
249− replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
250−
251− -- Wait for A to close it's connection to us
252− tlog "Wait for A to close connection"
253− ConnectionClosed cid' <- receive endpoint
254− guard (cid == cid')
255−
256− -- Send pongs to A
257− tlog "Send pongs to A"
258− replicateM_ numPings $ send conn ["pong"]
259−
260− -- Close our connection to A
261− tlog "Close connection to A"
262− close conn
263−
264− -- Done
265− tlog "Done"
266− putMVar doneB ()
267−
268− mapM_ takeMVar [doneA, doneB]
269−
270−-- | Collect a given number of events and order them by connection ID
271−collect :: EndPoint -> Int -> IO [(ConnectionId, [[ByteString]])]
272−collect endPoint numEvents = go numEvents Map.empty Map.empty
273− where
274− -- TODO: for more serious use of this function we'd need to make these arguments strict
275− go 0 open closed = if Map.null open
276− then return . Map.toList . Map.map reverse $ closed
277− else fail "Open connections"
278− go n open closed = do
279− event <- receive endPoint
280− case event of
281− ConnectionOpened cid _ _ ->
282− go (n - 1) (Map.insert cid [] open) closed
283− ConnectionClosed cid ->
284− let list = Map.findWithDefault (error "Invalid ConnectionClosed") cid open in
285− go (n - 1) (Map.delete cid open) (Map.insert cid list closed)
286− Received cid msg ->
287− go (n - 1) (Map.adjust (msg :) cid open) closed
288− ReceivedMulticast _ _ ->
289− fail "Unexpected multicast"
290− ErrorEvent _ ->
291− fail "Unexpected error"
292− EndPointClosed ->
293− fail "Unexpected endpoint closure"
294−
295−-- | Open connection, close it, then reopen it
296−-- (In the TCP transport this means the socket will be closed, then reopened)
297−--
298−-- Note that B cannot expect to receive all of A's messages on the first connection
299−-- before receiving the messages on the second connection. What might (and sometimes
300−-- does) happen is that finishes sending all of its messages on the first connection
301−-- (in the TCP transport, the first socket pair) while B is behind on reading _from_
302−-- this connection (socket pair) -- the messages are "in transit" on the network
303−-- (these tests are done on localhost, so there are in some OS buffer). Then when
304−-- A opens the second connection (socket pair) B will spawn a new thread for this
305−-- connection, and hence might start interleaving messages from the first and second
306−-- connection.
307−--
308−-- This is correct behaviour, however: the transport API guarantees reliability and
309−-- ordering _per connection_, but not _across_ connections.
310−testCloseReopen :: Transport -> Int -> IO ()
311−testCloseReopen transport numPings = do
312− addrB <- newEmptyMVar
313− doneB <- newEmptyMVar
314−
315− let numRepeats = 2 :: Int
316−
317− -- A
318− forkTry $ do
319− Right endpoint <- newEndPoint transport
320−
321− forM_ [1 .. numRepeats] $ \i -> do
322− tlog "A connecting"
323− -- Connect to B
324− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered
325−
326− tlog "A pinging"
327− -- Say hi
328− forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]
329−
330− tlog "A closing"
331− -- Disconnect again
332− close conn
333−
334− tlog "A finishing"
335−
336− -- B
337− forkTry $ do
338− Right endpoint <- newEndPoint transport
339− putMVar addrB (address endpoint)
340−
341− eventss <- collect endpoint (numRepeats * (numPings + 2))
342−
343− forM_ (zip [1 .. numRepeats] eventss) $ \(i, (_, events)) -> do
344− forM_ (zip [1 .. numPings] events) $ \(j, event) -> do
345− guard (event == [pack $ "ping" ++ show i ++ "/" ++ show j])
346−
347− putMVar doneB ()
348−
349− takeMVar doneB
350−
351−-- | Test lots of parallel connection attempts
352−testParallelConnects :: Transport -> Int -> IO ()
353−testParallelConnects transport numPings = do
354− server <- spawn transport echoServer
355− done <- newEmptyMVar
356−
357− Right endpoint <- newEndPoint transport
358−
359− -- Spawn lots of clients
360− forM_ [1 .. numPings] $ \i -> forkTry $ do
361− Right conn <- connect endpoint server ReliableOrdered
362− send conn [pack $ "ping" ++ show i]
363− send conn [pack $ "ping" ++ show i]
364− close conn
365−
366− forkTry $ do
367− eventss <- collect endpoint (numPings * 4)
368− -- Check that no pings got sent to the wrong connection
369− forM_ eventss $ \(_, [[ping1], [ping2]]) ->
370− guard (ping1 == ping2)
371− putMVar done ()
372−
373− takeMVar done
374−
375−-- | Test that sending on a closed connection gives an error
376−testSendAfterClose :: Transport -> Int -> IO ()
377−testSendAfterClose transport numRepeats = do
378− server <- spawn transport echoServer
379− clientDone <- newEmptyMVar
380−
381− forkTry $ do
382− Right endpoint <- newEndPoint transport
383−
384− -- We request two lightweight connections
385− replicateM numRepeats $ do
386− Right conn1 <- connect endpoint server ReliableOrdered
387− Right conn2 <- connect endpoint server ReliableOrdered
388−
389− -- Close the second, but leave the first open; then output on the second
390− -- connection (i.e., on a closed connection while there is still another
391− -- connection open)
392− close conn2
393− Left (TransportError SendFailed _) <- send conn2 ["ping2"]
394−
395− -- Now close the first connection, and output on it (i.e., output while
396− -- there are no lightweight connection at all anymore)
397− close conn1
398− Left (TransportError SendFailed _) <- send conn2 ["ping2"]
399−
400− return ()
401−
402− putMVar clientDone ()
403−
404− takeMVar clientDone
405−
406−-- | Test that closing the same connection twice has no effect
407−testCloseTwice :: Transport -> Int -> IO ()
408−testCloseTwice transport numRepeats = do
409− server <- spawn transport echoServer
410− clientDone <- newEmptyMVar
411−
412− forkTry $ do
413− Right endpoint <- newEndPoint transport
414−
415− replicateM numRepeats $ do
416− -- We request two lightweight connections
417− Right conn1 <- connect endpoint server ReliableOrdered
418− Right conn2 <- connect endpoint server ReliableOrdered
419−
420− -- Close the second one twice
421− close conn2
422− close conn2
423−
424− -- Then send a message on the first and close that twice too
425− send conn1 ["ping"]
426− close conn1
427−
428− -- Verify expected response from the echo server
429− ConnectionOpened cid1 _ _ <- receive endpoint
430− ConnectionOpened cid2 _ _ <- receive endpoint
431− ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
432− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
433− ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
434−
435− return ()
436−
437− putMVar clientDone ()
438−
439− takeMVar clientDone
440−
441−-- | Test that we can connect an endpoint to itself
442−testConnectToSelf :: Transport -> Int -> IO ()
443−testConnectToSelf transport numPings = do
444− done <- newEmptyMVar
445− Right endpoint <- newEndPoint transport
446−
447− tlog "Creating self-connection"
448− Right conn <- connect endpoint (address endpoint) ReliableOrdered
449−
450− tlog "Talk to myself"
451−
452− -- One thread to write to the endpoint
453− forkTry $ do
454− tlog $ "writing"
455−
456− tlog $ "Sending ping"
457− replicateM_ numPings $ send conn ["ping"]
458−
459− tlog $ "Closing connection"
460− close conn
461−
462− -- And one thread to read
463− forkTry $ do
464− tlog $ "reading"
465−
466− tlog "Waiting for ConnectionOpened"
467− ConnectionOpened cid _ addr <- receive endpoint ; True <- return $ addr == address endpoint
468−
469− tlog "Waiting for Received"
470− replicateM_ numPings $ do
471− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
472− return ()
473−
474− tlog "Waiting for ConnectionClosed"
475− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
476−
477− tlog "Done"
478− putMVar done ()
479−
480− takeMVar done
481−
482−-- | Test that we can connect an endpoint to itself multiple times
483−testConnectToSelfTwice :: Transport -> Int -> IO ()
484−testConnectToSelfTwice transport numPings = do
485− done <- newEmptyMVar
486− Right endpoint <- newEndPoint transport
487−
488− tlog "Creating self-connection"
489− Right conn1 <- connect endpoint (address endpoint) ReliableOrdered
490− Right conn2 <- connect endpoint (address endpoint) ReliableOrdered
491−
492− tlog "Talk to myself"
493−
494− -- One thread to write to the endpoint using the first connection
495− forkTry $ do
496− tlog $ "writing"
497−
498− tlog $ "Sending ping"
499− replicateM_ numPings $ send conn1 ["pingA"]
500−
501− tlog $ "Closing connection"
502− close conn1
503−
504− -- One thread to write to the endpoint using the second connection
505− forkTry $ do
506− tlog $ "writing"
507−
508− tlog $ "Sending ping"
509− replicateM_ numPings $ send conn2 ["pingB"]
510−
511− tlog $ "Closing connection"
512− close conn2
513−
514− -- And one thread to read
515− forkTry $ do
516− tlog $ "reading"
517−
518− [(_, events1), (_, events2)] <- collect endpoint (2 * (numPings + 2))
519− True <- return $ events1 == replicate numPings ["pingA"]
520− True <- return $ events2 == replicate numPings ["pingB"]
521−
522− tlog "Done"
523− putMVar done ()
524−
525− takeMVar done
526−
527−-- | Test various aspects of 'closeEndPoint'
528−testCloseEndPoint :: Transport -> Int -> IO ()
529−testCloseEndPoint transport _ = do
530− serverDone <- newEmptyMVar
531− clientDone <- newEmptyMVar
532− clientAddr1 <- newEmptyMVar
533− clientAddr2 <- newEmptyMVar
534− serverAddr <- newEmptyMVar
535−
536− -- Server
537− forkTry $ do
538− Right endpoint <- newEndPoint transport
539− putMVar serverAddr (address endpoint)
540−
541− -- First test (see client)
542− do
543− theirAddr <- readMVar clientAddr1
544− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
545− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
546− return ()
547−
548− -- Second test
549− do
550− theirAddr <- readMVar clientAddr2
551−
552− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
553− Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
554−
555− Right conn <- connect endpoint theirAddr ReliableOrdered
556− send conn ["pong"]
557−
558− ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''
559− ErrorEvent (TransportError (EventConnectionLost addr' []) _) <- receive endpoint ; True <- return $ addr' == theirAddr
560−
561− Left (TransportError SendFailed _) <- send conn ["pong2"]
562−
563− return ()
564−
565− putMVar serverDone ()
566−
567− -- Client
568− forkTry $ do
569− theirAddr <- readMVar serverAddr
570−
571− -- First test: close endpoint with one outgoing but no incoming connections
572− do
573− Right endpoint <- newEndPoint transport
574− putMVar clientAddr1 (address endpoint)
575−
576− -- Connect to the server, then close the endpoint without disconnecting explicitly
577− Right _ <- connect endpoint theirAddr ReliableOrdered
578− closeEndPoint endpoint
579− EndPointClosed <- receive endpoint
580− return ()
581−
582− -- Second test: close endpoint with one outgoing and one incoming connection
583− do
584− Right endpoint <- newEndPoint transport
585− putMVar clientAddr2 (address endpoint)
586−
587− Right conn <- connect endpoint theirAddr ReliableOrdered
588− send conn ["ping"]
589−
590− -- Reply from the server
591− ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
592− Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'
593−
594− -- Close the endpoint
595− closeEndPoint endpoint
596− EndPointClosed <- receive endpoint
597−
598− -- Attempt to send should fail with connection closed
599− Left (TransportError SendFailed _) <- send conn ["ping2"]
600−
601− -- An attempt to close the already closed connection should just return
602− () <- close conn
603−
604− -- And so should an attempt to connect
605− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered
606−
607− return ()
608−
609− putMVar clientDone ()
610−
611− mapM_ takeMVar [serverDone, clientDone]
612−
613−-- Test closeTransport
614−--
615−-- This tests many of the same things that testEndPoint does, and some more
616−testCloseTransport :: IO (Either String Transport) -> IO ()
617−testCloseTransport newTransport = do
618− serverDone <- newEmptyMVar
619− clientDone <- newEmptyMVar
620− clientAddr1 <- newEmptyMVar
621− clientAddr2 <- newEmptyMVar
622− serverAddr <- newEmptyMVar
623−
624− -- Server
625− forkTry $ do
626− Right transport <- newTransport
627− Right endpoint <- newEndPoint transport
628− putMVar serverAddr (address endpoint)
629−
630− -- Client sets up first endpoint
631− theirAddr1 <- readMVar clientAddr1
632− ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
633−
634− -- Client sets up second endpoint
635− theirAddr2 <- readMVar clientAddr2
636−
637− ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
638− Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
639−
640− Right conn <- connect endpoint theirAddr2 ReliableOrdered
641− send conn ["pong"]
642−
643− -- Client now closes down its transport. We should receive connection closed messages
644− -- TODO: this assumes a certain ordering on the messages we receive; that's not guaranteed
645− ConnectionClosed cid2'' <- receive endpoint ; True <- return $ cid2'' == cid2
646− ErrorEvent (TransportError (EventConnectionLost addr'' []) _) <- receive endpoint ; True <- return $ addr'' == theirAddr2
647− ConnectionClosed cid1' <- receive endpoint ; True <- return $ cid1' == cid1
648−
649− -- An attempt to send to the endpoint should now fail
650− Left (TransportError SendFailed _) <- send conn ["pong2"]
651−
652− putMVar serverDone ()
653−
654− -- Client
655− forkTry $ do
656− Right transport <- newTransport
657− theirAddr <- readMVar serverAddr
658−
659− -- Set up endpoint with one outgoing but no incoming connections
660− Right endpoint1 <- newEndPoint transport
661− putMVar clientAddr1 (address endpoint1)
662−
663− -- Connect to the server, then close the endpoint without disconnecting explicitly
664− Right _ <- connect endpoint1 theirAddr ReliableOrdered
665−
666− -- Set up an endpoint with one outgoing and out incoming connection
667− Right endpoint2 <- newEndPoint transport
668− putMVar clientAddr2 (address endpoint2)
669−
670− Right conn <- connect endpoint2 theirAddr ReliableOrdered
671− send conn ["ping"]
672−
673− -- Reply from the server
674− ConnectionOpened cid ReliableOrdered addr <- receive endpoint2 ; True <- return $ addr == theirAddr
675− Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid'
676−
677− -- Now shut down the entire transport
678− closeTransport transport
679−
680− -- Both endpoints should report that they have been closed
681− EndPointClosed <- receive endpoint1
682− EndPointClosed <- receive endpoint2
683−
684− -- Attempt to send should fail with connection closed
685− Left (TransportError SendFailed _) <- send conn ["ping2"]
686−
687− -- An attempt to close the already closed connection should just return
688− () <- close conn
689−
690− -- And so should an attempt to connect on either endpoint
691− Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered
692− Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered
693−
694− -- And finally, so should an attempt to create a new endpoint
695− Left (TransportError NewEndPointFailed _) <- newEndPoint transport
696−
697− putMVar clientDone ()
698−
699− mapM_ takeMVar [serverDone, clientDone]
700−
701−testMany :: IO (Either String Transport) -> IO ()
702−testMany newTransport = do
703− Right masterTransport <- newTransport
704− Right masterEndPoint <- newEndPoint masterTransport
705−
706− replicateM_ 20 $ do
707− Right transport <- newTransport
708− replicateM_ 2 $ do
709− Right endpoint <- newEndPoint transport
710− Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered
711− return ()
712−
713−-- Transport tests
714−testTransport :: IO (Either String Transport) -> IO ()
715−testTransport newTransport = do
716− Right transport <- newTransport
717− runTests
718− [ ("Many", testMany newTransport)
719− , ("PingPong", testPingPong transport numPings)
720− , ("EndPoints", testEndPoints transport numPings)
721− , ("Connections", testConnections transport numPings)
722− , ("CloseOneConnection", testCloseOneConnection transport numPings)
723− , ("CloseOneDirection", testCloseOneDirection transport numPings)
724− , ("CloseReopen", testCloseReopen transport numPings)
725− , ("ParallelConnects", testParallelConnects transport numPings)
726− , ("SendAfterClose", testSendAfterClose transport 100)
727− , ("CloseTwice", testCloseTwice transport 100)
728− , ("ConnectToSelf", testConnectToSelf transport numPings)
729− , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
730− , ("CloseEndPoint", testCloseEndPoint transport numPings)
731− , ("CloseTransport", testCloseTransport newTransport)
732− ]
733− where
734− numPings = 10000 :: Int
network-transport/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, throw, 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]) (reverse ts)))
180−
181−traceHandlers :: Traceable a => a -> [Handler b]
182−traceHandlers a = case trace a of
183− Nothing -> [ Handler $ \ex -> throw (ex :: SomeException) ]
184− Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (show t : ts) ex
185− , Handler $ \ex -> throw $ 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/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
src/Control/Distributed/Process.hsnew file+447
@@ -0,0 +1,447 @@
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
19+ ProcessId
20+ , NodeId(..)
21+ , Process
22+ , SendPortId
23+ , processNodeId
24+ , sendPortProcessId
25+ , liftIO -- Reexported for convenience
26+ -- * Basic messaging
27+ , send
28+ , usend
29+ , expect
30+ , expectTimeout
31+ -- * Channels
32+ , ReceivePort
33+ , SendPort
34+ , sendPortId
35+ , newChan
36+ , sendChan
37+ , receiveChan
38+ , receiveChanTimeout
39+ , mergePortsBiased
40+ , mergePortsRR
41+ -- * Unsafe messaging variants
42+ , unsafeSend
43+ , unsafeUSend
44+ , unsafeSendChan
45+ , unsafeNSend
46+ , unsafeNSendRemote
47+ , unsafeWrapMessage
48+ -- * Advanced messaging
49+ , Match
50+ , receiveWait
51+ , receiveTimeout
52+ , match
53+ , matchIf
54+ , 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
74+ -- * Process management
75+ , spawn
76+ , call
77+ , terminate
78+ , die
79+ , kill
80+ , exit
81+ , catchExit
82+ , catchesExit
83+ , ProcessTerminationException(..)
84+ , ProcessRegistrationException(..)
85+ , SpawnRef
86+ , getSelfPid
87+ , getSelfNode
88+ , ProcessInfo(..)
89+ , getProcessInfo
90+ , NodeStats(..)
91+ , getNodeStats
92+ , getLocalNodeStats
93+ -- * Monitoring and linking
94+ , link
95+ , linkNode
96+ , linkPort
97+ , unlink
98+ , unlinkNode
99+ , unlinkPort
100+ , monitor
101+ , monitorNode
102+ , monitorPort
103+ , unmonitor
104+ , withMonitor
105+ , withMonitor_
106+ , MonitorRef -- opaque
107+ , ProcessLinkException(..)
108+ , NodeLinkException(..)
109+ , PortLinkException(..)
110+ , ProcessMonitorNotification(..)
111+ , NodeMonitorNotification(..)
112+ , PortMonitorNotification(..)
113+ , DiedReason(..)
114+ -- * Closures
115+ , Closure
116+ , closure
117+ , Static
118+ , unStatic
119+ , unClosure
120+ , RemoteTable
121+ -- * Logging
122+ , say
123+ -- * Registry
124+ , register
125+ , reregister
126+ , unregister
127+ , whereis
128+ , nsend
129+ , registerRemoteAsync
130+ , reregisterRemoteAsync
131+ , unregisterRemoteAsync
132+ , whereisRemoteAsync
133+ , nsendRemote
134+ , WhereIsReply(..)
135+ , RegisterReply(..)
136+ -- * Exception handling
137+ , catch
138+ , Handler(..)
139+ , catches
140+ , try
141+ , mask
142+ , mask_
143+ , onException
144+ , bracket
145+ , bracket_
146+ , finally
147+ -- * Auxiliary API
148+ , spawnAsync
149+ , spawnSupervised
150+ , spawnLink
151+ , spawnMonitor
152+ , spawnChannel
153+ , DidSpawn(..)
154+ -- * Local versions of 'spawn'
155+ , spawnLocal
156+ , spawnChannelLocal
157+ , callLocal
158+ -- * Reconnecting
159+ , reconnect
160+ , reconnectPort
161+ ) where
162+
163+import Control.Monad.IO.Class (liftIO)
164+import Control.Applicative
165+import Control.Monad.Reader (ask)
166+import Control.Concurrent (killThread)
167+import Control.Concurrent.MVar
168+ ( MVar
169+ , newEmptyMVar
170+ , takeMVar
171+ , putMVar
172+ )
173+import Control.Distributed.Static
174+ ( Closure
175+ , closure
176+ , Static
177+ , RemoteTable
178+ )
179+import Control.Distributed.Process.Internal.Types
180+ ( NodeId(..)
181+ , ProcessId(..)
182+ , Process(..)
183+ , MonitorRef(..)
184+ , ProcessMonitorNotification(..)
185+ , NodeMonitorNotification(..)
186+ , PortMonitorNotification(..)
187+ , ProcessLinkException(..)
188+ , NodeLinkException(..)
189+ , PortLinkException(..)
190+ , ProcessRegistrationException(..)
191+ , DiedReason(..)
192+ , SpawnRef(..)
193+ , DidSpawn(..)
194+ , SendPort(..)
195+ , ReceivePort(..)
196+ , SendPortId(..)
197+ , WhereIsReply(..)
198+ , RegisterReply(..)
199+ , LocalProcess(processNode)
200+ , Message
201+ , localProcessWithId
202+ )
203+import Control.Distributed.Process.Serializable (Serializable)
204+import Control.Distributed.Process.Internal.Primitives
205+ ( -- Basic messaging
206+ send
207+ , usend
208+ , expect
209+ -- Channels
210+ , newChan
211+ , sendChan
212+ , receiveChan
213+ , mergePortsBiased
214+ , mergePortsRR
215+ , unsafeSend
216+ , unsafeUSend
217+ , unsafeSendChan
218+ , unsafeNSend
219+ , unsafeNSendRemote
220+ -- Advanced messaging
221+ , Match
222+ , receiveWait
223+ , receiveTimeout
224+ , match
225+ , matchIf
226+ , 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
246+ -- Process management
247+ , terminate
248+ , ProcessTerminationException(..)
249+ , die
250+ , exit
251+ , catchExit
252+ , catchesExit
253+ , kill
254+ , getSelfPid
255+ , getSelfNode
256+ , ProcessInfo(..)
257+ , getProcessInfo
258+ , NodeStats(..)
259+ , getNodeStats
260+ , getLocalNodeStats
261+ -- Monitoring and linking
262+ , link
263+ , linkNode
264+ , linkPort
265+ , unlink
266+ , unlinkNode
267+ , unlinkPort
268+ , monitor
269+ , monitorNode
270+ , monitorPort
271+ , unmonitor
272+ , withMonitor
273+ , withMonitor_
274+ -- Logging
275+ , say
276+ -- Registry
277+ , register
278+ , reregister
279+ , unregister
280+ , whereis
281+ , nsend
282+ , registerRemoteAsync
283+ , reregisterRemoteAsync
284+ , unregisterRemoteAsync
285+ , whereisRemoteAsync
286+ , nsendRemote
287+ -- Closures
288+ , unStatic
289+ , unClosure
290+ -- Exception handling
291+ , catch
292+ , Handler(..)
293+ , catches
294+ , try
295+ , mask
296+ , mask_
297+ , onException
298+ , bracket
299+ , bracket_
300+ , finally
301+ -- Auxiliary API
302+ , expectTimeout
303+ , receiveChanTimeout
304+ , spawnAsync
305+ -- Reconnecting
306+ , reconnect
307+ , reconnectPort
308+ )
309+import 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+
334+
335+-- INTERNAL NOTES
336+--
337+-- 1. 'send' never fails. If you want to know that the remote process received
338+-- your message, you will need to send an explicit acknowledgement. If you
339+-- want to know when the remote process failed, you will need to monitor
340+-- that remote process.
341+--
342+-- 2. 'send' may block (when the system TCP buffers are full, while we are
343+-- trying to establish a connection to the remote endpoint, etc.) but its
344+-- return does not imply that the remote process received the message (much
345+-- less processed it). When 'send' targets a local process, it is dispatched
346+-- via the node controller however, in which cases it will /not/ block. This
347+-- isn't part of the semantics, so it should be ok. The ordering is maintained
348+-- because the ctrlChannel still has FIFO semantics with regards interactions
349+-- between two disparate forkIO threads.
350+--
351+-- 3. Message delivery is reliable and ordered. That means that if process A
352+-- sends messages m1, m2, m3 to process B, B will either arrive all three
353+-- messages in order (m1, m2, m3) or a prefix thereof; messages will not be
354+-- 'missing' (m1, m3) or reordered (m1, m3, m2)
355+--
356+-- In order to guarantee (3), we stipulate that
357+--
358+-- 3a. We do not garbage collect connections because Network.Transport provides
359+-- ordering guarantees only *per connection*.
360+--
361+-- 3b. Once a connection breaks, we have no way of knowing which messages
362+-- arrived and which did not; hence, once a connection fails, we assume the
363+-- remote process to be forever unreachable. Otherwise we might sent m1 and
364+-- m2, get notified of the broken connection, reconnect, send m3, but only
365+-- m1 and m3 arrive.
366+--
367+-- 3c. As a consequence of (3b) we should not reuse PIDs. If a process dies,
368+-- we consider it forever unreachable. Hence, new processes should get new
369+-- IDs or they too would be considered unreachable.
370+--
371+-- Main reference for Cloud Haskell is
372+--
373+-- [1] "Towards Haskell in the Cloud", Jeff Epstein, Andrew Black and Simon
374+-- Peyton-Jones.
375+-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
376+--
377+-- The precise semantics for message passing is based on
378+--
379+-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund
380+-- and Clara Benac Earle (not freely available online, unfortunately)
381+--
382+-- Some pointers to related documentation about Erlang, for comparison and
383+-- inspiration:
384+--
385+-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",
386+-- Hans Svensson and Lars-Ake Fredlund
387+-- http://man.lupaworld.com/content/develop/p37-svensson.pdf
388+-- [4] The Erlang manual, sections "Message Sending" and "Send"
389+-- http://www.erlang.org/doc/reference_manual/processes.html#id82409
390+-- http://www.erlang.org/doc/reference_manual/expressions.html#send
391+-- [5] Questions "Is the order of message reception guaranteed?" and
392+-- "If I send a message, is it guaranteed to reach the receiver?" of
393+-- the Erlang FAQ
394+-- http://www.erlang.org/faq/academic.html
395+-- [6] "Delivery of Messages", post on erlang-questions
396+-- http://erlang.org/pipermail/erlang-questions/2012-February/064767.html
397+
398+--------------------------------------------------------------------------------
399+-- Local versions of spawn --
400+--------------------------------------------------------------------------------
401+
402+-- | Spawn a process on the local node
403+spawnLocal :: Process () -> Process ProcessId
404+spawnLocal proc = do
405+ node <- processNode <$> ask
406+ liftIO $ forkProcess node proc
407+
408+-- | Create a new typed channel, spawn a process on the local node, passing it
409+-- the receive port, and return the send port
410+spawnChannelLocal :: Serializable a
411+ => (ReceivePort a -> Process ())
412+ -> Process (SendPort a)
413+spawnChannelLocal proc = do
414+ node <- processNode <$> ask
415+ liftIO $ do
416+ mvar <- newEmptyMVar
417+ _ <- forkProcess node $ do
418+ -- It is important that we allocate the new channel in the new process,
419+ -- because otherwise it will be associated with the wrong process ID
420+ (sport, rport) <- newChan
421+ liftIO $ putMVar mvar sport
422+ proc rport
423+ takeMVar mvar
424+
425+-- | Local version of 'call'. Running a process in this way isolates it from
426+-- messages sent to the caller process, and also allows silently dropping late
427+-- or duplicate messages sent to the isolated process after it exits.
428+-- Silently dropping messages may not always be the best approach.
429+callLocal :: Process a -> Process a
430+callLocal proc = Catch.mask $ \release -> do
431+ mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))
432+ child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv
433+ lproc <- ask
434+ liftIO $ do
435+ rs <- Exception.onException (takeMVar mv) $ Catch.uninterruptibleMask_ $
436+ -- Exceptions need to be prevented from interrupting the clean up or
437+ -- the original exception which caused entering the handler could be
438+ -- forgotten. For instance, this could have a problematic effect
439+ -- when the original exception was meant to kill the thread and the
440+ -- second exception doesn't (like the exception thrown by
441+ -- 'System.Timeout.timeout').
442+ do mchildThreadId <- withValidLocalState (processNode lproc) $
443+ \vst -> return $ fmap processThread $
444+ vst ^. localProcessWithId (processLocalId child)
445+ forM_ mchildThreadId killThread
446+ takeMVar mv
447+ either Catch.throwM return rs
src/Control/Distributed/Process/Closure.hsnew file+244
@@ -0,0 +1,244 @@
1+{-# LANGUAGE CPP #-}
2+-- | /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)
3+-- proposes a new type construct called 'static' that characterizes values that
4+-- are known statically. Cloud Haskell uses the
5+-- 'Control.Distributed.Static.Static' implementation from
6+-- "Control.Distributed.Static". That module comes with its own extensive
7+-- documentation, which you should read if you want to know the details. Here
8+-- we explain the Template Haskell support only.
9+--
10+-- [Static values]
11+--
12+-- Given a top-level (possibly polymorphic, but unqualified) definition
13+--
14+-- > f :: forall a1 .. an. T
15+-- > f = ...
16+--
17+-- you can use a Template Haskell splice to create a static version of 'f':
18+--
19+-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T
20+--
21+-- Every module that you write that contains calls to 'mkStatic' needs to
22+-- have a call to 'remotable':
23+--
24+-- > remotable [ 'f, 'g, ... ]
25+--
26+-- where you must pass every function (or other value) that you pass as an
27+-- argument to 'mkStatic'. The call to 'remotable' will create a definition
28+--
29+-- > __remoteTable :: RemoteTable -> RemoteTable
30+--
31+-- which can be used to construct the 'RemoteTable' used to initialize
32+-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,
33+-- and compose all created functions when initializing Cloud Haskell:
34+--
35+-- > let rtable :: RemoteTable
36+-- > rtable = M1.__remoteTable
37+-- > . M2.__remoteTable
38+-- > . ...
39+-- > . Mn.__remoteTable
40+-- > $ initRemoteTable
41+--
42+-- NOTE: If you get a type error from ghc along these lines
43+--
44+-- > The exact Name `a_a30k' is not in scope
45+-- > Probable cause: you used a unique name (NameU) in Template Haskell but did not bind it
46+--
47+-- then you need to enable the @ScopedTypeVariables@ language extension.
48+--
49+-- [Static serialization dictionaries]
50+--
51+-- Some Cloud Haskell primitives require static serialization dictionaries (**):
52+--
53+-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
54+--
55+-- Given some serializable type 'T' you can define
56+--
57+-- > sdictT :: SerializableDict T
58+-- > sdictT = SerializableDict
59+--
60+-- and then have
61+--
62+-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)
63+--
64+-- However, since these dictionaries are so frequently required Cloud Haskell
65+-- provides special support for them. When you call 'remotable' on a
66+-- /monomorphic/ function @f :: T1 -> T2@
67+--
68+-- > remotable ['f]
69+--
70+-- then a serialization dictionary is automatically created for you, which you
71+-- can access with
72+--
73+-- > $(functionSDict 'f) :: Static (SerializableDict T1)
74+--
75+-- In addition, if @f :: T1 -> Process T2@, then a second dictionary is created
76+--
77+-- > $(functionTDict 'f) :: Static (SerializableDict T2)
78+--
79+-- [Closures]
80+--
81+-- Suppose you have a process
82+--
83+-- > isPrime :: Integer -> Process Bool
84+--
85+-- Then
86+--
87+-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)
88+--
89+-- which you can then 'call', for example, to have a remote node check if
90+-- a number is prime.
91+--
92+-- In general, if you have a /monomorphic/ function
93+--
94+-- > f :: T1 -> T2
95+--
96+-- then
97+--
98+-- > $(mkClosure 'f) :: T1 -> Closure T2
99+--
100+-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable').
101+--
102+-- (You can also create closures manually--see the documentation of
103+-- "Control.Distributed.Static" for examples.)
104+--
105+-- [Example]
106+--
107+-- Here is a small self-contained example that uses closures and serialization
108+-- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet
109+-- Cloud Haskell backend.
110+--
111+-- > {-# LANGUAGE TemplateHaskell #-}
112+-- > import System.Environment (getArgs)
113+-- > import Control.Distributed.Process
114+-- > import Control.Distributed.Process.Closure
115+-- > import Control.Distributed.Process.Backend.SimpleLocalnet
116+-- > import Control.Distributed.Process.Node (initRemoteTable)
117+-- >
118+-- > isPrime :: Integer -> Process Bool
119+-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
120+-- > where
121+-- > sieve :: [Integer] -> [Integer]
122+-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
123+-- >
124+-- > remotable ['isPrime]
125+-- >
126+-- > master :: [NodeId] -> Process ()
127+-- > master [] = liftIO $ putStrLn "no slaves"
128+-- > master (slave:_) = do
129+-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))
130+-- > liftIO $ print isPrime79
131+-- >
132+-- > main :: IO ()
133+-- > main = do
134+-- > args <- getArgs
135+-- > case args of
136+-- > ["master", host, port] -> do
137+-- > backend <- initializeBackend host port rtable
138+-- > startMaster backend master
139+-- > ["slave", host, port] -> do
140+-- > backend <- initializeBackend host port rtable
141+-- > startSlave backend
142+-- > where
143+-- > rtable :: RemoteTable
144+-- > rtable = __remoteTable initRemoteTable
145+--
146+-- [Notes]
147+--
148+-- (*) If 'T1' is not serializable you will get a type error in the generated
149+-- code. Unfortunately, the Template Haskell infrastructure cannot check
150+-- a priori if 'T1' is serializable or not due to a bug in the Template
151+-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)
152+--
153+-- (**) Even though 'call' is passed an explicit serialization
154+-- dictionary, we still need the 'Serializable' constraint because
155+-- 'Static' is not the /true/ static. If it was, we could 'unstatic'
156+-- the dictionary and pattern match on it to bring the 'Typeable'
157+-- instance into scope, but unless proper 'static' support is added to
158+-- ghc we need both the type class argument and the explicit dictionary.
159+module Control.Distributed.Process.Closure
160+ ( -- * Serialization dictionaries (and their static versions)
161+ SerializableDict(..)
162+ , staticDecode
163+ , sdictUnit
164+ , sdictProcessId
165+ , sdictSendPort
166+ , sdictStatic
167+ , sdictClosure
168+ -- * The CP type and associated combinators
169+ , CP
170+ , idCP
171+ , splitCP
172+ , returnCP
173+ , bindCP
174+ , seqCP
175+ -- * CP versions of Cloud Haskell primitives
176+ , cpLink
177+ , cpUnlink
178+ , cpRelay
179+ , cpSend
180+ , cpExpect
181+ , cpNewChan
182+ -- * Working with static values and closures (without Template Haskell)
183+ , RemoteRegister
184+ , MkTDict(..)
185+ , mkStaticVal
186+ , mkClosureValSingle
187+ , mkClosureVal
188+ , call'
189+#ifdef TemplateHaskellSupport
190+ -- * Template Haskell support for creating static values and closures
191+ , remotable
192+ , remotableDecl
193+ , mkStatic
194+ , mkClosure
195+ , mkStaticClosure
196+ , functionSDict
197+ , functionTDict
198+#endif
199+ ) where
200+
201+import Control.Distributed.Process.Serializable (SerializableDict(..))
202+import Control.Distributed.Process.Internal.Closure.BuiltIn
203+ ( -- Static dictionaries and associated operations
204+ staticDecode
205+ , sdictUnit
206+ , sdictProcessId
207+ , sdictSendPort
208+ , sdictStatic
209+ , sdictClosure
210+ -- The CP type and associated combinators
211+ , CP
212+ , idCP
213+ , splitCP
214+ , returnCP
215+ , bindCP
216+ , seqCP
217+ -- CP versions of Cloud Haskell primitives
218+ , cpLink
219+ , cpUnlink
220+ , cpRelay
221+ , cpSend
222+ , cpExpect
223+ , cpNewChan
224+ )
225+import Control.Distributed.Process.Internal.Closure.Explicit
226+ (
227+ RemoteRegister
228+ , MkTDict(..)
229+ , mkStaticVal
230+ , mkClosureValSingle
231+ , mkClosureVal
232+ , call'
233+ )
234+#ifdef TemplateHaskellSupport
235+import Control.Distributed.Process.Internal.Closure.TH
236+ ( remotable
237+ , remotableDecl
238+ , mkStatic
239+ , functionSDict
240+ , functionTDict
241+ , mkClosure
242+ , mkStaticClosure
243+ )
244+#endif
src/Control/Distributed/Process/Debug.hsnew file+288
@@ -0,0 +1,288 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE RankNTypes #-}
4+-----------------------------------------------------------------------------
5+-- |
6+-- Module : Control.Distributed.Process.Debug
7+-- Copyright : (c) Well-Typed / Tim Watson
8+-- License : BSD3 (see the file LICENSE)
9+--
10+-- Maintainer : Tim Watson <watson.timothy@gmail.com>
11+-- Stability : experimental
12+-- Portability : non-portable (requires concurrency)
13+--
14+-- [Tracing/Debugging Facilities]
15+--
16+-- Cloud Haskell provides a general purpose tracing mechanism, allowing a
17+-- user supplied /tracer process/ to receive messages when certain classes of
18+-- system events occur. It's possible to use this facility to aid in debugging
19+-- and/or perform other diagnostic tasks to a program at runtime.
20+--
21+-- [Enabling Tracing]
22+--
23+-- Throughout the lifecycle of a local node, the distributed-process runtime
24+-- generates /trace events/, describing internal runtime activities such as
25+-- the spawning and death of processes, message sending, delivery and so on.
26+-- See the 'MxEvent' type's documentation for a list of all the published
27+-- event types, which correspond directly to the types of /management/ events.
28+-- Users can additionally publish custom trace events in the form of
29+-- 'MxLog' log messages or pass custom (i.e., completely user defined)
30+-- event data using the 'traceMessage' function.
31+--
32+-- All published traces are forwarded to a /tracer process/, which can be
33+-- specified (and changed) at runtime using 'traceEnable'. Some pre-defined
34+-- tracer processes are provided for conveniently printing to stderr, a log file
35+-- or the GHC eventlog.
36+--
37+-- If a tracer process crashes, no attempt is made to restart it.
38+--
39+-- [Working with multiple tracer processes]
40+--
41+-- The tracing facility only ever writes to a single tracer process. This
42+-- invariant insulates the tracer controller and ensures a fast path for
43+-- handling all trace events. /This/ module provides facilities for layering
44+-- trace handlers using Cloud Haskell's built-in delegation primitives.
45+--
46+-- The 'startTracer' function wraps the registered @tracer@ process with the
47+-- supplied handler and also forwards trace events to the original tracer.
48+-- The corresponding 'stopTracer' function terminates tracer processes in
49+-- reverse of the order in which they were started, and re-registers the
50+-- previous tracer process.
51+--
52+-- [Built in tracers]
53+--
54+-- The built in tracers provide a simple /logging/ facility that writes trace
55+-- events out to either a log file, @stderr@ or the GHC eventlog. These tracers
56+-- can be configured using environment variables, or specified manually using
57+-- the 'traceEnable' function.
58+--
59+-- When a new local node is started, the contents of several environment
60+-- variables are checked to determine which default tracer process is selected.
61+-- If none of these variables is set, a no-op tracer process is installed,
62+-- which effectively ignores all trace messages. Note that in this case,
63+-- trace events are still generated and passed through the system.
64+-- Only one default tracer will be chosen - the first that contains a (valid)
65+-- value. These environment variables, in the order they're examined, are:
66+--
67+-- 1. @DISTRIBUTED_PROCESS_TRACE_FILE@
68+-- This is checked for a valid file path. If it exists and the file can be
69+-- opened for writing, all trace output will be directed thence. If the supplied
70+-- path is invalid, or the file is unavailable for writing, this tracer will not
71+-- be selected.
72+--
73+-- 2. @DISTRIBUTED_PROCESS_TRACE_CONSOLE@
74+-- This is checked for /any/ non-empty value. If set, then all trace output will
75+-- be directed to the system logger process.
76+--
77+-- 3. @DISTRIBUTED_PROCESS_TRACE_EVENTLOG@
78+-- This is checked for /any/ non-empty value. If set, all internal traces are
79+-- written to the GHC eventlog.
80+--
81+-- By default, the built in tracers will ignore all trace events! In order to
82+-- enable tracing the incoming 'MxEvent' stream, the @DISTRIBUTED_PROCESS_TRACE_FLAGS@
83+-- environment variable accepts the following flags, which enable tracing specific
84+-- event types:
85+--
86+-- * @p@ = trace the spawning of new processes
87+-- * @d@ = trace the death of processes
88+-- * @n@ = trace registration of names (i.e., named processes)
89+-- * @u@ = trace un-registration of names (i.e., named processes)
90+-- * @s@ = trace the sending of messages to other processes
91+-- * @r@ = trace the receipt of messages from other processes
92+-- * @l@ = trace node up/down events
93+--
94+-- Users of the /simplelocalnet/ Cloud Haskell backend should also note that
95+-- because the trace file option only supports trace output from a single node
96+-- (so as to avoid interleaving), a file trace configured for the master node
97+-- will prevent slaves from tracing to the file. They will need to fall back to
98+-- the console or eventlog tracers instead, which can be accomplished by setting
99+-- one of these environment variables /as well/, since the latter will only be
100+-- selected on slaves (when the file tracer selection fails).
101+--
102+-- Support for writing to the eventlog requires specific intervention to work,
103+-- without which, written traces are silently dropped/ignored and no output will
104+-- be generated. The GHC eventlog documentation provides information about
105+-- enabling, viewing and working with event traces at
106+-- <http://hackage.haskell.org/trac/ghc/wiki/EventLog>.
107+--
108+module Control.Distributed.Process.Debug
109+ ( -- * Exported Data Types
110+ TraceArg(..)
111+ , TraceFlags(..)
112+ , TraceSubject(..)
113+ -- * Configuring Tracing
114+ , enableTrace
115+ , enableTraceAsync
116+ , disableTrace
117+ , withTracer
118+ , withFlags
119+ , getTraceFlags
120+ , setTraceFlags
121+ , setTraceFlagsAsync
122+ , defaultTraceFlags
123+ , traceOn
124+ , traceOnly
125+ , traceOff
126+ -- * Debugging
127+ , startTracer
128+ , stopTracer
129+ -- * Sending Custom Trace Data
130+ , traceLog
131+ , traceLogFmt
132+ , traceMessage
133+ -- * Working with remote nodes
134+ , Remote.remoteTable
135+ , Remote.startTraceRelay
136+ , Remote.setTraceFlagsRemote
137+ -- * Built in tracers
138+ , systemLoggerTracer
139+ , logfileTracer
140+ , eventLogTracer
141+ )
142+ where
143+
144+import Control.Applicative
145+import Control.Distributed.Process.Internal.Primitives
146+ ( proxy
147+ , die
148+ , whereis
149+ , send
150+ , receiveWait
151+ , matchIf
152+ , monitor
153+ )
154+import Control.Distributed.Process.Internal.Types
155+ ( ProcessId
156+ , Process
157+ , LocalProcess(..)
158+ , ProcessMonitorNotification(..)
159+ )
160+import Control.Distributed.Process.Management.Internal.Types
161+ ( MxEvent(..)
162+ )
163+import Control.Distributed.Process.Management.Internal.Trace.Types
164+ ( TraceArg(..)
165+ , TraceFlags(..)
166+ , TraceSubject(..)
167+ , defaultTraceFlags
168+ )
169+import Control.Distributed.Process.Management.Internal.Trace.Tracer
170+ ( systemLoggerTracer
171+ , logfileTracer
172+ , eventLogTracer
173+ )
174+import Control.Distributed.Process.Management.Internal.Trace.Primitives
175+ ( withRegisteredTracer
176+ , enableTrace
177+ , enableTraceAsync
178+ , disableTrace
179+ , setTraceFlags
180+ , setTraceFlagsAsync
181+ , getTraceFlags
182+ , traceOn
183+ , traceOff
184+ , traceOnly
185+ , traceLog
186+ , traceLogFmt
187+ , traceMessage
188+ )
189+import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Remote
190+import Control.Distributed.Process.Node
191+
192+import Control.Exception (SomeException)
193+
194+import Control.Monad.IO.Class (liftIO)
195+import Control.Monad.Reader (ask)
196+import Control.Monad.Catch (finally, try)
197+
198+import Data.Binary()
199+
200+import Prelude
201+
202+--------------------------------------------------------------------------------
203+-- Debugging/Tracing API --
204+--------------------------------------------------------------------------------
205+
206+-- | Starts a new tracer, using the supplied trace function.
207+-- Only one tracer can be registered at a time, however /this/ function overlays
208+-- the registered tracer with the supplied handler, allowing the user to layer
209+-- multiple tracers on top of one another, with trace events forwarded down
210+-- through all the layers in turn. Once the top layer is stopped, the user
211+-- is responsible for re-registering the original (prior) tracer pid before
212+-- terminating. See 'withTracer' for a mechanism that handles that.
213+startTracer :: (MxEvent -> Process ()) -> Process ProcessId
214+startTracer handler = do
215+ withRegisteredTracer $ \pid -> do
216+ node <- processNode <$> ask
217+ newPid <- liftIO $ forkProcess node $ traceProxy pid handler
218+ enableTrace newPid -- invokes sync + registration
219+ return newPid
220+
221+-- | Evaluate @proc@ with tracing enabled via @handler@, and immediately
222+-- disable tracing thereafter, before giving the result (or exception
223+-- in case of failure).
224+withTracer :: forall a.
225+ (MxEvent -> Process ())
226+ -> Process a
227+ -> Process (Either SomeException a)
228+withTracer handler proc = do
229+ previous <- whereis "tracer"
230+ tracer <- startTracer handler
231+ finally (try proc)
232+ (stopTracing tracer previous)
233+ where
234+ stopTracing :: ProcessId -> Maybe ProcessId -> Process ()
235+ stopTracing tracer previousTracer = do
236+ case previousTracer of
237+ Nothing -> return ()
238+ Just _ -> do
239+ ref <- monitor tracer
240+ send tracer MxTraceDisable
241+ receiveWait [
242+ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
243+ (\_ -> return ())
244+ ]
245+
246+-- | Evaluate @proc@ with the supplied flags enabled. Any previously set
247+-- trace flags are restored immediately afterwards.
248+withFlags :: forall a.
249+ TraceFlags
250+ -> Process a
251+ -> Process (Either SomeException a)
252+withFlags flags proc = do
253+ oldFlags <- getTraceFlags
254+ finally (setTraceFlags flags >> try proc)
255+ (setTraceFlags oldFlags)
256+
257+traceProxy :: ProcessId -> (MxEvent -> Process ()) -> Process ()
258+traceProxy pid act = do
259+ proxy pid $ \(ev :: MxEvent) ->
260+ case ev of
261+ (MxTraceTakeover _) -> return False
262+ MxTraceDisable -> die "disabled"
263+ _ -> act ev >> return True
264+
265+-- | Stops a user supplied tracer started with 'startTracer'.
266+-- Note that only one tracer process can be active at any given time.
267+-- This process will stop the last process started with 'startTracer'.
268+-- If 'startTracer' is called multiple times, successive calls to this
269+-- function will stop the tracers in the reverse order which they were
270+-- started.
271+--
272+-- This function will never stop the system tracer (i.e., the tracer
273+-- initially started when the node is created), therefore once all user
274+-- supplied tracers (i.e., processes started via 'startTracer') have exited,
275+-- subsequent calls to this function will have no effect.
276+--
277+-- If the last tracer to have been registered was not started
278+-- with 'startTracer' then the behaviour of this function is /undefined/.
279+stopTracer :: Process ()
280+stopTracer =
281+ withRegisteredTracer $ \pid -> do
282+ -- we need to avoid killing the initial (base) tracer, as
283+ -- nothing we rely on having exactly 1 registered tracer
284+ -- process at all times.
285+ basePid <- whereis "tracer.initial"
286+ case basePid == (Just pid) of
287+ True -> return ()
288+ False -> send pid MxTraceDisable
src/Control/Distributed/Process/Internal/BiMultiMap.hsnew file+135
@@ -0,0 +1,135 @@
1+-- | This is an implementation of bidirectional multimaps.
2+module Control.Distributed.Process.Internal.BiMultiMap
3+ ( BiMultiMap
4+ , empty
5+ , singleton
6+ , size
7+ , insert
8+ , lookupBy1st
9+ , lookupBy2nd
10+ , delete
11+ , deleteAllBy1st
12+ , deleteAllBy2nd
13+ , partitionWithKeyBy1st
14+ , partitionWithKeyBy2nd
15+ , flip
16+ ) where
17+
18+import Data.List (foldl')
19+import Data.Map.Strict (Map)
20+import qualified Data.Map.Strict as Map
21+import Data.Set (Set)
22+import qualified Data.Set as Set
23+import Prelude hiding (flip, lookup)
24+
25+-- | A bidirectional multimaps @BiMultiMap a b v@ is a set of triplets of type
26+-- @(a, b, v)@.
27+--
28+-- It is possible to lookup values by using either @a@ or @b@ as keys.
29+--
30+data BiMultiMap a b v = BiMultiMap !(Map a (Set (b, v))) !(Map b (Set (a, v)))
31+
32+-- The bidirectional multimap is implemented with a pair of multimaps.
33+--
34+-- Each multimap represents a set of triples, and one invariant is that both
35+-- multimaps should represent exactly the same set of triples.
36+--
37+-- Each of the multimaps, however, uses a different component of the triplets
38+-- as key. This allows to do efficient deletions by any of the two components.
39+
40+-- | The empty bidirectional multimap.
41+empty :: BiMultiMap a b v
42+empty = BiMultiMap Map.empty Map.empty
43+
44+-- | A bidirectional multimap containing a single triplet.
45+singleton :: (Ord a, Ord b, Ord v) => a -> b -> v -> BiMultiMap a b v
46+singleton a b v = insert a b v empty
47+
48+-- | Yields the amount of triplets in the multimap.
49+size :: BiMultiMap a b v -> Int
50+size (BiMultiMap m _) = foldl' (+) 0 $ map Set.size $ Map.elems m
51+
52+-- | Inserts a triplet in the multimap.
53+insert :: (Ord a, Ord b, Ord v)
54+ => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v
55+insert a b v (BiMultiMap m r) =
56+ BiMultiMap (Map.insertWith (\_new old -> Set.insert (b, v) old)
57+ a
58+ (Set.singleton (b, v))
59+ m)
60+ (Map.insertWith (\_new old -> Set.insert (a, v) old)
61+ b
62+ (Set.singleton (a, v))
63+ r)
64+
65+-- | Looks up all the triplets whose first component is the given value.
66+lookupBy1st :: Ord a => a -> BiMultiMap a b v -> Set (b, v)
67+lookupBy1st a (BiMultiMap m _) = maybe Set.empty id $ Map.lookup a m
68+
69+-- | Looks up all the triplets whose second component is the given value.
70+lookupBy2nd :: Ord b => b -> BiMultiMap a b v -> Set (a, v)
71+lookupBy2nd b = lookupBy1st b . flip
72+
73+-- | Deletes a triplet. It yields the original multimap if the triplet is
74+-- not present.
75+delete :: (Ord a, Ord b, Ord v)
76+ => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v
77+delete a b v (BiMultiMap m r) =
78+ let m' = Map.update (nothingWhen Set.null . Set.delete (b, v)) a m
79+ r' = Map.update (nothingWhen Set.null . Set.delete (a, v)) b r
80+ in BiMultiMap m' r'
81+
82+-- | Deletes all triplets whose first component is the given value.
83+deleteAllBy1st :: (Ord a, Ord b, Ord v) => a -> BiMultiMap a b v -> BiMultiMap a b v
84+deleteAllBy1st a (BiMultiMap m r) =
85+ let (mm, m') = Map.updateLookupWithKey (\_ _ -> Nothing) a m
86+ r' = case mm of
87+ Nothing -> r
88+ Just mb -> reverseDelete a (Set.toList mb) r
89+ in BiMultiMap m' r'
90+
91+-- | Like 'deleteAllBy1st' but deletes by the second component of the triplets.
92+deleteAllBy2nd :: (Ord a, Ord b, Ord v)
93+ => b -> BiMultiMap a b v -> BiMultiMap a b v
94+deleteAllBy2nd b = flip . deleteAllBy1st b . flip
95+
96+-- | Yields the triplets satisfying the given predicate, and a multimap
97+-- with all this triplets removed.
98+partitionWithKeyBy1st :: (Ord a, Ord b, Ord v)
99+ => (a -> Set (b, v) -> Bool) -> BiMultiMap a b v
100+ -> (Map a (Set (b, v)), BiMultiMap a b v)
101+partitionWithKeyBy1st p (BiMultiMap m r) =
102+ let (m0, m1) = Map.partitionWithKey p m
103+ r1 = foldl' (\rr (a, mb) -> reverseDelete a (Set.toList mb) rr) r $
104+ Map.toList m0
105+ in (m0, BiMultiMap m1 r1)
106+
107+-- | Like 'partitionWithKeyBy1st' but the predicates takes the second component
108+-- of the triplets as first argument.
109+partitionWithKeyBy2nd :: (Ord a, Ord b, Ord v)
110+ => (b -> Set (a, v) -> Bool) -> BiMultiMap a b v
111+ -> (Map b (Set (a, v)), BiMultiMap a b v)
112+partitionWithKeyBy2nd p b = let (m, b') = partitionWithKeyBy1st p $ flip b
113+ in (m, flip b')
114+
115+-- | Exchange the first and the second components of all triplets.
116+flip :: BiMultiMap a b v -> BiMultiMap b a v
117+flip (BiMultiMap m r) = BiMultiMap r m
118+
119+-- Internal functions
120+
121+-- | @reverseDelete a bs m@ removes from @m@ all the triplets wich have @a@ as
122+-- first component and second and third components in @bs@.
123+--
124+-- The @m@ map is in reversed form, meaning that the second component of the
125+-- triplets is used as key.
126+reverseDelete :: (Ord a, Ord b, Ord v)
127+ => a -> [(b, v)] -> Map b (Set (a, v)) -> Map b (Set (a, v))
128+reverseDelete a bs r = foldl' (\rr (b, v) -> Map.update (rmb v) b rr) r bs
129+ where
130+ rmb v = nothingWhen Set.null . Set.delete (a, v)
131+
132+-- | @nothingWhen p a@ is @Just a@ when @a@ satisfies predicate @p@.
133+-- Yields @Nothing@ otherwise.
134+nothingWhen :: (a -> Bool) -> a -> Maybe a
135+nothingWhen p a = if p a then Nothing else Just a
src/Control/Distributed/Process/Internal/CQueue.hsnew file+300
@@ -0,0 +1,300 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards, ScopedTypeVariables, RankNTypes #-}
5+-- | Concurrent queue for single reader, single writer
6+module Control.Distributed.Process.Internal.CQueue
7+ ( CQueue
8+ , BlockSpec(..)
9+ , MatchOn(..)
10+ , newCQueue
11+ , enqueue
12+ , enqueueSTM
13+ , dequeue
14+ , mkWeakCQueue
15+ , queueSize
16+ ) where
17+
18+import Prelude hiding (length, reverse)
19+import Control.Concurrent.STM
20+ ( atomically
21+ , STM
22+ , TChan
23+ , TVar
24+ , modifyTVar'
25+ , tryReadTChan
26+ , newTChan
27+ , newTVarIO
28+ , writeTChan
29+ , readTChan
30+ , readTVarIO
31+ , orElse
32+ , retry
33+ )
34+import Control.Applicative ((<$>), (<*>))
35+import Control.Exception (mask_, onException)
36+import System.Timeout (timeout)
37+import Control.Distributed.Process.Internal.StrictMVar
38+ ( StrictMVar(StrictMVar)
39+ , newMVar
40+ , takeMVar
41+ , putMVar
42+ )
43+import Control.Distributed.Process.Internal.StrictList
44+ ( StrictList(..)
45+ , append
46+ )
47+import Data.Maybe (fromJust)
48+import Data.Traversable (traverse)
49+import GHC.MVar (MVar(MVar))
50+import GHC.IO (IO(IO), unIO)
51+import GHC.Exts (mkWeak#)
52+import GHC.Weak (Weak(Weak))
53+
54+-- We use a TCHan rather than a Chan so that we have a non-blocking read
55+data CQueue a = CQueue (StrictMVar (StrictList a)) -- Arrived
56+ (TChan a) -- Incoming
57+ (TVar Int) -- Queue size
58+
59+newCQueue :: IO (CQueue a)
60+newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan <*> newTVarIO 0
61+
62+-- | Enqueue an element
63+--
64+-- Enqueue is strict.
65+enqueue :: CQueue a -> a -> IO ()
66+enqueue c !a = atomically (enqueueSTM c a)
67+
68+-- | Variant of enqueue for use in the STM monad.
69+enqueueSTM :: CQueue a -> a -> STM ()
70+enqueueSTM (CQueue _arrived incoming size) !a = do
71+ writeTChan incoming a
72+ modifyTVar' size succ
73+
74+data BlockSpec =
75+ NonBlocking
76+ | Blocking
77+ | Timeout Int
78+
79+-- Match operations
80+--
81+-- They can be either a message match or a channel match.
82+data MatchOn m a
83+ = MatchMsg (m -> Maybe a)
84+ | MatchChan (STM a)
85+ deriving (Functor)
86+
87+-- Lists of chunks of matches
88+--
89+-- Two consecutive chunks never have the same kind of matches. i.e. if one chunk
90+-- contains message matches then the next one must contain channel matches and
91+-- viceversa.
92+type MatchChunks m a = [Either [m -> Maybe a] [STM a]]
93+
94+-- Splits a list of matches into chunks.
95+--
96+-- > concatMap (either (map MatchMsg) (map MatchChan)) . chunkMatches == id
97+--
98+chunkMatches :: [MatchOn m a] -> MatchChunks m a
99+chunkMatches [] = []
100+chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest
101+ where (chk, rest) = spanMatchMsg ms
102+chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest
103+ where (chk, rest) = spanMatchChan ms
104+
105+-- | @spanMatchMsg = first (map (\(MatchMsg x) -> x)) . span isMatchMsg@
106+spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a])
107+spanMatchMsg [] = ([],[])
108+spanMatchMsg (m : ms)
109+ | MatchMsg msg <- m = (msg:msgs, rest)
110+ | otherwise = ([], m:ms)
111+ where !(msgs,rest) = spanMatchMsg ms
112+
113+-- | @spanMatchMsg = first (map (\(MatchChan x) -> x)) . span isMatchChan@
114+spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a])
115+spanMatchChan [] = ([],[])
116+spanMatchChan (m : ms)
117+ | MatchChan stm <- m = (stm:stms, rest)
118+ | otherwise = ([], m:ms)
119+ where !(stms,rest) = spanMatchChan ms
120+
121+-- | Dequeue an element
122+--
123+-- The timeout (if any) is applied only to waiting for incoming messages, not
124+-- to checking messages that have already arrived
125+dequeue :: forall m a.
126+ CQueue m -- ^ Queue
127+ -> BlockSpec -- ^ Blocking behaviour
128+ -> [MatchOn m a] -- ^ List of matches
129+ -> IO (Maybe a) -- ^ 'Nothing' only on timeout
130+dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJust $
131+ case blockSpec of
132+ Timeout n -> timeout n $ fmap fromJust run
133+ _other ->
134+ case chunks of
135+ [Right ports] -> -- channels only, this is easy:
136+ case blockSpec of
137+ NonBlocking -> atomically $ waitChans ports (return Nothing)
138+ _ -> atomically $ waitChans ports retry
139+ -- no onException needed
140+ _other -> run
141+ where
142+ -- Decrement counter is smth is returned from the queue,
143+ -- this is safe to use as method is called under a mask
144+ -- and there is no 'unmasked' operation inside
145+ decrementJust :: IO (Maybe (Either a a)) -> IO (Maybe a)
146+ decrementJust f =
147+ traverse (either return (\x -> decrement >> return x)) =<< f
148+ decrement = atomically $ modifyTVar' size pred
149+
150+ chunks = chunkMatches matchons
151+
152+ run = do
153+ arr <- takeMVar arrived
154+ let grabNew xs = do
155+ r <- atomically $ tryReadTChan incoming
156+ case r of
157+ Nothing -> return xs
158+ Just x -> grabNew (Snoc xs x)
159+ arr' <- grabNew arr
160+ goCheck chunks arr'
161+
162+ -- Yields the value of the first succesful STM transaction as
163+ -- @Just (Left v)@. If all transactions fail, yields the value of the second
164+ -- argument.
165+ waitChans :: [STM a] -> STM (Maybe (Either a a)) -> STM (Maybe (Either a a))
166+ waitChans ports on_block =
167+ foldr orElse on_block (map (fmap (Just . Left)) ports)
168+
169+ --
170+ -- First check the MatchChunks against the messages already in the
171+ -- mailbox. For channel matches, we do a non-blocking check at
172+ -- this point.
173+ --
174+ -- Yields @Just (Left a)@ when a channel is matched, @Just (Right a)@
175+ -- when a message is matched and @Nothing@ when there are no messages and we
176+ -- aren't blocking.
177+ --
178+ goCheck :: MatchChunks m a
179+ -> StrictList m -- messages to check, in this order
180+ -> IO (Maybe (Either a a))
181+
182+ goCheck [] old = goWait old
183+
184+ goCheck (Right ports : rest) old = do
185+ r <- atomically $ waitChans ports (return Nothing) -- does not block
186+ case r of
187+ Just _ -> returnOld old r
188+ Nothing -> goCheck rest old
189+
190+ goCheck (Left matches : rest) old = do
191+ -- checkArrived might in principle take arbitrary time, so
192+ -- we ought to call restore and use an exception handler. However,
193+ -- the check is usually fast (just a comparison), and the overhead
194+ -- of passing around restore and setting up exception handlers is
195+ -- high. So just don't use expensive matchIfs!
196+ case checkArrived matches old of
197+ (old', Just r) -> returnOld old' (Just (Right r))
198+ (old', Nothing) -> goCheck rest old'
199+ -- use the result list, which is now left-biased
200+
201+ --
202+ -- Construct an STM transaction that looks at the relevant channels
203+ -- in the correct order.
204+ --
205+ mkSTM :: MatchChunks m a -> STM (Either m a)
206+ mkSTM [] = retry
207+ mkSTM (Left _ : rest)
208+ = fmap Left (readTChan incoming) `orElse` mkSTM rest
209+ mkSTM (Right ports : rest)
210+ = foldr orElse (mkSTM rest) (map (fmap Right) ports)
211+
212+ waitIncoming :: IO (Maybe (Either m a))
213+ waitIncoming = case blockSpec of
214+ NonBlocking -> atomically $ fmap Just stm `orElse` return Nothing
215+ _ -> atomically $ fmap Just stm
216+ where
217+ stm = mkSTM chunks
218+
219+ --
220+ -- The initial pass didn't find a message, so now we go into blocking
221+ -- mode.
222+ --
223+ -- Contents of 'arrived' from now on is (old ++ new), and
224+ -- messages that arrive are snocced onto new.
225+ --
226+ goWait :: StrictList m -> IO (Maybe (Either a a))
227+ goWait old = do
228+ r <- waitIncoming `onException` putMVar arrived old
229+ case r of
230+ -- Nothing => non-blocking and no message
231+ Nothing -> returnOld old Nothing
232+ Just e -> case e of
233+ --
234+ -- Left => message arrived in the process mailbox. We now have to
235+ -- run through the MatchChunks checking each one, because we might
236+ -- have a situation where the first chunk fails to match and the
237+ -- second chunk is a channel match and there *is* a message in the
238+ -- channel. In that case the channel wins.
239+ --
240+ Left m -> goCheck1 chunks m old
241+ --
242+ -- Right => message arrived on a channel first
243+ --
244+ Right a -> returnOld old (Just (Left a))
245+
246+ --
247+ -- A message arrived in the process inbox; check the MatchChunks for
248+ -- a valid match.
249+ --
250+ goCheck1 :: MatchChunks m a
251+ -> m -- single message to check
252+ -> StrictList m -- old messages we have already checked
253+ -> IO (Maybe (Either a a))
254+
255+ goCheck1 [] m old = goWait (Snoc old m)
256+
257+ goCheck1 (Right ports : rest) m old = do
258+ r <- atomically $ waitChans ports (return Nothing) -- does not block
259+ case r of
260+ Nothing -> goCheck1 rest m old
261+ Just _ -> returnOld (Snoc old m) r
262+
263+ goCheck1 (Left matches : rest) m old = do
264+ case checkMatches matches m of
265+ Nothing -> goCheck1 rest m old
266+ Just p -> returnOld old (Just (Right p))
267+
268+ -- a common pattern for putting back the arrived queue at the end
269+ returnOld :: StrictList m -> Maybe (Either a a) -> IO (Maybe (Either a a))
270+ returnOld old r = do putMVar arrived old; return r
271+
272+ -- as a side-effect, this left-biases the list
273+ checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)
274+ checkArrived matches list = go list Nil
275+ where
276+ -- @go xs ys@ searches for a message match in @append xs ys@
277+ go Nil Nil = (Nil, Nothing)
278+ go Nil r = go r Nil
279+ go (Append xs ys) tl = go xs (append ys tl)
280+ go (Snoc xs x) tl = go xs (Cons x tl)
281+ go (Cons x xs) tl
282+ | Just y <- checkMatches matches x = (append xs tl, Just y)
283+ | otherwise = let !(rest,r) = go xs tl in (Cons x rest, r)
284+
285+ checkMatches :: [m -> Maybe a] -> m -> Maybe a
286+ checkMatches [] _ = Nothing
287+ checkMatches (m:ms) a = case m a of Nothing -> checkMatches ms a
288+ Just b -> Just b
289+
290+-- | Weak reference to a CQueue
291+mkWeakCQueue :: CQueue a -> IO () -> IO (Weak (CQueue a))
292+mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _ _) f = IO $ \s ->
293+#if MIN_VERSION_base(4,9,0)
294+ case mkWeak# m# m (unIO f) s of (# s1, w #) -> (# s1, Weak w #)
295+#else
296+ case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)
297+#endif
298+
299+queueSize :: CQueue a -> IO Int
300+queueSize (CQueue _ _ size) = readTVarIO size
src/Control/Distributed/Process/Internal/Closure/BuiltIn.hsnew file+320
@@ -0,0 +1,320 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE RankNTypes #-}
3+module Control.Distributed.Process.Internal.Closure.BuiltIn
4+ ( -- * Remote table
5+ remoteTable
6+ -- * Static dictionaries and associated operations
7+ , staticDecode
8+ , sdictUnit
9+ , sdictProcessId
10+ , sdictSendPort
11+ , sdictStatic
12+ , sdictClosure
13+ -- * Some static values
14+ , sndStatic
15+ -- * The CP type and associated combinators
16+ , CP
17+ , idCP
18+ , splitCP
19+ , returnCP
20+ , bindCP
21+ , seqCP
22+ -- * CP versions of Cloud Haskell primitives
23+ , decodeProcessIdStatic
24+ , cpLink
25+ , cpUnlink
26+ , cpRelay
27+ , cpSend
28+ , cpExpect
29+ , cpNewChan
30+ -- * Support for some CH operations
31+ , cpDelayed
32+ , cpEnableTraceRemote
33+ ) where
34+
35+import Data.ByteString.Lazy (ByteString)
36+import Data.Binary (decode, encode)
37+import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)
38+import Data.Rank1Dynamic (toDynamic)
39+import Control.Distributed.Static
40+ ( RemoteTable
41+ , registerStatic
42+ , Static
43+ , staticLabel
44+ , staticApply
45+ , Closure
46+ , closure
47+ , closureApplyStatic
48+ , closureApply
49+ , staticCompose
50+ , staticClosure
51+ )
52+import Control.Distributed.Process.Serializable
53+ ( SerializableDict(..)
54+ , Serializable
55+ , TypeableDict(..)
56+ )
57+import Control.Distributed.Process.Internal.Types
58+ ( Process
59+ , ProcessId
60+ , SendPort
61+ , ReceivePort
62+ , ProcessMonitorNotification(ProcessMonitorNotification)
63+ )
64+import Control.Distributed.Process.Internal.Primitives
65+ ( link
66+ , unlink
67+ , relay
68+ , send
69+ , expect
70+ , newChan
71+ , monitor
72+ , unmonitor
73+ , match
74+ , matchIf
75+ , receiveWait
76+ )
77+
78+--------------------------------------------------------------------------------
79+-- Remote table --
80+--------------------------------------------------------------------------------
81+
82+remoteTable :: RemoteTable -> RemoteTable
83+remoteTable =
84+ registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY))
85+ . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ()))
86+ . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))
87+ . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)))
88+ . registerStatic "$sdictStatic" (toDynamic (sdictStatic_ :: TypeableDict ANY -> SerializableDict (Static ANY)))
89+ . registerStatic "$sdictClosure" (toDynamic (sdictClosure_ :: TypeableDict ANY -> SerializableDict (Closure ANY)))
90+ . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY))
91+ . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2))
92+ . registerStatic "$bindProcess" (toDynamic ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2))
93+ . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> ProcessId))
94+ . registerStatic "$link" (toDynamic link)
95+ . registerStatic "$unlink" (toDynamic unlink)
96+ . registerStatic "$relay" (toDynamic relay)
97+ . registerStatic "$sendDict" (toDynamic (sendDict :: SerializableDict ANY -> ProcessId -> ANY -> Process ()))
98+ . registerStatic "$expectDict" (toDynamic (expectDict :: SerializableDict ANY -> Process ANY))
99+ . registerStatic "$newChanDict" (toDynamic (newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)))
100+ . registerStatic "$cpSplit" (toDynamic (cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)))
101+ . registerStatic "$snd" (toDynamic (snd :: (ANY1, ANY2) -> ANY2))
102+ . registerStatic "$delay" (toDynamic delay)
103+ where
104+ decodeDict :: forall a. SerializableDict a -> ByteString -> a
105+ decodeDict SerializableDict = decode
106+
107+ sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a)
108+ sdictSendPort_ SerializableDict = SerializableDict
109+
110+ sdictStatic_ :: forall a. TypeableDict a -> SerializableDict (Static a)
111+ sdictStatic_ TypeableDict = SerializableDict
112+
113+ sdictClosure_ :: forall a. TypeableDict a -> SerializableDict (Closure a)
114+ sdictClosure_ TypeableDict = SerializableDict
115+
116+ sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process ()
117+ sendDict SerializableDict = send
118+
119+ expectDict :: forall a. SerializableDict a -> Process a
120+ expectDict SerializableDict = expect
121+
122+ newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a)
123+ newChanDict SerializableDict = newChan
124+
125+ cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d)
126+ cpSplit f g (a, b) = do
127+ c <- f a
128+ d <- g b
129+ return (c, d)
130+
131+--------------------------------------------------------------------------------
132+-- Static dictionaries and associated operations --
133+--------------------------------------------------------------------------------
134+
135+-- | Static decoder, given a static serialization dictionary.
136+--
137+-- See module documentation of "Control.Distributed.Process.Closure" for an
138+-- example.
139+staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
140+staticDecode dict = decodeDictStatic `staticApply` dict
141+ where
142+ decodeDictStatic :: Typeable a => Static (SerializableDict a -> ByteString -> a)
143+ decodeDictStatic = staticLabel "$decodeDict"
144+
145+-- | Serialization dictionary for '()'
146+sdictUnit :: Static (SerializableDict ())
147+sdictUnit = staticLabel "$sdictUnit"
148+
149+-- | Serialization dictionary for 'ProcessId'
150+sdictProcessId :: Static (SerializableDict ProcessId)
151+sdictProcessId = staticLabel "$sdictProcessId"
152+
153+-- | Serialization dictionary for 'SendPort'
154+sdictSendPort :: Typeable a
155+ => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))
156+sdictSendPort = staticApply (staticLabel "$sdictSendPort_")
157+
158+-- | Serialization dictionary for 'Static'.
159+sdictStatic :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Static a))
160+sdictStatic = staticApply (staticLabel "$sdictStatic")
161+
162+-- | Serialization dictionary for 'Closure'.
163+sdictClosure :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Closure a))
164+sdictClosure = staticApply (staticLabel "$sdictClosure")
165+
166+--------------------------------------------------------------------------------
167+-- Static values --
168+--------------------------------------------------------------------------------
169+
170+sndStatic :: Static ((a, b) -> b)
171+sndStatic = staticLabel "$snd"
172+
173+--------------------------------------------------------------------------------
174+-- The CP type and associated combinators --
175+--------------------------------------------------------------------------------
176+
177+-- | @CP a b@ is a process with input of type @a@ and output of type @b@
178+type CP a b = Closure (a -> Process b)
179+
180+returnProcessStatic :: Typeable a => Static (a -> Process a)
181+returnProcessStatic = staticLabel "$returnProcess"
182+
183+-- | 'CP' version of 'Control.Category.id'
184+idCP :: Typeable a => CP a a
185+idCP = staticClosure returnProcessStatic
186+
187+-- | 'CP' version of ('Control.Arrow.***')
188+splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)
189+ => CP a c -> CP b d -> CP (a, b) (c, d)
190+splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q
191+ where
192+ cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d))
193+ cpSplitStatic = staticLabel "$cpSplit"
194+
195+-- | 'CP' version of 'Control.Monad.return'
196+returnCP :: forall a. Serializable a
197+ => Static (SerializableDict a) -> a -> Closure (Process a)
198+returnCP dict x = closure decoder (encode x)
199+ where
200+ decoder :: Static (ByteString -> Process a)
201+ decoder = returnProcessStatic
202+ `staticCompose`
203+ staticDecode dict
204+
205+-- | 'CP' version of ('Control.Monad.>>')
206+seqCP :: (Typeable a, Typeable b)
207+ => Closure (Process a) -> Closure (Process b) -> Closure (Process b)
208+seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q
209+ where
210+ seqProcessStatic :: (Typeable a, Typeable b)
211+ => Static (Process a -> Process b -> Process b)
212+ seqProcessStatic = staticLabel "$seqProcess"
213+
214+-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')
215+bindCP :: forall a b. (Typeable a, Typeable b)
216+ => Closure (Process a) -> CP a b -> Closure (Process b)
217+bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f
218+ where
219+ bindProcessStatic :: (Typeable a, Typeable b)
220+ => Static (Process a -> (a -> Process b) -> Process b)
221+ bindProcessStatic = staticLabel "$bindProcess"
222+
223+--------------------------------------------------------------------------------
224+-- CP versions of Cloud Haskell primitives --
225+--------------------------------------------------------------------------------
226+
227+decodeProcessIdStatic :: Static (ByteString -> ProcessId)
228+decodeProcessIdStatic = staticLabel "$decodeProcessId"
229+
230+-- | 'CP' version of 'link'
231+cpLink :: ProcessId -> Closure (Process ())
232+cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode
233+ where
234+ linkStatic :: Static (ProcessId -> Process ())
235+ linkStatic = staticLabel "$link"
236+
237+-- | 'CP' version of 'unlink'
238+cpUnlink :: ProcessId -> Closure (Process ())
239+cpUnlink = closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode
240+ where
241+ unlinkStatic :: Static (ProcessId -> Process ())
242+ unlinkStatic = staticLabel "$unlink"
243+
244+-- | 'CP' version of 'send'
245+cpSend :: forall a. Typeable a
246+ => Static (SerializableDict a) -> ProcessId -> CP a ()
247+cpSend dict pid = closure decoder (encode pid)
248+ where
249+ decoder :: Static (ByteString -> a -> Process ())
250+ decoder = (sendDictStatic `staticApply` dict)
251+ `staticCompose`
252+ decodeProcessIdStatic
253+
254+ sendDictStatic :: Typeable a
255+ => Static (SerializableDict a -> ProcessId -> a -> Process ())
256+ sendDictStatic = staticLabel "$sendDict"
257+
258+-- | 'CP' version of 'expect'
259+cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
260+cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)
261+ where
262+ expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a)
263+ expectDictStatic = staticLabel "$expectDict"
264+
265+-- | 'CP' version of 'newChan'
266+cpNewChan :: Typeable a
267+ => Static (SerializableDict a)
268+ -> Closure (Process (SendPort a, ReceivePort a))
269+cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)
270+ where
271+ newChanDictStatic :: Typeable a
272+ => Static (SerializableDict a -> Process (SendPort a, ReceivePort a))
273+ newChanDictStatic = staticLabel "$newChanDict"
274+
275+-- | 'CP' version of 'relay'
276+cpRelay :: ProcessId -> Closure (Process ())
277+cpRelay = closure (relayStatic `staticCompose` decodeProcessIdStatic) . encode
278+ where
279+ relayStatic :: Static (ProcessId -> Process ())
280+ relayStatic = staticLabel "$relay"
281+
282+-- TODO: move cpEnableTraceRemote into Trace/Primitives.hs
283+
284+cpEnableTraceRemote :: ProcessId -> Closure (Process ())
285+cpEnableTraceRemote =
286+ closure (enableTraceStatic `staticCompose` decodeProcessIdStatic) . encode
287+ where
288+ enableTraceStatic :: Static (ProcessId -> Process ())
289+ enableTraceStatic = staticLabel "$enableTraceRemote"
290+
291+--------------------------------------------------------------------------------
292+-- Support for spawn --
293+--------------------------------------------------------------------------------
294+
295+-- | @delay them p@ is a process that waits for a signal (a message of type @()@)
296+-- from 'them' (origin is not verified) before proceeding as @p@. In order to
297+-- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a
298+-- monitor message instead, it proceeds as @p@ too.
299+delay :: ProcessId -> Process () -> Process ()
300+delay them p = do
301+ ref <- monitor them
302+ let sameRef (ProcessMonitorNotification ref' _ _) = ref == ref'
303+ receiveWait [
304+ match $ \() -> unmonitor ref
305+ , matchIf sameRef $ \_ -> return ()
306+ ]
307+ p
308+
309+-- | 'CP' version of 'delay'
310+cpDelayed :: ProcessId -> Closure (Process ()) -> Closure (Process ())
311+cpDelayed = closureApply . cpDelay'
312+ where
313+ cpDelay' :: ProcessId -> Closure (Process () -> Process ())
314+ cpDelay' pid = closure decoder (encode pid)
315+
316+ decoder :: Static (ByteString -> Process () -> Process ())
317+ decoder = delayStatic `staticCompose` decodeProcessIdStatic
318+
319+ delayStatic :: Static (ProcessId -> Process () -> Process ())
320+ delayStatic = staticLabel "$delay"
src/Control/Distributed/Process/Internal/Closure/Explicit.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE ScopedTypeVariables
2+ , MultiParamTypeClasses
3+ , FlexibleInstances
4+ , FunctionalDependencies
5+ , FlexibleContexts
6+ , UndecidableInstances
7+ , KindSignatures
8+ , GADTs
9+ , EmptyDataDecls
10+ , DeriveDataTypeable #-}
11+module Control.Distributed.Process.Internal.Closure.Explicit
12+ (
13+ RemoteRegister
14+ , MkTDict(..)
15+ , mkStaticVal
16+ , mkClosureValSingle
17+ , mkClosureVal
18+ , call'
19+ ) where
20+
21+import Control.Distributed.Static
22+import Control.Distributed.Process.Serializable
23+import Control.Distributed.Process.Internal.Closure.BuiltIn
24+ ( -- Static dictionaries and associated operations
25+ staticDecode
26+ )
27+import Control.Distributed.Process
28+import Data.Rank1Dynamic
29+import Data.Rank1Typeable
30+import Data.Binary(encode,put,get,Binary)
31+import qualified Data.ByteString.Lazy as B
32+
33+-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
34+type RemoteRegister = RemoteTable -> RemoteTable
35+
36+-- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it.
37+mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)
38+mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v))
39+ where n_s = n
40+
41+class MkTDict a where
42+ mkTDict :: String -> a -> RemoteRegister
43+
44+instance (Serializable b) => MkTDict (Process b) where
45+ mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))
46+
47+instance MkTDict a where
48+ mkTDict _ _ = id
49+
50+-- | This takes an explicit name, a function of arity one, and creates a creates a function yielding a closure and a remote register for it.
51+mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)
52+mkClosureValSingle n v = (c, registerStatic n_s (toDynamic v) .
53+ registerStatic n_sdict (toDynamic sdict) .
54+ mkTDict n_tdict (undefined :: b)
55+ ) where
56+ n_s = n
57+ n_sdict = n ++ "__sdict"
58+ n_tdict = n ++ "__tdict"
59+
60+ c = closure decoder . encode
61+
62+ decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a))
63+
64+ sdict :: (SerializableDict a)
65+ sdict = SerializableDict
66+
67+-- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it.
68+mkClosureVal :: forall func argTuple result closureFunction.
69+ (Curry (argTuple -> Closure result) closureFunction,
70+ MkTDict result,
71+ Uncurry HTrue argTuple func result,
72+ Typeable result, Serializable argTuple, IsFunction func HTrue) =>
73+ String -> func -> (closureFunction, RemoteRegister)
74+mkClosureVal n v = (curryFun c, rtable)
75+ where
76+ uv :: argTuple -> result
77+ uv = uncurry' reify v
78+
79+ n_s = n
80+ n_sdict = n ++ "__sdict"
81+ n_tdict = n ++ "__tdict"
82+
83+ c :: argTuple -> Closure result
84+ c = closure decoder . encode
85+
86+ decoder :: Static (B.ByteString -> result)
87+ decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple))
88+
89+ rtable = registerStatic n_s (toDynamic uv) .
90+ registerStatic n_sdict (toDynamic sdict) .
91+ mkTDict n_tdict (undefined :: result)
92+
93+
94+ sdict :: (SerializableDict argTuple)
95+ sdict = SerializableDict
96+
97+-- | Works just like standard call, but with a simpler signature.
98+call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a
99+call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict")
100+
101+
102+data EndOfTuple deriving Typeable
103+instance Binary EndOfTuple where
104+ put _ = return ()
105+ get = return undefined
106+
107+-- This generic curry is straightforward
108+class Curry a b | a -> b where
109+ curryFun :: a -> b
110+
111+instance Curry ((a, EndOfTuple) -> b) (a -> b) where
112+ curryFun f = \x -> f (x,undefined)
113+
114+instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where
115+ curryFun f = \x -> curryFun (\y -> (f (x,y)))
116+
117+
118+-- This generic uncurry courtesy Andrea Vezzosi
119+data HTrue
120+data HFalse
121+data Fun :: * -> * -> * -> * where
122+ Done :: Fun EndOfTuple r r
123+ Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r
124+
125+class Uncurry'' args func result | func -> args, func -> result, args result -> func where
126+ reify :: Fun args func result
127+
128+class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
129+ reify' :: flag -> Fun args func result
130+
131+instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
132+ reify' _ = Moar reify
133+
134+instance Uncurry HFalse EndOfTuple a a where
135+ reify' _ = Done
136+
137+instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
138+ reify = reify' (undefined :: b)
139+
140+uncurry' :: Fun args func result -> func -> args -> result
141+uncurry' Done r _ = r
142+uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs
143+
144+class IsFunction t b | t -> b
145+instance (b ~ HTrue) => IsFunction (a -> c) b
146+instance (b ~ HFalse) => IsFunction a b
147+
src/Control/Distributed/Process/Internal/Closure/TH.hsnew file+330
@@ -0,0 +1,330 @@
1+-- | Template Haskell support
2+{-# LANGUAGE TemplateHaskell, CPP #-}
3+module Control.Distributed.Process.Internal.Closure.TH
4+ ( -- * User-level API
5+ remotable
6+ , remotableDecl
7+ , mkStatic
8+ , functionSDict
9+ , functionTDict
10+ , mkClosure
11+ , mkStaticClosure
12+ ) where
13+
14+import Prelude hiding (succ, any)
15+import Control.Applicative ((<$>))
16+import Language.Haskell.TH
17+ ( -- Q monad and operations
18+ Q
19+ , reify
20+ , Loc(loc_module)
21+ , location
22+ -- Names
23+ , Name
24+ , mkName
25+ , nameBase
26+ -- Algebraic data types
27+ , Dec(SigD)
28+ , Exp
29+ , Type(AppT, ForallT, VarT, ArrowT)
30+ , Info(VarI)
31+ , TyVarBndr(PlainTV, KindedTV)
32+ , Pred
33+#if MIN_VERSION_template_haskell(2,10,0)
34+ , conT
35+ , appT
36+#else
37+ , classP
38+#endif
39+ , varT
40+ -- Lifted constructors
41+ -- .. Literals
42+ , stringL
43+ -- .. Patterns
44+ , normalB
45+ , clause
46+ -- .. Expressions
47+ , varE
48+ , litE
49+ -- .. Top-level declarations
50+ , funD
51+ , sigD
52+ )
53+import Data.Maybe (catMaybes)
54+import Data.Binary (encode)
55+import Data.Generics (everywhereM, mkM, gmapM)
56+import Data.Rank1Dynamic (toDynamic)
57+import Data.Rank1Typeable
58+ ( Zero
59+ , Succ
60+ , TypVar
61+ )
62+import Control.Distributed.Static
63+ ( RemoteTable
64+ , registerStatic
65+ , Static
66+ , staticLabel
67+ , closure
68+ , staticCompose
69+ , staticClosure
70+ )
71+import Control.Distributed.Process.Internal.Types (Process)
72+import Control.Distributed.Process.Serializable
73+ ( SerializableDict(SerializableDict)
74+ )
75+import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
76+
77+--------------------------------------------------------------------------------
78+-- User-level API --
79+--------------------------------------------------------------------------------
80+
81+-- | Create the closure, decoder, and metadata definitions for the given list
82+-- of functions
83+remotable :: [Name] -> Q [Dec]
84+remotable ns = do
85+ types <- mapM getType ns
86+ (closures, inserts) <- unzip <$> mapM generateDefs types
87+ rtable <- createMetaData (mkName "__remoteTable") (concat inserts)
88+ return $ concat closures ++ rtable
89+
90+-- | Like 'remotable', but parameterized by the declaration of a function
91+-- instead of the function name. So where for 'remotable' you'd do
92+--
93+-- > f :: T1 -> T2
94+-- > f = ...
95+-- >
96+-- > remotable ['f]
97+--
98+-- with 'remotableDecl' you would instead do
99+--
100+-- > remotableDecl [
101+-- > [d| f :: T1 -> T2 ;
102+-- > f = ...
103+-- > |]
104+-- > ]
105+--
106+-- 'remotableDecl' creates the function specified as well as the various
107+-- dictionaries and static versions that 'remotable' also creates.
108+-- 'remotableDecl' is sometimes necessary when you want to refer to, say,
109+-- @$(mkClosure 'f)@ within the definition of @f@ itself.
110+--
111+-- NOTE: 'remotableDecl' creates @__remoteTableDecl@ instead of @__remoteTable@
112+-- so that you can use both 'remotable' and 'remotableDecl' within the same
113+-- module.
114+remotableDecl :: [Q [Dec]] -> Q [Dec]
115+remotableDecl qDecs = do
116+ decs <- concat <$> sequence qDecs
117+ let types = catMaybes (map typeOf decs)
118+ (closures, inserts) <- unzip <$> mapM generateDefs types
119+ rtable <- createMetaData (mkName "__remoteTableDecl") (concat inserts)
120+ return $ decs ++ concat closures ++ rtable
121+ where
122+ typeOf :: Dec -> Maybe (Name, Type)
123+ typeOf (SigD name typ) = Just (name, typ)
124+ typeOf _ = Nothing
125+
126+-- | Construct a static value.
127+--
128+-- If @f : forall a1 .. an. T@
129+-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
130+-- Be sure to pass 'f' to 'remotable'.
131+mkStatic :: Name -> Q Exp
132+mkStatic = varE . staticName
133+
134+-- | If @f : T1 -> T2@ is a monomorphic function
135+-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
136+--
137+-- Be sure to pass 'f' to 'remotable'.
138+functionSDict :: Name -> Q Exp
139+functionSDict = varE . sdictName
140+
141+-- | If @f : T1 -> Process T2@ is a monomorphic function
142+-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
143+--
144+-- Be sure to pass 'f' to 'remotable'.
145+functionTDict :: Name -> Q Exp
146+functionTDict = varE . tdictName
147+
148+-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
149+--
150+-- TODO: The current version of mkClosure is too polymorphic
151+-- (@forall a. Binary a => a -> Closure T2).
152+mkClosure :: Name -> Q Exp
153+mkClosure n =
154+ [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
155+ . encode
156+ |]
157+
158+-- | Make a 'Closure' from a static function. This is useful for
159+-- making a closure for a top-level @Process ()@ function, because
160+-- using 'mkClosure' would require adding a dummy @()@ argument.
161+--
162+mkStaticClosure :: Name -> Q Exp
163+mkStaticClosure n = [| staticClosure $( mkStatic n ) |]
164+
165+--------------------------------------------------------------------------------
166+-- Internal (Template Haskell) --
167+--------------------------------------------------------------------------------
168+
169+-- | Generate the code to add the metadata to the CH runtime
170+createMetaData :: Name -> [Q Exp] -> Q [Dec]
171+createMetaData name is =
172+ sequence [ sigD name [t| RemoteTable -> RemoteTable |]
173+ , sfnD name (compose is)
174+ ]
175+
176+generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp])
177+generateDefs (origName, fullType) = do
178+ proc <- [t| Process |]
179+ let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono)
180+ _ -> ([], fullType)
181+
182+ -- The main "static" entry
183+ (static, register) <- makeStatic typVars typ'
184+
185+ -- If n :: T1 -> T2, static serializable dictionary for T1
186+ -- TODO: we should check if arg is an instance of Serializable, but we cannot
187+ -- http://hackage.haskell.org/trac/ghc/ticket/7066
188+ (sdict, registerSDict) <- case (typVars, typ') of
189+ ([], ArrowT `AppT` arg `AppT` _res) ->
190+ makeDict (sdictName origName) arg
191+ _ ->
192+ return ([], [])
193+
194+ -- If n :: T1 -> Process T2, static serializable dictionary for T2
195+ -- TODO: check if T2 is serializable (same as above)
196+ (tdict, registerTDict) <- case (typVars, typ') of
197+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
198+ makeDict (tdictName origName) res
199+ _ ->
200+ return ([], [])
201+
202+ return ( concat [static, sdict, tdict]
203+ , concat [register, registerSDict, registerTDict]
204+ )
205+ where
206+ makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
207+ makeStatic typVars typ = do
208+ static <- generateStatic origName typVars typ
209+ let dyn = case typVars of
210+ [] -> [| toDynamic $(varE origName) |]
211+ _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
212+ return ( static
213+ , [ [| registerStatic $(showFQN origName) $dyn |] ]
214+ )
215+
216+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
217+ makeDict dictName typ = do
218+ sdict <- generateDict dictName typ
219+ let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]
220+ return ( sdict
221+ , [ [| registerStatic $(showFQN dictName) $dyn |] ]
222+ )
223+
224+-- | Turn a polymorphic type into a monomorphic type using ANY and co
225+monomorphize :: [TyVarBndr] -> Type -> Q Type
226+monomorphize tvs =
227+ let subst = zip (map tyVarBndrName tvs) anys
228+ in everywhereM (mkM (applySubst subst))
229+ where
230+ anys :: [Q Type]
231+ anys = map typVar (iterate succ zero)
232+
233+ typVar :: Q Type -> Q Type
234+ typVar t = [t| TypVar $t |]
235+
236+ zero :: Q Type
237+ zero = [t| Zero |]
238+
239+ succ :: Q Type -> Q Type
240+ succ t = [t| Succ $t |]
241+
242+ applySubst :: [(Name, Q Type)] -> Type -> Q Type
243+ applySubst s (VarT n) =
244+ case lookup n s of
245+ Nothing -> return (VarT n)
246+ Just t -> t
247+ applySubst s t = gmapM (mkM (applySubst s)) t
248+
249+-- | Generate a static value
250+generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
251+generateStatic n xs typ = do
252+ staticTyp <- [t| Static |]
253+ sequence
254+ [ sigD (staticName n) $ do
255+ txs <- sequence $ map typeable xs
256+ return (ForallT xs
257+ txs
258+ (staticTyp `AppT` typ))
259+ , sfnD (staticName n) [| staticLabel $(showFQN n) |]
260+ ]
261+ where
262+ typeable :: TyVarBndr -> Q Pred
263+ typeable tv =
264+#if MIN_VERSION_template_haskell(2,10,0)
265+ conT (mkName "Typeable") `appT` varT (tyVarBndrName tv)
266+#else
267+ classP (mkName "Typeable") [varT (tyVarBndrName tv)]
268+#endif
269+
270+-- | Generate a serialization dictionary with name 'n' for type 'typ'
271+generateDict :: Name -> Type -> Q [Dec]
272+generateDict n typ = do
273+ sequence
274+ [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
275+ , sfnD n [| staticLabel $(showFQN n) |]
276+ ]
277+
278+staticName :: Name -> Name
279+staticName n = mkName $ nameBase n ++ "__static"
280+
281+sdictName :: Name -> Name
282+sdictName n = mkName $ nameBase n ++ "__sdict"
283+
284+tdictName :: Name -> Name
285+tdictName n = mkName $ nameBase n ++ "__tdict"
286+
287+--------------------------------------------------------------------------------
288+-- Generic Template Haskell auxiliary functions --
289+--------------------------------------------------------------------------------
290+
291+-- | Compose a set of expressions
292+compose :: [Q Exp] -> Q Exp
293+compose [] = [| id |]
294+compose [e] = e
295+compose (e:es) = [| $e . $(compose es) |]
296+
297+-- | Literal string as an expression
298+stringE :: String -> Q Exp
299+stringE = litE . stringL
300+
301+-- | Look up the "original name" (module:name) and type of a top-level function
302+getType :: Name -> Q (Name, Type)
303+getType name = do
304+ info <- reify name
305+ case info of
306+#if MIN_VERSION_template_haskell(2,11,0)
307+ VarI origName typ _ -> return (origName, typ)
308+#else
309+ VarI origName typ _ _ -> return (origName, typ)
310+#endif
311+ _ -> fail $ show name ++ " not found"
312+
313+-- | Variation on 'funD' which takes a single expression to define the function
314+sfnD :: Name -> Q Exp -> Q Dec
315+sfnD n e = funD n [clause [] (normalB e) []]
316+
317+-- | The name of a type variable binding occurrence
318+tyVarBndrName :: TyVarBndr -> Name
319+tyVarBndrName (PlainTV n) = n
320+tyVarBndrName (KindedTV n _) = n
321+
322+-- | Fully qualified name; that is, the name and the _current_ module
323+--
324+-- We ignore the module part of the Name argument (which may or may not exist)
325+-- because we construct various names (`staticName`, `sdictName`, `tdictName`)
326+-- and those names certainly won't have Module components.
327+showFQN :: Name -> Q Exp
328+showFQN n = do
329+ loc <- location
330+ stringE (loc_module loc ++ "." ++ nameBase n)
src/Control/Distributed/Process/Internal/Messaging.hsnew file+207
@@ -0,0 +1,207 @@
1+module Control.Distributed.Process.Internal.Messaging
2+ ( sendPayload
3+ , sendBinary
4+ , sendMessage
5+ , disconnect
6+ , closeImplicitReconnections
7+ , impliesDeathOf
8+ , sendCtrlMsg
9+ ) where
10+
11+import Data.Accessor ((^.), (^=))
12+import Data.Binary (Binary, encode)
13+import qualified Data.Map as Map (partitionWithKey, elems)
14+import qualified Data.ByteString.Lazy as BSL (toChunks)
15+import qualified Data.ByteString as BSS (ByteString)
16+import Control.Distributed.Process.Serializable ()
17+
18+import Control.Concurrent (forkIO)
19+import Control.Concurrent.Chan (writeChan)
20+import Control.Exception (mask_)
21+import Control.Monad (unless)
22+import Control.Monad.IO.Class (liftIO)
23+import Control.Monad.Reader (ask)
24+import qualified Network.Transport as NT
25+ ( Connection
26+ , send
27+ , defaultConnectHints
28+ , connect
29+ , Reliability(ReliableOrdered)
30+ , close
31+ )
32+import Control.Distributed.Process.Internal.Types
33+ ( LocalNode(localEndPoint, localCtrlChan)
34+ , withValidLocalState
35+ , modifyValidLocalState
36+ , modifyValidLocalState_
37+ , Identifier
38+ , localConnections
39+ , localConnectionBetween
40+ , nodeAddress
41+ , nodeOf
42+ , messageToPayload
43+ , createMessage
44+ , NCMsg(..)
45+ , ProcessSignal(Died)
46+ , DiedReason(DiedDisconnect)
47+ , ImplicitReconnect(WithImplicitReconnect)
48+ , NodeId(..)
49+ , ProcessId(..)
50+ , LocalNode(..)
51+ , LocalProcess(..)
52+ , Process(..)
53+ , SendPortId(sendPortProcessId)
54+ , Identifier(NodeIdentifier, ProcessIdentifier, SendPortIdentifier)
55+ )
56+import Control.Distributed.Process.Serializable (Serializable)
57+import Data.Foldable (forM_)
58+
59+--------------------------------------------------------------------------------
60+-- Message sending --
61+--------------------------------------------------------------------------------
62+
63+sendPayload :: LocalNode
64+ -> Identifier
65+ -> Identifier
66+ -> ImplicitReconnect
67+ -> [BSS.ByteString]
68+ -> IO ()
69+sendPayload node from to implicitReconnect payload = do
70+ mConn <- connBetween node from to implicitReconnect
71+ didSend <- case mConn of
72+ Just conn -> do
73+ didSend <- NT.send conn payload
74+ case didSend of
75+ Left _err -> return False
76+ Right () -> return True
77+ Nothing -> return False
78+ unless didSend $ do
79+ writeChan (localCtrlChan node) NCMsg
80+ { ctrlMsgSender = to
81+ , ctrlMsgSignal = Died (NodeIdentifier $ nodeOf to) DiedDisconnect
82+ }
83+
84+sendBinary :: Binary a
85+ => LocalNode
86+ -> Identifier
87+ -> Identifier
88+ -> ImplicitReconnect
89+ -> a
90+ -> IO ()
91+sendBinary node from to implicitReconnect
92+ = sendPayload node from to implicitReconnect . BSL.toChunks . encode
93+
94+sendMessage :: Serializable a
95+ => LocalNode
96+ -> Identifier
97+ -> Identifier
98+ -> ImplicitReconnect
99+ -> a
100+ -> IO ()
101+sendMessage node from to implicitReconnect =
102+ sendPayload node from to implicitReconnect . messageToPayload . createMessage
103+
104+setupConnBetween :: LocalNode
105+ -> Identifier
106+ -> Identifier
107+ -> ImplicitReconnect
108+ -> IO (Maybe NT.Connection)
109+setupConnBetween node from to implicitReconnect = do
110+ mConn <- NT.connect (localEndPoint node)
111+ (nodeAddress . nodeOf $ to)
112+ NT.ReliableOrdered
113+ NT.defaultConnectHints
114+ case mConn of
115+ Right conn -> do
116+ didSend <- NT.send conn (BSL.toChunks . encode $ to)
117+ case didSend of
118+ Left _ ->
119+ return Nothing
120+ Right () -> do
121+ modifyValidLocalState_ node $
122+ return . (localConnectionBetween from to ^= Just (conn, implicitReconnect))
123+ return $ Just conn
124+ Left _ ->
125+ return Nothing
126+
127+connBetween :: LocalNode
128+ -> Identifier
129+ -> Identifier
130+ -> ImplicitReconnect
131+ -> IO (Maybe NT.Connection)
132+connBetween node from to implicitReconnect = do
133+ mConn <- withValidLocalState node $
134+ return . (^. localConnectionBetween from to)
135+ case mConn of
136+ Just (conn, _) ->
137+ return $ Just conn
138+ Nothing ->
139+ setupConnBetween node from to implicitReconnect
140+
141+disconnect :: LocalNode -> Identifier -> Identifier -> IO ()
142+disconnect node from to = mask_ $ do
143+ mio <- modifyValidLocalState node $ \vst ->
144+ case vst ^. localConnectionBetween from to of
145+ Nothing ->
146+ return (vst, return ())
147+ Just (conn, _) -> do
148+ return ( localConnectionBetween from to ^= Nothing $ vst
149+ , NT.close conn
150+ )
151+ forM_ mio forkIO
152+
153+closeImplicitReconnections :: LocalNode -> Identifier -> IO ()
154+closeImplicitReconnections node to = mask_ $ do
155+ mconns <- modifyValidLocalState node $ \vst -> do
156+ let shouldClose (_, to') (_, WithImplicitReconnect) = to `impliesDeathOf` to'
157+ shouldClose _ _ = False
158+ let (affected, unaffected) =
159+ Map.partitionWithKey shouldClose (vst ^. localConnections)
160+ return ( localConnections ^= unaffected $ vst
161+ , map fst $ Map.elems affected
162+ )
163+ forM_ mconns $ forkIO . mapM_ NT.close
164+
165+-- | @a `impliesDeathOf` b@ is true if the death of @a@ (for instance, a node)
166+-- implies the death of @b@ (for instance, a process on that node)
167+impliesDeathOf :: Identifier
168+ -> Identifier
169+ -> Bool
170+NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
171+ nid' == nid
172+NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
173+ processNodeId pid == nid
174+NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =
175+ processNodeId (sendPortProcessId cid) == nid
176+ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =
177+ pid' == pid
178+ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =
179+ sendPortProcessId cid == pid
180+SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =
181+ cid' == cid
182+_ `impliesDeathOf` _ =
183+ False
184+
185+
186+-- Send a control message. Evaluates the message to HNF before sending it.
187+--
188+-- The message shouldn't produce more errors when further evaluated. If
189+-- evaluation threw errors the node controller or the receiver would crash when
190+-- inspecting it.
191+sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
192+ -> ProcessSignal -- ^ Message to send
193+ -> Process ()
194+sendCtrlMsg mNid signal = do
195+ proc <- ask
196+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
197+ , ctrlMsgSignal = signal
198+ }
199+ case mNid of
200+ Nothing -> do
201+ liftIO $ writeChan (localCtrlChan (processNode proc)) $! msg
202+ Just nid ->
203+ liftIO $ sendBinary (processNode proc)
204+ (NodeIdentifier (processNodeId $ processId proc))
205+ (NodeIdentifier nid)
206+ WithImplicitReconnect
207+ msg
src/Control/Distributed/Process/Internal/Primitives.hsnew file+1363
@@ -0,0 +1,1363 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFunctor #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE ExistentialQuantification #-}
7+{-# LANGUAGE BangPatterns #-}
8+
9+-- | Cloud Haskell primitives
10+--
11+-- We define these in a separate module so that we don't have to rely on
12+-- the closure combinators
13+module Control.Distributed.Process.Internal.Primitives
14+ ( -- * Basic messaging
15+ send
16+ , usend
17+ , expect
18+ -- * Channels
19+ , newChan
20+ , sendChan
21+ , receiveChan
22+ , mergePortsBiased
23+ , mergePortsRR
24+ -- * Unsafe messaging variants
25+ , unsafeSend
26+ , unsafeUSend
27+ , unsafeSendChan
28+ , unsafeNSend
29+ , unsafeNSendRemote
30+ -- * Advanced messaging
31+ , Match
32+ , receiveWait
33+ , receiveTimeout
34+ , match
35+ , matchIf
36+ , matchUnknown
37+ , matchAny
38+ , matchAnyIf
39+ , matchChan
40+ , matchSTM
41+ , matchMessage
42+ , matchMessageIf
43+ , isEncoded
44+ , wrapMessage
45+ , unsafeWrapMessage
46+ , unwrapMessage
47+ , handleMessage
48+ , handleMessageIf
49+ , handleMessage_
50+ , handleMessageIf_
51+ , forward
52+ , uforward
53+ , delegate
54+ , relay
55+ , proxy
56+ -- * Process management
57+ , terminate
58+ , ProcessTerminationException(..)
59+ , die
60+ , kill
61+ , exit
62+ , catchExit
63+ , catchesExit
64+ -- keep the exception constructor hidden, so that handling exit
65+ -- reasons /must/ take place via the 'catchExit' family of primitives
66+ , ProcessExitException()
67+ , getSelfPid
68+ , getSelfNode
69+ , ProcessInfo(..)
70+ , getProcessInfo
71+ , NodeStats(..)
72+ , getNodeStats
73+ , getLocalNodeStats
74+ -- * Monitoring and linking
75+ , link
76+ , unlink
77+ , monitor
78+ , unmonitor
79+ , unmonitorAsync
80+ , withMonitor
81+ , withMonitor_
82+ -- * Logging
83+ , SayMessage(..)
84+ , say
85+ -- * Registry
86+ , register
87+ , reregister
88+ , unregister
89+ , whereis
90+ , nsend
91+ , registerRemoteAsync
92+ , reregisterRemoteAsync
93+ , unregisterRemoteAsync
94+ , whereisRemoteAsync
95+ , nsendRemote
96+ -- * Closures
97+ , unClosure
98+ , unStatic
99+ -- * Exception handling
100+ , catch
101+ , Handler(..)
102+ , catches
103+ , try
104+ , mask
105+ , mask_
106+ , onException
107+ , bracket
108+ , bracket_
109+ , finally
110+ -- * Auxiliary API
111+ , expectTimeout
112+ , receiveChanTimeout
113+ , spawnAsync
114+ , linkNode
115+ , linkPort
116+ , unlinkNode
117+ , unlinkPort
118+ , monitorNode
119+ , monitorPort
120+ -- * Reconnecting
121+ , reconnect
122+ , reconnectPort
123+ -- * Internal Exports
124+ , sendCtrlMsg
125+ ) where
126+
127+#if ! MIN_VERSION_base(4,6,0)
128+import Prelude hiding (catch)
129+#endif
130+
131+import Data.Binary (Binary(..), Put, Get, decode)
132+import Data.Time.Clock (getCurrentTime, UTCTime(..))
133+import Data.Time.Calendar (Day(..))
134+import Data.Time.Format (formatTime)
135+#if MIN_VERSION_time(1,5,0)
136+import Data.Time.Format (defaultTimeLocale)
137+#else
138+import System.Locale (defaultTimeLocale)
139+#endif
140+import System.Timeout (timeout)
141+import Control.Monad (when, void)
142+import Control.Monad.Reader (ask)
143+import Control.Monad.IO.Class (liftIO)
144+import Control.Monad.Catch
145+ ( Exception
146+ , SomeException
147+ , throwM
148+ , fromException
149+ )
150+import qualified Control.Monad.Catch as Catch
151+import Control.Applicative
152+import Control.Distributed.Process.Internal.StrictMVar
153+ ( StrictMVar
154+ , modifyMVar
155+ , modifyMVar_
156+ )
157+import Control.Concurrent.STM
158+ ( STM
159+ , TVar
160+ , atomically
161+ , orElse
162+ , newTVar
163+ , readTVar
164+ , writeTVar
165+ )
166+import Control.Distributed.Process.Internal.CQueue
167+ ( dequeue
168+ , BlockSpec(..)
169+ , MatchOn(..)
170+ )
171+import Control.Distributed.Process.Serializable (Serializable, fingerprint)
172+import Data.Accessor ((^.), (^:), (^=))
173+import Control.Distributed.Static
174+ ( Static
175+ , Closure
176+ )
177+import Data.Rank1Typeable (Typeable)
178+import qualified Control.Distributed.Static as Static (unstatic, unclosure)
179+import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe
180+import Control.Distributed.Process.Internal.Types
181+ ( NodeId(..)
182+ , ProcessId(..)
183+ , LocalNode(..)
184+ , LocalProcess(..)
185+ , Process(..)
186+ , Message(..)
187+ , MonitorRef(..)
188+ , SpawnRef(..)
189+ , ProcessSignal(..)
190+ , NodeMonitorNotification(..)
191+ , ProcessMonitorNotification(..)
192+ , monitorCounter
193+ , spawnCounter
194+ , SendPort(..)
195+ , ReceivePort(..)
196+ , channelCounter
197+ , typedChannelWithId
198+ , TypedChannel(..)
199+ , SendPortId(..)
200+ , Identifier(..)
201+ , ProcessExitException(..)
202+ , DiedReason(..)
203+ , DidUnmonitor(..)
204+ , DidUnlinkProcess(..)
205+ , DidUnlinkNode(..)
206+ , DidUnlinkPort(..)
207+ , WhereIsReply(..)
208+ , RegisterReply(..)
209+ , ProcessRegistrationException(..)
210+ , ProcessInfo(..)
211+ , ProcessInfoNone(..)
212+ , NodeStats(..)
213+ , isEncoded
214+ , createMessage
215+ , createUnencodedMessage
216+ , ImplicitReconnect( NoImplicitReconnect)
217+ , LocalProcessState
218+ , LocalSendPortId
219+ , messageToPayload
220+ )
221+import Control.Distributed.Process.Internal.Messaging
222+ ( sendMessage
223+ , sendBinary
224+ , sendPayload
225+ , disconnect
226+ , sendCtrlMsg
227+ )
228+import Control.Distributed.Process.Management.Internal.Types
229+ ( MxEvent(..)
230+ )
231+import Control.Distributed.Process.Management.Internal.Trace.Types
232+ ( traceEvent
233+ )
234+import Control.Distributed.Process.Internal.WeakTQueue
235+ ( newTQueueIO
236+ , readTQueue
237+ , mkWeakTQueue
238+ )
239+import Prelude
240+
241+import Unsafe.Coerce
242+
243+--------------------------------------------------------------------------------
244+-- Basic messaging --
245+--------------------------------------------------------------------------------
246+
247+-- | Send a message
248+send :: Serializable a => ProcessId -> a -> Process ()
249+-- This requires a lookup on every send. If we want to avoid that we need to
250+-- modify serializable to allow for stateful (IO) deserialization.
251+send them msg = do
252+ proc <- ask
253+ let us = processId proc
254+ node = processNode proc
255+ nodeId = localNodeId node
256+ destNode = (processNodeId them) in do
257+ liftIO $ traceEvent (localEventBus node)
258+ (MxSent them us (createUnencodedMessage msg))
259+ if destNode == nodeId
260+ then sendLocal them msg
261+ else liftIO $ sendMessage (processNode proc)
262+ (ProcessIdentifier (processId proc))
263+ (ProcessIdentifier them)
264+ NoImplicitReconnect
265+ msg
266+
267+-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize
268+-- and (in the case when the destination process resides on the same local
269+-- node) therefore ensure that the payload is fully evaluated before it is
270+-- delivered.
271+unsafeSend :: Serializable a => ProcessId -> a -> Process ()
272+unsafeSend = Unsafe.send
273+
274+-- | Send a message unreliably.
275+--
276+-- Unlike 'send', this function is insensitive to 'reconnect'. It will
277+-- try to send the message regardless of the history of connection failures
278+-- between the nodes.
279+--
280+-- Message passing with 'usend' is ordered for a given sender and receiver
281+-- if the messages arrive at all.
282+--
283+usend :: Serializable a => ProcessId -> a -> Process ()
284+usend them msg = do
285+ proc <- ask
286+ let there = processNodeId them
287+ let (us, node) = (processId proc, processNode proc)
288+ let msg' = wrapMessage msg
289+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg')
290+ if localNodeId (processNode proc) == there
291+ then sendLocal them msg
292+ else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)
293+ (createMessage msg)
294+
295+-- | /Unsafe/ variant of 'usend'. This function makes /no/ attempt to serialize
296+-- the message when the destination process resides on the same local
297+-- node. Therefore, a local receiver would need to be prepared to cope with any
298+-- errors resulting from evaluation of the message.
299+unsafeUSend :: Serializable a => ProcessId -> a -> Process ()
300+unsafeUSend = Unsafe.usend
301+
302+-- | Wait for a message of a specific type
303+expect :: forall a. Serializable a => Process a
304+expect = receiveWait [match return]
305+
306+--------------------------------------------------------------------------------
307+-- Channels --
308+--------------------------------------------------------------------------------
309+
310+-- | Create a new typed channel, bound to the calling Process
311+--
312+-- Note that the channel is bound to the lifecycle of the process that evaluates
313+-- this function, such that when it dies/exits, the channel will no longer
314+-- function, but will remain accessible. Thus reading from the ReceivePort will
315+-- fail silently thereafter, blocking indefinitely (unless a timeout is used).
316+--
317+newChan :: Serializable a => Process (SendPort a, ReceivePort a)
318+newChan = do
319+ proc <- ask
320+ liftIO . modifyMVar (processState proc) $ \st -> do
321+ let lcid = st ^. channelCounter
322+ let cid = SendPortId { sendPortProcessId = processId proc
323+ , sendPortLocalId = lcid
324+ }
325+ let sport = SendPort cid
326+ chan <- liftIO newTQueueIO
327+ chan' <- mkWeakTQueue chan $ finalizer (processState proc) lcid
328+ let rport = ReceivePort $ readTQueue chan
329+ let tch = TypedChannel chan'
330+ return ( (channelCounter ^: (+ 1))
331+ . (typedChannelWithId lcid ^= Just tch)
332+ $ st
333+ , (sport, rport)
334+ )
335+ where
336+ finalizer :: StrictMVar LocalProcessState -> LocalSendPortId -> IO ()
337+ finalizer st lcid = modifyMVar_ st $
338+ return . (typedChannelWithId lcid ^= Nothing)
339+
340+-- | Send a message on a typed channel
341+sendChan :: Serializable a => SendPort a -> a -> Process ()
342+sendChan (SendPort cid) msg = do
343+ proc <- ask
344+ let node = processNode proc
345+ pid = processId proc
346+ us = localNodeId node
347+ them = processNodeId (sendPortProcessId cid) in do
348+ liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)
349+ case them == us of
350+ True -> sendChanLocal cid msg
351+ False -> do
352+ liftIO $ sendBinary node
353+ (ProcessIdentifier pid)
354+ (SendPortIdentifier cid)
355+ NoImplicitReconnect
356+ msg
357+
358+-- | Send a message on a typed channel. This function makes /no/ attempt to
359+-- serialize and (in the case when the @ReceivePort@ resides on the same local
360+-- node) therefore ensure that the payload is fully evaluated before it is
361+-- delivered.
362+unsafeSendChan :: Serializable a => SendPort a -> a -> Process ()
363+unsafeSendChan = Unsafe.sendChan
364+
365+-- | Wait for a message on a typed channel
366+receiveChan :: Serializable a => ReceivePort a -> Process a
367+receiveChan = liftIO . atomically . receiveSTM
368+
369+-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a
370+-- non-blocking check for a message.
371+receiveChanTimeout :: Serializable a => Int -> ReceivePort a -> Process (Maybe a)
372+receiveChanTimeout 0 ch = liftIO . atomically $
373+ (Just <$> receiveSTM ch) `orElse` return Nothing
374+receiveChanTimeout n ch = liftIO . timeout n . atomically $
375+ receiveSTM ch
376+
377+-- | Merge a list of typed channels.
378+--
379+-- The result port is left-biased: if there are messages available on more
380+-- than one port, the first available message is returned.
381+mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
382+mergePortsBiased = return . ReceivePort. foldr1 orElse . map receiveSTM
383+
384+-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than
385+-- left-biased)
386+mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
387+mergePortsRR = \ps -> do
388+ psVar <- liftIO . atomically $ newTVar (map receiveSTM ps)
389+ return $ ReceivePort (rr psVar)
390+ where
391+ rotate :: [a] -> [a]
392+ rotate [] = []
393+ rotate (x:xs) = xs ++ [x]
394+
395+ rr :: TVar [STM a] -> STM a
396+ rr psVar = do
397+ ps <- readTVar psVar
398+ a <- foldr1 orElse ps
399+ writeTVar psVar (rotate ps)
400+ return a
401+
402+--------------------------------------------------------------------------------
403+-- Advanced messaging --
404+--------------------------------------------------------------------------------
405+
406+-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
407+newtype Match b = Match { unMatch :: MatchOn Message (Process b) }
408+ deriving (Functor)
409+
410+-- | Test the matches in order against each message in the queue
411+receiveWait :: [Match b] -> Process b
412+receiveWait ms = do
413+ queue <- processQueue <$> ask
414+ mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)
415+ case mProc of
416+ Just proc' -> proc'
417+ Nothing -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "
418+ ++ "in the absence of a timeout value."
419+
420+-- | Like 'receiveWait' but with a timeout.
421+--
422+-- If the timeout is zero do a non-blocking check for matching messages. A
423+-- non-zero timeout is applied only when waiting for incoming messages (that is,
424+-- /after/ we have checked the messages that are already in the mailbox).
425+receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
426+receiveTimeout t ms = do
427+ queue <- processQueue <$> ask
428+ let blockSpec = if t == 0 then NonBlocking else Timeout t
429+ mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)
430+ case mProc of
431+ Nothing -> return Nothing
432+ Just proc -> Just <$> proc
433+
434+-- | Match on a typed channel
435+matchChan :: ReceivePort a -> (a -> Process b) -> Match b
436+matchChan p fn = Match $ MatchChan (fmap fn (receiveSTM p))
437+
438+-- | Match on an arbitrary STM action.
439+--
440+-- This rather unusaul /match primitive/ allows us to compose arbitrary STM
441+-- actions with checks against our process' mailbox and/or any typed channel
442+-- @ReceivePort@s we may hold.
443+--
444+-- This allows us to process multiple input streams /along with our mailbox/,
445+-- in just the same way that 'matchChan' supports checking both the mailbox
446+-- /and/ an arbitrary set of typed channels in one atomic transaction.
447+--
448+-- Note there are no ordering guarnatees with respect to these disparate input
449+-- sources.
450+--
451+matchSTM :: STM a -> (a -> Process b) -> Match b
452+matchSTM stm fn = Match $ MatchChan (fmap fn stm)
453+
454+-- | Match against any message of the right type
455+match :: forall a b. Serializable a => (a -> Process b) -> Match b
456+match = matchIf (const True)
457+
458+-- | Match against any message of the right type that satisfies a predicate
459+matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
460+matchIf c p = Match $ MatchMsg $ \msg ->
461+ case messageFingerprint msg == fingerprint (undefined :: a) of
462+ False -> Nothing
463+ True -> case msg of
464+ (UnencodedMessage _ m) ->
465+ let m' = unsafeCoerce m :: a in
466+ case (c m') of
467+ True -> Just (p m')
468+ False -> Nothing
469+ (EncodedMessage _ _) ->
470+ if (c decoded) then Just (p decoded) else Nothing
471+ where
472+ decoded :: a
473+ -- Make sure the value is fully decoded so that we don't hang to
474+ -- bytestrings when the process calling 'matchIf' doesn't process
475+ -- the values immediately
476+ !decoded = decode (messageEncoding msg)
477+
478+-- | Match against any message, regardless of the underlying (contained) type
479+matchMessage :: (Message -> Process Message) -> Match Message
480+matchMessage p = Match $ MatchMsg $ \msg -> Just (p msg)
481+
482+-- | Match against any message (regardless of underlying type) that satisfies a predicate
483+matchMessageIf :: (Message -> Bool) -> (Message -> Process Message) -> Match Message
484+matchMessageIf c p = Match $ MatchMsg $ \msg ->
485+ case (c msg) of
486+ True -> Just (p msg)
487+ False -> Nothing
488+
489+-- | Forward a raw 'Message' to the given 'ProcessId'.
490+forward :: Message -> ProcessId -> Process ()
491+forward msg them = do
492+ proc <- ask
493+ let node = processNode proc
494+ us = processId proc
495+ nid = localNodeId node
496+ destNode = (processNodeId them) in do
497+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)
498+ if destNode == nid
499+ then sendCtrlMsg Nothing (LocalSend them msg)
500+ else liftIO $ sendPayload (processNode proc)
501+ (ProcessIdentifier (processId proc))
502+ (ProcessIdentifier them)
503+ NoImplicitReconnect
504+ (messageToPayload msg)
505+
506+-- | Forward a raw 'Message' to the given 'ProcessId'.
507+--
508+-- Unlike 'forward', this function is insensitive to 'reconnect'. It will
509+-- try to send the message regardless of the history of connection failures
510+-- between the nodes.
511+uforward :: Message -> ProcessId -> Process ()
512+uforward msg them = do
513+ proc <- ask
514+ let node = processNode proc
515+ us = processId proc
516+ nid = localNodeId node
517+ destNode = (processNodeId them) in do
518+ liftIO $ traceEvent (localEventBus node) (MxSent them us msg)
519+ if destNode == nid
520+ then sendCtrlMsg Nothing (LocalSend them msg)
521+ else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg
522+
523+-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are
524+-- 'Serializable' - like the datum they contain - but also note, deserialising
525+-- such a 'Message' will yield a 'Message', not the type within it! To obtain the
526+-- wrapped datum, use 'unwrapMessage' or 'handleMessage' with a specific type.
527+--
528+-- @
529+-- do
530+-- self <- getSelfPid
531+-- send self (wrapMessage "blah")
532+-- Nothing <- expectTimeout 1000000 :: Process (Maybe String)
533+-- (Just m) <- expectTimeout 1000000 :: Process (Maybe Message)
534+-- (Just "blah") <- unwrapMessage m :: Process (Maybe String)
535+-- @
536+--
537+wrapMessage :: Serializable a => a -> Message
538+wrapMessage = createUnencodedMessage -- see [note Serializable UnencodedMessage]
539+
540+-- | This is the /unsafe/ variant of 'wrapMessage'. See
541+-- "Control.Distributed.Process.UnsafePrimitives" for details.
542+unsafeWrapMessage :: Serializable a => a -> Message
543+unsafeWrapMessage = Unsafe.wrapMessage
544+
545+-- [note Serializable UnencodedMessage]
546+-- if we attempt to serialise an UnencodedMessage, it will be converted to an
547+-- EncodedMessage first, so we're ok here. See 'messageToPayload' in
548+-- Primitives.hs for the gory details
549+
550+-- | Attempt to unwrap a raw 'Message'.
551+-- If the type of the decoded message payload matches the expected type, the
552+-- value will be returned with @Just@, otherwise @Nothing@ indicates the types
553+-- do not match.
554+--
555+-- This expression, for example, will evaluate to @Nothing@
556+-- > unwrapMessage (wrapMessage "foobar") :: Process (Maybe Int)
557+--
558+-- Whereas this expression, will yield @Just "foo"@
559+-- > unwrapMessage (wrapMessage "foo") :: Process (Maybe String)
560+--
561+unwrapMessage :: forall m a. (Monad m, Serializable a) => Message -> m (Maybe a)
562+unwrapMessage msg =
563+ case messageFingerprint msg == fingerprint (undefined :: a) of
564+ False -> return Nothing :: m (Maybe a)
565+ True -> case msg of
566+ (UnencodedMessage _ ms) ->
567+ let ms' = unsafeCoerce ms :: a
568+ in return (Just ms')
569+ (EncodedMessage _ _) ->
570+ return (Just (decoded))
571+ where
572+ decoded :: a -- note [decoding]
573+ !decoded = decode (messageEncoding msg)
574+
575+-- | Attempt to handle a raw 'Message'.
576+-- If the type of the message matches the type of the first argument to
577+-- the supplied expression, then the message will be decoded and the expression
578+-- evaluated against its value. If this runtime type checking fails however,
579+-- @Nothing@ will be returned to indicate the fact. If the check succeeds and
580+-- evaluation proceeds, the resulting value with be wrapped with @Just@.
581+--
582+-- Intended for use in `catchesExit` and `matchAny` primitives.
583+--
584+handleMessage :: forall m a b. (Monad m, Serializable a)
585+ => Message -> (a -> m b) -> m (Maybe b)
586+handleMessage msg proc = handleMessageIf msg (const True) proc
587+
588+-- | Conditionally handle a raw 'Message'.
589+-- If the predicate @(a -> Bool)@ evaluates to @True@, invokes the supplied
590+-- handler, other returns @Nothing@ to indicate failure. See 'handleMessage'
591+-- for further information about runtime type checking.
592+--
593+handleMessageIf :: forall m a b . (Monad m, Serializable a)
594+ => Message
595+ -> (a -> Bool)
596+ -> (a -> m b)
597+ -> m (Maybe b)
598+handleMessageIf msg c proc = do
599+ case messageFingerprint msg == fingerprint (undefined :: a) of
600+ False -> return Nothing :: m (Maybe b)
601+ True -> case msg of
602+ (UnencodedMessage _ ms) ->
603+ let ms' = unsafeCoerce ms :: a in
604+ case (c ms') of
605+ True -> do { r <- proc ms'; return (Just r) }
606+ False -> return Nothing :: m (Maybe b)
607+ (EncodedMessage _ _) ->
608+ case (c decoded) of
609+ True -> do { r <- proc (decoded :: a); return (Just r) }
610+ False -> return Nothing :: m (Maybe b)
611+ where
612+ decoded :: a -- note [decoding]
613+ !decoded = decode (messageEncoding msg)
614+
615+-- | As 'handleMessage' but ignores result, which is useful if you don't
616+-- care whether or not the handler succeeded.
617+--
618+handleMessage_ :: forall m a . (Monad m, Serializable a)
619+ => Message -> (a -> m ()) -> m ()
620+handleMessage_ msg proc = handleMessageIf_ msg (const True) proc
621+
622+-- | Conditional version of 'handleMessage_'.
623+--
624+handleMessageIf_ :: forall m a . (Monad m, Serializable a)
625+ => Message
626+ -> (a -> Bool)
627+ -> (a -> m ())
628+ -> m ()
629+handleMessageIf_ msg c proc = handleMessageIf msg c proc >> return ()
630+
631+-- | Match against an arbitrary message. 'matchAny' removes the first available
632+-- message from the process mailbox. To handle arbitrary /raw/ messages once
633+-- removed from the mailbox, see 'handleMessage' and 'unwrapMessage'.
634+--
635+matchAny :: forall b. (Message -> Process b) -> Match b
636+matchAny p = Match $ MatchMsg $ \msg -> Just (p msg)
637+
638+-- | Match against an arbitrary message. Intended for use with 'handleMessage'
639+-- and 'unwrapMessage', this function /only/ removes a message from the process
640+-- mailbox, /if/ the supplied condition matches. The success (or failure) of
641+-- runtime type checks deferred to @handleMessage@ and friends is irrelevant
642+-- here, i.e., if the condition evaluates to @True@ then the message will
643+-- be removed from the process mailbox and decoded, but that does /not/
644+-- guarantee that an expression passed to @handleMessage@ will pass the
645+-- runtime type checks and therefore be evaluated.
646+--
647+matchAnyIf :: forall a b. (Serializable a)
648+ => (a -> Bool)
649+ -> (Message -> Process b)
650+ -> Match b
651+matchAnyIf c p = Match $ MatchMsg $ \msg ->
652+ case messageFingerprint msg == fingerprint (undefined :: a) of
653+ True | check -> Just (p msg)
654+ where
655+ check :: Bool
656+ !check =
657+ case msg of
658+ (EncodedMessage _ _) -> c decoded
659+ (UnencodedMessage _ m') -> c (unsafeCoerce m')
660+
661+ decoded :: a -- note [decoding]
662+ !decoded = decode (messageEncoding msg)
663+ _ -> Nothing
664+
665+{- note [decoding]
666+For an EncodedMessage, we need to ensure the value is fully decoded so that
667+we don't hang to bytestrings if the calling process doesn't evaluate
668+immediately. For UnencodedMessage we know (because the fingerprint comparison
669+succeeds) that unsafeCoerce will not fail.
670+-}
671+
672+-- | Remove any message from the queue
673+matchUnknown :: Process b -> Match b
674+matchUnknown p = Match $ MatchMsg (const (Just p))
675+
676+-- | Receives messages and forwards them to @pid@ if @p msg == True@.
677+delegate :: ProcessId -> (Message -> Bool) -> Process ()
678+delegate pid p = do
679+ receiveWait [
680+ matchAny (\m -> case (p m) of
681+ True -> forward m pid
682+ False -> return ())
683+ ]
684+ delegate pid p
685+
686+-- | A straight relay that forwards all messages to the supplied pid.
687+relay :: ProcessId -> Process ()
688+relay !pid = receiveWait [ matchAny (\m -> forward m pid) ] >> relay pid
689+
690+-- | Proxies @pid@ and forwards messages whenever @proc@ evaluates to @True@.
691+-- Unlike 'delegate' the predicate @proc@ runs in the 'Process' monad, allowing
692+-- for richer proxy behaviour. If @proc@ returns @False@ or the /runtime type check/
693+-- fails, no action is taken and the proxy process will continue running.
694+proxy :: Serializable a => ProcessId -> (a -> Process Bool) -> Process ()
695+proxy pid proc = do
696+ receiveWait [
697+ matchAny (\m -> do
698+ next <- handleMessage m proc
699+ case next of
700+ Just True -> forward m pid
701+ Just False -> return () -- explicitly ignored
702+ Nothing -> return ()) -- un-routable
703+ ]
704+ proxy pid proc
705+
706+--------------------------------------------------------------------------------
707+-- Process management --
708+--------------------------------------------------------------------------------
709+
710+-- | Thrown by 'terminate'
711+data ProcessTerminationException = ProcessTerminationException
712+ deriving (Show, Typeable)
713+
714+instance Exception ProcessTerminationException
715+
716+-- | Terminate immediately (throws a ProcessTerminationException)
717+terminate :: Process a
718+terminate = throwM ProcessTerminationException
719+
720+-- [Issue #110]
721+-- | Die immediately - throws a 'ProcessExitException' with the given @reason@.
722+die :: Serializable a => a -> Process b
723+die reason = do
724+-- NOTE: We do /not/ want to use UnencodedMessage here, as the exception
725+-- could be decoded by a handler passed to 'catchExit', re-thrown or even
726+-- passed to another process via the tracing mechanism.
727+ pid <- getSelfPid
728+ throwM (ProcessExitException pid (createMessage reason))
729+
730+-- | Forceful request to kill a process. Where 'exit' provides an exception
731+-- that can be caught and handled, 'kill' throws an unexposed exception type
732+-- which cannot be handled explicitly (by type).
733+kill :: ProcessId -> String -> Process ()
734+-- NOTE: We send the message to our local node controller, which will then
735+-- forward it to a remote node controller (if applicable). Sending it directly
736+-- to a remote node controller means that that the message may overtake a
737+-- 'monitor' or 'link' request.
738+kill them reason = sendCtrlMsg Nothing (Kill them reason)
739+
740+-- | Graceful request to exit a process. Throws 'ProcessExitException' with the
741+-- supplied @reason@ encoded as a message. Any /exit signal/ raised in this
742+-- manner can be handled using the 'catchExit' family of functions.
743+exit :: Serializable a => ProcessId -> a -> Process ()
744+-- NOTE: We send the message to our local node controller, which will then
745+-- forward it to a remote node controller (if applicable). Sending it directly
746+-- to a remote node controller means that that the message may overtake a
747+-- 'monitor' or 'link' request.
748+exit them reason = sendCtrlMsg Nothing (Exit them (createMessage reason))
749+
750+-- | Catches 'ProcessExitException'. The handler will not be applied unless its
751+-- type matches the encoded data stored in the exception (see the /reason/
752+-- argument given to the 'exit' primitive). If the handler cannot be applied,
753+-- the exception will be re-thrown.
754+--
755+-- To handle 'ProcessExitException' without regard for /reason/, see 'catch'.
756+-- To handle multiple /reasons/ of differing types, see 'catchesExit'.
757+catchExit :: forall a b . (Show a, Serializable a)
758+ => Process b
759+ -> (ProcessId -> a -> Process b)
760+ -> Process b
761+catchExit act exitHandler = Catch.catch act handleExit
762+ where
763+ handleExit ex@(ProcessExitException from msg) =
764+ if messageFingerprint msg == fingerprint (undefined :: a)
765+ then exitHandler from decoded
766+ else throwM ex
767+ where
768+ decoded :: a
769+ -- Make sure the value is fully decoded so that we don't hang to
770+ -- bytestrings if the caller doesn't use the value immediately
771+ !decoded = decode (messageEncoding msg)
772+
773+-- | Lift 'Control.Exception.catches' (almost).
774+--
775+-- As 'ProcessExitException' stores the exit @reason@ as a typed, encoded
776+-- message, a handler must accept inputs of the expected type. In order to
777+-- handle a list of potentially different handlers (and therefore input types),
778+-- a handler passed to 'catchesExit' must accept 'Message' and return
779+-- @Maybe@ (i.e., @Just p@ if it handled the exit reason, otherwise @Nothing@).
780+--
781+-- See 'maybeHandleMessage' and 'Message' for more details.
782+catchesExit :: Process b
783+ -> [(ProcessId -> Message -> (Process (Maybe b)))]
784+ -> Process b
785+catchesExit act handlers = Catch.catch act ((flip handleExit) handlers)
786+ where
787+ handleExit :: ProcessExitException
788+ -> [(ProcessId -> Message -> Process (Maybe b))]
789+ -> Process b
790+ handleExit ex [] = throwM ex
791+ handleExit ex@(ProcessExitException from msg) (h:hs) = do
792+ r <- h from msg
793+ case r of
794+ Nothing -> handleExit ex hs
795+ Just p -> return p
796+
797+-- | Our own process ID
798+getSelfPid :: Process ProcessId
799+getSelfPid = processId <$> ask
800+
801+-- | Get the node ID of our local node
802+getSelfNode :: Process NodeId
803+getSelfNode = localNodeId . processNode <$> ask
804+
805+
806+-- | Get statistics about the specified node
807+getNodeStats :: NodeId -> Process (Either DiedReason NodeStats)
808+getNodeStats nid = do
809+ selfNode <- getSelfNode
810+ if nid == selfNode
811+ then Right `fmap` getLocalNodeStats -- optimisation
812+ else getNodeStatsRemote selfNode
813+ where
814+ getNodeStatsRemote :: NodeId -> Process (Either DiedReason NodeStats)
815+ getNodeStatsRemote selfNode = do
816+ sendCtrlMsg (Just nid) $ GetNodeStats selfNode
817+ bracket (monitorNode nid) unmonitor $ \mRef ->
818+ receiveWait [ match (\(stats :: NodeStats) -> return $ Right stats)
819+ , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)
820+ (\(NodeMonitorNotification _ _ dr) -> return $ Left dr)
821+ ]
822+
823+-- | Get statistics about our local node
824+getLocalNodeStats :: Process NodeStats
825+getLocalNodeStats = do
826+ self <- getSelfNode
827+ sendCtrlMsg Nothing $ GetNodeStats self
828+ receiveWait [ match (\(stats :: NodeStats) -> return stats) ]
829+
830+-- | Get information about the specified process
831+getProcessInfo :: ProcessId -> Process (Maybe ProcessInfo)
832+getProcessInfo pid =
833+ let them = processNodeId pid in do
834+ us <- getSelfNode
835+ dest <- mkNode them us
836+ sendCtrlMsg dest $ GetInfo pid
837+ receiveWait [
838+ match (\(p :: ProcessInfo) -> return $ Just p)
839+ , match (\(_ :: ProcessInfoNone) -> return Nothing)
840+ ]
841+ where mkNode :: NodeId -> NodeId -> Process (Maybe NodeId)
842+ mkNode them us = case them == us of
843+ True -> return Nothing
844+ _ -> return $ Just them
845+
846+--------------------------------------------------------------------------------
847+-- Monitoring and linking --
848+--------------------------------------------------------------------------------
849+
850+-- | Link to a remote process (asynchronous)
851+--
852+-- When process A links to process B (that is, process A calls
853+-- @link pidB@) then an asynchronous exception will be thrown to process A
854+-- when process B terminates (normally or abnormally), or when process A gets
855+-- disconnected from process B. Although it is /technically/ possible to catch
856+-- these exceptions, chances are if you find yourself trying to do so you should
857+-- probably be using 'monitor' rather than 'link'. In particular, code such as
858+--
859+-- > link pidB -- Link to process B
860+-- > expect -- Wait for a message from process B
861+-- > unlink pidB -- Unlink again
862+--
863+-- doesn't quite do what one might expect: if process B sends a message to
864+-- process A, and /subsequently terminates/, then process A might or might not
865+-- be terminated too, depending on whether the exception is thrown before or
866+-- after the 'unlink' (i.e., this code has a race condition).
867+--
868+-- Linking is all-or-nothing: A is either linked to B, or it's not. A second
869+-- call to 'link' has no effect.
870+--
871+-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').
872+-- Linking makes no distinction between normal and abnormal termination of
873+-- the remote process.
874+link :: ProcessId -> Process ()
875+link = sendCtrlMsg Nothing . Link . ProcessIdentifier
876+
877+-- | Monitor another process (asynchronous)
878+--
879+-- When process A monitors process B (that is, process A calls
880+-- @monitor pidB@) then process A will receive a 'ProcessMonitorNotification'
881+-- when process B terminates (normally or abnormally), or when process A gets
882+-- disconnected from process B. You receive this message like any other (using
883+-- 'expect'); the notification includes a reason ('DiedNormal', 'DiedException',
884+-- 'DiedDisconnect', etc.).
885+--
886+-- Every call to 'monitor' returns a new monitor reference 'MonitorRef'; if
887+-- multiple monitors are set up, multiple notifications will be delivered
888+-- and monitors can be disabled individually using 'unmonitor'.
889+monitor :: ProcessId -> Process MonitorRef
890+monitor = monitor' . ProcessIdentifier
891+
892+-- | Establishes temporary monitoring of another process.
893+--
894+-- @withMonitor pid code@ sets up monitoring of @pid@ for the duration
895+-- of @code@. Note: although monitoring is no longer active when
896+-- @withMonitor@ returns, there might still be unreceived monitor
897+-- messages in the queue.
898+--
899+withMonitor :: ProcessId -> (MonitorRef -> Process a) -> Process a
900+withMonitor pid = bracket (monitor pid) unmonitor
901+
902+-- | Establishes temporary monitoring of another process.
903+--
904+-- @withMonitor_ pid code@ sets up monitoring of @pid@ for the duration
905+-- of @code@. Note: although monitoring is no longer active when
906+-- @withMonitor_@ returns, there might still be unreceived monitor
907+-- messages in the queue.
908+--
909+-- Since 0.6.1
910+withMonitor_ :: ProcessId -> Process a -> Process a
911+withMonitor_ p = withMonitor p . const
912+
913+-- | Remove a link
914+--
915+-- This is synchronous in the sense that once it returns you are guaranteed
916+-- that no exception will be raised if the remote process dies. However, it is
917+-- asynchronous in the sense that we do not wait for a response from the remote
918+-- node.
919+unlink :: ProcessId -> Process ()
920+unlink pid = do
921+ unlinkAsync pid
922+ receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
923+ (\_ -> return ())
924+ ]
925+
926+-- | Remove a node link
927+--
928+-- This has the same synchronous/asynchronous nature as 'unlink'.
929+unlinkNode :: NodeId -> Process ()
930+unlinkNode nid = do
931+ unlinkNodeAsync nid
932+ receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)
933+ (\_ -> return ())
934+ ]
935+
936+-- | Remove a channel (send port) link
937+--
938+-- This has the same synchronous/asynchronous nature as 'unlink'.
939+unlinkPort :: SendPort a -> Process ()
940+unlinkPort sport = do
941+ unlinkPortAsync sport
942+ receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)
943+ (\_ -> return ())
944+ ]
945+
946+-- | Remove a monitor
947+--
948+-- This has the same synchronous/asynchronous nature as 'unlink'.
949+--
950+-- ProcessMonitorNotification messages for the given MonitorRef are removed from
951+-- the mailbox.
952+unmonitor :: MonitorRef -> Process ()
953+unmonitor ref = do
954+ unmonitorAsync ref
955+ receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)
956+ (\_ -> return ())
957+ ]
958+ -- Discard the notification if any. With the current NC implementation at most
959+ -- one notification is in the mailbox for any given ref.
960+ void $ receiveTimeout 0
961+ [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == ref)
962+ (const $ return ())
963+ ]
964+
965+--------------------------------------------------------------------------------
966+-- Exception handling --
967+--------------------------------------------------------------------------------
968+
969+-- | Lift 'Control.Exception.catch'
970+catch :: Exception e => Process a -> (e -> Process a) -> Process a
971+catch = Catch.catch
972+{-# DEPRECATED catch "Use Control.Monad.Catch.catch instead" #-}
973+
974+-- | Lift 'Control.Exception.try'
975+try :: Exception e => Process a -> Process (Either e a)
976+try = Catch.try
977+{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}
978+
979+-- | Lift 'Control.Exception.mask'
980+mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b
981+mask = Catch.mask
982+{-# DEPRECATED mask "Use Control.Monad.Catch.mask_ instead" #-}
983+
984+-- | Lift 'Control.Exception.mask_'
985+mask_ :: Process a -> Process a
986+mask_ = Catch.mask_
987+{-# DEPRECATED mask_ "Use Control.Monad.Catch.mask_ instead" #-}
988+
989+-- | Lift 'Control.Exception.onException'
990+onException :: Process a -> Process b -> Process a
991+onException = Catch.onException
992+{-# DEPRECATED onException "Use Control.Monad.Catch.onException instead" #-}
993+
994+-- | Lift 'Control.Exception.bracket'
995+bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c
996+bracket = Catch.bracket
997+{-# DEPRECATED bracket "Use Control.Monad.Catch.bracket instead" #-}
998+
999+-- | Lift 'Control.Exception.bracket_'
1000+bracket_ :: Process a -> Process b -> Process c -> Process c
1001+bracket_ = Catch.bracket_
1002+{-# DEPRECATED bracket_ "Use Control.Monad.Catch.bracket_ instead" #-}
1003+
1004+-- | Lift 'Control.Exception.finally'
1005+finally :: Process a -> Process b -> Process a
1006+finally = Catch.finally
1007+{-# DEPRECATED finally "Use Control.Monad.Catch.finally instead" #-}
1008+
1009+-- | You need this when using 'catches'
1010+data Handler a = forall e . Exception e => Handler (e -> Process a)
1011+
1012+instance Functor Handler where
1013+ fmap f (Handler h) = Handler (fmap f . h)
1014+
1015+-- | Lift 'Control.Exception.catches'
1016+catches :: Process a -> [Handler a] -> Process a
1017+catches proc handlers = proc `Catch.catch` catchesHandler handlers
1018+
1019+catchesHandler :: [Handler a] -> SomeException -> Process a
1020+catchesHandler handlers e = foldr tryHandler (throwM e) handlers
1021+ where tryHandler (Handler handler) res
1022+ = case fromException e of
1023+ Just e' -> handler e'
1024+ Nothing -> res
1025+
1026+--------------------------------------------------------------------------------
1027+-- Auxiliary API --
1028+--------------------------------------------------------------------------------
1029+
1030+-- | Like 'expect' but with a timeout
1031+expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
1032+expectTimeout n = receiveTimeout n [match return]
1033+
1034+-- | Asynchronous version of 'spawn'
1035+--
1036+-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
1037+spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
1038+spawnAsync nid proc = do
1039+ spawnRef <- getSpawnRef
1040+ node <- getSelfNode
1041+ if nid == node
1042+ then sendCtrlMsg Nothing $ Spawn proc spawnRef
1043+ else sendCtrlMsg (Just nid) $ Spawn proc spawnRef
1044+ return spawnRef
1045+
1046+-- | Monitor a node (asynchronous)
1047+monitorNode :: NodeId -> Process MonitorRef
1048+monitorNode =
1049+ monitor' . NodeIdentifier
1050+
1051+-- | Monitor a typed channel (asynchronous)
1052+monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
1053+monitorPort (SendPort cid) =
1054+ monitor' (SendPortIdentifier cid)
1055+
1056+-- | Remove a monitor (asynchronous)
1057+unmonitorAsync :: MonitorRef -> Process ()
1058+unmonitorAsync =
1059+ sendCtrlMsg Nothing . Unmonitor
1060+
1061+-- | Link to a node (asynchronous)
1062+linkNode :: NodeId -> Process ()
1063+linkNode = link' . NodeIdentifier
1064+
1065+-- | Link to a channel (asynchronous)
1066+linkPort :: SendPort a -> Process ()
1067+linkPort (SendPort cid) =
1068+ link' (SendPortIdentifier cid)
1069+
1070+-- | Remove a process link (asynchronous)
1071+unlinkAsync :: ProcessId -> Process ()
1072+unlinkAsync =
1073+ sendCtrlMsg Nothing . Unlink . ProcessIdentifier
1074+
1075+-- | Remove a node link (asynchronous)
1076+unlinkNodeAsync :: NodeId -> Process ()
1077+unlinkNodeAsync =
1078+ sendCtrlMsg Nothing . Unlink . NodeIdentifier
1079+
1080+-- | Remove a channel (send port) link (asynchronous)
1081+unlinkPortAsync :: SendPort a -> Process ()
1082+unlinkPortAsync (SendPort cid) =
1083+ sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
1084+
1085+--------------------------------------------------------------------------------
1086+-- Logging --
1087+--------------------------------------------------------------------------------
1088+
1089+data SayMessage = SayMessage { sayTime :: UTCTime
1090+ , sayProcess :: ProcessId
1091+ , sayMessage :: String }
1092+ deriving (Typeable)
1093+
1094+-- There is sadly no Show UTCTime instance
1095+instance Show SayMessage where
1096+ showsPrec p msg =
1097+ showParen (p >= 11)
1098+ $ showString "SayMessage "
1099+ . showString (formatTime defaultTimeLocale "%c" (sayTime msg))
1100+ . showChar ' '
1101+ . showsPrec 11 (sayProcess msg) . showChar ' '
1102+ . showsPrec 11 (sayMessage msg) . showChar ' '
1103+
1104+instance Binary SayMessage where
1105+ put s = do
1106+ putUTCTime (sayTime s)
1107+ put (sayProcess s)
1108+ put (sayMessage s)
1109+ get = SayMessage <$> getUTCTime <*> get <*> get
1110+
1111+-- Sadly there is no Binary UTCTime instance
1112+putUTCTime :: UTCTime -> Put
1113+putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do
1114+ put day
1115+ put (toRational tod)
1116+
1117+getUTCTime :: Get UTCTime
1118+getUTCTime = do
1119+ day <- get
1120+ tod <- get
1121+ return $! UTCTime (ModifiedJulianDay day)
1122+ (fromRational tod)
1123+
1124+-- | Log a string
1125+--
1126+-- @say message@ sends a message of type 'SayMessage' with the current time and
1127+-- 'ProcessId' of the current process to the process registered as @logger@. By
1128+-- default, this process simply sends the string to @stderr@. Individual Cloud
1129+-- Haskell backends might replace this with a different logger process, however.
1130+say :: String -> Process ()
1131+say string = do
1132+ now <- liftIO getCurrentTime
1133+ us <- getSelfPid
1134+ nsend "logger" (SayMessage now us string)
1135+
1136+--------------------------------------------------------------------------------
1137+-- Registry --
1138+--------------------------------------------------------------------------------
1139+
1140+-- | Register a process with the local registry (synchronous). The name must not
1141+-- already be registered. The process need not be on this node. A bad
1142+-- registration will result in a 'ProcessRegistrationException'
1143+--
1144+-- The process to be registered does not have to be local itself.
1145+register :: String -> ProcessId -> Process ()
1146+register = registerImpl False
1147+
1148+-- | Like 'register', but will replace an existing registration.
1149+-- The name must already be registered.
1150+reregister :: String -> ProcessId -> Process ()
1151+reregister = registerImpl True
1152+
1153+registerImpl :: Bool -> String -> ProcessId -> Process ()
1154+registerImpl force label pid = do
1155+ mynid <- getSelfNode
1156+ sendCtrlMsg Nothing (Register label mynid (Just pid) force)
1157+ receiveWait
1158+ [ matchIf (\(RegisterReply label' _ _) -> label == label')
1159+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)
1160+ ]
1161+
1162+-- | Register a process with a remote registry (asynchronous).
1163+--
1164+-- The process to be registered does not have to live on the same remote node.
1165+-- Reply wil come in the form of a 'RegisterReply' message
1166+--
1167+-- See comments in 'whereisRemoteAsync'
1168+registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
1169+registerRemoteAsync nid label pid = do
1170+ here <- getSelfNode
1171+ sendCtrlMsg (if nid == here then Nothing else Just nid)
1172+ (Register label nid (Just pid) False)
1173+
1174+reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
1175+reregisterRemoteAsync nid label pid =
1176+ sendCtrlMsg (Just nid) (Register label nid (Just pid) True)
1177+
1178+-- | Remove a process from the local registry (asynchronous).
1179+-- This version will wait until a response is gotten from the
1180+-- management process. The name must already be registered.
1181+unregister :: String -> Process ()
1182+unregister label = do
1183+ mynid <- getSelfNode
1184+ sendCtrlMsg Nothing (Register label mynid Nothing False)
1185+ receiveWait
1186+ [ matchIf (\(RegisterReply label' _ _) -> label == label')
1187+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)
1188+ ]
1189+
1190+-- | Deal with the result from an attempted registration or unregistration
1191+-- by throwing an exception if necessary
1192+handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process ()
1193+handleRegistrationReply label ok owner =
1194+ when (not ok) $
1195+ throwM $ ProcessRegistrationException label owner
1196+
1197+-- | Remove a process from a remote registry (asynchronous).
1198+--
1199+-- Reply wil come in the form of a 'RegisterReply' message
1200+--
1201+-- See comments in 'whereisRemoteAsync'
1202+unregisterRemoteAsync :: NodeId -> String -> Process ()
1203+unregisterRemoteAsync nid label =
1204+ sendCtrlMsg (Just nid) (Register label nid Nothing False)
1205+
1206+-- | Query the local process registry
1207+whereis :: String -> Process (Maybe ProcessId)
1208+whereis label = do
1209+ sendCtrlMsg Nothing (WhereIs label)
1210+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
1211+ (\(WhereIsReply _ mPid) -> return mPid)
1212+ ]
1213+
1214+-- | Query a remote process registry (asynchronous)
1215+--
1216+-- Reply will come in the form of a 'WhereIsReply' message.
1217+--
1218+-- There is currently no synchronous version of 'whereisRemoteAsync': if
1219+-- you implement one yourself, be sure to take into account that the remote
1220+-- node might die or get disconnect before it can respond (i.e. you should
1221+-- use 'monitorNode' and take appropriate action when you receive a
1222+-- 'NodeMonitorNotification').
1223+whereisRemoteAsync :: NodeId -> String -> Process ()
1224+whereisRemoteAsync nid label = do
1225+ here <- getSelfNode
1226+ sendCtrlMsg (if nid == here then Nothing else Just nid) (WhereIs label)
1227+
1228+-- | Named send to a process in the local registry (asynchronous)
1229+nsend :: Serializable a => String -> a -> Process ()
1230+nsend label msg = do
1231+ proc <- ask
1232+ let msg' = createUnencodedMessage msg
1233+ liftIO $ traceEvent (localEventBus (processNode proc))
1234+ (MxSentToName label (processId proc) msg')
1235+ sendCtrlMsg Nothing (NamedSend label msg')
1236+
1237+-- | Named send to a process in the local registry (asynchronous).
1238+-- This function makes /no/ attempt to serialize and (in the case when the
1239+-- destination process resides on the same local node) therefore ensure that
1240+-- the payload is fully evaluated before it is delivered.
1241+unsafeNSend :: Serializable a => String -> a -> Process ()
1242+unsafeNSend = Unsafe.nsend
1243+
1244+-- | Named send to a process in a remote registry (asynchronous)
1245+nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
1246+nsendRemote nid label msg = do
1247+ proc <- ask
1248+ let us = processId proc
1249+ let node = processNode proc
1250+ if localNodeId node == nid
1251+ then nsend label msg
1252+ else let lbl = label ++ "@" ++ show nid in do
1253+ liftIO $ traceEvent (localEventBus node)
1254+ (MxSentToName lbl us (wrapMessage msg))
1255+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
1256+
1257+-- | Named send to a process in a remote registry (asynchronous)
1258+-- This function makes /no/ attempt to serialize and (in the case when the
1259+-- destination process resides on the same local node) therefore ensure that
1260+-- the payload is fully evaluated before it is delivered.
1261+unsafeNSendRemote :: Serializable a => NodeId -> String -> a -> Process ()
1262+unsafeNSendRemote = Unsafe.nsendRemote
1263+
1264+--------------------------------------------------------------------------------
1265+-- Closures --
1266+--------------------------------------------------------------------------------
1267+
1268+-- | Resolve a static value
1269+unStatic :: Typeable a => Static a -> Process a
1270+unStatic static = do
1271+ rtable <- remoteTable . processNode <$> ask
1272+ case Static.unstatic rtable static of
1273+ Left err -> fail $ "Could not resolve static value: " ++ err
1274+ Right x -> return x
1275+
1276+-- | Resolve a closure
1277+unClosure :: Typeable a => Closure a -> Process a
1278+unClosure closure = do
1279+ rtable <- remoteTable . processNode <$> ask
1280+ case Static.unclosure rtable closure of
1281+ Left err -> fail $ "Could not resolve closure: " ++ err
1282+ Right x -> return x
1283+
1284+--------------------------------------------------------------------------------
1285+-- Reconnecting --
1286+--------------------------------------------------------------------------------
1287+
1288+-- | Cloud Haskell provides the illusion of connection-less, reliable, ordered
1289+-- message passing. However, when network connections get disrupted this
1290+-- illusion cannot always be maintained. Once a network connection breaks (even
1291+-- temporarily) no further communication on that connection will be possible.
1292+-- For example, if process A sends a message to process B, and A is then
1293+-- notified (by monitor notification) that it got disconnected from B, A will
1294+-- not be able to send any further messages to B, /unless/ A explicitly
1295+-- indicates that it is acceptable to attempt to reconnect to B using the
1296+-- Cloud Haskell 'reconnect' primitive.
1297+--
1298+-- Importantly, when A calls 'reconnect' it acknowledges that some messages to
1299+-- B might have been lost. For instance, if A sends messages m1 and m2 to B,
1300+-- then receives a monitor notification that its connection to B has been lost,
1301+-- calls 'reconnect' and then sends m3, it is possible that B will receive m1
1302+-- and m3 but not m2.
1303+--
1304+-- Note that 'reconnect' does not mean /reconnect now/ but rather /it is okay
1305+-- to attempt to reconnect on the next send/. In particular, if no further
1306+-- communication attempts are made to B then A can use reconnect to clean up
1307+-- its connection to B.
1308+reconnect :: ProcessId -> Process ()
1309+reconnect them = do
1310+ us <- getSelfPid
1311+ node <- processNode <$> ask
1312+ liftIO $ disconnect node (ProcessIdentifier us) (ProcessIdentifier them)
1313+
1314+-- | Reconnect to a sendport. See 'reconnect' for more information.
1315+reconnectPort :: SendPort a -> Process ()
1316+reconnectPort them = do
1317+ us <- getSelfPid
1318+ node <- processNode <$> ask
1319+ liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))
1320+
1321+--------------------------------------------------------------------------------
1322+-- Auxiliary functions --
1323+--------------------------------------------------------------------------------
1324+
1325+sendLocal :: (Serializable a) => ProcessId -> a -> Process ()
1326+sendLocal to msg =
1327+ sendCtrlMsg Nothing $ LocalSend to (createUnencodedMessage msg)
1328+
1329+sendChanLocal :: (Serializable a) => SendPortId -> a -> Process ()
1330+sendChanLocal spId msg =
1331+ -- we *must* fully serialize/encode the message here, because
1332+ -- attempting to use `unsafeCoerce' in the node controller
1333+ -- won't work since we know nothing about the required type
1334+ sendCtrlMsg Nothing $ LocalPortSend spId (createUnencodedMessage msg)
1335+
1336+getMonitorRefFor :: Identifier -> Process MonitorRef
1337+getMonitorRefFor ident = do
1338+ proc <- ask
1339+ liftIO $ modifyMVar (processState proc) $ \st -> do
1340+ let counter = st ^. monitorCounter
1341+ return ( monitorCounter ^: (+ 1) $ st
1342+ , MonitorRef ident counter
1343+ )
1344+
1345+getSpawnRef :: Process SpawnRef
1346+getSpawnRef = do
1347+ proc <- ask
1348+ liftIO $ modifyMVar (processState proc) $ \st -> do
1349+ let counter = st ^. spawnCounter
1350+ return ( spawnCounter ^: (+ 1) $ st
1351+ , SpawnRef counter
1352+ )
1353+
1354+-- | Monitor a process/node/channel
1355+monitor' :: Identifier -> Process MonitorRef
1356+monitor' ident = do
1357+ monitorRef <- getMonitorRefFor ident
1358+ sendCtrlMsg Nothing $ Monitor monitorRef
1359+ return monitorRef
1360+
1361+-- | Link to a process/node/channel
1362+link' :: Identifier -> Process ()
1363+link' = sendCtrlMsg Nothing . Link
src/Control/Distributed/Process/Internal/Spawn.hsnew file+165
@@ -0,0 +1,165 @@
1+{-# LANGUAGE RankNTypes #-}
2+module Control.Distributed.Process.Internal.Spawn
3+ ( spawn
4+ , spawnLink
5+ , spawnMonitor
6+ , call
7+ , spawnSupervised
8+ , spawnChannel
9+ ) where
10+
11+import Control.Distributed.Static
12+ ( Static
13+ , Closure
14+ , closureCompose
15+ , staticClosure
16+ )
17+import Control.Distributed.Process.Internal.Types
18+ ( NodeId(..)
19+ , ProcessId(..)
20+ , Process(..)
21+ , MonitorRef(..)
22+ , ProcessMonitorNotification(..)
23+ , NodeMonitorNotification(..)
24+ , DidSpawn(..)
25+ , SendPort(..)
26+ , ReceivePort(..)
27+ , nullProcessId
28+ )
29+import Control.Distributed.Process.Serializable (Serializable, SerializableDict)
30+import Control.Distributed.Process.Internal.Closure.BuiltIn
31+ ( sdictSendPort
32+ , sndStatic
33+ , idCP
34+ , seqCP
35+ , bindCP
36+ , splitCP
37+ , cpLink
38+ , cpSend
39+ , cpNewChan
40+ , cpDelayed
41+ , returnCP
42+ , sdictUnit
43+ )
44+import Control.Distributed.Process.Internal.Primitives
45+ ( -- Basic messaging
46+ usend
47+ , expect
48+ , receiveWait
49+ , match
50+ , matchIf
51+ , link
52+ , getSelfPid
53+ , monitor
54+ , monitorNode
55+ , unmonitor
56+ , spawnAsync
57+ , reconnect
58+ )
59+
60+-- | Spawn a process
61+--
62+-- For more information about 'Closure', see
63+-- "Control.Distributed.Process.Closure".
64+--
65+-- See also 'call'.
66+spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
67+spawn nid proc = do
68+ us <- getSelfPid
69+ mRef <- monitorNode nid
70+ sRef <- spawnAsync nid (cpDelayed us proc)
71+ receiveWait [
72+ matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do
73+ unmonitor mRef
74+ usend pid ()
75+ return pid
76+ , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) $ \_ ->
77+ return (nullProcessId nid)
78+ ]
79+
80+-- | Spawn a process and link to it
81+--
82+-- Note that this is just the sequential composition of 'spawn' and 'link'.
83+-- (The "Unified" semantics that underlies Cloud Haskell does not even support
84+-- a synchronous link operation)
85+spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
86+spawnLink nid proc = do
87+ pid <- spawn nid proc
88+ link pid
89+ return pid
90+
91+-- | Like 'spawnLink', but monitor the spawned process
92+spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
93+spawnMonitor nid proc = do
94+ pid <- spawn nid proc
95+ ref <- monitor pid
96+ return (pid, ref)
97+
98+-- | Run a process remotely and wait for it to reply
99+--
100+-- We monitor the remote process: if it dies before it can send a reply, we die
101+-- too.
102+--
103+-- For more information about 'Static', 'SerializableDict', and 'Closure', see
104+-- "Control.Distributed.Process.Closure".
105+--
106+-- See also 'spawn'.
107+call :: Serializable a
108+ => Static (SerializableDict a)
109+ -> NodeId
110+ -> Closure (Process a)
111+ -> Process a
112+call dict nid proc = do
113+ us <- getSelfPid
114+ (pid, mRef) <- spawnMonitor nid (proc `bindCP`
115+ cpSend dict us `seqCP`
116+ -- Delay so the process does not terminate
117+ -- before the response arrives.
118+ cpDelayed us (returnCP sdictUnit ())
119+ )
120+ mResult <- receiveWait
121+ [ match $ \a -> usend pid () >> return (Right a)
122+ , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
123+ (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))
124+ ]
125+ case mResult of
126+ Right a -> do
127+ -- Wait for the monitor message so that we the mailbox doesn't grow
128+ receiveWait
129+ [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
130+ (\(ProcessMonitorNotification {}) -> return ())
131+ ]
132+ -- Clean up connection to pid
133+ reconnect pid
134+ return a
135+ Left err ->
136+ fail $ "call: remote process died: " ++ show err
137+
138+-- | Spawn a child process, have the child link to the parent and the parent
139+-- monitor the child
140+spawnSupervised :: NodeId
141+ -> Closure (Process ())
142+ -> Process (ProcessId, MonitorRef)
143+spawnSupervised nid proc = do
144+ us <- getSelfPid
145+ them <- spawn nid (cpLink us `seqCP` proc)
146+ ref <- monitor them
147+ return (them, ref)
148+
149+-- | Spawn a new process, supplying it with a new 'ReceivePort' and return
150+-- the corresponding 'SendPort'.
151+spawnChannel :: forall a. Serializable a => Static (SerializableDict a)
152+ -> NodeId
153+ -> Closure (ReceivePort a -> Process ())
154+ -> Process (SendPort a)
155+spawnChannel dict nid proc = do
156+ us <- getSelfPid
157+ _ <- spawn nid (go us)
158+ expect
159+ where
160+ go :: ProcessId -> Closure (Process ())
161+ go pid = cpNewChan dict
162+ `bindCP`
163+ (cpSend (sdictSendPort dict) pid `splitCP` proc)
164+ `bindCP`
165+ (idCP `closureCompose` staticClosure sndStatic)
src/Control/Distributed/Process/Internal/StrictContainerAccessors.hsnew file+21
@@ -0,0 +1,21 @@
1+module Control.Distributed.Process.Internal.StrictContainerAccessors
2+ ( mapMaybe
3+ , mapDefault
4+ ) where
5+
6+import Prelude hiding (map)
7+import Data.Accessor
8+import Data.Map (Map)
9+import qualified Data.Map as Map (lookup, insert, delete, findWithDefault)
10+
11+mapMaybe :: Ord key => key -> Accessor (Map key elem) (Maybe elem)
12+mapMaybe key = accessor
13+ (Map.lookup key)
14+ (\mVal map -> case mVal of
15+ Nothing -> Map.delete key map
16+ Just val -> val `seq` Map.insert key val map)
17+
18+mapDefault :: Ord key => elem -> key -> Accessor (Map key elem) elem
19+mapDefault def key = accessor
20+ (Map.findWithDefault def key)
21+ (\val map -> val `seq` Map.insert key val map)
src/Control/Distributed/Process/Internal/StrictList.hsnew file+27
@@ -0,0 +1,27 @@
1+-- | Spine and element strict list
2+module Control.Distributed.Process.Internal.StrictList
3+ ( StrictList(..)
4+ , append
5+ , foldr
6+ ) where
7+
8+import Prelude hiding (length, reverse, foldr)
9+
10+-- | Strict list
11+data StrictList a
12+ = Cons !a !(StrictList a)
13+ | Nil
14+ | Snoc !(StrictList a) !a
15+ | Append !(StrictList a) !(StrictList a)
16+
17+append :: StrictList a -> StrictList a -> StrictList a
18+append Nil l = l
19+append l Nil = l
20+append l1 l2 = l1 `Append` l2
21+
22+foldr :: (a -> b -> b) -> b -> StrictList a -> b
23+foldr f c0 xs0 = go xs0 c0
24+ where go Nil c = c
25+ go (Cons x xs) c = f x (go xs c)
26+ go (Snoc xs x) c = go xs (f x c)
27+ go (Append xs ys) c = go xs (go ys c)
src/Control/Distributed/Process/Internal/StrictMVar.hsnew file+93
@@ -0,0 +1,93 @@
1+-- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF
2+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
3+module Control.Distributed.Process.Internal.StrictMVar
4+ ( StrictMVar(StrictMVar)
5+ , newEmptyMVar
6+ , newMVar
7+ , takeMVar
8+ , putMVar
9+ , readMVar
10+ , withMVar
11+ , modifyMVar_
12+ , modifyMVar
13+ , modifyMVarMasked
14+ , mkWeakMVar
15+ ) where
16+
17+import Control.Applicative ((<$>))
18+import Control.Monad ((>=>))
19+#if MIN_VERSION_base(4,6,0)
20+import Control.Exception (evaluate)
21+#else
22+import Control.Exception (evaluate, mask_, onException)
23+#endif
24+import qualified Control.Concurrent.MVar as MVar
25+ ( MVar
26+ , newEmptyMVar
27+ , newMVar
28+ , takeMVar
29+ , putMVar
30+ , readMVar
31+ , withMVar
32+ , modifyMVar_
33+ , modifyMVar
34+#if MIN_VERSION_base(4,6,0)
35+ , modifyMVarMasked
36+#endif
37+ )
38+import GHC.MVar (MVar(MVar))
39+import GHC.IO (IO(IO), unIO)
40+import GHC.Exts (mkWeak#)
41+import GHC.Weak (Weak(Weak))
42+
43+newtype StrictMVar a = StrictMVar (MVar.MVar a)
44+
45+newEmptyMVar :: IO (StrictMVar a)
46+newEmptyMVar = StrictMVar <$> MVar.newEmptyMVar
47+
48+newMVar :: a -> IO (StrictMVar a)
49+newMVar x = evaluate x >> StrictMVar <$> MVar.newMVar x
50+
51+takeMVar :: StrictMVar a -> IO a
52+takeMVar (StrictMVar v) = MVar.takeMVar v
53+
54+putMVar :: StrictMVar a -> a -> IO ()
55+putMVar (StrictMVar v) x = evaluate x >> MVar.putMVar v x
56+
57+readMVar :: StrictMVar a -> IO a
58+readMVar (StrictMVar v) = MVar.readMVar v
59+
60+withMVar :: StrictMVar a -> (a -> IO b) -> IO b
61+withMVar (StrictMVar v) = MVar.withMVar v
62+
63+modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO ()
64+modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)
65+
66+modifyMVar :: StrictMVar a -> (a -> IO (a, b)) -> IO b
67+modifyMVar (StrictMVar v) f = MVar.modifyMVar v (f >=> evaluateFst)
68+ where
69+ evaluateFst :: (a, b) -> IO (a, b)
70+ evaluateFst (x, y) = evaluate x >> return (x, y)
71+
72+modifyMVarMasked :: StrictMVar a -> (a -> IO (a, b)) -> IO b
73+modifyMVarMasked (StrictMVar v) f =
74+#if MIN_VERSION_base(4,6,0)
75+ MVar.modifyMVarMasked v (f >=> evaluateFst)
76+#else
77+ mask_ $ do
78+ a <- MVar.takeMVar v
79+ (a',b) <- (f a >>= evaluate) `onException` MVar.putMVar v a
80+ MVar.putMVar v a'
81+ return b
82+#endif
83+ where
84+ evaluateFst :: (a, b) -> IO (a, b)
85+ evaluateFst (x, y) = evaluate x >> return (x, y)
86+
87+mkWeakMVar :: StrictMVar a -> IO () -> IO (Weak (StrictMVar a))
88+mkWeakMVar q@(StrictMVar (MVar m#)) f = IO $ \s ->
89+#if MIN_VERSION_base(4,9,0)
90+ case mkWeak# m# q (unIO f) s of (# s', w #) -> (# s', Weak w #)
91+#else
92+ case mkWeak# m# q f s of (# s', w #) -> (# s', Weak w #)
93+#endif
src/Control/Distributed/Process/Internal/Types.hsnew file+887
@@ -0,0 +1,887 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE DeriveGeneric #-}
6+{-# LANGUAGE CPP #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE Rank2Types #-}
10+
11+-- | Types used throughout the Cloud Haskell framework
12+--
13+-- We collect all types used internally in a single module because
14+-- many of these data types are mutually recursive and cannot be split across
15+-- modules.
16+module Control.Distributed.Process.Internal.Types
17+ ( -- * Node and process identifiers
18+ NodeId(..)
19+ , LocalProcessId(..)
20+ , ProcessId(..)
21+ , Identifier(..)
22+ , nodeOf
23+ , firstNonReservedProcessId
24+ , nullProcessId
25+ -- * Local nodes and processes
26+ , LocalNode(..)
27+ , LocalNodeState(..)
28+ , ValidLocalNodeState(..)
29+ , NodeClosedException(..)
30+ , withValidLocalState
31+ , modifyValidLocalState
32+ , modifyValidLocalState_
33+ , Tracer(..)
34+ , MxEventBus(..)
35+ , LocalProcess(..)
36+ , LocalProcessState(..)
37+ , Process(..)
38+ , runLocalProcess
39+ , ImplicitReconnect(..)
40+ -- * Typed channels
41+ , LocalSendPortId
42+ , SendPortId(..)
43+ , TypedChannel(..)
44+ , SendPort(..)
45+ , ReceivePort(..)
46+ -- * Messages
47+ , Message(..)
48+ , isEncoded
49+ , createMessage
50+ , createUnencodedMessage
51+ , unsafeCreateUnencodedMessage
52+ , messageToPayload
53+ , payloadToMessage
54+ -- * Node controller user-visible data types
55+ , MonitorRef(..)
56+ , ProcessMonitorNotification(..)
57+ , NodeMonitorNotification(..)
58+ , PortMonitorNotification(..)
59+ , ProcessExitException(..)
60+ , ProcessLinkException(..)
61+ , NodeLinkException(..)
62+ , PortLinkException(..)
63+ , ProcessRegistrationException(..)
64+ , DiedReason(..)
65+ , DidUnmonitor(..)
66+ , DidUnlinkProcess(..)
67+ , DidUnlinkNode(..)
68+ , DidUnlinkPort(..)
69+ , SpawnRef(..)
70+ , DidSpawn(..)
71+ , WhereIsReply(..)
72+ , RegisterReply(..)
73+ , ProcessInfo(..)
74+ , ProcessInfoNone(..)
75+ , NodeStats(..)
76+ -- * Node controller internal data types
77+ , NCMsg(..)
78+ , ProcessSignal(..)
79+ -- * Accessors
80+ , localProcesses
81+ , localPidCounter
82+ , localPidUnique
83+ , localConnections
84+ , localProcessWithId
85+ , localConnectionBetween
86+ , monitorCounter
87+ , spawnCounter
88+ , channelCounter
89+ , typedChannels
90+ , typedChannelWithId
91+ -- * Utilities
92+ , forever'
93+ ) where
94+
95+import System.Mem.Weak (Weak)
96+import Data.Map (Map)
97+import Data.Int (Int32)
98+import Data.Data (Data)
99+import Data.Typeable (Typeable, typeOf)
100+import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
101+import qualified Data.ByteString as BSS (ByteString, concat, copy)
102+import qualified Data.ByteString.Lazy as BSL
103+ ( ByteString
104+ , toChunks
105+ , splitAt
106+ , fromChunks
107+ , length
108+ )
109+import qualified Data.ByteString.Lazy.Internal as BSL (ByteString(..))
110+import Data.Accessor (Accessor, accessor)
111+import Control.Category ((>>>))
112+import Control.DeepSeq (NFData(..))
113+import Control.Exception (Exception, throwIO)
114+import Control.Concurrent (ThreadId)
115+import Control.Concurrent.Chan (Chan)
116+import Control.Concurrent.STM (STM)
117+import Control.Concurrent.STM.TChan (TChan)
118+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
119+import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
120+import Control.Applicative
121+import Control.Monad.Fix (MonadFix)
122+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
123+import Control.Monad.IO.Class (MonadIO(..))
124+import Control.Distributed.Process.Serializable
125+ ( Fingerprint
126+ , Serializable
127+ , fingerprint
128+ , encodeFingerprint
129+ , sizeOfFingerprint
130+ , decodeFingerprint
131+ , showFingerprint
132+ )
133+import Control.Distributed.Process.Internal.CQueue (CQueue)
134+import Control.Distributed.Process.Internal.StrictMVar
135+ ( StrictMVar
136+ , withMVar
137+ , modifyMVar
138+ , modifyMVar_
139+ )
140+import Control.Distributed.Process.Internal.WeakTQueue (TQueue)
141+import Control.Distributed.Static (RemoteTable, Closure)
142+import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC (mapMaybe)
143+
144+import Data.Hashable
145+import GHC.Generics
146+import Prelude
147+
148+--------------------------------------------------------------------------------
149+-- Node and process identifiers --
150+--------------------------------------------------------------------------------
151+
152+-- | Node identifier
153+newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
154+ deriving (Eq, Ord, Typeable, Data, Generic)
155+instance Binary NodeId where
156+instance NFData NodeId where rnf (NodeId a) = rnf a `seq` ()
157+instance Hashable NodeId where
158+instance Show NodeId where
159+ show (NodeId addr) = "nid://" ++ show addr
160+
161+-- | A local process ID consists of a seed which distinguishes processes from
162+-- different instances of the same local node and a counter
163+data LocalProcessId = LocalProcessId
164+ { lpidUnique :: {-# UNPACK #-} !Int32
165+ , lpidCounter :: {-# UNPACK #-} !Int32
166+ }
167+ deriving (Eq, Ord, Typeable, Data, Generic, Show)
168+
169+instance Hashable LocalProcessId where
170+
171+-- | Process identifier
172+data ProcessId = ProcessId
173+ { -- | The ID of the node the process is running on
174+ processNodeId :: !NodeId
175+ -- | Node-local identifier for the process
176+ , processLocalId :: {-# UNPACK #-} !LocalProcessId
177+ }
178+ deriving (Eq, Ord, Typeable, Data, Generic)
179+
180+instance Binary ProcessId where
181+instance NFData ProcessId where rnf (ProcessId n _) = rnf n `seq` ()
182+instance Hashable ProcessId where
183+
184+instance Show ProcessId where
185+ show (ProcessId (NodeId addr) (LocalProcessId _ lid))
186+ = "pid://" ++ show addr ++ ":" ++ show lid
187+
188+-- | Union of all kinds of identifiers
189+data Identifier =
190+ NodeIdentifier !NodeId
191+ | ProcessIdentifier !ProcessId
192+ | SendPortIdentifier !SendPortId
193+ deriving (Eq, Ord, Generic)
194+
195+instance Hashable Identifier where
196+instance NFData Identifier where
197+ rnf (NodeIdentifier n) = rnf n `seq` ()
198+ rnf (ProcessIdentifier n) = rnf n `seq` ()
199+ rnf n@SendPortIdentifier{} = n `seq` ()
200+
201+instance Show Identifier where
202+ show (NodeIdentifier nid) = show nid
203+ show (ProcessIdentifier pid) = show pid
204+ show (SendPortIdentifier cid) = show cid
205+
206+nodeOf :: Identifier -> NodeId
207+nodeOf (NodeIdentifier nid) = nid
208+nodeOf (ProcessIdentifier pid) = processNodeId pid
209+nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)
210+
211+--------------------------------------------------------------------------------
212+-- Special PIDs --
213+--------------------------------------------------------------------------------
214+
215+firstNonReservedProcessId :: Int32
216+firstNonReservedProcessId = 1
217+
218+nullProcessId :: NodeId -> ProcessId
219+nullProcessId nid =
220+ ProcessId { processNodeId = nid
221+ , processLocalId = LocalProcessId { lpidUnique = 0
222+ , lpidCounter = 0
223+ }
224+ }
225+
226+--------------------------------------------------------------------------------
227+-- Local nodes and processes --
228+--------------------------------------------------------------------------------
229+
230+-- | Provides access to the trace controller
231+data Tracer = Tracer
232+ {
233+ -- | Process id for the currently active trace handler
234+ tracerPid :: !ProcessId
235+ -- | Weak reference to the tracer controller's mailbox
236+ , weakQ :: !(Weak (CQueue Message))
237+ }
238+
239+-- | Local system management event bus state
240+data MxEventBus =
241+ MxEventBusInitialising
242+ | MxEventBus
243+ {
244+ -- | Process id of the management agent controller process
245+ agent :: !ProcessId
246+ -- | Configuration for the local trace controller
247+ , tracer :: !Tracer
248+ -- | Weak reference to the management agent controller's mailbox
249+ , evbuss :: !(Weak (CQueue Message))
250+ -- | API for adding management agents to a running node
251+ , mxNew :: !(((TChan Message, TChan Message) -> Process ()) -> IO ProcessId)
252+-- , mxReg :: !(StrictMVar (Map MxAgentId ))
253+ }
254+
255+-- | Local nodes
256+data LocalNode = LocalNode
257+ { -- | 'NodeId' of the node
258+ localNodeId :: !NodeId
259+ -- | The network endpoint associated with this node
260+ , localEndPoint :: !NT.EndPoint
261+ -- | Local node state
262+ , localState :: !(StrictMVar LocalNodeState)
263+ -- | Channel for the node controller
264+ , localCtrlChan :: !(Chan NCMsg)
265+ -- | Internal management event bus
266+ , localEventBus :: !MxEventBus
267+ -- | Runtime lookup table for supporting closures
268+ -- TODO: this should be part of the CH state, not the local endpoint state
269+ , remoteTable :: !RemoteTable
270+ }
271+
272+data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
273+ deriving (Eq, Show)
274+
275+-- | Local node state
276+data LocalNodeState =
277+ LocalNodeValid {-# UNPACK #-} !ValidLocalNodeState
278+ | LocalNodeClosed
279+
280+data ValidLocalNodeState = ValidLocalNodeState
281+ { -- | Processes running on this node
282+ _localProcesses :: !(Map LocalProcessId LocalProcess)
283+ -- | Counter to assign PIDs
284+ , _localPidCounter :: !Int32
285+ -- | The 'unique' value used to create PIDs (so that processes on
286+ -- restarted nodes have new PIDs)
287+ , _localPidUnique :: !Int32
288+ -- | Outgoing connections
289+ , _localConnections :: !(Map (Identifier, Identifier)
290+ (NT.Connection, ImplicitReconnect))
291+ }
292+
293+-- | Thrown by some primitives when they notice the node has been closed.
294+data NodeClosedException = NodeClosedException NodeId
295+ deriving (Show, Typeable)
296+
297+instance Exception NodeClosedException
298+
299+-- | Wrapper around 'withMVar' that checks that the local node is still in
300+-- a valid state.
301+withValidLocalState :: LocalNode
302+ -> (ValidLocalNodeState -> IO r)
303+ -> IO r
304+withValidLocalState node f = withMVar (localState node) $ \st -> case st of
305+ LocalNodeValid vst -> f vst
306+ LocalNodeClosed -> throwIO $ NodeClosedException (localNodeId node)
307+
308+-- | Wrapper around 'modifyMVar' that checks that the local node is still in
309+-- a valid state.
310+modifyValidLocalState :: LocalNode
311+ -> (ValidLocalNodeState -> IO (ValidLocalNodeState, a))
312+ -> IO (Maybe a)
313+modifyValidLocalState node f = modifyMVar (localState node) $ \st -> case st of
314+ LocalNodeValid vst -> do (vst', a) <- f vst
315+ return (LocalNodeValid vst', Just a)
316+ LocalNodeClosed -> return (LocalNodeClosed, Nothing)
317+
318+-- | Wrapper around 'modifyMVar_' that checks that the local node is still in
319+-- a valid state.
320+modifyValidLocalState_ :: LocalNode
321+ -> (ValidLocalNodeState -> IO ValidLocalNodeState)
322+ -> IO ()
323+modifyValidLocalState_ node f = modifyMVar_ (localState node) $ \st -> case st of
324+ LocalNodeValid vst -> LocalNodeValid <$> f vst
325+ LocalNodeClosed -> return LocalNodeClosed
326+
327+-- | Processes running on our local node
328+data LocalProcess = LocalProcess
329+ { processQueue :: !(CQueue Message)
330+ , processWeakQ :: !(Weak (CQueue Message))
331+ , processId :: !ProcessId
332+ , processState :: !(StrictMVar LocalProcessState)
333+ , processThread :: !ThreadId
334+ , processNode :: !LocalNode
335+ }
336+
337+-- | Deconstructor for 'Process' (not exported to the public API)
338+runLocalProcess :: LocalProcess -> Process a -> IO a
339+runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
340+
341+-- | Local process state
342+data LocalProcessState = LocalProcessState
343+ { _monitorCounter :: !Int32
344+ , _spawnCounter :: !Int32
345+ , _channelCounter :: !Int32
346+ , _typedChannels :: !(Map LocalSendPortId TypedChannel)
347+ }
348+
349+-- | The Cloud Haskell 'Process' type
350+newtype Process a = Process {
351+ unProcess :: ReaderT LocalProcess IO a
352+ }
353+ deriving ( Applicative
354+ , Functor
355+ , Monad
356+ , MonadFix
357+ , MonadIO
358+ , MonadReader LocalProcess
359+ , Typeable
360+ )
361+
362+instance MonadThrow Process where
363+ throwM = liftIO . throwIO
364+instance MonadCatch Process where
365+ catch p h = do
366+ lproc <- ask
367+ liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
368+instance MonadMask Process where
369+#if MIN_VERSION_exceptions(0,10,0)
370+ generalBracket acquire release inner = do
371+ lproc <- ask
372+ liftIO $
373+ generalBracket (runLocalProcess lproc acquire)
374+ (\a e -> runLocalProcess lproc $ release a e)
375+ (runLocalProcess lproc . inner)
376+#endif
377+ mask p = do
378+ lproc <- ask
379+ liftIO $ mask $ \restore ->
380+ runLocalProcess lproc (p (liftRestore restore))
381+ where
382+ liftRestore :: (forall a. IO a -> IO a)
383+ -> (forall a. Process a -> Process a)
384+ liftRestore restoreIO = \p2 -> do
385+ ourLocalProc <- ask
386+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2
387+ uninterruptibleMask p = do
388+ lproc <- ask
389+ liftIO $ uninterruptibleMask $ \restore ->
390+ runLocalProcess lproc (p (liftRestore restore))
391+ where
392+ liftRestore :: (forall a. IO a -> IO a)
393+ -> (forall a. Process a -> Process a)
394+ liftRestore restoreIO = \p2 -> do
395+ ourLocalProc <- ask
396+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2
397+
398+--------------------------------------------------------------------------------
399+-- Typed channels --
400+--------------------------------------------------------------------------------
401+
402+type LocalSendPortId = Int32
403+
404+-- | A send port is identified by a SendPortId.
405+--
406+-- You cannot send directly to a SendPortId; instead, use 'newChan'
407+-- to create a SendPort.
408+data SendPortId = SendPortId {
409+ -- | The ID of the process that will receive messages sent on this port
410+ sendPortProcessId :: {-# UNPACK #-} !ProcessId
411+ -- | Process-local ID of the channel
412+ , sendPortLocalId :: {-# UNPACK #-} !LocalSendPortId
413+ }
414+ deriving (Eq, Ord, Typeable, Generic)
415+
416+instance Hashable SendPortId where
417+instance Show SendPortId where
418+ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
419+ = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
420+
421+instance NFData SendPortId where
422+ rnf (SendPortId p _) = rnf p `seq` ()
423+
424+data TypedChannel = forall a. Serializable a => TypedChannel (Weak (TQueue a))
425+
426+-- | The send send of a typed channel (serializable)
427+newtype SendPort a = SendPort {
428+ -- | The (unique) ID of this send port
429+ sendPortId :: SendPortId
430+ }
431+ deriving (Typeable, Generic, Show, Eq, Ord)
432+
433+instance (Serializable a) => Binary (SendPort a) where
434+instance (Hashable a) => Hashable (SendPort a) where
435+instance (NFData a) => NFData (SendPort a) where rnf (SendPort x) = x `seq` ()
436+
437+-- | The receive end of a typed channel (not serializable)
438+--
439+-- Note that 'ReceivePort' implements 'Functor', 'Applicative', 'Alternative'
440+-- and 'Monad'. This is especially useful when merging receive ports.
441+newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }
442+ deriving (Typeable, Functor, Applicative, Alternative, Monad)
443+
444+{-
445+data ReceivePort a =
446+ -- | A single receive port
447+ ReceivePortSingle (TQueue a)
448+ -- | A left-biased combination of receive ports
449+ | ReceivePortBiased [ReceivePort a]
450+ -- | A round-robin combination of receive ports
451+ | ReceivePortRR (TVar [ReceivePort a])
452+ deriving Typeable
453+-}
454+
455+--------------------------------------------------------------------------------
456+-- Messages --
457+--------------------------------------------------------------------------------
458+
459+-- | Messages consist of their typeRep fingerprint and their encoding
460+data Message =
461+ EncodedMessage
462+ { messageFingerprint :: !Fingerprint
463+ , messageEncoding :: !BSL.ByteString
464+ } |
465+ forall a . Serializable a =>
466+ UnencodedMessage
467+ {
468+ messageFingerprint :: !Fingerprint
469+ , messagePayload :: !a
470+ }
471+ deriving (Typeable)
472+
473+instance NFData Message where
474+#if MIN_VERSION_bytestring(0,10,0)
475+ rnf (EncodedMessage _ e) = rnf e `seq` ()
476+#else
477+ rnf (EncodedMessage _ e) = BSL.length e `seq` ()
478+#endif
479+ rnf (UnencodedMessage _ a) = e `seq` ()
480+ where e = BSL.length (encode a)
481+
482+instance Show Message where
483+ show (EncodedMessage fp enc) = show enc ++ " :: " ++ showFingerprint fp []
484+ show (UnencodedMessage _ uenc) = "[unencoded message] :: " ++ (show $ typeOf uenc)
485+
486+-- | /internal use only/.
487+isEncoded :: Message -> Bool
488+isEncoded (EncodedMessage _ _) = True
489+isEncoded _ = False
490+-- [note] isEncoded:
491+-- This is just as internal as it looks and yes, it does feel a bit odd that
492+-- we're exporting it for use, however DPP does a /lot/ of work with low
493+-- level APIs such as unwrapMessage and handleMessage, and in the process
494+-- tries very hard to avoid copying (and re-serialisation) where possible.
495+-- Being able to determine that a message is encoded (or otherwise) makes
496+-- that a lot more manageable.
497+
498+-- | Turn any serialiable term into a message
499+createMessage :: Serializable a => a -> Message
500+createMessage a = EncodedMessage (fingerprint a) (encode a)
501+
502+-- | Turn any serializable term into an unencoded/local message
503+createUnencodedMessage :: Serializable a => a -> Message
504+createUnencodedMessage a =
505+ let encoded = encode a in BSL.length encoded `seq` UnencodedMessage (fingerprint a) a
506+
507+-- | Turn any serializable term into an unencodede/local message, without
508+-- evalutaing it! This is a dangerous business.
509+unsafeCreateUnencodedMessage :: Serializable a => a -> Message
510+unsafeCreateUnencodedMessage a = UnencodedMessage (fingerprint a) a
511+
512+-- | Serialize a message
513+messageToPayload :: Message -> [BSS.ByteString]
514+messageToPayload (EncodedMessage fp enc) = encodeFingerprint fp : BSL.toChunks enc
515+messageToPayload (UnencodedMessage fp m) = messageToPayload ((EncodedMessage fp (encode m)))
516+
517+-- | Deserialize a message
518+payloadToMessage :: [BSS.ByteString] -> Message
519+payloadToMessage payload = EncodedMessage fp (copy msg)
520+ where
521+ encFp :: BSL.ByteString
522+ msg :: BSL.ByteString
523+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
524+ $ BSL.fromChunks payload
525+
526+ fp :: Fingerprint
527+ fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
528+
529+ copy :: BSL.ByteString -> BSL.ByteString
530+ copy (BSL.Chunk bs BSL.Empty) = BSL.Chunk (BSS.copy bs) BSL.Empty
531+ copy bsl = BSL.fromChunks . return . BSS.concat . BSL.toChunks $ bsl
532+
533+--------------------------------------------------------------------------------
534+-- Node controller user-visible data types --
535+--------------------------------------------------------------------------------
536+
537+-- | MonitorRef is opaque for regular Cloud Haskell processes
538+data MonitorRef = MonitorRef
539+ { -- | ID of the entity to be monitored
540+ monitorRefIdent :: !Identifier
541+ -- | Unique to distinguish multiple monitor requests by the same process
542+ , monitorRefCounter :: !Int32
543+ }
544+ deriving (Eq, Ord, Show, Typeable, Generic)
545+instance Hashable MonitorRef
546+
547+instance NFData MonitorRef where
548+ rnf (MonitorRef i _) = rnf i `seq` ()
549+
550+-- | Message sent by process monitors
551+data ProcessMonitorNotification =
552+ ProcessMonitorNotification !MonitorRef !ProcessId !DiedReason
553+ deriving (Typeable, Show)
554+
555+-- | Message sent by node monitors
556+data NodeMonitorNotification =
557+ NodeMonitorNotification !MonitorRef !NodeId !DiedReason
558+ deriving (Typeable, Show)
559+
560+-- | Message sent by channel (port) monitors
561+data PortMonitorNotification =
562+ PortMonitorNotification !MonitorRef !SendPortId !DiedReason
563+ deriving (Typeable, Show)
564+
565+-- | Exceptions thrown when a linked process dies
566+data ProcessLinkException =
567+ ProcessLinkException !ProcessId !DiedReason
568+ deriving (Typeable, Show)
569+
570+-- | Exception thrown when a linked node dies
571+data NodeLinkException =
572+ NodeLinkException !NodeId !DiedReason
573+ deriving (Typeable, Show)
574+
575+-- | Exception thrown when a linked channel (port) dies
576+data PortLinkException =
577+ PortLinkException !SendPortId !DiedReason
578+ deriving (Typeable, Show)
579+
580+-- | Exception thrown when a process attempts to register
581+-- a process under an already-registered name or to
582+-- unregister a name that hasn't been registered. Returns
583+-- the name and the identifier of the process that owns it,
584+-- if any.
585+data ProcessRegistrationException =
586+ ProcessRegistrationException !String !(Maybe ProcessId)
587+ deriving (Typeable, Show)
588+
589+-- | Internal exception thrown indirectly by 'exit'
590+data ProcessExitException =
591+ ProcessExitException !ProcessId !Message
592+ deriving Typeable
593+
594+instance Exception ProcessExitException
595+instance Show ProcessExitException where
596+ show (ProcessExitException pid _) = "exit-from=" ++ (show pid)
597+
598+instance Exception ProcessLinkException
599+instance Exception NodeLinkException
600+instance Exception PortLinkException
601+instance Exception ProcessRegistrationException
602+
603+-- | Why did a process die?
604+data DiedReason =
605+ -- | Normal termination
606+ DiedNormal
607+ -- | The process exited with an exception
608+ -- (provided as 'String' because 'Exception' does not implement 'Binary')
609+ | DiedException !String
610+ -- | We got disconnected from the process node
611+ | DiedDisconnect
612+ -- | The process node died
613+ | DiedNodeDown
614+ -- | Invalid (process/node/channel) identifier
615+ | DiedUnknownId
616+ deriving (Show, Eq)
617+
618+instance NFData DiedReason where
619+ rnf (DiedException s) = rnf s `seq` ()
620+ rnf x = x `seq` ()
621+
622+-- | (Asynchronous) reply from unmonitor
623+newtype DidUnmonitor = DidUnmonitor MonitorRef
624+ deriving (Typeable, Binary)
625+
626+-- | (Asynchronous) reply from unlink
627+newtype DidUnlinkProcess = DidUnlinkProcess ProcessId
628+ deriving (Typeable, Binary)
629+
630+-- | (Asynchronous) reply from unlinkNode
631+newtype DidUnlinkNode = DidUnlinkNode NodeId
632+ deriving (Typeable, Binary)
633+
634+-- | (Asynchronous) reply from unlinkPort
635+newtype DidUnlinkPort = DidUnlinkPort SendPortId
636+ deriving (Typeable, Binary)
637+
638+-- | 'SpawnRef' are used to return pids of spawned processes
639+newtype SpawnRef = SpawnRef Int32
640+ deriving (Show, Binary, Typeable, Eq, Ord)
641+
642+-- | (Asynchronius) reply from 'spawn'
643+data DidSpawn = DidSpawn SpawnRef ProcessId
644+ deriving (Show, Typeable)
645+
646+-- | (Asynchronous) reply from 'whereis'
647+data WhereIsReply = WhereIsReply String (Maybe ProcessId)
648+ deriving (Show, Typeable)
649+
650+-- | (Asynchronous) reply from 'register' and 'unregister'
651+data RegisterReply = RegisterReply String Bool (Maybe ProcessId)
652+ deriving (Show, Typeable)
653+
654+data NodeStats = NodeStats {
655+ nodeStatsNode :: NodeId
656+ , nodeStatsRegisteredNames :: Int
657+ , nodeStatsMonitors :: Int
658+ , nodeStatsLinks :: Int
659+ , nodeStatsProcesses :: Int
660+ }
661+ deriving (Show, Eq, Typeable)
662+
663+-- | Provide information about a running process
664+data ProcessInfo = ProcessInfo {
665+ infoNode :: NodeId
666+ , infoRegisteredNames :: [String]
667+ , infoMessageQueueLength :: Int
668+ , infoMonitors :: [(ProcessId, MonitorRef)]
669+ , infoLinks :: [ProcessId]
670+ } deriving (Show, Eq, Typeable)
671+
672+data ProcessInfoNone = ProcessInfoNone DiedReason
673+ deriving (Show, Typeable)
674+
675+--------------------------------------------------------------------------------
676+-- Node controller internal data types --
677+--------------------------------------------------------------------------------
678+
679+-- | Messages to the node controller
680+data NCMsg = NCMsg
681+ { ctrlMsgSender :: !Identifier
682+ , ctrlMsgSignal :: !ProcessSignal
683+ }
684+ deriving Show
685+
686+-- | Signals to the node controller (see 'NCMsg')
687+data ProcessSignal =
688+ Link !Identifier
689+ | Unlink !Identifier
690+ | Monitor !MonitorRef
691+ | Unmonitor !MonitorRef
692+ | Died Identifier !DiedReason
693+ | Spawn !(Closure (Process ())) !SpawnRef
694+ | WhereIs !String
695+ | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister
696+ | NamedSend !String !Message
697+ | UnreliableSend !LocalProcessId !Message
698+ | LocalSend !ProcessId !Message
699+ | LocalPortSend !SendPortId !Message
700+ | Kill !ProcessId !String
701+ | Exit !ProcessId !Message
702+ | GetInfo !ProcessId
703+ | SigShutdown
704+ | GetNodeStats !NodeId
705+ deriving Show
706+
707+--------------------------------------------------------------------------------
708+-- Binary instances --
709+--------------------------------------------------------------------------------
710+
711+instance Binary Message where
712+ put msg = put $ messageToPayload msg
713+ get = payloadToMessage <$> get
714+
715+instance Binary LocalProcessId where
716+ put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
717+ get = LocalProcessId <$> get <*> get
718+
719+instance Binary ProcessMonitorNotification where
720+ put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
721+ get = ProcessMonitorNotification <$> get <*> get <*> get
722+
723+instance Binary NodeMonitorNotification where
724+ put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason
725+ get = NodeMonitorNotification <$> get <*> get <*> get
726+
727+instance Binary PortMonitorNotification where
728+ put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason
729+ get = PortMonitorNotification <$> get <*> get <*> get
730+
731+instance Binary NCMsg where
732+ put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)
733+ get = NCMsg <$> get <*> get
734+
735+instance Binary MonitorRef where
736+ put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)
737+ get = MonitorRef <$> get <*> get
738+
739+instance Binary ProcessSignal where
740+ put (Link pid) = putWord8 0 >> put pid
741+ put (Unlink pid) = putWord8 1 >> put pid
742+ put (Monitor ref) = putWord8 2 >> put ref
743+ put (Unmonitor ref) = putWord8 3 >> put ref
744+ put (Died who reason) = putWord8 4 >> put who >> put reason
745+ put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
746+ put (WhereIs label) = putWord8 6 >> put label
747+ put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force
748+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
749+ put (Kill pid reason) = putWord8 9 >> put pid >> put reason
750+ put (Exit pid reason) = putWord8 10 >> put pid >> put (messageToPayload reason)
751+ put (LocalSend to' msg) = putWord8 11 >> put to' >> put (messageToPayload msg)
752+ put (LocalPortSend sid msg) = putWord8 12 >> put sid >> put (messageToPayload msg)
753+ put (UnreliableSend lpid msg) = putWord8 13 >> put lpid >> put (messageToPayload msg)
754+ put (GetInfo about) = putWord8 30 >> put about
755+ put (SigShutdown) = putWord8 31
756+ put (GetNodeStats nid) = putWord8 32 >> put nid
757+ get = do
758+ header <- getWord8
759+ case header of
760+ 0 -> Link <$> get
761+ 1 -> Unlink <$> get
762+ 2 -> Monitor <$> get
763+ 3 -> Unmonitor <$> get
764+ 4 -> Died <$> get <*> get
765+ 5 -> Spawn <$> get <*> get
766+ 6 -> WhereIs <$> get
767+ 7 -> Register <$> get <*> get <*> get <*> get
768+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
769+ 9 -> Kill <$> get <*> get
770+ 10 -> Exit <$> get <*> (payloadToMessage <$> get)
771+ 11 -> LocalSend <$> get <*> (payloadToMessage <$> get)
772+ 12 -> LocalPortSend <$> get <*> (payloadToMessage <$> get)
773+ 13 -> UnreliableSend <$> get <*> (payloadToMessage <$> get)
774+ 30 -> GetInfo <$> get
775+ 31 -> return SigShutdown
776+ 32 -> GetNodeStats <$> get
777+ _ -> fail "ProcessSignal.get: invalid"
778+
779+instance Binary DiedReason where
780+ put DiedNormal = putWord8 0
781+ put (DiedException e) = putWord8 1 >> put e
782+ put DiedDisconnect = putWord8 2
783+ put DiedNodeDown = putWord8 3
784+ put DiedUnknownId = putWord8 4
785+ get = do
786+ header <- getWord8
787+ case header of
788+ 0 -> return DiedNormal
789+ 1 -> DiedException <$> get
790+ 2 -> return DiedDisconnect
791+ 3 -> return DiedNodeDown
792+ 4 -> return DiedUnknownId
793+ _ -> fail "DiedReason.get: invalid"
794+
795+instance Binary DidSpawn where
796+ put (DidSpawn ref pid) = put ref >> put pid
797+ get = DidSpawn <$> get <*> get
798+
799+instance Binary SendPortId where
800+ put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
801+ get = SendPortId <$> get <*> get
802+
803+instance Binary Identifier where
804+ put (ProcessIdentifier pid) = putWord8 0 >> put pid
805+ put (NodeIdentifier nid) = putWord8 1 >> put nid
806+ put (SendPortIdentifier cid) = putWord8 2 >> put cid
807+ get = do
808+ header <- getWord8
809+ case header of
810+ 0 -> ProcessIdentifier <$> get
811+ 1 -> NodeIdentifier <$> get
812+ 2 -> SendPortIdentifier <$> get
813+ _ -> fail "Identifier.get: invalid"
814+
815+instance Binary WhereIsReply where
816+ put (WhereIsReply label mPid) = put label >> put mPid
817+ get = WhereIsReply <$> get <*> get
818+
819+instance Binary RegisterReply where
820+ put (RegisterReply label ok owner) = put label >> put ok >> put owner
821+ get = RegisterReply <$> get <*> get <*> get
822+
823+instance Binary ProcessInfo where
824+ get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
825+ put pInfo = put (infoNode pInfo)
826+ >> put (infoRegisteredNames pInfo)
827+ >> put (infoMessageQueueLength pInfo)
828+ >> put (infoMonitors pInfo)
829+ >> put (infoLinks pInfo)
830+
831+instance Binary NodeStats where
832+ get = NodeStats <$> get <*> get <*> get <*> get <*> get
833+ put nStats = put (nodeStatsNode nStats)
834+ >> put (nodeStatsRegisteredNames nStats)
835+ >> put (nodeStatsMonitors nStats)
836+ >> put (nodeStatsLinks nStats)
837+ >> put (nodeStatsProcesses nStats)
838+
839+instance Binary ProcessInfoNone where
840+ get = ProcessInfoNone <$> get
841+ put (ProcessInfoNone r) = put r
842+
843+--------------------------------------------------------------------------------
844+-- Accessors --
845+--------------------------------------------------------------------------------
846+
847+localProcesses :: Accessor ValidLocalNodeState (Map LocalProcessId LocalProcess)
848+localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })
849+
850+localPidCounter :: Accessor ValidLocalNodeState Int32
851+localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })
852+
853+localPidUnique :: Accessor ValidLocalNodeState Int32
854+localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
855+
856+localConnections :: Accessor ValidLocalNodeState (Map (Identifier, Identifier) (NT.Connection, ImplicitReconnect))
857+localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })
858+
859+localProcessWithId :: LocalProcessId -> Accessor ValidLocalNodeState (Maybe LocalProcess)
860+localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
861+
862+localConnectionBetween :: Identifier -> Identifier -> Accessor ValidLocalNodeState (Maybe (NT.Connection, ImplicitReconnect))
863+localConnectionBetween from' to' = localConnections >>> DAC.mapMaybe (from', to')
864+
865+monitorCounter :: Accessor LocalProcessState Int32
866+monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
867+
868+spawnCounter :: Accessor LocalProcessState Int32
869+spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })
870+
871+channelCounter :: Accessor LocalProcessState LocalSendPortId
872+channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })
873+
874+typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)
875+typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })
876+
877+typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)
878+typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid
879+
880+--------------------------------------------------------------------------------
881+-- Utilities --
882+--------------------------------------------------------------------------------
883+
884+-- Like 'Control.Monad.forever' but sans space leak
885+{-# INLINE forever' #-}
886+forever' :: Monad m => m a -> m b
887+forever' a = let a' = a >> a' in a'
src/Control/Distributed/Process/Internal/WeakTQueue.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE MagicHash, UnboxedTuples #-}
4+-- | Clone of Control.Concurrent.STM.TQueue with support for mkWeakTQueue
5+--
6+-- Not all functionality from the original module is available: unGetTQueue,
7+-- peekTQueue and tryPeekTQueue are missing. In order to implement these we'd
8+-- need to be able to touch# the write end of the queue inside unGetTQueue, but
9+-- that means we need a version of touch# that works within the STM monad.
10+module Control.Distributed.Process.Internal.WeakTQueue (
11+ -- * Original functionality
12+ TQueue,
13+ newTQueue,
14+ newTQueueIO,
15+ readTQueue,
16+ tryReadTQueue,
17+ writeTQueue,
18+ isEmptyTQueue,
19+ -- * New functionality
20+ mkWeakTQueue
21+ ) where
22+
23+import Prelude hiding (read)
24+import GHC.Conc
25+import Data.Typeable (Typeable)
26+import GHC.IO (IO(IO), unIO)
27+import GHC.Exts (mkWeak#)
28+import GHC.Weak (Weak(Weak))
29+
30+--------------------------------------------------------------------------------
31+-- Original functionality --
32+--------------------------------------------------------------------------------
33+
34+-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.
35+data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])
36+ {-# UNPACK #-} !(TVar [a])
37+ deriving Typeable
38+
39+instance Eq (TQueue a) where
40+ TQueue a _ == TQueue b _ = a == b
41+
42+-- |Build and returns a new instance of 'TQueue'
43+newTQueue :: STM (TQueue a)
44+newTQueue = do
45+ read <- newTVar []
46+ write <- newTVar []
47+ return (TQueue read write)
48+
49+-- |@IO@ version of 'newTQueue'. This is useful for creating top-level
50+-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using
51+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
52+-- possible.
53+newTQueueIO :: IO (TQueue a)
54+newTQueueIO = do
55+ read <- newTVarIO []
56+ write <- newTVarIO []
57+ return (TQueue read write)
58+
59+-- |Write a value to a 'TQueue'.
60+writeTQueue :: TQueue a -> a -> STM ()
61+writeTQueue (TQueue _read write) a = do
62+ listend <- readTVar write
63+ writeTVar write (a:listend)
64+
65+-- |Read the next value from the 'TQueue'.
66+readTQueue :: TQueue a -> STM a
67+readTQueue (TQueue read write) = do
68+ xs <- readTVar read
69+ case xs of
70+ (x:xs') -> do writeTVar read xs'
71+ return x
72+ [] -> do ys <- readTVar write
73+ case ys of
74+ [] -> retry
75+ _ -> case reverse ys of
76+ [] -> error "readTQueue"
77+ (z:zs) -> do writeTVar write []
78+ writeTVar read zs
79+ return z
80+
81+-- | A version of 'readTQueue' which does not retry. Instead it
82+-- returns @Nothing@ if no value is available.
83+tryReadTQueue :: TQueue a -> STM (Maybe a)
84+tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing
85+
86+-- |Returns 'True' if the supplied 'TQueue' is empty.
87+isEmptyTQueue :: TQueue a -> STM Bool
88+isEmptyTQueue (TQueue read write) = do
89+ xs <- readTVar read
90+ case xs of
91+ (_:_) -> return False
92+ [] -> do ys <- readTVar write
93+ case ys of
94+ [] -> return True
95+ _ -> return False
96+
97+--------------------------------------------------------------------------------
98+-- New functionality --
99+--------------------------------------------------------------------------------
100+
101+mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a))
102+mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->
103+#if MIN_VERSION_base(4,9,0)
104+ case mkWeak# write# q (unIO f) s of (# s', w #) -> (# s', Weak w #)
105+#else
106+ case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)
107+#endif
src/Control/Distributed/Process/Management.hsnew file+509
@@ -0,0 +1,509 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE RecordWildCards #-}
7+{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Control.Distributed.Process.Management
14+-- Copyright : (c) Well-Typed / Tim Watson
15+-- License : BSD3 (see the file LICENSE)
16+--
17+-- Maintainer : Tim Watson <watson.timothy@gmail.com>
18+-- Stability : experimental
19+-- Portability : non-portable (requires concurrency)
20+--
21+-- [Management Extensions API]
22+--
23+-- This module presents an API for creating /Management Agents/:
24+-- special processes that are capable of receiving and responding to
25+-- a node's internal system events. These /system events/ are delivered by
26+-- the management event bus: An internal subsystem maintained for each
27+-- running node, to which all agents are automatically subscribed.
28+--
29+-- /Agents/ are defined in terms of /event sinks/, taking a particular
30+-- @Serializable@ type and evaluating to an action in the 'MxAgent' monad in
31+-- response. Each 'MxSink' evaluates to an 'MxAction' that specifies whether
32+-- the agent should continue processing it's inputs or stop. If the type of a
33+-- message cannot be matched to any of the agent's sinks, it will be discarded.
34+-- A sink can also deliberately skip processing a message, deferring to the
35+-- remaining handlers. This is the /only/ way that more than one event sink
36+-- can handle the same data type, since otherwise the first /type match/ will
37+-- /win/ every time a message arrives. See 'mxSkip' for details.
38+--
39+-- Various events are published to the management event bus automatically,
40+-- the full list of which can be found in the definition of the 'MxEvent' data
41+-- type. Additionally, clients of the /Management API/ can publish arbitrary
42+-- @Serializable@ data to the event bus using 'mxNotify'. All running agents
43+-- receive all events (from the primary event bus to which they're subscribed).
44+--
45+-- Agent processes are automatically registered on the local node, and can
46+-- receive messages via their mailbox just like ordinary processes. Unlike
47+-- ordinary @Process@ code however, it is unnecessary (though possible) for
48+-- agents to use the base @expect@ and @receiveX@ primitives to do this, since
49+-- the management infrastructure will continuously read from both the primary
50+-- event bus /and/ the process' own mailbox. Messages are transparently passed
51+-- to the agent's event sinks from both sources, so an agent need only concern
52+-- itself with how to respond to its inputs.
53+--
54+-- Some agents may wish to prioritise messages from their mailbox over traffic
55+-- on the management event bus, or vice versa. The 'mxReceive' and
56+-- 'mxReceiveChan' API calls do this for the mailbox and event bus,
57+-- respectively. The /prioritisation/ these APIs offer is simply that the chosen
58+-- data stream will be checked first. No blocking will occur if the chosen
59+-- (prioritised) source is devoid of input messages, instead the agent handling
60+-- code will revert to switching between the alternatives in /round-robin/ as
61+-- usual. If messages exist in one or more channels, they will be consumed as
62+-- soon as they're available, priority is effectively a hint about which
63+-- channel to consume from, should messages be available in both.
64+--
65+-- Prioritisation then, is a /hint/ about the preference of data source from
66+-- which the next input should be chosen. No guarantee can be made that the
67+-- chosen source will in fact be selected at runtime.
68+--
69+-- [Management API Semantics]
70+--
71+-- The management API provides /no guarantees whatsoever/, viz:
72+--
73+-- * The ordering of messages delivered to the event bus.
74+--
75+-- * The order in which agents will be executed.
76+--
77+-- * Whether messages will be taken from the mailbox first, or the event bus.
78+--
79+-- Since the event bus uses STM broadcast channels to communicate with agents,
80+-- no message written to the bus successfully can be lost.
81+--
82+-- Agents can also receive messages via their mailboxes - these are subject to
83+-- the same guarantees as all inter-process message sending.
84+--
85+-- Messages dispatched on an STM broadcast channel (i.e., management event bus)
86+-- are guaranteed to be delivered with the same FIFO ordering guarantees that
87+-- exist between two communicating processes, such that communication from the
88+-- node controller's threads (i.e., MxEvent's) will never be re-ordered, but
89+-- messages dispatched to the event bus by other processes (including, but not
90+-- limited to agents) are only guaranteed to be ordered between one sender and
91+-- one receiver.
92+--
93+-- No guarantee exists for the ordering in which messages sent to an agent's
94+-- mailbox will be delivered, vs messages dispatched via the event bus.
95+--
96+-- Because of the above, there are no ordering guarantees for messages sent
97+-- between agents, or for processes to agents, except for those that apply to
98+-- messages sent between regular processes, since agents are
99+-- implemented as such.
100+--
101+-- The event bus is serial and single threaded. Anything that is published by
102+-- the node controller will be seen in FIFO order. There are no ordering
103+-- guarantees pertaining to entries published to the event bus by other
104+-- processes or agents.
105+--
106+-- It should not be possible to see, for example, an @MxReceived@ before the
107+-- corresponding @MxSent@ event, since the places where we issue the @MxSent@
108+-- write directly to the event bus (using STM) in the calling (green) thread,
109+-- before dispatching instructions to the node controller to perform the
110+-- necessary routing to deliver the message to a process (or registered name,
111+-- or typed channel) locally or remotely.
112+--
113+-- [Management Data API]
114+--
115+-- Both management agents and clients of the API have access to a variety of
116+-- data storage capabilities, to facilitate publishing and consuming useful
117+-- system information. Agents maintain their own internal state privately (via a
118+-- state transformer - see 'mxGetLocal' et al), however it is possible for
119+-- agents to share additional data with each other (and the outside world)
120+-- using whatever mechanism the user wishes, e.g., acidstate, or shared memory
121+-- primitives.
122+--
123+-- [Defining Agents]
124+--
125+-- New agents are defined with 'mxAgent' and require a unique 'MxAgentId', an
126+-- initial state - 'MxAgent' runs in a state transformer - and a list of the
127+-- agent's event sinks. Each 'MxSink' is defined in terms of a specific
128+-- @Serializable@ type, via the 'mxSink' function, binding the event handler
129+-- expression to inputs of only that type.
130+--
131+-- Apart from modifying its own local state, an agent can execute arbitrary
132+-- @Process a@ code via lifting (see 'liftMX') and even publish its own messages
133+-- back to the primary event bus (see 'mxBroadcast').
134+--
135+-- Since messages are delivered to agents from both the management event bus and
136+-- the agent processes mailbox, agents (i.e., event sinks) will generally have
137+-- no idea as to their origin. An agent can, however, choose to prioritise the
138+-- choice of input (source) each time one of its event sinks runs. The /standard/
139+-- way for an event sink to indicate that the agent is ready for its next input
140+-- is to evaluate 'mxReady'. When this happens, the management infrastructure
141+-- will obtain data from the event bus and process' mailbox in a round robbin
142+-- fashion, i.e., one after the other, changing each time.
143+--
144+-- [Example Code]
145+--
146+-- What follows is a grossly over-simplified example of a management agent that
147+-- provides a basic name monitoring facility. Whenever a process name is
148+-- registered or unregistered, clients are informed of the fact.
149+--
150+-- > -- simple notification data type
151+-- >
152+-- > data Registration = Reg { added :: Bool
153+-- > , procId :: ProcessId
154+-- > , name :: String
155+-- > }
156+-- >
157+-- > -- start a /name monitoring agent/
158+-- > nameMonitorAgent = do
159+-- > mxAgent (MxAgentId "name-monitor") Set.empty [
160+-- > (mxSink $ \(pid :: ProcessId) -> do
161+-- > mxUpdateState $ Set.insert pid
162+-- > mxReady)
163+-- > , (mxSink $
164+-- > let act =
165+-- > case ev of
166+-- > (MxRegistered p n) -> notify True n p
167+-- > (MxUnRegistered p n) -> notify False n p
168+-- > _ -> return ()
169+-- > act >> mxReady)
170+-- > ]
171+-- > where
172+-- > notify a n p = do
173+-- > Foldable.mapM_ (liftMX . deliver (Reg a n p)) =<< mxGetLocal
174+-- >
175+--
176+-- The client interface (for sending their pid) can take one of two forms:
177+--
178+-- > monitorNames = getSelfPid >>= nsend "name-monitor"
179+-- > monitorNames2 = getSelfPid >>= mxNotify
180+--
181+-- [Performance, Stablity and Scalability]
182+--
183+-- /Management Agents/ offer numerous advantages over regular processes:
184+-- broadcast communication with them can have a lower latency, they offer
185+-- simplified messgage (i.e., input type) handling and they have access to
186+-- internal system information that would be otherwise unobtainable.
187+--
188+-- Do not be tempted to implement everything (e.g., the kitchen sink) using the
189+-- management API though. There are overheads associated with management agents
190+-- which is why they're presented as tools for consuming low level system
191+-- information, instead of as /application level/ development tools.
192+--
193+-- Agents that rely heavily on a busy mailbox can cause the management event
194+-- bus to backlog un-GC'ed data, leading to increased heap space. Producers that
195+-- do not take care to avoid passing unevaluated thunks to the API can crash
196+-- /all/ the agents in the system. Agents are not monitored or managed in any
197+-- way, and those that crash will not be restarted.
198+--
199+-- The management event bus can receive a great deal of traffic. Every time
200+-- a message is sent and/or received, an event is passed to the agent controller
201+-- and broadcast to all agents (plus the trace controller, if tracing is enabled
202+-- for the node). This is already a significant overhead - though profiling and
203+-- benchmarks have demonstrated that it does not adversely affect performance
204+-- if few agents are installed. Agents will typically use more cycles than plain
205+-- processes, since they perform additional work: selecting input data from both
206+-- the event bus /and/ their own mailboxes, plus searching through the set of
207+-- event sinks (for each agent) to determine the right handler for the event.
208+--
209+-- [Architecture Overview]
210+--
211+-- The architecture of the management event bus is internal and subject to
212+-- change without prior notice. The description that follows is provided for
213+-- informational purposes only.
214+--
215+-- When a node initially starts, two special, internal system processes are
216+-- started to support the management infrastructure. The first, known as the
217+-- /trace controller/, is responsible for consuming 'MxEvent's and forwarding
218+-- them to the configured tracer - see "Control.Distributed.Process.Debug" for
219+-- further details. The second is the /management agent controller/, and is the
220+-- primary worker process underpinning the management infrastructure. All
221+-- published management events are routed to this process, which places them
222+-- onto a system wide /event bus/ and additionally passes them directly to the
223+-- /trace controller/.
224+--
225+-- There are several reasons for segregating the tracing and management control
226+-- planes in this fashion. Tracing can be enabled or disabled by clients, whilst
227+-- the management event bus cannot, since in addition to providing
228+-- runtime instrumentation, its intended use-cases include node monitoring, peer
229+-- discovery (via topology providing backends) and other essential system
230+-- services that require knowledge of otherwise hidden system internals. Tracing
231+-- is also subject to /trace flags/ that limit the specific 'MxEvent's delivered
232+-- to trace clients - an overhead/complexity not shared by management agents.
233+-- Finally, tracing and management agents are implemented using completely
234+-- different signalling techniques - more on this later - which would introduce
235+-- considerable complexity if the shared the same /event loop/.
236+--
237+-- The management control plane is driven by a shared broadcast channel, which
238+-- is written to by the agent controller and subscribed to by all agent
239+-- processes. Agents are spawned as regular processes, whose primary
240+-- implementation (i.e., /server loop/) is responsible for consuming
241+-- messages from both the broadcast channel and their own mailbox. Once
242+-- consumed, messages are applied to the agent's /event sinks/ until one
243+-- matches the input, at which point it is applied and the loop continues.
244+-- The implementation chooses from the event bus and the mailbox in a
245+-- round-robin fashion, until a message is received. This polling activity would
246+-- lead to management agents consuming considerable system resources if left
247+-- unchecked, therefore the implementation will poll for a limitted number of
248+-- retries, after which it will perform a blocking read on the event bus.
249+--
250+-----------------------------------------------------------------------------
251+module Control.Distributed.Process.Management
252+ (
253+ MxEvent(..)
254+ -- * Firing Arbitrary /Mx Events/
255+ , mxNotify
256+ -- * Constructing Mx Agents
257+ , MxAction()
258+ , MxAgentId(..)
259+ , MxAgent()
260+ , mxAgent
261+ , mxAgentWithFinalize
262+ , MxSink()
263+ , mxSink
264+ , mxGetId
265+ , mxDeactivate
266+ , mxReady
267+ , mxSkip
268+ , mxReceive
269+ , mxReceiveChan
270+ , mxBroadcast
271+ , mxSetLocal
272+ , mxGetLocal
273+ , mxUpdateLocal
274+ , liftMX
275+ ) where
276+
277+import Control.Applicative
278+import Control.Concurrent.STM (atomically)
279+import Control.Concurrent.STM.TChan
280+ ( readTChan
281+ , writeTChan
282+ , TChan
283+ )
284+import Control.Distributed.Process.Internal.Primitives
285+ ( receiveWait
286+ , matchAny
287+ , matchSTM
288+ , unwrapMessage
289+ , register
290+ , whereis
291+ , die
292+ )
293+import Control.Distributed.Process.Internal.Types
294+ ( Process
295+ , ProcessId
296+ , Message
297+ , LocalProcess(..)
298+ , LocalNode(..)
299+ , MxEventBus(..)
300+ , unsafeCreateUnencodedMessage
301+ )
302+import Control.Distributed.Process.Management.Internal.Bus (publishEvent)
303+import Control.Distributed.Process.Management.Internal.Types
304+ ( MxAgentId(..)
305+ , MxAgent(..)
306+ , MxAction(..)
307+ , ChannelSelector(..)
308+ , MxAgentState(..)
309+ , MxSink
310+ , MxEvent(..)
311+ )
312+import Control.Distributed.Process.Serializable (Serializable)
313+import Control.Monad.IO.Class (liftIO)
314+import Control.Monad.Reader (ask)
315+import Control.Monad.Catch (onException)
316+import qualified Control.Monad.State as ST
317+ ( get
318+ , modify
319+ , lift
320+ , runStateT
321+ )
322+import Prelude
323+
324+-- | Publishes an arbitrary @Serializable@ message to the management event bus.
325+-- Note that /no attempt is made to force the argument/, therefore it is very
326+-- important that you do not pass unevaluated thunks that might crash the
327+-- receiving process via this API, since /all/ registered agents will gain
328+-- access to the data structure once it is broadcast by the agent controller.
329+mxNotify :: (Serializable a) => a -> Process ()
330+mxNotify msg = do
331+ bus <- localEventBus . processNode <$> ask
332+ liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg
333+
334+--------------------------------------------------------------------------------
335+-- API for writing user defined management extensions (i.e., agents) --
336+--------------------------------------------------------------------------------
337+
338+-- | Return the 'MxAgentId' for the currently executing agent.
339+--
340+mxGetId :: MxAgent s MxAgentId
341+mxGetId = ST.get >>= return . mxAgentId
342+
343+-- | The 'MxAgent' version of 'mxNotify'.
344+--
345+mxBroadcast :: (Serializable m) => m -> MxAgent s ()
346+mxBroadcast msg = do
347+ state <- ST.get
348+ liftMX $ liftIO $ atomically $ do
349+ writeTChan (mxBus state) (unsafeCreateUnencodedMessage msg)
350+
351+-- | Gracefully terminate an agent.
352+--
353+mxDeactivate :: forall s. String -> MxAgent s MxAction
354+mxDeactivate = return . MxAgentDeactivate
355+
356+-- | Continue executing (i.e., receiving and processing messages).
357+--
358+mxReady :: forall s. MxAgent s MxAction
359+mxReady = return MxAgentReady
360+
361+-- | Causes the currently executing /event sink/ to be skipped.
362+-- The remaining declared event sinks will be evaluated to find
363+-- a matching handler. Can be used to allow multiple event sinks
364+-- to process data of the same type.
365+--
366+mxSkip :: forall s. MxAgent s MxAction
367+mxSkip = return MxAgentSkip
368+
369+-- | Continue exeucting, prioritising inputs from the process' own
370+-- /mailbox/ ahead of data from the management event bus.
371+--
372+mxReceive :: forall s. MxAgent s MxAction
373+mxReceive = return $ MxAgentPrioritise Mailbox
374+
375+-- | Continue exeucting, prioritising inputs from the management event bus
376+-- over the process' own /mailbox/.
377+--
378+mxReceiveChan :: forall s. MxAgent s MxAction
379+mxReceiveChan = return $ MxAgentPrioritise InputChan
380+
381+-- | Lift a @Process@ action.
382+--
383+liftMX :: Process a -> MxAgent s a
384+liftMX p = MxAgent $ ST.lift p
385+
386+-- | Set the agent's local state.
387+--
388+mxSetLocal :: s -> MxAgent s ()
389+mxSetLocal s = ST.modify $ \st -> st { mxLocalState = s }
390+
391+-- | Update the agent's local state.
392+--
393+mxUpdateLocal :: (s -> s) -> MxAgent s ()
394+mxUpdateLocal f = ST.modify $ \st -> st { mxLocalState = (f $ mxLocalState st) }
395+
396+-- | Fetch the agent's local state.
397+--
398+mxGetLocal :: MxAgent s s
399+mxGetLocal = ST.get >>= return . mxLocalState
400+
401+-- | Create an 'MxSink' from an expression taking a @Serializable@ type @m@,
402+-- that yields an 'MxAction' in the 'MxAgent' monad.
403+--
404+mxSink :: forall s m . (Serializable m)
405+ => (m -> MxAgent s MxAction)
406+ -> MxSink s
407+mxSink act msg = do
408+ msg' <- liftMX $ (unwrapMessage msg :: Process (Maybe m))
409+ case msg' of
410+ Nothing -> return Nothing
411+ Just m -> do
412+ r <- act m
413+ case r of
414+ MxAgentSkip -> return Nothing
415+ _ -> return $ Just r
416+
417+-- private ADT: a linked list of event sinks
418+data MxPipeline s =
419+ MxPipeline
420+ {
421+ current :: !(MxSink s)
422+ , next :: !(MxPipeline s)
423+ } | MxStop
424+
425+-- | Activates a new agent.
426+--
427+mxAgent :: MxAgentId -> s -> [MxSink s] -> Process ProcessId
428+mxAgent mxId st hs = mxAgentWithFinalize mxId st hs $ return ()
429+
430+-- | Activates a new agent. This variant takes a /finalizer/ expression,
431+-- that is run once the agent shuts down (even in case of failure/exceptions).
432+-- The /finalizer/ expression runs in the mx monad - @MxAgent s ()@ - such
433+-- that the agent's internal state remains accessible to the shutdown/cleanup
434+-- code.
435+--
436+mxAgentWithFinalize :: MxAgentId
437+ -> s
438+ -> [MxSink s]
439+ -> MxAgent s ()
440+ -> Process ProcessId
441+mxAgentWithFinalize mxId initState handlers dtor = do
442+ let name = agentId mxId
443+ existing <- whereis name
444+ case existing of
445+ Just _ -> die "DuplicateAgentId" -- TODO: better error handling policy
446+ Nothing -> do
447+ node <- processNode <$> ask
448+ pid <- liftIO $ mxNew (localEventBus node) $ start
449+ register name pid
450+ return pid
451+ where
452+ start (sendTChan, recvTChan) = do
453+ let nState = MxAgentState mxId sendTChan initState
454+ runAgent dtor handlers InputChan recvTChan nState
455+
456+ runAgent :: MxAgent s ()
457+ -> [MxSink s]
458+ -> ChannelSelector
459+ -> TChan Message
460+ -> MxAgentState s
461+ -> Process ()
462+ runAgent eh hs cs c s =
463+ runAgentWithFinalizer eh hs cs c s
464+ `onException` runAgentFinalizer eh s
465+
466+ runAgentWithFinalizer :: MxAgent s ()
467+ -> [MxSink s]
468+ -> ChannelSelector
469+ -> TChan Message
470+ -> MxAgentState s
471+ -> Process ()
472+ runAgentWithFinalizer eh' hs' cs' c' s' = do
473+ msg <- getNextInput cs' c'
474+ (action, state) <- runPipeline msg s' $ pipeline hs'
475+ case action of
476+ MxAgentReady -> runAgent eh' hs' InputChan c' state
477+ MxAgentPrioritise priority -> runAgent eh' hs' priority c' state
478+ MxAgentDeactivate _ -> runAgentFinalizer eh' state
479+ MxAgentSkip -> error "IllegalState"
480+-- MxAgentBecome h' -> runAgent h' c state
481+
482+ getNextInput sel chan =
483+ let matches =
484+ case sel of
485+ Mailbox -> [ matchAny return
486+ , matchSTM (readTChan chan) return]
487+ InputChan -> [ matchSTM (readTChan chan) return
488+ , matchAny return]
489+ in receiveWait matches
490+
491+ runAgentFinalizer :: MxAgent s () -> MxAgentState s -> Process ()
492+ runAgentFinalizer f s = ST.runStateT (unAgent f) s >>= return . fst
493+
494+ pipeline :: forall s . [MxSink s] -> MxPipeline s
495+ pipeline [] = MxStop
496+ pipeline (sink:sinks) = MxPipeline sink (pipeline sinks)
497+
498+ runPipeline :: forall s .
499+ Message
500+ -> MxAgentState s
501+ -> MxPipeline s
502+ -> Process (MxAction, MxAgentState s)
503+ runPipeline _ state MxStop = return (MxAgentReady, state)
504+ runPipeline msg state MxPipeline{..} = do
505+ let act = current msg
506+ (pass, state') <- ST.runStateT (unAgent act) state
507+ case pass of
508+ Nothing -> runPipeline msg state next
509+ Just result -> return (result, state')
src/Control/Distributed/Process/Management/Internal/Agent.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE RecordWildCards #-}
3+
4+module Control.Distributed.Process.Management.Internal.Agent where
5+
6+import Control.Applicative
7+import Control.Concurrent (forkIO)
8+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
9+import Control.Concurrent.STM (atomically)
10+import Control.Concurrent.STM.TChan
11+ ( TChan
12+ , newBroadcastTChanIO
13+ , readTChan
14+ , writeTChan
15+ , dupTChan
16+ )
17+import Control.Distributed.Process.Internal.Primitives
18+ ( receiveWait
19+ , matchAny
20+ , die
21+ , catches
22+ , Handler(..)
23+ )
24+import Control.Distributed.Process.Internal.CQueue
25+ ( enqueueSTM
26+ , CQueue
27+ )
28+import Control.Distributed.Process.Management.Internal.Types
29+ ( Fork
30+ )
31+import Control.Distributed.Process.Management.Internal.Trace.Tracer
32+ ( traceController
33+ )
34+import Control.Distributed.Process.Internal.Types
35+ ( Process
36+ , Message
37+ , Tracer(..)
38+ , LocalProcess(..)
39+ , ProcessId
40+ , forever'
41+ )
42+import Control.Exception (AsyncException(ThreadKilled), SomeException)
43+import Control.Monad (void)
44+import Control.Monad.IO.Class (liftIO)
45+import Control.Monad.Reader (ask)
46+import GHC.Weak (Weak, deRefWeak)
47+import Prelude
48+
49+--------------------------------------------------------------------------------
50+-- Agent Controller Implementation --
51+--------------------------------------------------------------------------------
52+
53+-- | A triple containing a configured tracer, weak pointer to the
54+-- agent controller's mailbox (CQueue) and an expression used to
55+-- instantiate new agents on the current node.
56+type AgentConfig =
57+ (Tracer, Weak (CQueue Message),
58+ (((TChan Message, TChan Message) -> Process ()) -> IO ProcessId))
59+
60+-- | Starts a management agent for the current node. The agent process
61+-- must not crash or be killed, so we generally avoid publishing its
62+-- @ProcessId@ where possible.
63+--
64+-- Our process is also responsible for forwarding messages to the trace
65+-- controller, since having two /special processes/ handled via the
66+-- @LocalNode@ would be inelegant. We forward messages directly to the
67+-- trace controller's message queue, just as the @MxEventBus@ that's
68+-- set up on the @LocalNode@ forwards messages directly to us. This
69+-- optimises the code path for tracing and avoids overloading the node
70+-- node controller's internal control plane with additional routing, at the
71+-- cost of a little more complexity and two cases where we break
72+-- encapsulation.
73+--
74+mxAgentController :: Fork
75+ -> MVar AgentConfig
76+ -> Process ()
77+mxAgentController forkProcess mv = do
78+ trc <- liftIO $ startTracing forkProcess
79+ sigbus <- liftIO $ newBroadcastTChanIO
80+ liftIO $ startDeadLetterQueue sigbus
81+ weakQueue <- processWeakQ <$> ask
82+ liftIO $ putMVar mv (trc, weakQueue, mxStartAgent forkProcess sigbus)
83+ go sigbus trc
84+ where
85+ go bus tracer = forever' $ do
86+ void $ receiveWait [
87+ -- This is exactly what it appears to be: a "catch all" handler.
88+ -- Since mxNotify can potentially pass an unevaluated thunk to
89+ -- our mailbox, the dequeue (i.e., matchMessage) can fail and
90+ -- crash this process, which we DO NOT want. Alternatively,
91+ -- we handle IO exceptions here explicitly, since we don't want
92+ -- this process to ever crash, and the assumption we therefore
93+ -- make is thus:
94+ --
95+ -- 1. only ThreadKilled can tell this process to terminate
96+ -- 2. all other exceptions are invalid and should be ignored
97+ --
98+ -- The outcome of course, is that /bad/ calls to mxNotify
99+ -- (e.g., passing unevaluated thunks that will crash when
100+ -- they're eventually forced) are thus silently ignored.
101+ --
102+ matchAny (liftIO . broadcast bus tracer)
103+ ] `catches` [Handler (\ThreadKilled -> die "Killed"),
104+ Handler (\(_ :: SomeException) -> return ())]
105+
106+ broadcast :: TChan Message -> Tracer -> Message -> IO ()
107+ broadcast ch tr msg = do
108+ tmQueue <- tracerQueue tr
109+ atomicBroadcast ch tmQueue msg
110+
111+ tracerQueue :: Tracer -> IO (Maybe (CQueue Message))
112+ tracerQueue (Tracer _ wQ) = deRefWeak wQ
113+
114+ atomicBroadcast :: TChan Message
115+ -> Maybe (CQueue Message)
116+ -> Message -> IO ()
117+ atomicBroadcast ch Nothing msg = liftIO $ atomically $ writeTChan ch msg
118+ atomicBroadcast ch (Just q) msg = do
119+ -- liftIO $ putStrLn $ "broadcasting " ++ (show msg)
120+ liftIO $ atomically $ enqueueSTM q msg >> writeTChan ch msg
121+
122+-- | Forks a new process in which an mxAgent is run.
123+--
124+mxStartAgent :: Fork
125+ -> TChan Message
126+ -> ((TChan Message, TChan Message) -> Process ())
127+ -> IO ProcessId
128+mxStartAgent fork chan handler = do
129+ chan' <- atomically (dupTChan chan)
130+ let proc = handler (chan, chan')
131+ fork proc
132+
133+-- | Start the tracer controller.
134+--
135+startTracing :: Fork -> IO Tracer
136+startTracing forkProcess = do
137+ mv <- newEmptyMVar
138+ pid <- forkProcess $ traceController mv
139+ wQ <- liftIO $ takeMVar mv
140+ return $ Tracer pid wQ
141+
142+-- | Start a dead letter (agent) queue.
143+--
144+-- If no agents are registered on the system, the management
145+-- event bus will fill up and its data won't be GC'ed until someone
146+-- comes along and reads from the broadcast channel (via dupTChan
147+-- of course). This is effectively a leak, so to mitigate it, we
148+-- start a /dead letter queue/ that drains the event bus continuously,
149+-- thus ensuring if there are no other consumers that we won't use
150+-- up heap space unnecessarily.
151+--
152+startDeadLetterQueue :: TChan Message
153+ -> IO ()
154+startDeadLetterQueue sigbus = do
155+ chan' <- atomically (dupTChan sigbus)
156+ void $ forkIO $ forever' $ do
157+ void $ atomically $ readTChan chan'
src/Control/Distributed/Process/Management/Internal/Bus.hsnew file+21
@@ -0,0 +1,21 @@
1+-- | Interface to the management event bus.
2+module Control.Distributed.Process.Management.Internal.Bus
3+ ( publishEvent
4+ ) where
5+
6+import Control.Distributed.Process.Internal.CQueue
7+ ( enqueue
8+ )
9+import Control.Distributed.Process.Internal.Types
10+ ( MxEventBus(..)
11+ , Message
12+ )
13+import Data.Foldable (forM_)
14+import System.Mem.Weak (deRefWeak)
15+
16+publishEvent :: MxEventBus -> Message -> IO ()
17+publishEvent MxEventBusInitialising _ = return ()
18+publishEvent (MxEventBus _ _ wqRef _) msg = do
19+ mQueue <- deRefWeak wqRef
20+ forM_ mQueue $ \queue -> enqueue queue msg
21+
src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hsnew file+179
@@ -0,0 +1,179 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE TypeSynonymInstances #-}
3+-- | Keeps the tracing API calls separate from the Tracer implementation,
4+-- which allows us to avoid a nasty import cycle between tracing and
5+-- the messaging primitives that rely on it, and also between the node
6+-- controller (which requires access to the tracing related elements of
7+-- our RemoteTable) and the Debug module, which requires @forkProcess@.
8+-- This module is also used by the management agent, which relies on the
9+-- tracing infrastructure's messaging fabric.
10+module Control.Distributed.Process.Management.Internal.Trace.Primitives
11+ ( -- * Sending Trace Data
12+ traceLog
13+ , traceLogFmt
14+ , traceMessage
15+ -- * Configuring A Tracer
16+ , defaultTraceFlags
17+ , enableTrace
18+ , enableTraceAsync
19+ , disableTrace
20+ , disableTraceAsync
21+ , getTraceFlags
22+ , setTraceFlags
23+ , setTraceFlagsAsync
24+ , traceOnly
25+ , traceOn
26+ , traceOff
27+ , withLocalTracer
28+ , withRegisteredTracer
29+ ) where
30+
31+import Control.Applicative
32+import Control.Distributed.Process.Internal.Primitives
33+ ( whereis
34+ , newChan
35+ , receiveChan
36+ , die
37+ )
38+import Control.Distributed.Process.Management.Internal.Trace.Types
39+ ( TraceArg(..)
40+ , TraceFlags(..)
41+ , TraceOk(..)
42+ , TraceSubject(..)
43+ , defaultTraceFlags
44+ )
45+import qualified Control.Distributed.Process.Management.Internal.Trace.Types as Tracer
46+ ( traceLog
47+ , traceLogFmt
48+ , traceMessage
49+ , enableTrace
50+ , enableTraceSync
51+ , disableTrace
52+ , disableTraceSync
53+ , setTraceFlags
54+ , setTraceFlagsSync
55+ , getTraceFlags
56+ , getCurrentTraceClient
57+ )
58+import Control.Distributed.Process.Internal.Types
59+ ( Process
60+ , ProcessId
61+ , LocalProcess(..)
62+ , LocalNode(localEventBus)
63+ , SendPort
64+ , MxEventBus(..)
65+ )
66+import Control.Distributed.Process.Serializable
67+import Control.Monad.IO.Class (liftIO)
68+import Control.Monad.Reader (ask)
69+
70+import qualified Data.Set as Set (fromList)
71+import Prelude
72+
73+--------------------------------------------------------------------------------
74+-- Main API --
75+--------------------------------------------------------------------------------
76+
77+-- | Converts a list of identifiers (that can be
78+-- mapped to process ids), to a 'TraceSubject'.
79+class Traceable a where
80+ uod :: [a] -> TraceSubject
81+
82+instance Traceable ProcessId where
83+ uod = TraceProcs . Set.fromList
84+
85+instance Traceable String where
86+ uod = TraceNames . Set.fromList
87+
88+-- | Turn tracing for for a subset of trace targets.
89+traceOnly :: Traceable a => [a] -> Maybe TraceSubject
90+traceOnly = Just . uod
91+
92+-- | Trace all targets.
93+traceOn :: Maybe TraceSubject
94+traceOn = Just TraceAll
95+
96+-- | Trace no targets.
97+traceOff :: Maybe TraceSubject
98+traceOff = Nothing
99+
100+-- | Enable tracing to the supplied process.
101+enableTraceAsync :: ProcessId -> Process ()
102+enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
103+
104+-- TODO: refactor _Sync versions of trace configuration functions...
105+
106+-- | Enable tracing to the supplied process and wait for a @TraceOk@
107+-- response from the trace coordinator process.
108+enableTrace :: ProcessId -> Process ()
109+enableTrace pid =
110+ withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
111+
112+-- | Disable the currently configured trace.
113+disableTraceAsync :: Process ()
114+disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
115+
116+-- | Disable the currently configured trace and wait for a @TraceOk@
117+-- response from the trace coordinator process.
118+disableTrace :: Process ()
119+disableTrace =
120+ withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
121+
122+getTraceFlags :: Process TraceFlags
123+getTraceFlags = do
124+ (sp, rp) <- newChan
125+ withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
126+ receiveChan rp
127+
128+-- | Set the given flags for the current tracer.
129+setTraceFlagsAsync :: TraceFlags -> Process ()
130+setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
131+
132+-- | Set the given flags for the current tracer and wait for a @TraceOk@
133+-- response from the trace coordinator process.
134+setTraceFlags :: TraceFlags -> Process ()
135+setTraceFlags f =
136+ withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
137+
138+-- | Send a log message to the internal tracing facility. If tracing is
139+-- enabled, this will create a custom trace log event.
140+--
141+traceLog :: String -> Process ()
142+traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
143+
144+-- | Send a log message to the internal tracing facility, using the given
145+-- list of printable 'TraceArg's interspersed with the preceding delimiter.
146+--
147+traceLogFmt :: String -> [TraceArg] -> Process ()
148+traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
149+
150+-- | Send an arbitrary 'Message' to the tracer process.
151+traceMessage :: Serializable m => m -> Process ()
152+traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
153+
154+withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
155+withLocalTracer act = do
156+ node <- processNode <$> ask
157+ act (localEventBus node)
158+
159+withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
160+withLocalTracerSync act = do
161+ (sp, rp) <- newChan
162+ withLocalTracer $ \t -> liftIO $ (act t sp)
163+ TraceOk <- receiveChan rp
164+ return ()
165+
166+withRegisteredTracer :: (ProcessId -> Process a) -> Process a
167+withRegisteredTracer act = do
168+ (sp, rp) <- newChan
169+ withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
170+ currentTracer <- receiveChan rp
171+ case currentTracer of
172+ Nothing -> do mTP <- whereis "tracer.initial"
173+ -- NB: this should NOT ever happen, but forcing pattern matches
174+ -- is not considered cool in later versions of MonadFail
175+ case mTP of
176+ Just p' -> act p'
177+ Nothing -> die $ "System Invariant Violation: Tracer Process "
178+ ++ "Name Not Found (whereis tracer.initial)"
179+ (Just p) -> act p
src/Control/Distributed/Process/Management/Internal/Trace/Remote.hsnew file+61
@@ -0,0 +1,61 @@
1+module Control.Distributed.Process.Management.Internal.Trace.Remote
2+ ( -- * Configuring A Remote Tracer
3+ setTraceFlagsRemote
4+ , startTraceRelay
5+ -- * Remote Table
6+ , remoteTable
7+ ) where
8+
9+import Control.Distributed.Process.Internal.Closure.BuiltIn
10+ ( cpEnableTraceRemote
11+ )
12+import Control.Distributed.Process.Internal.Primitives
13+ ( getSelfPid
14+ , relay
15+ , nsendRemote
16+ )
17+import Control.Distributed.Process.Management.Internal.Trace.Types
18+ ( TraceFlags(..)
19+ , TraceOk(..)
20+ )
21+import Control.Distributed.Process.Management.Internal.Trace.Primitives
22+ ( withRegisteredTracer
23+ , enableTrace
24+ )
25+import Control.Distributed.Process.Internal.Spawn
26+ ( spawn
27+ )
28+import Control.Distributed.Process.Internal.Types
29+ ( Process
30+ , ProcessId
31+ , SendPort
32+ , NodeId
33+ )
34+import Control.Distributed.Static
35+ ( RemoteTable
36+ , registerStatic
37+ )
38+import Data.Rank1Dynamic (toDynamic)
39+
40+-- | Remote Table.
41+remoteTable :: RemoteTable -> RemoteTable
42+remoteTable = registerStatic "$enableTraceRemote" (toDynamic enableTraceRemote)
43+
44+enableTraceRemote :: ProcessId -> Process ()
45+enableTraceRemote pid =
46+ getSelfPid >>= enableTrace >> relay pid
47+
48+-- | Starts a /trace relay/ process on the remote node, which forwards all trace
49+-- events to the registered tracer on /this/ (the calling process') node.
50+startTraceRelay :: NodeId -> Process ProcessId
51+startTraceRelay nodeId = do
52+ withRegisteredTracer $ \pid ->
53+ spawn nodeId $ cpEnableTraceRemote pid
54+
55+-- | Set the given flags for a remote node (asynchronous).
56+setTraceFlagsRemote :: TraceFlags -> NodeId -> Process ()
57+setTraceFlagsRemote flags node = do
58+ nsendRemote node
59+ "trace.controller"
60+ ((Nothing :: Maybe (SendPort TraceOk)), flags)
61+
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.

src/Control/Distributed/Process/Serializable.hsnew file+73

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.