git.iko.soy/distributed-process
on 3ddacf5 help sign in
660d554
swap
0 ahead, 1026 behind
127 files changed+7851−14387
since splitsnapshots
unifiedsplit
.gitignore+11−3 .travis.yml−43 CONTRIBUTING.md−1 ChangeLog−236 README.md+108−10 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-tests/README.md−14 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-tests/LICENSE → distributed-process/LICENSE+1−1 Setup.hs → distributed-process/Setup.hs 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 LICENSE → network-transport-pipes/LICENSE+1−2 network-transport-pipes/network-transport-pipes.cabal+33 network-transport-pipes/src/Network/Transport/Pipes.hs+264 network-transport/LICENSE+31 distributed-process-tests/Setup.hs → network-transport/Setup.hs 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+11−3
@@ -1,4 +1,12 @@
1+tags
2+TAGS
13dist/
2−.cabal-sandbox
3−cabal.sandbox.config
4−.stack*
4+\#*#
5+*~
6+*.aux
7+*.hp
8+*.hi
9+*.o
10+*.prof
11+*.ps
12+*.swp
.travis.ymldeleted−43
@@ -1,43 +0,0 @@
1−language: c
2−
3−sudo: false
4−
5−matrix:
6− include:
7− - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"
8− addons: {apt: {packages: [libgmp-dev]}}
9− - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"
10− addons: {apt: {packages: [libgmp-dev]}}
11− - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"
12− addons: {apt: {packages: [libgmp-dev]}}
13− - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"
14− addons: {apt: {packages: [libgmp-dev]}}
15−
16−cache:
17− directories:
18− - $HOME/.stack
19−
20−before_install:
21−- export PATH=$HOME/.local/bin:$PATH;
22− mkdir -p ~/.local/bin;
23− travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';
24− stack --version
25−
26−install:
27−- stack $ARGS setup --no-terminal;
28− stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;
29−
30−script:
31−- export ARG='--test-arguments'
32− export TEST_PACKAGE="distributed-process-tests:"
33−- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory
34−- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP
35−- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure
36−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats
37−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory
38−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP
39−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory
40−
41−notifications:
42− slack:
43− secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=
CONTRIBUTING.mddeleted−1
@@ -1 +0,0 @@
1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
ChangeLogdeleted−236
@@ -1,236 +0,0 @@
1−[Unrealeased]
2−
3−*
4−
5−2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4
6−
7−* Added support for exceptions >= 0.10
8−
9−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3
10−
11−* Drop support for ghc-7.8.* and earlier.
12−
13−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2
14−
15−* Fixed build errors with ghc-8.2.1.
16−
17−2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1
18−
19−* Relax upper bounds in dependencies to build with ghc-8.2.1.
20−
21−2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0
22−
23−* Change type of message sent by `say` from a 3-tuple to a proper
24−type (`SayMessage`) with a proper `UTCTime`. (#291)
25−* Expose the MonitorRef in the withMonitor call.
26−* Have unmonitor remove the monitor message in the inbox. (#268)
27−* Remove Mx Data Tables. This API isn't used, is easy to replace with various
28−other packages. (#276)
29−* Add Ord instance to SpawnRef.
30−
31−2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6
32−
33−* Remove monitors from remote nodes when a process dies. (#295)
34−
35−2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5
36−
37−* Use only one connection to communicate between NCs. (#296, #297)
38−* Improve documentation of CQueue.
39−* Implement bidirectional multimaps for links and monitors. (#293, #294)
40−* Fix various warnings. (#292)
41−* Fix some of the intermittent failures in tests.
42−* Improve error messages when node controllers receive invalid requests.
43−(#290)
44−
45−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4
46−
47−* Fixup build errors.
48−
49−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3
50−
51−* Relax template-haskell upper bound.
52−
53−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2
54−
55−* Provide compatibility with ghc-8.0.1
56−* Remove dependency on ghc-prim.
57−* Don't throw exceptions asynchronously.
58−* Bump upper bounds of dependencies.
59−* Fix exception handling in callLocal.
60−* Have spawnLocal inherit the masking state of the caller.
61−* Have nsend send unencoded messages to local processes.
62−
63−2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1
64−
65−* Implement MonadCatch, MonadThrow, MonadMask for Process.
66−
67−2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0
68−
69−* Have nsendRemote skip the transport for local communication.
70−* Unsafe primitives for usend and nsendRemote.
71−* Stop using the transport for local communication.
72−* Skip the transport for whereisRemoteAsync and registerRemoteAsync.
73−* Have nsendRemote skip the transport for local communication.
74−* Have runProcess forward exceptions.
75−* Reimport distributed-process-tests. d-p and d-p-test now can be kept in
76−sync.
77−* Add a stack.yaml file for building tests and d-p all at once conveniently.
78−* Implement unreliable forward (uforward).
79−* Add Functor instance for Match data type
80−* Have `spawnAsync` not use the transport in the local case.
81−* Fix monitor race in 'call'.
82−* Add compatibility with ghc-7.10: support new typeable, loosen deps, write
83−proper NFData instances, support new TH.
84−* Kill processes on a local node upon closeLocalNode.
85−* Fix getNodeStats function, see DP-97
86−* Return size of the queue in ProcessInfo.
87−* Implement unreliable send (usend).
88−* Implement MonadFix instance for Process.
89−* Introduce callLocal primitive.
90−* Prevent message loss due to timeouts in CQueue.
91−* More informative ProcessRegistrationException. Now includes the identifier
92−of the process that owns the name, if any.
93−* Avoid message loop between threads when tracing received messages.
94−
95−2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5
96−
97−* Fix dependencies.
98−* Add compatibility with GHC-7.10.
99−* Fix various race conditions (DP-99, DP-103).
100−
101−2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.5.2
102−
103−* Fix docstring for `register`
104−* Added Data instance to ProcessId, LocalProcessId and NodeId
105−* Add static serialiation dictionary for 'Static', for completeness
106−* Add Closure static serialization dictionary
107−* Replacement for modifyMVarMasked for GHC <= 7.4
108−* Document the use of built-in trace flags
109−* Make forkProcess exception-safe
110−* Make -Wall clean
111−
112−2014-08-13 Tim Watson <watson.timothy@gmail.com> 0.5.1
113−
114−* Fix cabal docs (thanks Markus Barenhoff)
115−* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)
116−
117−2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.5.0
118−
119−* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file
120−* Race condition in local monitoring when using call
121−* mask now works correctly if unmask is called by another process
122−* Improve efficiency of local message passing
123−* nsend uses local communication channels
124−* Link Node Controller and Network Listener
125−* Label spawned processes using labelThread
126−* Relaxed upper bound on syb in the cabal manifest
127−* Bump binary version to include 0.7.*
128−* Exposed process info
129−* Exposed node statistics
130−* Moved tests to https://github.com/haskell-distributed/distributed-process-tests
131−* Added "polymorphic expect"
132−* Exposed Message type and broaden scope of polymorphic expect
133−* Added Management API (for working with internal/system events)
134−* Tracing can no longer be disabled
135−* We now report node statistics for monitoring/management
136−* Node.runProcess now propagates exceptions to its caller
137−* Added simple micro benchmarks
138−
139−2013-01-27 Tim Watson <watson.timothy@gmail.com> 0.4.2
140−
141−* Improved exception handling for deferred type checked exit reasons
142−* Add matchChan primitive (thanks Simon Marlow)
143−* Expose deferred message handling/checking for AbstractMessage
144−* Add `getProcessInfo' API
145−* Add `trace' API backed by the GHC eventlog
146−
147−2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.4.1
148−
149−* Make behaviour of 'register' more Erlang-like (register will now fail if the
150−name is already registered). Patch by Jeff Epstein.
151−* Functor, Applicative, Alternative and Monad instances for ReceivePort
152−* Add support for receiveChanTimeout
153−* Improved documentation
154−* Avoid name clashes in the TH generation for closures
155−* Relax package bounds to allow for Binary 0.6
156−
157−2012-10-23 Edsko de Vries <edsko@well-typed.com> 0.4.0.2
158−
159−* Fix race condition in spawn
160−
161−2012-10-04 Edsko de Vries <edsko@well-typed.com> 0.4.0.1
162−
163−* Relax package boundaries
164−
165−2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.4.0
166−
167−* Improved treatment of network failure, using new failure semantics of
168−Network.Transport.
169−* Make NodeId Typeable
170−* Extend Template Haskell support with "remotableDec" so that you can refer to
171−$(mkClosure 'f) within the body of "f".
172−* Fix bug in spawnChannelLocal
173−* Numerous memory leaks plugged
174−* Relax upper bound on dependency on 'network'
175−* New primitive 'matchAny'
176−* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync')
177−
178−2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1
179−
180−* Fix memory leaks
181−* Make Template Haskell support optional
182−* Relax dependency constraints
183−
184−2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0
185−
186−* Extract 'static' into a separate package (C.D.Static)
187−* Use new package rank1dynamic to proper runtime checks for polymorphic values
188−
189−2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0
190−
191−* Expose the constructors of Closure
192−* Add instance (Typeable a => Serializable (Static a)) and make sure we only
193−use the internal representation of Static where really necessary
194−* Improved docs
195−
196−2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0
197−
198−* Add exception handling primitives
199−* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on
200−MVar' exception would be thrown.
201−
202−2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
203−
204−* Bugfix in the node controller
205−(one way this bug materialized: when using the SimpleLocalnet backend,
206−slave nodes could not be reused)
207−* Improved documentation in Control.Distributed.Process.Closure
208−
209−2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
210−
211−* Improve docs
212−* Local versions of spawn
213−
214−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
215−
216−* Base 4.6 compatibility
217−* Relax constraints on bytestring and containers
218−
219−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1
220−
221−* Relax upper bound on 'time' dependency
222−
223−2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1
224−
225−* Complete redesign of the underlying implementation of static values and
226−closures.
227−
228−* Add support for 'spawnChannel'
229−
230−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
231−
232−* Bugfix: Continue processing messages when a connection breaks.
233−
234−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
235−
236−* Initial release.
README.md+108−10
@@ -1,16 +1,114 @@
1−# distributed-process
2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)
3−[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)
1+Haskell Distributed Project
2+===========================
43
5−This repository is part of Cloud Haskell.
4+This repository holds an implementation of [Cloud Haskell][1] based on the work
5+of Jeff Epstein, Andrew Black, and Simon Peyton-Jones.
66
7−See http://haskell-distributed.github.com for documentation, user guides,
8−tutorials and assistance.
7+At present, this repository hosts two packages:
98
10−## Getting Help / Raising Issues
9+* distributed-process
10+* network-transport
1111
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.
12+For more detailed information about the interfaces provided by these packages,
13+please refer to the [distributed-process repository wiki][2].
1314
14−## License
15+Examples
16+--------
1517
16−This package is made available under a 3-clause BSD-style license.
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
benchmarks/.gitignorenew file+3
@@ -0,0 +1,3 @@
1+*.swp
2+*.exe
3+*.data
benchmarks/Channels.hsdeleted−43
@@ -1,43 +0,0 @@
1−-- | Like Latency, but creating lots of channels
2−import System.Environment
3−import Control.Monad
4−import Control.Applicative
5−import Control.Distributed.Process
6−import Control.Distributed.Process.Node
7−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
8−import Data.Binary (encode, decode)
9−import qualified Data.ByteString.Lazy as BSL
10−
11−pingServer :: Process ()
12−pingServer = forever $ do
13− them <- expect
14− sendChan them ()
15− -- TODO: should this be automatic?
16− reconnectPort them
17−
18−pingClient :: Int -> ProcessId -> Process ()
19−pingClient n them = do
20− replicateM_ n $ do
21− (sc, rc) <- newChan :: Process (SendPort (), ReceivePort ())
22− send them sc
23− receiveChan rc
24− liftIO . putStrLn $ "Did " ++ show n ++ " pings"
25−
26−initialProcess :: String -> Process ()
27−initialProcess "SERVER" = do
28− us <- getSelfPid
29− liftIO $ BSL.writeFile "pingServer.pid" (encode us)
30− pingServer
31−initialProcess "CLIENT" = do
32− n <- liftIO $ getLine
33− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
34− pingClient (read n) them
35−
36−main :: IO ()
37−main = do
38− [role, host, port] <- getArgs
39− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
40− case trans of
41− Right transport -> do node <- newLocalNode transport initRemoteTable
42− runProcess node $ initialProcess role
43− Left other -> error $ show other
benchmarks/Headers.gnuplotnew file+16
@@ -0,0 +1,16 @@
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.gnuplotnew file+16
@@ -0,0 +1,16 @@
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.cnew file+150
@@ -0,0 +1,150 @@
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.hsnew file+134
@@ -0,0 +1,134 @@
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.hsnew file+105
@@ -0,0 +1,105 @@
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.hsnew file+131
@@ -0,0 +1,131 @@
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.hsnew file+127
@@ -0,0 +1,127 @@
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.hsnew file+127
@@ -0,0 +1,127 @@
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.hsnew file+95
@@ -0,0 +1,95 @@
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.hsnew file+151
@@ -0,0 +1,151 @@
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.hsnew file+131
@@ -0,0 +1,131 @@
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.hsdeleted−39
@@ -1,39 +0,0 @@
1−import System.Environment
2−import Control.Monad
3−import Control.Applicative
4−import Control.Distributed.Process
5−import Control.Distributed.Process.Node
6−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
7−import Data.Binary (encode, decode)
8−import qualified Data.ByteString.Lazy as BSL
9−
10−pingServer :: Process ()
11−pingServer = forever $ do
12− them <- expect
13− send them ()
14−
15−pingClient :: Int -> ProcessId -> Process ()
16−pingClient n them = do
17− us <- getSelfPid
18− replicateM_ n $ send them us >> (expect :: Process ())
19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20−
21−initialProcess :: String -> Process ()
22−initialProcess "SERVER" = do
23− us <- getSelfPid
24− liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25− pingServer
26−initialProcess "CLIENT" = do
27− n <- liftIO $ getLine
28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29− pingClient (read n) them
30−
31−main :: IO ()
32−main = do
33− [role, host, port] <- getArgs
34− trans <- createTransport
35− (defaultTCPAddr host port) defaultTCPParameters
36− case trans of
37− Right transport -> do node <- newLocalNode transport initRemoteTable
38− runProcess node $ initialProcess role
39− Left other -> error $ show other
benchmarks/Makefilenew file+72
@@ -0,0 +1,72 @@
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.JustPingnew file+48
@@ -0,0 +1,48 @@
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.hsnew file+112
@@ -0,0 +1,112 @@
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.hsnew file+133
@@ -0,0 +1,133 @@
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.hsnew file+128
@@ -0,0 +1,128 @@
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.hsdeleted−117
@@ -1,117 +0,0 @@
1−{- ProcessRing benchmarks.
2−
3−To run the benchmarks, select a value for the ring size (sz) and
4−the number of times to send a message around the ring
5−
6−-}
7−
8−{-# LANGUAGE BangPatterns #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−
11−import Control.Monad
12−import Control.Distributed.Process hiding (catch)
13−import Control.Distributed.Process.Node
14−import Control.Exception (catch, SomeException)
15−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
16−import System.Environment
17−import System.Console.GetOpt
18−
19−data Options = Options
20− { optRingSize :: Int
21− , optIterations :: Int
22− , optForward :: Bool
23− , optParallel :: Bool
24− , optUnsafe :: Bool
25− } deriving Show
26−
27−initialProcess :: Options -> Process ()
28−initialProcess op =
29− let ringSz = optRingSize op
30− msgCnt = optIterations op
31− fwd = optForward op
32− unsafe = optUnsafe op
33− msg = ("foobar", "baz")
34− in do
35− self <- getSelfPid
36− ring <- makeRing fwd unsafe ringSz self
37− forM_ [1..msgCnt] (\_ -> send ring msg)
38− collect msgCnt
39− where relay fsend pid = do
40− msg <- expect :: Process (String, String)
41− fsend pid msg
42− relay fsend pid
43−
44− forward' pid =
45− receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid
46−
47− makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId
48− makeRing !f !u !n !pid
49− | n == 0 = go f u pid
50− | otherwise = go f u pid >>= makeRing f u (n - 1)
51−
52− go :: Bool -> Bool -> ProcessId -> Process ProcessId
53− go False False next = spawnLocal $ relay send next
54− go False True next = spawnLocal $ relay unsafeSend next
55− go True _ next = spawnLocal $ forward' next
56−
57− collect :: Int -> Process ()
58− collect !n
59− | n == 0 = return ()
60− | otherwise = do
61− receiveWait [
62− matchIf (\(a, b) -> a == "foobar" && b == "baz")
63− (\_ -> return ())
64− , matchAny (\_ -> error "unexpected input!")
65− ]
66− collect (n - 1)
67−
68−defaultOptions :: Options
69−defaultOptions = Options
70− { optRingSize = 10
71− , optIterations = 100
72− , optForward = False
73− , optParallel = False
74− , optUnsafe = False
75− }
76−
77−options :: [OptDescr (Options -> Options)]
78−options =
79− [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"
80− , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"
81− , Option ['f'] ["forward"]
82− (NoArg (\opts -> opts { optForward = True }))
83− "use `forward' instead of send - default = False"
84− , Option ['u'] ["unsafe-send"]
85− (NoArg (\opts -> opts { optUnsafe = True }))
86− "use 'unsafeSend' (ignored with -f) - default = False"
87− , Option ['p'] ["parallel"]
88− (NoArg (\opts -> opts { optParallel = True }))
89− "send in parallel and consume sequentially - default = False"
90− ]
91−
92−optMsgCnt :: Maybe String -> Options -> Options
93−optMsgCnt Nothing opts = opts
94−optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }
95−
96−optSz :: Maybe String -> Options -> Options
97−optSz Nothing opts = opts
98−optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }
99−
100−parseArgv :: [String] -> IO (Options, [String])
101−parseArgv argv = do
102− pn <- getProgName
103− case getOpt Permute options argv of
104− (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
105− (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))
106− where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"
107−
108−main :: IO ()
109−main = do
110− argv <- getArgs
111− (opt, _) <- parseArgv argv
112− putStrLn $ "options: " ++ (show opt)
113− Right transport <- createTransport
114− (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters
115− node <- newLocalNode transport initRemoteTable
116− catch (void $ runProcess node $ initialProcess opt)
117− (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
benchmarks/SendTCP.hsnew file+109
@@ -0,0 +1,109 @@
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.hsnew file+117
@@ -0,0 +1,117 @@
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.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−-- | Like Throughput, but send every ping from a different process
4−-- (i.e., require a lightweight connection per ping)
5−import System.Environment
6−import Control.Monad
7−import Control.Applicative
8−import Control.Distributed.Process
9−import Control.Distributed.Process.Node
10−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)
11−import Data.Binary (encode, decode)
12−import qualified Data.ByteString.Lazy as BSL
13−
14−counter :: Process ()
15−counter = go 0
16− where
17− go :: Int -> Process ()
18− go !n = do
19− b <- expect
20− case b of
21− Nothing -> go (n + 1)
22− Just them -> send them n >> go 0
23−
24−count :: Int -> ProcessId -> Process ()
25−count n them = do
26− us <- getSelfPid
27− replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)
28− send them (Just us)
29− n' <- expect
30− liftIO $ print (n == n')
31−
32−initialProcess :: String -> Process ()
33−initialProcess "SERVER" = do
34− us <- getSelfPid
35− liftIO $ BSL.writeFile "counter.pid" (encode us)
36− counter
37−initialProcess "CLIENT" = do
38− n <- liftIO $ getLine
39− them <- liftIO $ decode <$> BSL.readFile "counter.pid"
40− count (read n) them
41−
42−main :: IO ()
43−main = do
44− [role, host, port] <- getArgs
45− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
46− case trans of
47− Right transport -> do node <- newLocalNode transport initRemoteTable
48− runProcess node $ initialProcess role
49− Left other -> error $ show other
benchmarks/Throughput.hsdeleted−74
@@ -1,74 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−
4−import System.Environment
5−import Control.Monad
6−import Control.Applicative
7−import Control.Distributed.Process
8−import Control.Distributed.Process.Node
9−import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)
10−import Data.Binary
11−import qualified Data.ByteString.Lazy as BSL
12−import Data.Typeable
13−
14−data SizedList a = SizedList { size :: Int , elems :: [a] }
15− deriving (Typeable)
16−
17−instance Binary a => Binary (SizedList a) where
18− put (SizedList sz xs) = put sz >> mapM_ put xs
19− get = do
20− sz <- get
21− xs <- getMany sz
22− return (SizedList sz xs)
23−
24−-- Copied from Data.Binary
25−getMany :: Binary a => Int -> Get [a]
26−getMany = go []
27− where
28− go xs 0 = return $! reverse xs
29− go xs i = do x <- get
30− x `seq` go (x:xs) (i-1)
31−{-# INLINE getMany #-}
32−
33−nats :: Int -> SizedList Int
34−nats = \n -> SizedList n (aux n)
35− where
36− aux 0 = []
37− aux n = n : aux (n - 1)
38−
39−counter :: Process ()
40−counter = go 0
41− where
42− go :: Int -> Process ()
43− go !n =
44− receiveWait
45− [ match $ \xs -> go (n + size (xs :: SizedList Int))
46− , match $ \them -> send them n >> go 0
47− ]
48−
49−count :: (Int, Int) -> ProcessId -> Process ()
50−count (packets, sz) them = do
51− us <- getSelfPid
52− replicateM_ packets $ send them (nats sz)
53− send them us
54− n' <- expect
55− liftIO $ print (packets * sz, n' == packets * sz)
56−
57−initialProcess :: String -> Process ()
58−initialProcess "SERVER" = do
59− us <- getSelfPid
60− liftIO $ BSL.writeFile "counter.pid" (encode us)
61− counter
62−initialProcess "CLIENT" = do
63− n <- liftIO getLine
64− them <- liftIO $ decode <$> BSL.readFile "counter.pid"
65− count (read n) them
66−
67−main :: IO ()
68−main = do
69− [role, host, port] <- getArgs
70− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
71− case trans of
72− Right transport -> do node <- newLocalNode transport initRemoteTable
73− runProcess node $ initialProcess role
74− Left other -> error $ show other
benchmarks/erlang/latency.erldeleted−35
@@ -1,35 +0,0 @@
1−-module(latency).
2−
3−-export([server/0, client/2, start_server/0, start_client/2]).
4−
5−forever(What) ->
6− What(),
7− forever(What).
8−
9−replicate(0, _) ->
10− ok;
11−replicate(N, What) ->
12− What(),
13− replicate(N - 1, What).
14−
15−server() ->
16− forever(fun () ->
17− receive
18− Them -> Them ! pong
19− end
20− end).
21−
22−client(N, Them) ->
23− replicate(N, fun() ->
24− {pingServer, Them} ! self(),
25− receive
26− pong -> ok
27− end
28− end),
29− io:format("Did ~B pings", [N]).
30−
31−start_server() ->
32− register(pingServer, spawn(latency, server, [])).
33−
34−start_client(N, Them) ->
35− client(N, Them).
benchmarks/erlang/ring.erldeleted−62
@@ -1,62 +0,0 @@
1−%% can be run via escript if desired...
2−-module(ring).
3−
4−-export([main/1]).
5−
6−-record(opts, {
7− ring_size = 1 :: non_neg_integer(),
8− iterations = 1 :: non_neg_integer()
9−}).
10−
11−main(Argv) when is_list(Argv) ->
12− Opts = parse_args(Argv),
13− {Time, ok} = timer:tc(fun() -> run(Opts) end),
14− io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).
15−
16−run(#opts{ ring_size=RingSize, iterations=SendCount }) ->
17− Self = self(),
18− Msg = {"foobar", "baz"},
19− Pid = make_ring(RingSize, Self),
20− [Pid ! Msg || _ <- lists:seq(1, SendCount)],
21− collect(SendCount).
22−
23−collect(0) ->
24− ok;
25−collect(N) ->
26− receive
27− {"foobar", "baz"} -> collect(N - 1);
28− Other -> exit({unexpected_message, Other})
29− end.
30−
31−-spec(make_ring(integer(), pid()) -> pid()).
32−make_ring(0, NextPid) ->
33− go(NextPid);
34−make_ring(NumProcs, NextPid) ->
35− make_ring(NumProcs - 1, go(NextPid)).
36−
37−-spec(go(pid()) -> pid()).
38−go(NextPid) ->
39− spawn(fun() -> relay(NextPid) end).
40−
41−-spec(relay(pid()) -> no_return()).
42−relay(NextPid) ->
43− receive
44− {_, _}=Msg -> NextPid ! Msg, relay(NextPid)
45− end.
46−
47−-spec(parse_args([string()]) -> #opts{}).
48−parse_args(Argv) ->
49− lists:foldl(fun parse_args/2, #opts{}, Argv).
50−
51−parse_args(("-r" ++ Val), Opts) ->
52− Sz = check_positive(ring_size, list_to_integer(Val)),
53− Opts#opts{ ring_size = Sz };
54−parse_args(("-i" ++ Val), Opts) ->
55− Iter = check_positive(iterations, list_to_integer(Val)),
56− Opts#opts{ iterations = Iter }.
57−
58−check_positive(K, N) when N < 1 ->
59− io:format("~p must be >= 1~n", [K]),
60− error({K, N});
61−check_positive(_, N) ->
62− N.
benchmarks/erlang/throughput.erldeleted−39
@@ -1,39 +0,0 @@
1−-module(throughput).
2−
3−-export([start_counter/0, start_count/3, counter/0, count/3, nats/1]).
4−
5−nats(0) ->
6− [];
7−nats(N) ->
8− [N | nats(N - 1)].
9−
10−counter() ->
11− counter(0).
12−
13−counter(N) ->
14− receive
15− {count, List} ->
16− counter(N + length(List));
17− {get, Them} ->
18− Them ! N,
19− counter(0)
20− end.
21−
22−replicate(0, _) ->
23− ok;
24−replicate(N, What) ->
25− What(),
26− replicate(N - 1, What).
27−
28−count(Packets, Size, Them) ->
29− replicate(Packets, fun() -> {counter, Them} ! {count, nats(Size)} end),
30− {counter, Them} ! {get, self()},
31− receive
32− N -> io:format("Did ~B pings", [N])
33− end.
34−
35−start_counter() ->
36− register(counter, spawn(throughput, counter, [])).
37−
38−start_count(Packets, Size, Them) ->
39− count(Packets, Size, Them).
benchmarks/pingtest.cnew file+183
@@ -0,0 +1,183 @@
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.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2−
3−import Control.Monad
4−import Control.Applicative
5−import Control.Monad.IO.Class (liftIO)
6−import qualified Data.ByteString.Lazy as BSL
7−import Data.Binary (encode, decode)
8−import Remote
9−
10−pingServer :: ProcessM ()
11−pingServer = forever $ do
12− them <- expect
13− send them ()
14−
15−pingClient :: Int -> ProcessId -> ProcessM ()
16−pingClient n them = do
17− us <- getSelfPid
18− replicateM_ n $ send them us >> (expect :: ProcessM ())
19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"
20−
21−initialProcess :: String -> ProcessM ()
22−initialProcess "SERVER" = do
23− us <- getSelfPid
24− liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25− pingServer
26−initialProcess "CLIENT" = do
27− n <- liftIO $ getLine
28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
29− pingClient (read n) them
30−
31−main :: IO ()
32−main = remoteInit (Just "config") [] initialProcess
benchmarks/remote/Throughput.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-# LANGUAGE BangPatterns, TemplateHaskell #-}
2−
3−import Control.Monad
4−import Control.Applicative
5−import Control.Monad.IO.Class (liftIO)
6−import qualified Data.ByteString.Lazy as BSL
7−import Data.Binary (encode, decode)
8−import Remote
9−
10−counter :: ProcessM ()
11−counter = go 0
12− where
13− go :: Int -> ProcessM ()
14− go !n = do
15− b <- expect
16− case b of
17− Nothing -> go (n + 1)
18− Just them -> send them n >> go 0
19−
20−count :: Int -> ProcessId -> ProcessM ()
21−count n them = do
22− us <- getSelfPid
23− replicateM_ n $ send them (Nothing :: Maybe ProcessId)
24− send them (Just us)
25− n' <- expect
26− liftIO $ print (n == n')
27−
28−initialProcess :: String -> ProcessM ()
29−initialProcess "SERVER" = do
30− us <- getSelfPid
31− liftIO $ BSL.writeFile "counter.pid" (encode us)
32− counter
33−initialProcess "CLIENT" = do
34− n <- liftIO $ getLine
35− them <- liftIO $ decode <$> BSL.readFile "counter.pid"
36− count (read n) them
37−
38−main :: IO ()
39−main = remoteInit (Just "config") [] initialProcess
benchmarks/results_notes.mdnew file+111
@@ -0,0 +1,111 @@
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/.gitignoredeleted−4
@@ -1,4 +0,0 @@
1−dist/
2−.cabal-sandbox
3−cabal.sandbox.config
4−.stack*
distributed-process-tests/CONTRIBUTING.mddeleted−1
@@ -1 +0,0 @@
1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.
distributed-process-tests/README.mddeleted−14
@@ -1,14 +0,0 @@
1−# distributed-process-tests
2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process-tests.png)](http://travis-ci.org/haskell-distributed/distributed-process-tests)
3−[![Release](https://img.shields.io/hackage/v/distributed-process-tests.svg)](https://hackage.haskell.org/package/distributed-process-tests)
4−
5−See http://haskell-distributed.github.com for documentation, user guides,
6−tutorials and assistance.
7−
8−## Getting Help / Raising Issues
9−
10−Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-tests/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.
11−
12−## License
13−
14−This package is made available under a 3-clause BSD-style license.
distributed-process-tests/distributed-process-tests.cabaldeleted−158
@@ -1,158 +0,0 @@
1−name: distributed-process-tests
2−version: 0.4.11
3−synopsis: Tests and test support tools for distributed-process.
4−homepage: http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests
5−description: Tests and test suite for Cloud Haskell libraries.
6−license: BSD3
7−license-file: LICENSE
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: Tim Watson <watson.timothy@gmail.com>
10−copyright: Well-Typed LLP
11−category: Control, Cloud Haskell
12−build-type: Simple
13−cabal-version: >=1.8
14−
15−flag tcp
16− Description: build and run TCP tests
17− Default: False
18−
19−library
20− exposed-modules: Network.Transport.Test
21− Control.Distributed.Process.Tests.CH
22− Control.Distributed.Process.Tests.Closure
23− Control.Distributed.Process.Tests.Mx
24− Control.Distributed.Process.Tests.Receive
25− Control.Distributed.Process.Tests.Stats
26− Control.Distributed.Process.Tests.Tracing
27− Control.Distributed.Process.Tests.Internal.Utils
28− Build-Depends: base >= 4.4 && < 5,
29− ansi-terminal >= 0.5,
30− binary >= 0.5 && < 0.9,
31− bytestring >= 0.9 && < 0.12,
32− distributed-process >= 0.6.0 && < 0.8,
33− distributed-static,
34− exceptions >= 0.5,
35− HUnit >= 1.2 && < 1.7,
36− network-transport >= 0.4.1.0 && < 0.6,
37− network >= 2.5 && < 2.9,
38− random >= 1.0 && < 1.2,
39− rematch >= 0.1.2.1,
40− setenv >= 0.1.1.3,
41− test-framework >= 0.6 && < 0.9,
42− test-framework-hunit >= 0.2.0 && < 0.4,
43− stm
44− hs-source-dirs: src
45− ghc-options: -Wall -fno-warn-unused-do-bind
46− extensions: CPP,
47− ExistentialQuantification,
48− FlexibleInstances,
49− DeriveDataTypeable,
50− DeriveGeneric,
51− GeneralizedNewtypeDeriving,
52− RankNTypes,
53− RecordWildCards,
54− ScopedTypeVariables
55− if impl(ghc <= 7.4.2)
56− Build-Depends: ghc-prim == 0.2.0.0
57−
58−Test-Suite TestCHInMemory
59− Type: exitcode-stdio-1.0
60− Main-Is: runInMemory.hs
61− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
62− Build-Depends: base >= 4.4 && < 5,
63− distributed-process-tests,
64− network >= 2.3 && < 2.9,
65− network-transport >= 0.4.1.0 && < 0.6,
66− network-transport-inmemory >= 0.5,
67− test-framework >= 0.6 && < 0.9
68− Extensions: CPP
69− ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
70− HS-Source-Dirs: tests
71−
72−Test-Suite TestCHInTCP
73− Type: exitcode-stdio-1.0
74− Main-Is: runTCP.hs
75− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
76− if flag(tcp)
77− Build-Depends: base >= 4.4 && < 5,
78− distributed-process-tests,
79− network >= 2.3 && < 2.9,
80− network-transport >= 0.4.1.0 && < 0.6,
81− network-transport-tcp >= 0.5 && < 0.7,
82− test-framework >= 0.6 && < 0.9
83− else
84− Buildable: False
85− Extensions: CPP
86− ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
87− HS-Source-Dirs: tests
88−
89−
90−Test-Suite TestClosure
91− Type: exitcode-stdio-1.0
92− Main-Is: runInMemory.hs
93− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure
94− Build-Depends: base >= 4.4 && < 5,
95− distributed-process-tests,
96− network >= 2.3 && < 2.9,
97− network-transport >= 0.4.1.0 && < 0.6,
98− network-transport-inmemory >= 0.5,
99− test-framework >= 0.6 && < 0.9
100− Extensions: CPP
101− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
102− HS-Source-Dirs: tests
103−
104−Test-Suite TestStats
105− Type: exitcode-stdio-1.0
106− Main-Is: runInMemory.hs
107− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats
108− Build-Depends: base >= 4.4 && < 5,
109− distributed-process-tests,
110− network >= 2.3 && < 2.9,
111− network-transport >= 0.4.1.0 && < 0.6,
112− network-transport-inmemory >= 0.5,
113− test-framework >= 0.6 && < 0.9
114− Extensions: CPP
115− ghc-options: -Wall -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
116− HS-Source-Dirs: tests
117−
118−Test-Suite TestMxInMemory
119− Type: exitcode-stdio-1.0
120− Main-Is: runInMemory.hs
121− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
122− Build-Depends: base >= 4.4 && < 5,
123− distributed-process-tests,
124− network >= 2.3 && < 2.9,
125− network-transport >= 0.4.1.0 && < 0.6,
126− network-transport-inmemory >= 0.5,
127− test-framework >= 0.6 && < 0.9
128− Extensions: CPP
129− ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
130− HS-Source-Dirs: tests
131−
132−Test-Suite TestTracingInMemory
133− Type: exitcode-stdio-1.0
134− Main-Is: runInMemory.hs
135− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing
136− Build-Depends: base >= 4.4 && < 5,
137− distributed-process-tests,
138− network >= 2.3 && < 2.9,
139− network-transport >= 0.4.1.0 && < 0.6,
140− network-transport-inmemory >= 0.5,
141− test-framework >= 0.6 && < 0.9
142− Extensions: CPP
143− ghc-options: -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
144− HS-Source-Dirs: tests
145−
146−Test-Suite TestMxInTCP
147− Type: exitcode-stdio-1.0
148− Main-Is: runInMemory.hs
149− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
150− Build-Depends: base >= 4.4 && < 5,
151− distributed-process-tests,
152− network >= 2.3 && < 2.9,
153− network-transport >= 0.4.1.0 && < 0.6,
154− network-transport-inmemory >= 0.5,
155− test-framework >= 0.6 && < 0.9
156− Extensions: CPP
157− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
158− HS-Source-Dirs: tests
distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hsdeleted−1879
@@ -1,1879 +0,0 @@
1−module Control.Distributed.Process.Tests.CH (tests) where
2−
3−#if ! MIN_VERSION_base(4,6,0)
4−import Prelude hiding (catch)
5−#endif
6−
7−import Network.Transport.Test (TestTransport(..))
8−
9−import Data.Binary (Binary(..))
10−import Data.Typeable (Typeable)
11−import Data.Foldable (forM_)
12−import Data.Function (fix)
13−import Data.IORef
14− ( readIORef
15− , writeIORef
16− , newIORef
17− )
18−import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)
19−import Control.Concurrent.MVar
20− ( MVar
21− , newEmptyMVar
22− , putMVar
23− , takeMVar
24− , readMVar
25− )
26−import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
27−import Control.Exception (SomeException, throwIO, ErrorCall(..))
28−import Control.Monad.Catch (try, catch, finally, mask, onException)
29−import Control.Applicative ((<|>))
30−import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31−import Control.Distributed.Process hiding
32− ( try
33− , catch
34− , finally
35− , mask
36− , onException
37− )
38−import Control.Distributed.Process.Internal.Types
39− ( LocalNode(localEndPoint)
40− , ProcessExitException(..)
41− , nullProcessId
42− , createUnencodedMessage
43− )
44−import Control.Distributed.Process.Node
45−import Control.Distributed.Process.Debug
46−import Control.Distributed.Process.Management.Internal.Types
47−import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)
48−import Control.Distributed.Process.Serializable (Serializable)
49−import Data.Maybe (isNothing, isJust)
50−import Test.HUnit (Assertion, assertBool, assertFailure)
51−import Test.Framework (Test, testGroup)
52−import Test.Framework.Providers.HUnit (testCase)
53−import Control.Rematch hiding (match, isNothing, isJust)
54−import Control.Rematch.Run (Match(..))
55−
56−newtype Ping = Ping ProcessId
57− deriving (Typeable, Binary, Show)
58−
59−newtype Pong = Pong ProcessId
60− deriving (Typeable, Binary, Show)
61−
62−--------------------------------------------------------------------------------
63−-- Supporting definitions --
64−--------------------------------------------------------------------------------
65−
66−expectThat :: a -> Matcher a -> Assertion
67−expectThat a matcher = case res of
68− MatchSuccess -> return ()
69− (MatchFailure msg) -> assertFailure msg
70− where res = runMatch matcher a
71−
72−-- | Like fork, but throw exceptions in the child thread to the parent
73−forkTry :: IO () -> IO ThreadId
74−forkTry p = do
75− tid <- myThreadId
76− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
77−
78−-- | The ping server from the paper
79−ping :: Process ()
80−ping = do
81− Pong partner <- expect
82− self <- getSelfPid
83− send partner (Ping self)
84− ping
85−
86−verifyClient :: String -> MVar Bool -> IO ()
87−verifyClient s b = takeMVar b >>= assertBool s
88−
89−expectPing :: MVar Bool -> Process ()
90−expectPing mv = expect >>= liftIO . putMVar mv . checkPing
91− where
92− checkPing (Ping _) = True
93−
94−-- | Quick and dirty synchronous version of whereisRemoteAsync
95−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
96−whereisRemote nid string = do
97− whereisRemoteAsync nid string
98− receiveWait [
99− match (\(WhereIsReply _ mPid) -> return mPid)
100− ]
101−
102−verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
103−verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return
104−
105−waitForExit :: ProcessId -> Process DiedReason
106−waitForExit pid = monitor pid >>= waitForDown
107−
108−waitForDown :: MonitorRef -> Process DiedReason
109−waitForDown ref =
110− receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
111− (\(ProcessMonitorNotification _ _ dr) -> return dr) ]
112−
113−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
114−syncBreakConnection breakConnection nid0 nid1 = do
115− m <- newEmptyMVar
116− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
117− runProcess nid0 $ do
118− them <- liftIO $ takeMVar m
119− pinger <- spawnLocal $ forever $ send them ()
120− _ <- monitorNode (localNodeId nid1)
121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
122− (nodeAddress $ localNodeId nid1)
123− NodeMonitorNotification _ _ _ <- expect
124− kill pinger "finished"
125− return ()
126−
127−data Add = Add ProcessId Double Double deriving (Typeable)
128−data Divide = Divide ProcessId Double Double deriving (Typeable)
129−data DivByZero = DivByZero deriving (Typeable)
130−
131−instance Binary Add where
132− put (Add pid x y) = put pid >> put x >> put y
133− get = Add <$> get <*> get <*> get
134−
135−instance Binary Divide where
136− put (Divide pid x y) = put pid >> put x >> put y
137− get = Divide <$> get <*> get <*> get
138−
139−instance Binary DivByZero where
140− put DivByZero = return ()
141− get = return DivByZero
142−
143−-- The math server from the paper
144−math :: Process ()
145−math = do
146− receiveWait
147− [ match (\(Add pid x y) -> send pid (x + y))
148− , matchIf (\(Divide _ _ y) -> y /= 0)
149− (\(Divide pid x y) -> send pid (x / y))
150− , match (\(Divide pid _ _) -> send pid DivByZero)
151− ]
152− math
153−
154−-- | Monitor or link to a remote node
155−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
156− -> ProcessId -- ^ Process to monitor/link to
157− -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up
158− -> Process (Maybe MonitorRef)
159−monitorOrLink mOrL pid mSignal = do
160− result <- if mOrL then Just <$> monitor pid
161− else link pid >> return Nothing
162− -- Monitor is asynchronous, which usually does not matter but if we want a
163− -- *specific* signal then it does. Therefore we wait until the MonitorRef is
164− -- listed in the ProcessInfo and hope that this means the monitor has been set
165− -- up.
166− forM_ mSignal $ \signal -> do
167− self <- getSelfPid
168− spawnLocal $ do
169− let waitForMOrL = do
170− liftIO $ threadDelay 100000
171− mpinfo <- getProcessInfo pid
172− case mpinfo of
173− Nothing -> waitForMOrL
174− Just pinfo ->
175− if mOrL then
176− unless (result == lookup self (infoMonitors pinfo)) waitForMOrL
177− else
178− unless (elem self $ infoLinks pinfo) waitForMOrL
179− waitForMOrL
180− liftIO $ putMVar signal ()
181− return result
182−
183−monitorTestProcess :: ProcessId -- Process to monitor/link to
184− -> Bool -- 'True' for monitor, 'False' for link
185− -> Bool -- Should we unmonitor?
186− -> DiedReason -- Expected cause of death
187− -> Maybe (MVar ()) -- Signal for 'monitor set up'
188− -> MVar () -- Signal for successful termination
189− -> Process ()
190−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
191− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
192− case (un, mRef) of
193− (True, Nothing) -> do
194− unlink theirAddr
195− liftIO $ putMVar done ()
196− (True, Just ref) -> do
197− unmonitor ref
198− liftIO $ putMVar done ()
199− (False, ref) -> do
200− receiveWait [
201− match (\(ProcessMonitorNotification ref' pid reason') -> do
202− liftIO $ do
203− assertBool "Bad Monitor Signal"
204− (Just ref' == ref && pid == theirAddr &&
205− mOrL && reason == reason')
206− putMVar done ())
207− ]
208− )
209− (\(ProcessLinkException pid reason') -> do
210− (liftIO $ assertBool "link exception unmatched" $
211− pid == theirAddr && not mOrL && not un && reason == reason')
212− liftIO $ putMVar done ()
213− )
214−
215−--------------------------------------------------------------------------------
216−-- The tests proper --
217−--------------------------------------------------------------------------------
218−
219−-- | Basic ping test
220−testPing :: TestTransport -> Assertion
221−testPing TestTransport{..} = do
222− serverAddr <- newEmptyMVar
223− clientDone <- newEmptyMVar
224−
225− -- Server
226− forkIO $ do
227− localNode <- newLocalNode testTransport initRemoteTable
228− addr <- forkProcess localNode ping
229− putMVar serverAddr addr
230−
231− -- Client
232− forkIO $ do
233− localNode <- newLocalNode testTransport initRemoteTable
234− pingServer <- readMVar serverAddr
235−
236− let numPings = 10000
237−
238− runProcess localNode $ do
239− pid <- getSelfPid
240− replicateM_ numPings $ do
241− send pingServer (Pong pid)
242− p <- expectTimeout 3000000
243− case p of
244− Just (Ping _) -> return ()
245− Nothing -> die "Failed to receive Ping"
246−
247− putMVar clientDone ()
248−
249− takeMVar clientDone
250−
251−-- | Monitor a process on an unreachable node
252−testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
253−testMonitorUnreachable TestTransport{..} mOrL un = do
254− deadProcess <- newEmptyMVar
255− done <- newEmptyMVar
256−
257− forkIO $ do
258− localNode <- newLocalNode testTransport initRemoteTable
259− addr <- forkProcess localNode expect
260− closeLocalNode localNode
261− putMVar deadProcess addr
262−
263− forkIO $ do
264− localNode <- newLocalNode testTransport initRemoteTable
265− theirAddr <- readMVar deadProcess
266− runProcess localNode $
267− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
268−
269− takeMVar done
270−
271−-- | Monitor a process which terminates normally
272−testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion
273−testMonitorNormalTermination TestTransport{..} mOrL un = do
274− monitorSetup <- newEmptyMVar
275− monitoredProcess <- newEmptyMVar
276− done <- newEmptyMVar
277−
278− forkIO $ do
279− localNode <- newLocalNode testTransport initRemoteTable
280− addr <- forkProcess localNode $
281− liftIO $ readMVar monitorSetup
282− putMVar monitoredProcess addr
283−
284− forkIO $ do
285− localNode <- newLocalNode testTransport initRemoteTable
286− theirAddr <- readMVar monitoredProcess
287− runProcess localNode $
288− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
289−
290− takeMVar done
291−
292−-- | Monitor a process which terminates abnormally
293−testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion
294−testMonitorAbnormalTermination TestTransport{..} mOrL un = do
295− monitorSetup <- newEmptyMVar
296− monitoredProcess <- newEmptyMVar
297− done <- newEmptyMVar
298−
299− let err = userError "Abnormal termination"
300−
301− forkIO $ do
302− localNode <- newLocalNode testTransport initRemoteTable
303− addr <- forkProcess localNode . liftIO $ do
304− readMVar monitorSetup
305− throwIO err
306− putMVar monitoredProcess addr
307−
308− forkIO $ do
309− localNode <- newLocalNode testTransport initRemoteTable
310− theirAddr <- readMVar monitoredProcess
311− runProcess localNode $
312− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
313−
314− takeMVar done
315−
316−-- | Monitor a local process that is already dead
317−testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
318−testMonitorLocalDeadProcess TestTransport{..} mOrL un = do
319− processAddr <- newEmptyMVar
320− localNode <- newLocalNode testTransport initRemoteTable
321− done <- newEmptyMVar
322−
323− forkIO $ do
324− addr <- forkProcess localNode $ return ()
325− putMVar processAddr addr
326−
327− forkIO $ do
328− theirAddr <- readMVar processAddr
329− runProcess localNode $ do
330− monitor theirAddr
331− -- wait for the process to die
332− expect :: Process ProcessMonitorNotification
333− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
334−
335− takeMVar done
336−
337−-- | Monitor a remote process that is already dead
338−testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
339−testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do
340− processDead <- newEmptyMVar
341− processAddr <- newEmptyMVar
342− done <- newEmptyMVar
343−
344− forkIO $ do
345− localNode <- newLocalNode testTransport initRemoteTable
346− addr <- forkProcess localNode . liftIO $ putMVar processDead ()
347− putMVar processAddr addr
348−
349− forkIO $ do
350− localNode <- newLocalNode testTransport initRemoteTable
351− theirAddr <- readMVar processAddr
352− readMVar processDead
353− runProcess localNode $ do
354− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
355−
356− takeMVar done
357−
358−-- | Monitor a process that becomes disconnected
359−testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
360−testMonitorDisconnect TestTransport{..} mOrL un = do
361− processAddr <- newEmptyMVar
362− processAddr2 <- newEmptyMVar
363− monitorSetup <- newEmptyMVar
364− done <- newEmptyMVar
365−
366− forkIO $ do
367− localNode <- newLocalNode testTransport initRemoteTable
368− addr <- forkProcess localNode $ expect
369− addr2 <- forkProcess localNode $ return ()
370− putMVar processAddr addr
371− readMVar monitorSetup
372− NT.closeEndPoint (localEndPoint localNode)
373− putMVar processAddr2 addr2
374−
375− forkIO $ do
376− localNode <- newLocalNode testTransport initRemoteTable
377− theirAddr <- readMVar processAddr
378− forkProcess localNode $ do
379− lc <- liftIO $ readMVar processAddr2
380− send lc ()
381− runProcess localNode $ do
382− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
383−
384− takeMVar done
385−
386−-- | Test the math server (i.e., receiveWait)
387−testMath :: TestTransport -> Assertion
388−testMath TestTransport{..} = do
389− serverAddr <- newEmptyMVar
390− clientDone <- newEmptyMVar
391−
392− -- Server
393− forkIO $ do
394− localNode <- newLocalNode testTransport initRemoteTable
395− addr <- forkProcess localNode math
396− putMVar serverAddr addr
397−
398− -- Client
399− forkIO $ do
400− localNode <- newLocalNode testTransport initRemoteTable
401− mathServer <- readMVar serverAddr
402−
403− runProcess localNode $ do
404− pid <- getSelfPid
405− send mathServer (Add pid 1 2)
406− three <- expect :: Process Double
407− send mathServer (Divide pid 8 2)
408− four <- expect :: Process Double
409− send mathServer (Divide pid 8 0)
410− divByZ <- expect
411− liftIO $ putMVar clientDone (three, four, divByZ)
412−
413− res <- takeMVar clientDone
414− case res of
415− (3, 4, DivByZero) -> return ()
416− _ -> error $ "Something went horribly wrong"
417−
418−-- | Send first message (i.e. connect) to an already terminated process
419−-- (without monitoring); then send another message to a second process on
420−-- the same remote node (we're checking that the remote node did not die)
421−testSendToTerminated :: TestTransport -> Assertion
422−testSendToTerminated TestTransport{..} = do
423− serverAddr1 <- newEmptyMVar
424− serverAddr2 <- newEmptyMVar
425− clientDone <- newEmptyMVar
426−
427− forkIO $ do
428− terminated <- newEmptyMVar
429− localNode <- newLocalNode testTransport initRemoteTable
430− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
431− addr2 <- forkProcess localNode $ ping
432− readMVar terminated
433− putMVar serverAddr1 addr1
434− putMVar serverAddr2 addr2
435−
436− forkIO $ do
437− localNode <- newLocalNode testTransport initRemoteTable
438− server1 <- readMVar serverAddr1
439− server2 <- readMVar serverAddr2
440− runProcess localNode $ do
441− pid <- getSelfPid
442− send server1 "Hi"
443− send server2 (Pong pid)
444− expectPing clientDone
445−
446− verifyClient "Expected Ping from server" clientDone
447−
448−-- | Test (non-zero) timeout
449−testTimeout :: TestTransport -> Assertion
450−testTimeout TestTransport{..} = do
451− localNode <- newLocalNode testTransport initRemoteTable
452− done <- newEmptyMVar
453−
454− runProcess localNode $ do
455− res <- receiveTimeout 1000000 [match (\Add{} -> return ())]
456− liftIO $ putMVar done $ res == Nothing
457−
458− verifyClient "Expected receiveTimeout to timeout..." done
459−
460−-- | Test zero timeout
461−testTimeout0 :: TestTransport -> Assertion
462−testTimeout0 TestTransport{..} = do
463− serverAddr <- newEmptyMVar
464− clientDone <- newEmptyMVar
465−
466− forkIO $ do
467− localNode <- newLocalNode testTransport initRemoteTable
468− addr <- forkProcess localNode $ do
469− -- Variation on the venerable ping server which uses a zero timeout
470− partner <- fix $ \loop ->
471− receiveTimeout 0 [match (\(Pong partner) -> return partner)]
472− >>= maybe (liftIO (threadDelay 100000) >> loop) return
473− self <- getSelfPid
474− send partner (Ping self)
475− putMVar serverAddr addr
476−
477− forkIO $ do
478− localNode <- newLocalNode testTransport initRemoteTable
479− server <- readMVar serverAddr
480− runProcess localNode $ do
481− pid <- getSelfPid
482− -- Send a bunch of messages. A large number of messages that the server
483− -- is not interested in, and then a single message that it wants
484− replicateM_ 10000 $ send server "Irrelevant message"
485− send server (Pong pid)
486− expectPing clientDone
487−
488− verifyClient "Expected Ping from server" clientDone
489−
490−-- | Test typed channels
491−testTypedChannels :: TestTransport -> Assertion
492−testTypedChannels TestTransport{..} = do
493− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
494− clientDone <- newEmptyMVar
495−
496− forkIO $ do
497− localNode <- newLocalNode testTransport initRemoteTable
498− forkProcess localNode $ do
499− (serverSendPort, rport) <- newChan
500− liftIO $ putMVar serverChannel serverSendPort
501− (clientSendPort, i) <- receiveChan rport
502− sendChan clientSendPort (even i)
503− return ()
504−
505− forkIO $ do
506− localNode <- newLocalNode testTransport initRemoteTable
507− serverSendPort <- readMVar serverChannel
508− runProcess localNode $ do
509− (clientSendPort, rport) <- newChan
510− sendChan serverSendPort (clientSendPort, 5)
511− ch <- receiveChan rport
512− liftIO $ putMVar clientDone $ ch == False
513−
514− verifyClient "Expected channel to send 'False'" clientDone
515−
516−-- | Test merging receive ports
517−testMergeChannels :: TestTransport -> Assertion
518−testMergeChannels TestTransport{..} = do
519− localNode <- newLocalNode testTransport initRemoteTable
520− testFlat localNode True "aaabbbccc"
521− testFlat localNode False "abcabcabc"
522− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
523− testNested localNode True False "adgadgadgbehbehbehcficficfi"
524− testNested localNode False True "abcabcabcdefdefdefghighighi"
525− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
526− testBlocked localNode True
527− testBlocked localNode False
528− where
529− -- Single layer of merging
530− testFlat :: LocalNode -> Bool -> String -> IO ()
531− testFlat localNode biased expected = do
532− done <- newEmptyMVar
533− forkProcess localNode $ do
534− rs <- mapM charChannel "abc"
535− m <- mergePorts biased rs
536− xs <- replicateM 9 $ receiveChan m
537− liftIO $ putMVar done $ xs == expected
538− verifyClient "Expected single layer merge to match expected ordering" done
539−
540− -- Two layers of merging
541− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
542− testNested localNode biasedInner biasedOuter expected = do
543− done <- newEmptyMVar
544− forkProcess localNode $ do
545− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
546− ms <- mapM (mergePorts biasedInner) rss
547− m <- mergePorts biasedOuter ms
548− xs <- replicateM (9 * 3) $ receiveChan m
549− liftIO $ putMVar done $ xs == expected
550− verifyClient "Expected nested channels to match expeted ordering" done
551−
552− -- Test that if no messages are (immediately) available, the scheduler makes no difference
553− testBlocked :: LocalNode -> Bool -> IO ()
554− testBlocked localNode biased = do
555− vs <- replicateM 3 newEmptyMVar
556− done <- newEmptyMVar
557−
558− forkProcess localNode $ do
559− ss <- liftIO $ mapM readMVar vs
560− case ss of
561− [sa, sb, sc] ->
562− mapM_ ((>> pause 10000) . uncurry sendChan)
563− [ -- a, b, c
564− (sa, 'a')
565− , (sb, 'b')
566− , (sc, 'c')
567− -- a, c, b
568− , (sa, 'a')
569− , (sc, 'c')
570− , (sb, 'b')
571− -- b, a, c
572− , (sb, 'b')
573− , (sa, 'a')
574− , (sc, 'c')
575− -- b, c, a
576− , (sb, 'b')
577− , (sc, 'c')
578− , (sa, 'a')
579− -- c, a, b
580− , (sc, 'c')
581− , (sa, 'a')
582− , (sb, 'b')
583− -- c, b, a
584− , (sc, 'c')
585− , (sb, 'b')
586− , (sa, 'a')
587− ]
588− _ -> die "Something went horribly wrong"
589−
590− forkProcess localNode $ do
591− (ss, rs) <- unzip <$> replicateM 3 newChan
592− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
593− m <- mergePorts biased rs
594− xs <- replicateM (6 * 3) $ receiveChan m
595− liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"
596−
597− verifyClient "Expected merged ports to match expected ordering" done
598−
599− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
600− mergePorts True = mergePortsBiased
601− mergePorts False = mergePortsRR
602−
603− charChannel :: Char -> Process (ReceivePort Char)
604− charChannel c = do
605− (sport, rport) <- newChan
606− replicateM_ 3 $ sendChan sport c
607− liftIO $ threadDelay 10000 -- Make sure messages have been sent
608− return rport
609−
610−testTerminate :: TestTransport -> Assertion
611−testTerminate TestTransport{..} = do
612− localNode <- newLocalNode testTransport initRemoteTable
613− runProcess localNode $ do
614− e <- try terminate :: Process (Either ProcessTerminationException ())
615− if either show show e == show ProcessTerminationException
616− then return ()
617− else die "Unexpected result from terminate"
618−
619−testMonitorNode :: TestTransport -> Assertion
620−testMonitorNode TestTransport{..} = do
621− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
622− done <- newEmptyMVar
623−
624− closeLocalNode node1
625−
626− runProcess node2 $ do
627− ref <- monitorNode (localNodeId node1)
628− receiveWait [
629− match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->
630− return $ ref == ref' && nid == localNodeId node1)
631− ] >>= liftIO . putMVar done
632−
633− verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done
634−
635−testMonitorLiveNode :: TestTransport -> Assertion
636−testMonitorLiveNode TestTransport{..} = do
637− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
638− ready <- newEmptyMVar
639− readyr <- newEmptyMVar
640− done <- newEmptyMVar
641−
642− p <- forkProcess node1 $ return ()
643− forkProcess node2 $ do
644− ref <- monitorNode (localNodeId node1)
645− liftIO $ putMVar ready ()
646− liftIO $ takeMVar readyr
647− send p ()
648− receiveWait [
649− match (\(NodeMonitorNotification ref' nid _) ->
650− (return $ ref == ref' && nid == localNodeId node1))
651− ] >>= liftIO . putMVar done
652−
653− takeMVar ready
654− closeLocalNode node1
655− putMVar readyr ()
656−
657− verifyClient "Expected NodeMonitorNotification for LIVE node" done
658−
659−testMonitorChannel :: TestTransport -> Assertion
660−testMonitorChannel TestTransport{..} = do
661− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
662− gotNotification <- newEmptyMVar
663−
664− pid <- forkProcess node1 $ do
665− sport <- expect :: Process (SendPort ())
666− ref <- monitorPort sport
667− receiveWait [
668− -- reason might be DiedUnknownId if the receive port is GCed before the
669− -- monitor is established (TODO: not sure that this is reasonable)
670− match (\(PortMonitorNotification ref' port' reason) ->
671− return $ ref' == ref && port' == sendPortId sport &&
672− (reason == DiedNormal || reason == DiedUnknownId))
673− ] >>= liftIO . putMVar gotNotification
674−
675− runProcess node2 $ do
676− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
677− send pid sport
678− liftIO $ threadDelay 100000
679−
680− verifyClient "Expected PortMonitorNotification" gotNotification
681−
682−testRegistry :: TestTransport -> Assertion
683−testRegistry TestTransport{..} = do
684− node <- newLocalNode testTransport initRemoteTable
685− done <- newEmptyMVar
686−
687− pingServer <- forkProcess node ping
688− deadProcess <- forkProcess node (return ())
689−
690− runProcess node $ do
691− register "ping" pingServer
692− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
693− us <- getSelfPid
694− nsend "ping" (Pong us)
695− receiveWait [
696− matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())
697− ]
698− checkRegException "dead" Nothing deadProcess
699− checkRegException "ping" (Just pingServer) deadProcess
700− try (unregister "dead") >>= checkReg "dead" Nothing
701− liftIO $ putMVar done ()
702−
703− takeMVar done
704−
705− where
706− checkRegException name pid dead =
707− try (register name dead) >>= checkReg name pid
708−
709− checkReg name pid res =
710− case res of
711− Left (ProcessRegistrationException name pid) -> return ()
712− _ -> die $ "Unexpected Registration" ++ show res
713−
714−testRegistryRemoteProcess :: TestTransport -> Assertion
715−testRegistryRemoteProcess TestTransport{..} = do
716− node1 <- newLocalNode testTransport initRemoteTable
717− node2 <- newLocalNode testTransport initRemoteTable
718− done <- newEmptyMVar
719−
720− pingServer <- forkProcess node1 ping
721−
722− runProcess node2 $ do
723− register "ping" pingServer
724− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)
725− us <- getSelfPid
726− nsend "ping" (Pong us)
727− receiveWait [
728− matchIf (\(Ping pid') -> pingServer == pid')
729− (const $ liftIO $ putMVar done ())
730− ]
731−
732− takeMVar done
733−
734−testRemoteRegistry :: TestTransport -> Assertion
735−testRemoteRegistry TestTransport{..} = do
736− node1 <- newLocalNode testTransport initRemoteTable
737− node2 <- newLocalNode testTransport initRemoteTable
738−
739− pingServer <- forkProcess node1 ping
740− deadProcess <- forkProcess node1 (return ())
741−
742− runProcess node2 $ do
743− let nid1 = localNodeId node1
744− registerRemoteAsync nid1 "ping" pingServer
745− receiveWait [
746− matchIf (\(RegisterReply label' _ (Just pid)) ->
747− "ping" == label' && pid == pingServer)
748− (\(RegisterReply _ _ _) -> return ()) ]
749−
750− pid <- verifyWhereIsRemote nid1 "ping"
751− liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
752−
753− us <- getSelfPid
754− nsendRemote nid1 "ping" (Pong us)
755− receiveWait [
756− match (\(Ping pid') -> return $ pingServer == pid')
757− ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"
758−
759− -- test that if process was not registered Nothing is returned
760− -- in owner field.
761− registerRemoteAsync nid1 "dead" deadProcess
762− receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
763− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764− ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
765−
766− registerRemoteAsync nid1 "ping" deadProcess
767− receiveWait [
768− matchIf (\(RegisterReply label' False mPid) ->
769− "ping" == label' && isJust mPid)
770− (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771− ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
772−
773− unregisterRemoteAsync nid1 "dead"
774− receiveWait [
775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
778−
779−testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
780−testRemoteRegistryRemoteProcess TestTransport{..} = do
781− node1 <- newLocalNode testTransport initRemoteTable
782− node2 <- newLocalNode testTransport initRemoteTable
783− done <- newEmptyMVar
784−
785− pingServer <- forkProcess node2 ping
786−
787− runProcess node2 $ do
788− let nid1 = localNodeId node1
789− registerRemoteAsync nid1 "ping" pingServer
790− receiveWait [
791− matchIf (\(RegisterReply label' _ _) -> "ping" == label')
792− (\(RegisterReply _ _ _) -> return ()) ]
793− pid <- verifyWhereIsRemote nid1 "ping"
794− liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid
795− us <- getSelfPid
796− nsendRemote nid1 "ping" (Pong us)
797− receiveWait [
798− match (\(Ping pid') -> return $ pingServer == pid')
799− ] >>= liftIO . putMVar done
800−
801− verifyClient "Expected Ping with ping server's ProcessId" done
802−
803−testSpawnLocal :: TestTransport -> Assertion
804−testSpawnLocal TestTransport{..} = do
805− node <- newLocalNode testTransport initRemoteTable
806− done <- newEmptyMVar
807−
808− runProcess node $ do
809− us <- getSelfPid
810−
811− pid <- spawnLocal $ do
812− sport <- expect
813− sendChan sport (1234 :: Int)
814−
815− sport <- spawnChannelLocal $
816− \rport -> (receiveChan rport :: Process Int) >>= send us
817−
818− send pid sport
819− expect >>= liftIO . putMVar done
820−
821− res <- takeMVar done
822− assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)
823−
824−testSpawnAsyncStrictness :: TestTransport -> Assertion
825−testSpawnAsyncStrictness TestTransport{..} = do
826− node <- newLocalNode testTransport initRemoteTable
827− done <- newEmptyMVar
828−
829− runProcess node $ do
830− here <-getSelfNode
831−
832− ev <- try $ spawnAsync here (error "boom")
833− liftIO $ case ev of
834− Right _ -> putMVar done (error "Exception didn't fire")
835− Left (_::SomeException) -> putMVar done (return ())
836−
837− join $ takeMVar done
838−
839−testReconnect :: TestTransport -> Assertion
840−testReconnect TestTransport{..} = do
841− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
842− let nid1 = localNodeId node1
843− processA <- newEmptyMVar
844− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
845−
846− forkProcess node1 $ do
847− us <- getSelfPid
848− liftIO $ putMVar processA us
849− msg1 <- expect
850− msg2 <- expect
851− liftIO $ do
852− assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"
853− putMVar sendTestOk ()
854−
855− forkProcess node2 $ do
856− {-
857− - Make sure there is no implicit reconnect on normal message sending
858− -}
859−
860− them <- liftIO $ readMVar processA
861− send them "message 1" >> liftIO (threadDelay 100000)
862−
863− -- Simulate network failure
864− liftIO $ syncBreakConnection testBreakConnection node1 node2
865−
866−
867− -- Should not arrive
868− send them "message 2"
869−
870− -- Should arrive
871− reconnect them
872− send them "message 3"
873−
874− liftIO $ takeMVar sendTestOk
875−
876− {-
877− - Test that there *is* implicit reconnect on node controller messages
878− -}
879−
880− us <- getSelfPid
881− registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
882− receiveWait [
883− matchIf (\(RegisterReply label' _ _) -> "a" == label')
884− (\(RegisterReply _ _ _) -> return ()) ]
885−
886− _ <- whereisRemote nid1 "a"
887−
888−
889− -- Simulate network failure
890− liftIO $ syncBreakConnection testBreakConnection node1 node2
891−
892− -- This will happen due to implicit reconnect
893− registerRemoteAsync nid1 "b" us
894− receiveWait [
895− matchIf (\(RegisterReply label' _ _) -> "b" == label')
896− (\(RegisterReply _ _ _) -> return ()) ]
897−
898− -- Should happen
899− registerRemoteAsync nid1 "c" us
900− receiveWait [
901− matchIf (\(RegisterReply label' _ _) -> "c" == label')
902− (\(RegisterReply _ _ _) -> return ()) ]
903−
904− -- Check
905− mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
906− liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing
907− verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect
908− verifyWhereIsRemote nid1 "c"
909−
910− liftIO $ putMVar registerTestOk ()
911−
912− takeMVar registerTestOk
913−
914−-- | Tests that unreliable messages arrive sorted even when there are connection
915−-- failures.
916−testUSend :: (ProcessId -> Int -> Process ())
917− -> TestTransport -> Int -> Assertion
918−testUSend usendPrim TestTransport{..} numMessages = do
919− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
920− let nid1 = localNodeId node1
921− nid2 = localNodeId node2
922− processA <- newEmptyMVar
923− usendTestOk <- newEmptyMVar
924−
925− forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do
926− us <- getSelfPid
927− liftIO $ putMVar processA us
928− them <- expect
929− send them ()
930− _ <- monitor them
931− let -- Collects messages from 'them' until the sender dies.
932− -- Disconnection notifications are ignored.
933− receiveMessages :: Process [Int]
934− receiveMessages = receiveWait
935− [ match $ \mn -> case mn of
936− ProcessMonitorNotification _ _ DiedDisconnect -> do
937− monitor them
938− receiveMessages
939− _ -> return []
940− , match $ \i -> fmap (i :) receiveMessages
941− ]
942− msgs <- receiveMessages
943− let -- Checks that the input list is sorted.
944− isSorted :: [Int] -> Bool
945− isSorted (x : xs@(y : _)) = x <= y && isSorted xs
946− isSorted _ = True
947− -- The list can't be null since there are no failures after sending
948− -- the last message.
949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
950−
951− forkProcess node2 $ do
952− them <- liftIO $ readMVar processA
953− getSelfPid >>= send them
954− expect :: Process ()
955− forM_ [1..numMessages] $ \i -> do
956− liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
957− usendPrim them i
958− liftIO (threadDelay 30000)
959−
960− res <- takeMVar usendTestOk
961− assertBool "Unexpected failure after sending last msg" res
962−
963−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
964−-- in between
965−testMatchAny :: TestTransport -> Assertion
966−testMatchAny TestTransport{..} = do
967− proxyAddr <- newEmptyMVar
968− clientDone <- newEmptyMVar
969−
970− -- Math server
971− forkIO $ do
972− localNode <- newLocalNode testTransport initRemoteTable
973− mathServer <- forkProcess localNode math
974− proxyServer <- forkProcess localNode $ forever $ do
975− msg <- receiveWait [ matchAny return ]
976− forward msg mathServer
977− putMVar proxyAddr proxyServer
978−
979− -- Client
980− forkIO $ do
981− localNode <- newLocalNode testTransport initRemoteTable
982− mathServer <- readMVar proxyAddr
983−
984− runProcess localNode $ do
985− pid <- getSelfPid
986− send mathServer (Add pid 1 2)
987− three <- expect :: Process Double
988− send mathServer (Divide pid 8 2)
989− four <- expect :: Process Double
990− send mathServer (Divide pid 8 0)
991− divByZ <- expect
992− liftIO $ putMVar clientDone (three, four, divByZ)
993−
994− res <- takeMVar clientDone
995− case res of
996− (3, 4, DivByZero) -> return ()
997− _ -> error "Unexpected result"
998−
999−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
1000−-- in between, however we block 'Divide' requests ....
1001−testMatchAnyHandle :: TestTransport -> Assertion
1002−testMatchAnyHandle TestTransport{..} = do
1003− proxyAddr <- newEmptyMVar
1004− clientDone <- newEmptyMVar
1005−
1006− -- Math server
1007− forkIO $ do
1008− localNode <- newLocalNode testTransport initRemoteTable
1009− mathServer <- forkProcess localNode math
1010− proxyServer <- forkProcess localNode $ forever $ do
1011− receiveWait [
1012− matchAny (maybeForward mathServer)
1013− ]
1014− putMVar proxyAddr proxyServer
1015−
1016− -- Client
1017− forkIO $ do
1018− localNode <- newLocalNode testTransport initRemoteTable
1019− mathServer <- readMVar proxyAddr
1020−
1021− runProcess localNode $ do
1022− pid <- getSelfPid
1023− send mathServer (Add pid 1 2)
1024− three <- expect :: Process Double
1025− send mathServer (Divide pid 8 2)
1026− res <- (expectTimeout 100000) :: Process (Maybe Double)
1027− liftIO $ putMVar clientDone $ three == 3 && res == Nothing
1028−
1029− verifyClient "Expected Nothing (i.e. timeout)" clientDone
1030−
1031− where maybeForward :: ProcessId -> Message -> Process (Maybe ())
1032− maybeForward s msg =
1033− handleMessage msg (\m@(Add _ _ _) -> send s m)
1034−
1035−testMatchAnyNoHandle :: TestTransport -> Assertion
1036−testMatchAnyNoHandle TestTransport{..} = do
1037− addr <- newEmptyMVar
1038− clientDone <- newEmptyMVar
1039− serverDone <- newEmptyMVar
1040−
1041− -- Math server
1042− forkIO $ do
1043− localNode <- newLocalNode testTransport initRemoteTable
1044− server <- forkProcess localNode $ forever $ do
1045− receiveWait [
1046− matchAnyIf
1047− -- the condition has type `Add -> Bool`
1048− (\(Add _ _ _) -> True)
1049− -- the match `AbstractMessage -> Process ()` will succeed!
1050− (\m -> do
1051− -- `String -> Process ()` does *not* match the input types however
1052− r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))
1053− case r of
1054− Nothing -> return ()
1055− Just _ -> die "NONSENSE")
1056− ]
1057− -- we *must* have removed the message from our mailbox though!!!
1058− res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]
1059− liftIO $ do
1060− assertBool "Expected timeout!" $ res == Nothing
1061− putMVar serverDone ()
1062− putMVar addr server
1063−
1064− -- Client
1065− forkIO $ do
1066− localNode <- newLocalNode testTransport initRemoteTable
1067− server <- readMVar addr
1068−
1069− runProcess localNode $ do
1070− pid <- getSelfPid
1071− send server (Add pid 1 2)
1072− -- we only care about the client having sent a message, so we're done
1073− liftIO $ putMVar clientDone ()
1074−
1075− takeMVar clientDone
1076− takeMVar serverDone
1077−
1078−-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
1079−-- unless the text body @/= "bar"@ - this case should time out rather than
1080−-- removing the message from the process mailbox.
1081−testMatchAnyIf :: TestTransport -> Assertion
1082−testMatchAnyIf TestTransport{..} = do
1083− echoAddr <- newEmptyMVar
1084− clientDone <- newEmptyMVar
1085−
1086− -- echo server
1087− forkIO $ do
1088− localNode <- newLocalNode testTransport initRemoteTable
1089− echoServer <- forkProcess localNode $ forever $ do
1090− receiveWait [
1091− matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")
1092− tryHandleMessage
1093− ]
1094− putMVar echoAddr echoServer
1095−
1096− -- Client
1097− forkIO $ do
1098− localNode <- newLocalNode testTransport initRemoteTable
1099− server <- readMVar echoAddr
1100−
1101− runProcess localNode $ do
1102− pid <- getSelfPid
1103− send server (pid, "foo")
1104− foo <- expect
1105− -- provoking what would be the wrong ordering is informative here...
1106−
1107− send server (pid, "bar")
1108− bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?
1109−
1110− send server (pid, "baz")
1111− baz <- expect
1112−
1113− liftIO $ putMVar clientDone (foo, bar, baz)
1114−
1115− res <- takeMVar clientDone
1116− let res' = res == ("foo", Nothing, "baz")
1117− assertBool "Expected timeout due to type mismatch" res'
1118−
1119− where tryHandleMessage :: Message -> Process (Maybe ())
1120− tryHandleMessage msg =
1121− handleMessage msg (\(pid :: ProcessId, (m :: String))
1122− -> do { send pid m; return () })
1123−
1124−testMatchMessageWithUnwrap :: TestTransport -> Assertion
1125−testMatchMessageWithUnwrap TestTransport{..} = do
1126− echoAddr <- newEmptyMVar
1127− clientDone <- newEmptyMVar
1128−
1129− -- echo server
1130− forkIO $ do
1131− localNode <- newLocalNode testTransport initRemoteTable
1132− echoServer <- forkProcess localNode $ forever $ do
1133− msg <- receiveWait [
1134− matchMessage (\(m :: Message) -> do
1135− return m)
1136− ]
1137− unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))
1138− case unwrapped of
1139− (Just (p, msg')) -> forward msg' p
1140− Nothing -> die "unable to unwrap the message"
1141− putMVar echoAddr echoServer
1142−
1143− -- Client
1144− forkIO $ do
1145− localNode <- newLocalNode testTransport initRemoteTable
1146− server <- readMVar echoAddr
1147−
1148− runProcess localNode $ do
1149− pid <- getSelfPid
1150− send server (pid, wrapMessage ("foo" :: String))
1151− foo <- expect
1152− send server (pid, wrapMessage ("baz" :: String))
1153− baz <- expect
1154− liftIO $ putMVar clientDone (foo, baz)
1155−
1156− res <- takeMVar clientDone
1157− assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")
1158−
1159−-- Test 'receiveChanTimeout'
1160−testReceiveChanTimeout :: TestTransport -> Assertion
1161−testReceiveChanTimeout TestTransport{..} = do
1162− done <- newEmptyMVar
1163− mvSender <- newEmptyMVar
1164− sendPort <- newEmptyMVar
1165−
1166− forkTry $ do
1167− localNode <- newLocalNode testTransport initRemoteTable
1168− runProcess localNode $ do
1169− -- Create a typed channel
1170− (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1171− liftIO $ putMVar sendPort sp
1172−
1173− -- Wait for a message with a delay. No message arrives, we should get
1174− -- Nothing after the delay.
1175− receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1176−
1177− -- Let the sender know that it can send a message.
1178− liftIO $ putMVar mvSender ()
1179−
1180− -- Wait for a message with a delay again. Now a message arrives after
1181− -- 0.1 seconds
1182− res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return
1183− liftIO $ assertBool "Expected result to be 'True'" res
1184−
1185− -- Wait for a message with zero timeout: non-blocking check. No message is
1186− -- available, we get Nothing
1187− receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")
1188−
1189− -- Let the sender know that it can send a message.
1190− liftIO $ putMVar mvSender ()
1191−
1192− -- Again, but now there is a message available
1193− fix $ \loop -> do
1194− liftIO $ threadDelay 100000
1195− mb <- receiveChanTimeout 0 rp
1196− case mb of
1197− Just b -> do liftIO $ assertBool "Unexpected Message" $ not b
1198− _ -> loop
1199−
1200− liftIO $ putMVar done ()
1201−
1202− forkTry $ do
1203− localNode <- newLocalNode testTransport initRemoteTable
1204− runProcess localNode $ do
1205− sp <- liftIO $ readMVar sendPort
1206−
1207− liftIO $ takeMVar mvSender
1208− liftIO $ threadDelay 100000
1209− sendChan sp True
1210−
1211− liftIO $ takeMVar mvSender
1212− sendChan sp False
1213−
1214− takeMVar done
1215−
1216−-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
1217−testReceiveChanFeatures :: TestTransport -> Assertion
1218−testReceiveChanFeatures TestTransport{..} = do
1219− done <- newEmptyMVar
1220−
1221− forkTry $ do
1222− localNode <- newLocalNode testTransport initRemoteTable
1223− runProcess localNode $ do
1224− (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
1225− (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
1226−
1227− -- Test Functor instance
1228−
1229− sendChan spInt 2
1230− sendChan spBool False
1231−
1232− rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
1233−
1234− receiveChan rp1 >>= liftIO . assertBool "Expected True"
1235− receiveChan rp1 >>= liftIO . assertBool "Expected False" . not
1236−
1237− -- Test Applicative instance
1238−
1239− sendChan spInt 3
1240− sendChan spInt 4
1241−
1242− let rp2 = pure (+) <*> rpInt <*> rpInt
1243−
1244− receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)
1245−
1246− -- Test Alternative instance
1247−
1248− sendChan spInt 3
1249− sendChan spBool True
1250−
1251− let rp3 = (even <$> rpInt) <|> rpBool
1252−
1253− receiveChan rp3 >>= liftIO . assertBool "Expected False" . not
1254− receiveChan rp3 >>= liftIO . assertBool "Expected True"
1255−
1256− -- Test Monad instance
1257−
1258− sendChan spBool True
1259− sendChan spBool False
1260− sendChan spInt 5
1261−
1262− let rp4 :: ReceivePort Int
1263− rp4 = do b <- rpBool
1264− if b
1265− then rpInt
1266− else return 7
1267−
1268− receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)
1269− receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)
1270−
1271− liftIO $ putMVar done ()
1272−
1273− takeMVar done
1274−
1275−testChanLifecycle :: TestTransport -> Assertion
1276−testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1277− result <- newEmptyMVar
1278− tchMV <- newEmptyMVar
1279− localNode <- newLocalNode testTransport initRemoteTable
1280− runProcess localNode $ do
1281−
1282− pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283− liftIO $ putMVar tchMV tCh
1284− expect :: Process ()
1285− let (sp, _) = tCh
1286− sendChan sp ()
1287− expect :: Process ()
1288−
1289− mRefPid <- monitor pid
1290−
1291− cPid <- spawnLocal $ do
1292− (sp', rp) <- liftIO $ takeMVar tchMV
1293− -- say "picked up our test channel"
1294− send pid ()
1295− -- say "told pid to continue"
1296− res <- receiveChanTimeout delay rp
1297− case res of
1298− Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299− Just () -> do mr <- monitor pid
1300− pause 10000
1301− -- say "sending pid a second () will cause it to exit"
1302− send pid ()
1303−
1304− -- say "make sure we see a DOWN notification for pid having stopped"
1305− receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1306−
1307− -- now that pid has died, the send port should be useless...
1308− liftIO $ putMVar tchMV (sp', rp)
1309−
1310− -- let's verify that we do not see the message from our
1311− -- parent process on the channel, once pid has died...
1312− recv <- receiveChanTimeout delay rp
1313− -- say $ "finished waiting for second (), writing result" ++ (show recv)
1314− liftIO $ putMVar result $ isNothing recv
1315−
1316− mRefCPid <- monitor cPid
1317−
1318− receiveWait
1319− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1320− (\_ -> return ())
1321− ]
1322−
1323− -- say "seen first pid die..."
1324−
1325− (sendPort, _) <- liftIO $ takeMVar tchMV
1326− sendChan sendPort ()
1327− -- say "sent () after owning pid died"
1328−
1329− -- let cPid know we've written to the channel...
1330− send cPid ()
1331−
1332− receiveWait
1333− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1334− (\_ -> return ())
1335− ]
1336−
1337− -- say "seen both pids die now..."
1338−
1339− -- and wait on the result back in IO land...
1340− testRes <- takeMVar result
1341− -- runProcess localNode $ say "got result..."
1342− assertBool "Expected sending on the channel to fail, but received data!" testRes
1343−
1344−
1345−testKillLocal :: TestTransport -> Assertion
1346−testKillLocal TestTransport{..} = do
1347− localNode <- newLocalNode testTransport initRemoteTable
1348−
1349− pid <- forkProcess localNode $ do
1350− liftIO $ threadDelay 1000000
1351−
1352− runProcess localNode $ do
1353− ref <- monitor pid
1354− us <- getSelfPid
1355− kill pid "TestKill"
1356− mn <- expect
1357− case mn of
1358− ProcessMonitorNotification ref' pid' (DiedException ex) ->
1359− case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of
1360− True -> return ()
1361− False -> die "Invalid ProcessMonitorNotification received"
1362− _ -> die "Something went horribly wrong"
1363−
1364−testKillRemote :: TestTransport -> Assertion
1365−testKillRemote TestTransport{..} = do
1366− node1 <- newLocalNode testTransport initRemoteTable
1367− node2 <- newLocalNode testTransport initRemoteTable
1368−
1369− pid <- forkProcess node1 $ do
1370− liftIO $ threadDelay 1000000
1371−
1372− runProcess node2 $ do
1373− ref <- monitor pid
1374− us <- getSelfPid
1375− kill pid "TestKill"
1376− mn <- expect
1377− case mn of
1378− ProcessMonitorNotification ref' pid' (DiedException reason) ->
1379− case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of
1380− (True, True, True) -> return ()
1381− (a, b, c) -> do
1382− let a' = if a then "" else "Invalid ref"
1383− let b' = if b then "" else "Invalid pid"
1384− let c' = if c then "" else "Invalid message"
1385− die $ unwords [a', b', c']
1386− _ -> die "Received unexpected message"
1387−
1388−testCatchesExit :: TestTransport -> Assertion
1389−testCatchesExit TestTransport{..} = do
1390− localNode <- newLocalNode testTransport initRemoteTable
1391− done <- newEmptyMVar
1392−
1393− _ <- forkProcess localNode $ do
1394− (die ("foobar", 123 :: Int))
1395− `catchesExit` [
1396− (\_ m -> handleMessage m (\(_ :: String) -> return ()))
1397− , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))
1398− , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)
1399− -> (liftIO $ putMVar done ()) >> return ()))
1400− ]
1401−
1402− takeMVar done
1403−
1404−testHandleMessageIf :: TestTransport -> Assertion
1405−testHandleMessageIf TestTransport{..} = do
1406− localNode <- newLocalNode testTransport initRemoteTable
1407− done <- newEmptyMVar
1408− _ <- forkProcess localNode $ do
1409− self <- getSelfPid
1410− send self (5 :: Integer, 10 :: Integer)
1411− msg <- receiveWait [ matchMessage return ]
1412− handleMessageIf msg
1413− (\() -> True)
1414− (\() -> die "whoops") >>= maybe (return ())
1415− (const $ die "Expected Mismatch")
1416− handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)
1417− (\input -> liftIO $ putMVar done input)
1418− return ()
1419−
1420− result <- takeMVar done
1421− expectThat result $ equalTo (5, 10)
1422−
1423−testCatches :: TestTransport -> Assertion
1424−testCatches TestTransport{..} = do
1425− localNode <- newLocalNode testTransport initRemoteTable
1426− done <- newEmptyMVar
1427−
1428− _ <- forkProcess localNode $ do
1429− node <- getSelfNode
1430− (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))
1431− `catches` [
1432− Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())
1433− ]
1434−
1435− takeMVar done
1436−
1437−testMaskRestoreScope :: TestTransport -> Assertion
1438−testMaskRestoreScope TestTransport{..} = do
1439− localNode <- newLocalNode testTransport initRemoteTable
1440− parentPid <- newEmptyMVar :: IO (MVar ProcessId)
1441− spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)
1442−
1443− void $ runProcess localNode $ mask $ \unmask -> do
1444− getSelfPid >>= liftIO . putMVar parentPid
1445− void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)
1446−
1447− parent <- liftIO $ takeMVar parentPid
1448− child <- liftIO $ takeMVar spawnedPid
1449− expectThat parent $ isNot $ equalTo child
1450−
1451−testDie :: TestTransport -> Assertion
1452−testDie TestTransport{..} = do
1453− localNode <- newLocalNode testTransport initRemoteTable
1454− done <- newEmptyMVar
1455−
1456− _ <- forkProcess localNode $ do
1457− (die ("foobar", 123 :: Int))
1458− `catchExit` \_from reason -> do
1459− -- TODO: should verify that 'from' has the right value
1460− let res = reason == ("foobar", 123 :: Int)
1461− liftIO $ putMVar done ()
1462− if res
1463− then return ()
1464− else die "Something went horribly wrong"
1465−
1466− takeMVar done
1467−
1468−testPrettyExit :: TestTransport -> Assertion
1469−testPrettyExit TestTransport{..} = do
1470− localNode <- newLocalNode testTransport initRemoteTable
1471− done <- newEmptyMVar
1472−
1473− _ <- forkProcess localNode $ do
1474− (die "timeout")
1475− `catch` \ex@(ProcessExitException from _) ->
1476− let expected = "exit-from=" ++ (show from)
1477− in do
1478− let res = (show ex) == expected
1479− liftIO $ putMVar done ()
1480− if res
1481− then return ()
1482− else die "Something went horribly wrong"
1483−
1484− takeMVar done
1485−
1486−testExitLocal :: TestTransport -> Assertion
1487−testExitLocal TestTransport{..} = do
1488− localNode <- newLocalNode testTransport initRemoteTable
1489− supervisedDone <- newEmptyMVar
1490− supervisorDone <- newEmptyMVar
1491− -- XXX: we guarantee that exception handler will be set up
1492− -- regardless if forkProcess preserve masking state or not.
1493− handlerSetUp <- newEmptyMVar
1494−
1495− pid <- forkProcess localNode $ do
1496− (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do
1497− -- TODO: should verify that 'from' has the right value
1498− res <- return $ reason == "TestExit"
1499− liftIO $ putMVar supervisedDone ()
1500− if res
1501− then return ()
1502− else die "Something went horribly wrong"
1503−
1504− runProcess localNode $ do
1505− liftIO $ takeMVar handlerSetUp
1506− ref <- monitor pid
1507− exit pid "TestExit"
1508− -- This time the client catches the exception, so it dies normally
1509− mn <- expect
1510− case mn of
1511− ProcessMonitorNotification ref' pid' DiedNormal -> do
1512− let res = ref == ref' && pid == pid'
1513− liftIO $ putMVar supervisorDone ()
1514− if res
1515− then return ()
1516− else die "Something went horribly wrong"
1517− _ -> die "Something went horribly wrong"
1518−
1519− takeMVar supervisedDone
1520− takeMVar supervisorDone
1521−
1522−testExitRemote :: TestTransport -> Assertion
1523−testExitRemote TestTransport{..} = do
1524− node1 <- newLocalNode testTransport initRemoteTable
1525− node2 <- newLocalNode testTransport initRemoteTable
1526− supervisedDone <- newEmptyMVar
1527− supervisorDone <- newEmptyMVar
1528−
1529− pid <- forkProcess node1 $ do
1530− (receiveWait [] :: Process ()) -- block forever
1531− `catchExit` \_from reason -> do
1532− -- TODO: should verify that 'from' has the right value
1533− res <- return $ reason == "TestExit"
1534− liftIO $ putMVar supervisedDone ()
1535− if res
1536− then return ()
1537− else die "Something went horribly wrong"
1538−
1539− runProcess node2 $ do
1540− ref <- monitor pid
1541− exit pid "TestExit"
1542− mn <- expect
1543− case mn of
1544− ProcessMonitorNotification ref' pid' DiedNormal -> do
1545− res' <- return $ ref == ref' && pid == pid'
1546− liftIO $ putMVar supervisorDone ()
1547− if res'
1548− then return ()
1549− else die "Something went horribly wrong"
1550− _ -> die "Something went horribly wrong"
1551−
1552− takeMVar supervisedDone
1553− takeMVar supervisorDone
1554−
1555−testRegistryMonitoring :: TestTransport -> Assertion
1556−testRegistryMonitoring TestTransport{..} = do
1557− node1 <- newLocalNode testTransport initRemoteTable
1558− node2 <- newLocalNode testTransport initRemoteTable
1559−
1560− let nid = localNodeId node2
1561− pid <- forkProcess node1 $ do
1562− self <- getSelfPid
1563− runUntilRegistered nid self
1564− say $ (show self) ++ " registered as " ++ regName
1565− expect :: Process ()
1566− say $ (show self) ++ " exiting normally"
1567−
1568− runProcess node2 $ do
1569− register regName pid
1570− say $ regName ++ " registered to " ++ show pid
1571− res <- whereis regName
1572− send pid ()
1573− say $ " sent finish signal to " ++ show pid
1574− us <- getSelfPid
1575− liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
1576−
1577−
1578− -- This delay isn't essential!
1579− -- The test case passes perfectly fine without it (feel free to comment out
1580− -- and see), however waiting a few seconds here, makes it much more likely
1581− -- that in delayUntilMaybeUnregistered we will hit the match case right
1582− -- away, and thus not be subjected to a 20 second delay. The value of 4
1583− -- seconds appears to work optimally on osx and across several linux distros
1584− -- running in virtual machines (which is essentially what we do in CI)
1585− void $ receiveTimeout 4000000 [ matchAny return ]
1586−
1587− -- This delay doesn't serve much purpose in the happy path, however if some
1588− -- future patch breaks the cooperative behaviour of node controllers viz
1589− -- remote process registration and notification taking place via ncEffectDied,
1590− -- there would be the possibility of a race in the test case should we attempt
1591− -- to evaluate `whereis regName` on node2 right away. In case the name is still
1592− -- erroneously registered, observing the 20 second delay (or lack of), could at
1593− -- least give a hint that something is wrong, and we give up our time slice
1594− -- so that there's a higher change the registrations have been cleaned up
1595− -- in either case.
1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid
1597−
1598− regHere <- newEmptyMVar
1599− runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600− res <- takeMVar regHere
1601− case res of
1602− Nothing -> return ()
1603− Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1604−
1605− where
1606− runUntilRegistered nid us = do
1607− whereisRemoteAsync nid regName
1608− receiveWait [
1609− matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610− (const $ return ())
1611− ]
1612−
1613− delayUntilMaybeUnregistered nid p = do
1614− whereisRemoteAsync nid regName
1615− res <- receiveTimeout 20000000 {- 20 sec delay -} [
1616− matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)
1617− (const $ return ())
1618− ]
1619− case res of
1620− Just () -> return ()
1621− Nothing -> delayUntilMaybeUnregistered nid p
1622−
1623− regName = "testRegisterRemote"
1624−
1625−testUnsafeSend :: TestTransport -> Assertion
1626−testUnsafeSend TestTransport{..} = do
1627− serverAddr <- newEmptyMVar
1628− clientDone <- newEmptyMVar
1629−
1630− localNode <- newLocalNode testTransport initRemoteTable
1631− void $ forkProcess localNode $ do
1632− self <- getSelfPid
1633− liftIO $ putMVar serverAddr self
1634− clientAddr <- expect
1635− unsafeSend clientAddr ()
1636−
1637− void $ forkProcess localNode $ do
1638− serverPid <- liftIO $ takeMVar serverAddr
1639− getSelfPid >>= unsafeSend serverPid
1640− expect >>= liftIO . putMVar clientDone
1641−
1642− takeMVar clientDone
1643−
1644−testUnsafeUSend :: TestTransport -> Assertion
1645−testUnsafeUSend TestTransport{..} = do
1646− serverAddr <- newEmptyMVar
1647− clientDone <- newEmptyMVar
1648−
1649− localNode <- newLocalNode testTransport initRemoteTable
1650− void $ forkProcess localNode $ do
1651− self <- getSelfPid
1652− liftIO $ putMVar serverAddr self
1653− clientAddr <- expect
1654− unsafeUSend clientAddr ()
1655−
1656− void $ forkProcess localNode $ do
1657− serverPid <- liftIO $ takeMVar serverAddr
1658− getSelfPid >>= unsafeUSend serverPid
1659− expect >>= liftIO . putMVar clientDone
1660−
1661− takeMVar clientDone
1662−
1663−testUnsafeNSend :: TestTransport -> Assertion
1664−testUnsafeNSend TestTransport{..} = do
1665− clientDone <- newEmptyMVar
1666−
1667− localNode <- newLocalNode testTransport initRemoteTable
1668−
1669− pid <- forkProcess localNode $ do
1670− expect >>= liftIO . putMVar clientDone
1671−
1672− void $ runProcess localNode $ do
1673− register "foobar" pid
1674− unsafeNSend "foobar" ()
1675−
1676− takeMVar clientDone
1677−
1678−testUnsafeNSendRemote :: TestTransport -> Assertion
1679−testUnsafeNSendRemote TestTransport{..} = do
1680− clientDone <- newEmptyMVar
1681−
1682− localNode1 <- newLocalNode testTransport initRemoteTable
1683− localNode2 <- newLocalNode testTransport initRemoteTable
1684−
1685− _ <- forkProcess localNode1 $ do
1686− getSelfPid >>= register "foobar"
1687− liftIO $ putMVar clientDone ()
1688− expect >>= liftIO . putMVar clientDone
1689−
1690− takeMVar clientDone
1691− void $ runProcess localNode2 $ do
1692− unsafeNSendRemote (localNodeId localNode1) "foobar" ()
1693−
1694− takeMVar clientDone
1695−
1696−testUnsafeSendChan :: TestTransport -> Assertion
1697−testUnsafeSendChan TestTransport{..} = do
1698− serverAddr <- newEmptyMVar
1699− clientDone <- newEmptyMVar
1700−
1701− localNode <- newLocalNode testTransport initRemoteTable
1702− void $ forkProcess localNode $ do
1703− self <- getSelfPid
1704− liftIO $ putMVar serverAddr self
1705− sp <- expect
1706− unsafeSendChan sp ()
1707−
1708− void $ forkProcess localNode $ do
1709− serverPid <- liftIO $ takeMVar serverAddr
1710− (sp, rp) <- newChan
1711− unsafeSend serverPid sp
1712− receiveChan rp :: Process ()
1713− liftIO $ putMVar clientDone ()
1714−
1715− takeMVar clientDone
1716−
1717−testCallLocal :: TestTransport -> Assertion
1718−testCallLocal TestTransport{..} = do
1719− node <- newLocalNode testTransport initRemoteTable
1720−
1721− -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
1722− result <- newEmptyMVar
1723− runProcess node $ do
1724− r <- (/=) <$> getSelfPid <*> callLocal getSelfPid
1725− liftIO $ putMVar result r
1726−
1727− takeMVar result >>= assertBool "Expected 'True'"
1728−
1729− -- Testing that when callLocal is interrupted, the worker is interrupted.
1730− ibox <- newIORef False
1731− runProcess node $ do
1732− keeper <- getSelfPid
1733− spawnLocal $ do
1734− caller <- getSelfPid
1735− send keeper caller
1736− onException
1737− (callLocal $ do
1738− onException (do send keeper caller
1739− expect)
1740− (do liftIO $ writeIORef ibox True))
1741− (send keeper ())
1742− caller <- expect
1743− exit caller "test"
1744− expect :: Process ()
1745−
1746− readIORef ibox >>= assertBool "Expected 'True'"
1747−
1748− -- Testing that when the worker raises an exception, the exception is propagated to the parent.
1749− ibox2 <- newIORef False
1750− runProcess node $ do
1751− r <- try (callLocal $ error "e" >> return ())
1752− liftIO $ writeIORef ibox2 $ case r of
1753− Left (ErrorCall "e") -> True
1754− _ -> False
1755−
1756− readIORef ibox >>= assertBool "Expected 'True'"
1757−
1758− -- Test that caller waits for the worker in correct situation
1759− ibox3 <- newIORef False
1760− result3 <- newEmptyMVar
1761− runProcess node $ do
1762− keeper <- getSelfPid
1763− spawnLocal $ do
1764− callLocal $
1765− (do us <- getSelfPid
1766− send keeper us
1767− () <- expect
1768− liftIO yield)
1769− `finally` (liftIO $ writeIORef ibox3 True)
1770− liftIO $ putMVar result3 =<< readIORef ibox3
1771− worker <- expect
1772− send worker ()
1773−
1774− takeMVar result3 >>= assertBool "Expected 'True'"
1775−
1776− -- Test that caller waits for the worker in case when caller gets an exception
1777− ibox4 <- newIORef False
1778− result4 <- newEmptyMVar
1779− runProcess node $ do
1780− keeper <- getSelfPid
1781− spawnLocal $ do
1782− caller <- getSelfPid
1783− callLocal
1784− ((do send keeper caller
1785− expect)
1786− `finally` (liftIO $ writeIORef ibox4 True))
1787− `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)
1788− caller <- expect
1789− exit caller "hi!"
1790−
1791− takeMVar result4 >>= assertBool "Expected 'True'"
1792− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.
1793−
1794−tests :: TestTransport -> IO [Test]
1795−tests testtrans = return [
1796− testGroup "Basic features" [
1797− testCase "Ping" (testPing testtrans)
1798− , testCase "Math" (testMath testtrans)
1799− , testCase "Timeout" (testTimeout testtrans)
1800− , testCase "Timeout0" (testTimeout0 testtrans)
1801− , testCase "SendToTerminated" (testSendToTerminated testtrans)
1802− , testCase "TypedChannnels" (testTypedChannels testtrans)
1803− , testCase "Terminate" (testTerminate testtrans)
1804− , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)
1805− , testCase "RemoteRegistry" (testRemoteRegistry testtrans)
1806− , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)
1807− , testCase "SpawnLocal" (testSpawnLocal testtrans)
1808− , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)
1809− , testCase "HandleMessageIf" (testHandleMessageIf testtrans)
1810− , testCase "MatchAny" (testMatchAny testtrans)
1811− , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)
1812− , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)
1813− , testCase "MatchAnyIf" (testMatchAnyIf testtrans)
1814− , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
1815− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
1816− , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)
1818− , testCase "KillLocal" (testKillLocal testtrans)
1819− , testCase "KillRemote" (testKillRemote testtrans)
1820− , testCase "Die" (testDie testtrans)
1821− , testCase "PrettyExit" (testPrettyExit testtrans)
1822− , testCase "CatchesExit" (testCatchesExit testtrans)
1823− , testCase "Catches" (testCatches testtrans)
1824− , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1825− , testCase "ExitLocal" (testExitLocal testtrans)
1826− , testCase "ExitRemote" (testExitRemote testtrans)
1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1828− , testCase "TextCallLocal" (testCallLocal testtrans)
1829− -- Unsafe Primitives
1830− , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1831− , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)
1832− , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)
1833− , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)
1834− , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)
1835− -- usend
1836− , testCase "USend" (testUSend usend testtrans 50)
1837− , testCase "UForward"
1838− (testUSend (\p m -> uforward (createUnencodedMessage m) p)
1839− testtrans 50
1840− )
1841− ]
1842− , testGroup "Monitoring and Linking" [
1843− -- Monitoring processes
1844− --
1845− -- The "missing" combinations in the list below don't make much sense, as
1846− -- we cannot guarantee that the monitor reply or link exception will not
1847− -- happen before the unmonitor or unlink
1848− testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)
1849− , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)
1850− , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)
1851− , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)
1852− , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)
1853− , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)
1854− , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)
1855− , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)
1856− , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)
1857− , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)
1858− , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)
1859− , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)
1860− , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)
1861− , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)
1862− , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)
1863− , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)
1864− , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)
1865− -- Monitoring nodes and channels
1866− , testCase "MonitorNode" (testMonitorNode testtrans)
1867− , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)
1868− , testCase "MonitorChannel" (testMonitorChannel testtrans)
1869− -- Reconnect
1870− ]
1871−
1872− -- Tests that fail occasionally and should be revised
1873− , testGroup "Flaky" [
1874− testCase "Reconnect" (testReconnect testtrans)
1875− , testCase "Registry" (testRegistry testtrans)
1876− , testCase "MergeChannels" (testMergeChannels testtrans)
1877− , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
1878− ]
1879− ]
distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hsdeleted−589
@@ -1,589 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, KindSignatures #-}
2−module Control.Distributed.Process.Tests.Closure (tests) where
3−
4−import Network.Transport.Test (TestTransport(..))
5−
6−import Data.ByteString.Lazy (empty)
7−import Data.IORef
8−import Data.Typeable (Typeable)
9−import Data.Maybe
10−import Control.Monad (join, replicateM, forever, replicateM_, void, when, unless)
11−import Control.Exception (IOException, throw)
12−import Control.Concurrent (forkIO, threadDelay)
13−import Control.Concurrent.MVar
14− ( MVar
15− , newEmptyMVar
16− , readMVar
17− , takeMVar
18− , putMVar
19− , modifyMVar_
20− , newMVar
21− )
22−import Control.Applicative ((<$>))
23−import System.Random (randomIO)
24−import Control.Distributed.Process
25−import Control.Distributed.Process.Closure
26−import Control.Distributed.Process.Node
27−import Control.Distributed.Process.Internal.Types
28− ( NodeId(nodeAddress)
29− , createMessage
30− , messageToPayload
31− )
32−import Control.Distributed.Static (staticLabel, staticClosure)
33−import qualified Network.Transport as NT
34−
35−import Test.HUnit (Assertion)
36−import Test.Framework (Test)
37−import Test.Framework.Providers.HUnit (testCase)
38−
39−--------------------------------------------------------------------------------
40−-- Supporting definitions --
41−--------------------------------------------------------------------------------
42−
43−quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
44−quintuple a b c d e = (a, b, c, d, e)
45−
46−sdictInt :: SerializableDict Int
47−sdictInt = SerializableDict
48−
49−factorial :: Int -> Process Int
50−factorial 0 = return 1
51−factorial n = (n *) <$> factorial (n - 1)
52−
53−addInt :: Int -> Int -> Int
54−addInt x y = x + y
55−
56−putInt :: Int -> MVar Int -> IO ()
57−putInt = flip putMVar
58−
59−sendPid :: ProcessId -> Process ()
60−sendPid toPid = do
61− fromPid <- getSelfPid
62− send toPid fromPid
63−
64−wait :: Int -> Process ()
65−wait = liftIO . threadDelay
66−
67−expectUnit :: Process ()
68−expectUnit = expect
69−
70−isPrime :: Integer -> Process Bool
71−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
72− where
73− sieve :: [Integer] -> [Integer]
74− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
75− sieve [] = error "Uh oh -- we've run out of primes"
76−
77−-- | First argument indicates empty closure environment
78−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
79−typedPingServer () rport = forever $ do
80− sport <- receiveChan rport
81− sendChan sport ()
82−
83−signal :: ProcessId -> Process ()
84−signal pid = send pid ()
85−
86−remotable [ 'factorial
87− , 'addInt
88− , 'putInt
89− , 'sendPid
90− , 'sdictInt
91− , 'wait
92− , 'expectUnit
93− , 'typedPingServer
94− , 'isPrime
95− , 'quintuple
96− , 'signal
97− ]
98−
99−randomElement :: [a] -> IO a
100−randomElement xs = do
101− ix <- randomIO
102− return (xs !! (ix `mod` length xs))
103−
104−remotableDecl [
105− [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
106− dfib (_, reply, 0) = sendChan reply 0
107− dfib (_, reply, 1) = sendChan reply 1
108− dfib (nids, reply, n) = do
109− nid1 <- liftIO $ randomElement nids
110− nid2 <- liftIO $ randomElement nids
111− (sport, rport) <- newChan
112− spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)
113− spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)
114− n1 <- receiveChan rport
115− n2 <- receiveChan rport
116− sendChan reply $ n1 + n2
117− |]
118− ]
119−
120−-- Just try creating a static polymorphic value
121−staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
122− => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
123−staticQuintuple = $(mkStatic 'quintuple)
124−
125−factorialClosure :: Int -> Closure (Process Int)
126−factorialClosure = $(mkClosure 'factorial)
127−
128−addIntClosure :: Int -> Closure (Int -> Int)
129−addIntClosure = $(mkClosure 'addInt)
130−
131−putIntClosure :: Int -> Closure (MVar Int -> IO ())
132−putIntClosure = $(mkClosure 'putInt)
133−
134−sendPidClosure :: ProcessId -> Closure (Process ())
135−sendPidClosure = $(mkClosure 'sendPid)
136−
137−sendFac :: Int -> ProcessId -> Closure (Process ())
138−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid
139−
140−factorialOf :: Closure (Int -> Process Int)
141−factorialOf = staticClosure $(mkStatic 'factorial)
142−
143−factorial' :: Int -> Closure (Process Int)
144−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
145−
146−waitClosure :: Int -> Closure (Process ())
147−waitClosure = $(mkClosure 'wait)
148−
149−simulateNetworkFailure :: TestTransport -> LocalNode -> LocalNode -> Process ()
150−simulateNetworkFailure TestTransport{..} from to = liftIO $ do
151− m <- newEmptyMVar
152− _ <- forkProcess to $ getSelfPid >>= liftIO . putMVar m
153− runProcess from $ do
154− them <- liftIO $ takeMVar m
155− pinger <- spawnLocal $ forever $ send them ()
156− _ <- monitorNode (localNodeId to)
157− liftIO $ testBreakConnection (nodeAddress $ localNodeId from)
158− (nodeAddress $ localNodeId to)
159− NodeMonitorNotification _ _ _ <- expect
160− kill pinger "finished"
161− return ()
162−
163−--------------------------------------------------------------------------------
164−-- The tests proper --
165−--------------------------------------------------------------------------------
166−
167−testUnclosure :: TestTransport -> RemoteTable -> Assertion
168−testUnclosure TestTransport{..} rtable = do
169− node <- newLocalNode testTransport rtable
170− done <- newEmptyMVar
171− forkProcess node $ do
172− i <- join . unClosure $ factorialClosure 5
173− liftIO $ putMVar done ()
174− if i == 720
175− then return ()
176− else error "Something went horribly wrong"
177− takeMVar done
178−
179−testBind :: TestTransport -> RemoteTable -> Assertion
180−testBind TestTransport{..} rtable = do
181− node <- newLocalNode testTransport rtable
182− done <- newEmptyMVar
183− runProcess node $ do
184− us <- getSelfPid
185− join . unClosure $ sendFac 6 us
186− (i :: Int) <- expect
187− liftIO $ putMVar done ()
188− if i == 720
189− then return ()
190− else error "Something went horribly wrong"
191− takeMVar done
192−
193−testSendPureClosure :: TestTransport -> RemoteTable -> Assertion
194−testSendPureClosure TestTransport{..} rtable = do
195− serverAddr <- newEmptyMVar
196− serverDone <- newEmptyMVar
197−
198− forkIO $ do
199− node <- newLocalNode testTransport rtable
200− addr <- forkProcess node $ do
201− cl <- expect
202− fn <- unClosure cl :: Process (Int -> Int)
203− (_ :: Int) <- return $ fn 6
204− liftIO $ putMVar serverDone ()
205− putMVar serverAddr addr
206−
207− forkIO $ do
208− node <- newLocalNode testTransport rtable
209− theirAddr <- readMVar serverAddr
210− runProcess node $ send theirAddr (addIntClosure 7)
211−
212− takeMVar serverDone
213−
214−testSendIOClosure :: TestTransport -> RemoteTable -> Assertion
215−testSendIOClosure TestTransport{..} rtable = do
216− serverAddr <- newEmptyMVar
217− serverDone <- newEmptyMVar
218−
219− forkIO $ do
220− node <- newLocalNode testTransport rtable
221− addr <- forkProcess node $ do
222− cl <- expect
223− io <- unClosure cl :: Process (MVar Int -> IO ())
224− liftIO $ do
225− someMVar <- newEmptyMVar
226− io someMVar
227− i <- readMVar someMVar
228− putMVar serverDone ()
229− if i == 5
230− then return ()
231− else error "Something went horribly wrong"
232− putMVar serverAddr addr
233−
234− forkIO $ do
235− node <- newLocalNode testTransport rtable
236− theirAddr <- readMVar serverAddr
237− runProcess node $ send theirAddr (putIntClosure 5)
238−
239− takeMVar serverDone
240−
241−testSendProcClosure :: TestTransport -> RemoteTable -> Assertion
242−testSendProcClosure TestTransport{..} rtable = do
243− serverAddr <- newEmptyMVar
244− clientDone <- newEmptyMVar
245−
246− forkIO $ do
247− node <- newLocalNode testTransport rtable
248− addr <- forkProcess node $ do
249− cl <- expect
250− pr <- unClosure cl :: Process (Int -> Process ())
251− pr 5
252− putMVar serverAddr addr
253−
254− forkIO $ do
255− node <- newLocalNode testTransport rtable
256− theirAddr <- readMVar serverAddr
257− runProcess node $ do
258− pid <- getSelfPid
259− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
260− i <- expect :: Process Int
261− if i == 5
262− then liftIO $ putMVar clientDone ()
263− else error "Something went horribly wrong"
264−
265− takeMVar clientDone
266−
267−testSpawn :: TestTransport -> RemoteTable -> Assertion
268−testSpawn TestTransport{..} rtable = do
269− serverNodeAddr <- newEmptyMVar
270− clientDone <- newEmptyMVar
271−
272− forkIO $ do
273− node <- newLocalNode testTransport rtable
274− putMVar serverNodeAddr (localNodeId node)
275−
276− forkIO $ do
277− node <- newLocalNode testTransport rtable
278− nid <- readMVar serverNodeAddr
279− runProcess node $ do
280− pid <- getSelfPid
281− pid' <- spawn nid (sendPidClosure pid)
282− pid'' <- expect
283− if pid' == pid''
284− then liftIO $ putMVar clientDone ()
285− else error "Something went horribly wrong"
286−
287− takeMVar clientDone
288−
289−-- | Tests that spawn executes the supplied closure even if the caller dies
290−-- immediately after calling spawn.
291−--
292−-- This situation is of interest because the implementation of spawn has the
293−-- remote peer monitor the caller. See DP-99.
294−--
295−-- The condition is tested by using a transport which refuses to send to the
296−-- remote peer the message that it is waiting to stop monitoring the caller,
297−-- namely @()@.
298−--
299−testSpawnRace :: TestTransport -> RemoteTable -> Assertion
300−testSpawnRace TestTransport{..} rtable = do
301− node1 <- newLocalNode (wrapTransport testTransport) rtable
302− node2 <- newLocalNode testTransport rtable
303−
304− runProcess node1 $ do
305− pid <- getSelfPid
306− spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid
307− pid' <- expect :: Process ProcessId
308− pid'' <- expect :: Process ProcessId
309− if pid' == pid''
310− then return ()
311− else error "Something went horribly wrong"
312−
313− where
314−
315− wrapTransport (NT.Transport ne ct) = NT.Transport (fmap (fmap wrapEP) ne) ct
316−
317− wrapEP :: NT.EndPoint -> NT.EndPoint
318− wrapEP e =
319− e { NT.connect = \x y z -> do
320− healthy <- newIORef True
321− fmap (fmap $ wrapConnection healthy e x) $ NT.connect e x y z
322− }
323−
324− wrapConnection :: IORef Bool -> NT.EndPoint -> NT.EndPointAddress
325− -> NT.Connection -> NT.Connection
326− wrapConnection healthy e remoteAddr (NT.Connection s closeC) =
327− flip NT.Connection closeC $ \msg -> do
328− when (msg == messageToPayload (createMessage ())) $ do
329− writeIORef healthy False
330− testBreakConnection (NT.address e) remoteAddr
331− isHealthy <- readIORef healthy
332− if isHealthy then s msg
333− else return $ Left $ NT.TransportError NT.SendFailed ""
334−
335−testCall :: TestTransport -> RemoteTable -> Assertion
336−testCall TestTransport{..} rtable = do
337− serverNodeAddr <- newEmptyMVar
338− clientDone <- newEmptyMVar
339−
340− forkIO $ do
341− node <- newLocalNode testTransport rtable
342− putMVar serverNodeAddr (localNodeId node)
343−
344− forkIO $ do
345− node <- newLocalNode testTransport rtable
346− nid <- readMVar serverNodeAddr
347− runProcess node $ do
348− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
349− if a == 120
350− then liftIO $ putMVar clientDone ()
351− else error "something went horribly wrong"
352−
353− takeMVar clientDone
354−
355−testCallBind :: TestTransport -> RemoteTable -> Assertion
356−testCallBind TestTransport{..} rtable = do
357− serverNodeAddr <- newEmptyMVar
358− clientDone <- newEmptyMVar
359−
360− forkIO $ do
361− node <- newLocalNode testTransport rtable
362− putMVar serverNodeAddr (localNodeId node)
363−
364− forkIO $ do
365− node <- newLocalNode testTransport rtable
366− nid <- readMVar serverNodeAddr
367− runProcess node $ do
368− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
369− if a == 120
370− then liftIO $ putMVar clientDone ()
371− else error "Something went horribly wrong"
372−
373− takeMVar clientDone
374−
375−testSeq :: TestTransport -> RemoteTable -> Assertion
376−testSeq TestTransport{..} rtable = do
377− node <- newLocalNode testTransport rtable
378− done <- newEmptyMVar
379− runProcess node $ do
380− us <- getSelfPid
381− join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
382− a :: Int <- expect
383− b :: Int <- expect
384− if a == 120 && b == 720
385− then liftIO $ putMVar done ()
386− else error "Something went horribly wrong"
387− takeMVar done
388−
389−-- Test 'spawnSupervised'
390−--
391−-- Set up a supervisor, spawn a child, then have a third process monitor the
392−-- child. The supervisor then throws an exception, the child dies because it
393−-- was linked to the supervisor, and the third process notices that the child
394−-- dies.
395−testSpawnSupervised :: TestTransport -> RemoteTable -> Assertion
396−testSpawnSupervised TestTransport{..} rtable = do
397− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
398− [superPid, childPid] <- replicateM 2 $ newEmptyMVar
399− thirdProcessDone <- newEmptyMVar
400− linkUp <- newEmptyMVar
401−
402− forkProcess node1 $ do
403− us <- getSelfPid
404− liftIO $ putMVar superPid us
405− (child, _ref) <- spawnSupervised (localNodeId node2)
406− (sendPidClosure us `seqCP` $(mkStaticClosure 'expectUnit))
407− _ <- expect :: Process ProcessId
408−
409− liftIO $ do putMVar childPid child
410− -- Give the child a chance to link to us
411− takeMVar linkUp
412− throw supervisorDeath
413−
414− forkProcess node2 $ do
415− res <- liftIO $ mapM readMVar [superPid, childPid]
416− case res of
417− [super, child] -> do
418− ref <- monitor child
419− self <- getSelfPid
420− let waitForMOrL = do
421− liftIO $ threadDelay 10000
422− mpinfo <- getProcessInfo child
423− case mpinfo of
424− Nothing -> waitForMOrL
425− Just pinfo ->
426− unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL
427− waitForMOrL
428− liftIO $ putMVar linkUp ()
429− -- because monitor message was sent before message to process
430− -- we hope that it will be processed before
431− res' <- expect
432− case res' of
433− (ProcessMonitorNotification ref' pid' (DiedException e)) ->
434− if (ref' == ref && pid' == child &&
435− e == show (ProcessLinkException super
436− (DiedException (show supervisorDeath))))
437− then liftIO $ putMVar thirdProcessDone ()
438− else error "Something went horribly wrong"
439− _ -> error "Something went horribly wrong"
440−
441− _ -> die $ "Something went horribly wrong"
442−
443− takeMVar thirdProcessDone
444− where
445− supervisorDeath :: IOException
446− supervisorDeath = userError "Supervisor died"
447−
448−testSpawnInvalid :: TestTransport -> RemoteTable -> Assertion
449−testSpawnInvalid TestTransport{..} rtable = do
450− node <- newLocalNode testTransport rtable
451− done <- newEmptyMVar
452− forkProcess node $ do
453− (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
454− ProcessMonitorNotification ref' pid' _reason <- expect
455− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
456− res <- return $ ref' == ref && pid == pid'
457− if res == True
458− then liftIO $ putMVar done ()
459− else error "Something went horribly wrong"
460− takeMVar done
461−
462−testClosureExpect :: TestTransport -> RemoteTable -> Assertion
463−testClosureExpect TestTransport{..} rtable = do
464− node <- newLocalNode testTransport rtable
465− done <- newEmptyMVar
466− runProcess node $ do
467− nodeId <- getSelfNode
468− us <- getSelfPid
469− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
470− send them (1234 :: Int)
471− (res :: Int) <- expect
472− if res == 1234
473− then liftIO $ putMVar done ()
474− else error "Something went horribly wrong"
475− takeMVar done
476−
477−testSpawnChannel :: TestTransport -> RemoteTable -> Assertion
478−testSpawnChannel TestTransport{..} rtable = do
479− done <- newEmptyMVar
480− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
481−
482− forkProcess node1 $ do
483− pingServer <- spawnChannel
484− (sdictSendPort sdictUnit)
485− (localNodeId node2)
486− ($(mkClosure 'typedPingServer) ())
487− (sendReply, receiveReply) <- newChan
488− sendChan pingServer sendReply
489− receiveChan receiveReply
490− liftIO $ putMVar done ()
491−
492− takeMVar done
493−
494−testTDict :: TestTransport -> RemoteTable -> Assertion
495−testTDict TestTransport{..} rtable = do
496− done <- newEmptyMVar
497− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
498− forkProcess node1 $ do
499− res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
500− if res == True
501− then liftIO $ putMVar done ()
502− else error "Something went horribly wrong..."
503− takeMVar done
504−
505−testFib :: TestTransport -> RemoteTable -> Assertion
506−testFib TestTransport{..} rtable = do
507− nodes <- replicateM 4 $ newLocalNode testTransport rtable
508− done <- newEmptyMVar
509−
510− forkProcess (head nodes) $ do
511− (sport, rport) <- newChan
512− spawnLocal $ dfib (map localNodeId nodes, sport, 10)
513− ff <- receiveChan rport :: Process Integer
514− liftIO $ putMVar done ()
515− if ff /= 55
516− then die $ "Something went horribly wrong"
517− else return ()
518−
519− takeMVar done
520−
521−testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion
522−testSpawnReconnect testtrans@TestTransport{..} rtable = do
523− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
524− let nid1 = localNodeId node1
525− -- nid2 = localNodeId node2
526− done <- newEmptyMVar
527− iv <- newMVar (0 :: Int)
528−
529− incr <- forkProcess node1 $ forever $ do
530− () <- expect
531− liftIO $ modifyMVar_ iv (return . (+ 1))
532−
533− forkProcess node2 $ do
534− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)
535− simulateNetworkFailure testtrans node2 node1
536− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)
537− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)
538−
539− liftIO $ threadDelay 100000
540−
541− count <- liftIO $ takeMVar iv
542− res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
543−
544− liftIO $ putMVar done ()
545− if res /= True
546− then error "Something went horribly wrong"
547− else return ()
548−
549− takeMVar done
550−
551−-- | 'spawn' used to ave a race condition which would be triggered if the
552−-- spawning process terminates immediately after spawning
553−testSpawnTerminate :: TestTransport -> RemoteTable -> Assertion
554−testSpawnTerminate TestTransport{..} rtable = do
555− slave <- newLocalNode testTransport rtable
556− master <- newLocalNode testTransport rtable
557− masterDone <- newEmptyMVar
558−
559− runProcess master $ do
560− us <- getSelfPid
561− replicateM_ 1000 . spawnLocal . void . spawn (localNodeId slave) $ $(mkClosure 'signal) us
562− replicateM_ 1000 $ (expect :: Process ())
563− liftIO $ putMVar masterDone ()
564−
565− takeMVar masterDone
566−
567−tests :: TestTransport -> IO [Test]
568−tests testtrans = do
569− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
570− return
571− [ testCase "Unclosure" (testUnclosure testtrans rtable)
572− , testCase "Bind" (testBind testtrans rtable)
573− , testCase "SendPureClosure" (testSendPureClosure testtrans rtable)
574− , testCase "SendIOClosure" (testSendIOClosure testtrans rtable)
575− , testCase "SendProcClosure" (testSendProcClosure testtrans rtable)
576− , testCase "Spawn" (testSpawn testtrans rtable)
577− , testCase "SpawnRace" (testSpawnRace testtrans rtable)
578− , testCase "Call" (testCall testtrans rtable)
579− , testCase "CallBind" (testCallBind testtrans rtable)
580− , testCase "Seq" (testSeq testtrans rtable)
581− , testCase "SpawnSupervised" (testSpawnSupervised testtrans rtable)
582− , testCase "SpawnInvalid" (testSpawnInvalid testtrans rtable)
583− , testCase "ClosureExpect" (testClosureExpect testtrans rtable)
584− , testCase "SpawnChannel" (testSpawnChannel testtrans rtable)
585− , testCase "TDict" (testTDict testtrans rtable)
586− , testCase "Fib" (testFib testtrans rtable)
587− , testCase "SpawnTerminate" (testSpawnTerminate testtrans rtable)
588− , testCase "SpawnReconnect" (testSpawnReconnect testtrans rtable)
589− ]
distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hsdeleted−243
@@ -1,243 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE CPP #-}
5−
6−-----------------------------------------------------------------------------
7−-- |
8−-- Module : Control.Distributed.Process.Tests.Internal.Utils
9−-- Copyright : (c) Tim Watson, Jeff Epstein 2013
10−-- License : BSD3 (see the file LICENSE)
11−--
12−-- Maintainer : Tim Watson
13−-- Stability : experimental
14−-- Portability : non-portable (requires concurrency)
15−--
16−-- This module provides basic building blocks for testing Cloud Haskell programs.
17−-----------------------------------------------------------------------------
18−module Control.Distributed.Process.Tests.Internal.Utils
19− ( TestResult
20− -- ping !
21− , Ping(Ping)
22− , ping
23− , pause
24− , shouldBe
25− , shouldMatch
26− , shouldContain
27− , shouldNotContain
28− , expectThat
29− , synchronisedAssertion
30− -- test process utilities
31− , TestProcessControl
32− , startTestProcess
33− , runTestProcess
34− , testProcessGo
35− , testProcessStop
36− , testProcessReport
37− , delayedAssertion
38− , assertComplete
39− -- logging
40− , Logger()
41− , newLogger
42− , putLogMsg
43− , stopLogger
44− -- runners
45− , tryRunProcess
46− , tryForkProcess
47− , noop
48− , stash
49− ) where
50−
51−#if ! MIN_VERSION_base(4,6,0)
52−import Prelude hiding (catch)
53−#endif
54−import Control.Concurrent
55− ( ThreadId
56− , myThreadId
57− , forkIO
58− )
59−import Control.Concurrent.STM
60− ( TQueue
61− , newTQueueIO
62− , readTQueue
63− , writeTQueue
64− )
65−import Control.Concurrent.MVar
66− ( MVar
67− , newEmptyMVar
68− , takeMVar
69− )
70−
71−import Control.Concurrent
72− ( throwTo
73− )
74−import Control.Concurrent.MVar
75− ( putMVar
76− )
77−import Control.Distributed.Process hiding (finally, catch)
78−import Control.Distributed.Process.Node
79−import Control.Distributed.Process.Serializable()
80−
81−import Control.Exception (AsyncException(ThreadKilled), SomeException)
82−import Control.Monad (forever, void)
83−import Control.Monad.Catch (finally, catch)
84−import Control.Monad.STM (atomically)
85−import Control.Rematch hiding (match)
86−import Control.Rematch.Run
87−import Data.Binary
88−import Data.Typeable (Typeable)
89−
90−import Test.HUnit (Assertion, assertFailure)
91−import Test.HUnit.Base (assertBool)
92−
93−import GHC.Generics
94−import System.Timeout (timeout)
95−
96−-- | A mutable cell containing a test result.
97−type TestResult a = MVar a
98−
99−-- | A simple @Ping@ signal
100−data Ping = Ping
101− deriving (Typeable, Generic, Eq, Show)
102−instance Binary Ping where
103−
104−ping :: ProcessId -> Process ()
105−ping pid = send pid Ping
106−
107−-- | Control signals used to manage /test processes/
108−data TestProcessControl = Stop | Go | Report ProcessId
109− deriving (Typeable, Generic)
110−
111−instance Binary TestProcessControl where
112−
113−data Private = Private
114− deriving (Typeable, Generic)
115−instance Binary Private where
116−
117−-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
118−noop :: Process ()
119−noop = return ()
120−
121−pause :: Int -> Process ()
122−pause delay =
123− void $ receiveTimeout delay [ match (\Private -> return ()) ]
124−
125−synchronisedAssertion :: Eq a
126− => String
127− -> LocalNode
128− -> a
129− -> (TestResult a -> Process ())
130− -> MVar ()
131− -> Assertion
132−synchronisedAssertion note localNode expected testProc lock = do
133− result <- newEmptyMVar
134− _ <- forkProcess localNode $ do
135− acquire lock
136− finally (testProc result)
137− (release lock)
138− assertComplete note result expected
139− where acquire lock' = liftIO $ takeMVar lock'
140− release lock' = liftIO $ putMVar lock' ()
141−
142−stash :: TestResult a -> a -> Process ()
143−stash mvar x = liftIO $ putMVar mvar x
144−
145−expectThat :: a -> Matcher a -> Process ()
146−expectThat a matcher = case res of
147− MatchSuccess -> return ()
148− (MatchFailure msg) -> liftIO $ assertFailure msg
149− where res = runMatch matcher a
150−
151−shouldBe :: a -> Matcher a -> Process ()
152−shouldBe = expectThat
153−
154−shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()
155−shouldContain xs x = expectThat xs $ hasItem (equalTo x)
156−
157−shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()
158−shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))
159−
160−shouldMatch :: a -> Matcher a -> Process ()
161−shouldMatch = expectThat
162−
163−-- | Run the supplied @testProc@ using an @MVar@ to collect and assert
164−-- against its result. Uses the supplied @note@ if the assertion fails.
165−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
166− (TestResult a -> Process ()) -> Assertion
167−delayedAssertion note localNode expected testProc = do
168− result <- newEmptyMVar
169− _ <- forkProcess localNode $ testProc result
170− assertComplete note result expected
171−
172−-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@
173−assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
174−assertComplete msg mv a = do
175− b <- takeMVar mv
176− assertBool msg (a == b)
177−
178−-- synchronised logging
179−
180−data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }
181−
182−-- | Create a new Logger.
183−-- Logger uses a 'TQueue' to receive and process messages on a worker thread.
184−newLogger :: IO Logger
185−newLogger = do
186− tid <- liftIO $ myThreadId
187− q <- liftIO $ newTQueueIO
188− _ <- forkIO $ logger q
189− return $ Logger tid q
190− where logger q' = forever $ do
191− msg <- atomically $ readTQueue q'
192− putStrLn msg
193−
194−-- | Send a message to the Logger
195−putLogMsg :: Logger -> String -> Process ()
196−putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg
197−
198−-- | Stop the worker thread for the given Logger
199−stopLogger :: Logger -> IO ()
200−stopLogger = (flip throwTo) ThreadKilled . _tid
201−
202−-- | Starts a test process on the local node.
203−startTestProcess :: Process () -> Process ProcessId
204−startTestProcess proc =
205− spawnLocal $ do
206− getSelfPid >>= register "test-process"
207− runTestProcess proc
208−
209−-- | Runs a /test process/ around the supplied @proc@, which is executed
210−-- whenever the outer process loop receives a 'Go' signal.
211−runTestProcess :: Process () -> Process ()
212−runTestProcess proc = do
213− ctl <- expect
214− case ctl of
215− Stop -> return ()
216− Go -> proc >> runTestProcess proc
217− Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc
218−
219−-- | Tell a /test process/ to continue executing
220−testProcessGo :: ProcessId -> Process ()
221−testProcessGo pid = send pid Go
222−
223−-- | Tell a /test process/ to stop (i.e., 'terminate')
224−testProcessStop :: ProcessId -> Process ()
225−testProcessStop pid = send pid Stop
226−
227−-- | Tell a /test process/ to send a report (message)
228−-- back to the calling process
229−testProcessReport :: ProcessId -> Process ()
230−testProcessReport pid = do
231− self <- getSelfPid
232− send pid $ Report self
233−
234−tryRunProcess :: LocalNode -> Process () -> IO ()
235−tryRunProcess node p = do
236− tid <- liftIO myThreadId
237− void $ timeout (1000000 * 60 * 5 :: Int) $
238− runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
239−
240−tryForkProcess :: LocalNode -> Process () -> IO ProcessId
241−tryForkProcess node p = do
242− tid <- liftIO myThreadId
243− forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hsdeleted−542
@@ -1,542 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE ParallelListComp #-}
3−
4−module Control.Distributed.Process.Tests.Mx (tests) where
5−
6−import Control.Distributed.Process.Tests.Internal.Utils
7−import Network.Transport.Test (TestTransport(..))
8−import Control.Distributed.Process hiding (bracket, finally, try)
9−import Control.Distributed.Process.Internal.Types
10− ( ProcessExitException(..)
11− , unsafeCreateUnencodedMessage
12− )
13−import Control.Distributed.Process.Node
14−import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe
15− ( send
16− , nsend
17− , nsendRemote
18− , usend
19− , sendChan
20− )
21−import Control.Distributed.Process.Management
22− ( MxEvent(..)
23− , MxAgentId(..)
24− , mxAgent
25− , mxSink
26− , mxReady
27− , mxReceive
28− , mxDeactivate
29− , liftMX
30− , mxGetLocal
31− , mxSetLocal
32− , mxUpdateLocal
33− , mxNotify
34− , mxBroadcast
35− )
36−import Control.Monad (void, unless)
37−import Control.Monad.Catch(finally, bracket, try)
38−import Control.Rematch (equalTo)
39−import Data.Binary
40−import Data.List (find, sort, intercalate)
41−import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)
42−import Data.Typeable
43−import GHC.Generics hiding (from)
44−#if ! MIN_VERSION_base(4,6,0)
45−import Prelude hiding (catch, log)
46−#endif
47−
48−import Test.Framework
49− ( Test
50− , testGroup
51− )
52−import Test.Framework.Providers.HUnit (testCase)
53−
54−data Publish = Publish
55− deriving (Typeable, Generic, Eq)
56−
57−instance Binary Publish where
58−
59−awaitExit :: ProcessId -> Process ()
60−awaitExit pid =
61− withMonitorRef pid $ \ref -> do
62− receiveWait
63− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == ref)
64− (\_ -> return ())
65− ]
66− where
67− withMonitorRef p = bracket (monitor p) unmonitor
68−
69−testAgentBroadcast :: TestResult (Maybe ()) -> Process ()
70−testAgentBroadcast result = do
71− (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())
72−
73− publisher <- mxAgent (MxAgentId "publisher-agent") () [
74− mxSink $ \() -> mxBroadcast Publish >> mxReady
75− ]
76−
77− consumer <- mxAgent (MxAgentId "consumer-agent") () [
78− mxSink $ \Publish -> (liftMX $ sendChan resultSP ()) >> mxReady
79− ]
80−
81− mxNotify ()
82− -- Once the publisher has seen our message, it will broadcast the Publish
83− -- and the consumer will see that and send the result to our typed channel.
84− stash result =<< receiveChanTimeout 10000000 resultRP
85−
86− kill publisher "finished"
87− kill consumer "finished"
88−
89−testAgentDualInput :: TestResult (Maybe Int) -> Process ()
90−testAgentDualInput result = do
91− (sp, rp) <- newChan
92− s <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [
93− mxSink $ (\(i :: Int) -> do
94− mxSetLocal . (+i) =<< mxGetLocal
95− i' <- mxGetLocal
96− if i' == 15
97− then do mxGetLocal >>= liftMX . sendChan sp
98− mxDeactivate "finished"
99− else mxReady)
100− ]
101−
102− mRef <- monitor s
103−
104− mxNotify (1 :: Int)
105− nsend "sum-agent" (3 :: Int)
106− mxNotify (2 :: Int)
107− nsend "sum-agent" (4 :: Int)
108− mxNotify (5 :: Int)
109−
110− stash result =<< receiveChanTimeout 10000000 rp
111− died <- receiveTimeout 10000000 [
112− matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) (const $ return True)
113− ]
114− died `shouldBe` equalTo (Just True)
115−
116−testAgentPrioritisation :: TestResult [String] -> Process ()
117−testAgentPrioritisation result = do
118−
119− -- TODO: this isn't really testing how we /prioritise/ one source
120− -- over another at all, but I've not yet figured out the right way
121− -- to do so, since we're at the whim of the scheduler with regards
122− -- the timeliness of nsend versus mxNotify anyway.
123−
124− let name = "prioritising-agent"
125− (sp, rp) <- newChan
126− s <- mxAgent (MxAgentId name) ["first"] [
127− mxSink (\(s :: String) -> do
128− mxUpdateLocal (s:)
129− st <- mxGetLocal
130− case length st of
131− n | n == 5 -> do liftMX $ sendChan sp (sort st)
132− mxDeactivate "finished"
133− _ -> mxReceive -- go to the mailbox
134− )
135− ]
136−
137− nsend name "second"
138− mxNotify "third"
139− mxNotify "fourth"
140− nsend name "fifth"
141−
142− stash result . fromMaybe [] =<< receiveChanTimeout 10000000 rp
143− awaitExit s
144−
145−testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()
146−testAgentMailboxHandling result = do
147− (sp, rp) <- newChan
148− agent <- mxAgent (MxAgentId "mailbox-agent") () [
149− mxSink $ \() -> (liftMX $ sendChan sp ()) >> mxReady
150− ]
151−
152− nsend "mailbox-agent" ()
153−
154− stash result =<< receiveChanTimeout 1000000 rp
155− kill agent "finished"
156−
157−testAgentEventHandling :: TestResult Bool -> Process ()
158−testAgentEventHandling result = do
159− us <- getSelfPid
160− -- because this test is a bit racy, let's ensure it can't run indefinitely
161− timer <- spawnLocal $ do
162− pause (1000000 * 60 * 5)
163− -- okay we've waited 5 mins, let's kill the test off if it's stuck...
164− stash result False
165− kill us "Test Timed Out"
166−
167− let initState = [] :: [MxEvent]
168− (rc, rs) <- newChan
169− agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [
170− (mxSink $ \ev -> do
171− st <- mxGetLocal
172− let act =
173− case ev of
174− (MxSpawned _) -> mxSetLocal (ev:st)
175− (MxProcessDied _ _) -> mxSetLocal (ev:st)
176− _ -> return ()
177− act >> (liftMX $ sendChan rc ()) >> mxReady),
178− (mxSink $ \(ev, sp :: SendPort Bool) -> do
179− st <- mxGetLocal
180− let found =
181− case ev of
182− MxSpawned p ->
183− isJust $ find (\ev' ->
184− case ev' of
185− (MxSpawned p') -> p' == p
186− _ -> False) st
187− MxProcessDied p r ->
188− isJust $ find (\ev' ->
189− case ev' of
190− (MxProcessDied p' r') -> p' == p && r == r'
191− _ -> False) st
192− _ -> False
193− liftMX $ sendChan sp found
194− mxReady)
195− ]
196−
197− -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
198− faff 2000000 rs
199−
200− (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())
201−
202− pid <- spawnLocal $ expect >>= sendChan sp
203−
204− -- By waiting for a monitor notification, we have a
205− -- higher probably that the agent has seen the spawn and died events
206− monitor pid
207−
208− send pid ()
209− rct <- receiveChanTimeout 10000000 rp
210− unless (isJust rct) $ die "No response on channel"
211−
212− pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]
213− unless (isJust pmn) $ die "No monitor notification arrived"
214−
215− -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
216− faff 2000000 rs
217−
218− (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
219− mxNotify (MxSpawned pid, replyTo)
220− mxNotify (MxProcessDied pid DiedNormal, replyTo)
221−
222− seenAlive <- receiveChanTimeout 10000000 reply
223− seenDead <- receiveChanTimeout 10000000 reply
224−
225− stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]
226− kill timer "test-complete"
227− kill agentPid "test-complete"
228− where
229− faff delay port = do
230− res <- receiveChanTimeout delay port
231− unless (isNothing res) $ pause delay
232−
233−testMxRegEvents :: TestResult () -> Process ()
234−testMxRegEvents result = do
235− {- This test only deals with the local case, to ensure that we are being
236− notified in the expected order - the remote cases related to the
237− behaviour of the node controller are contained in the CH test suite. -}
238− ensure (stash result ()) $ do
239− let label = "testMxRegEvents"
240− let agentLabel = "mxRegEvents-agent"
241− let delay = 1000000
242− (regChan, regSink) <- newChan
243− (unRegChan, unRegSink) <- newChan
244− agent <- mxAgent (MxAgentId agentLabel) () [
245− mxSink $ \ev -> do
246− case ev of
247− MxRegistered pid label'
248− | label' == label -> liftMX $ sendChan regChan (label', pid)
249− MxUnRegistered pid label'
250− | label' == label -> liftMX $ sendChan unRegChan (label', pid)
251− _ -> return ()
252− mxReady
253− ]
254−
255− p1 <- spawnLocal expect
256− p2 <- spawnLocal expect
257−
258− register label p1
259− reg1 <- receiveChanTimeout delay regSink
260− reg1 `shouldBe` equalTo (Just (label, p1))
261−
262− unregister label
263− unreg1 <- receiveChanTimeout delay unRegSink
264− unreg1 `shouldBe` equalTo (Just (label, p1))
265−
266− register label p2
267− reg2 <- receiveChanTimeout delay regSink
268− reg2 `shouldBe` equalTo (Just (label, p2))
269−
270− reregister label p1
271− unreg2 <- receiveChanTimeout delay unRegSink
272− unreg2 `shouldBe` equalTo (Just (label, p2))
273−
274− reg3 <- receiveChanTimeout delay regSink
275− reg3 `shouldBe` equalTo (Just (label, p1))
276−
277− mapM_ (flip kill $ "test-complete") [agent, p1, p2]
278−
279−testMxRegMon :: LocalNode -> TestResult () -> Process ()
280−testMxRegMon remoteNode result = do
281− ensure (stash result ()) $ do
282− -- ensure that when a registered process dies, we get a notification that
283− -- it has been unregistered as well as seeing the name get removed
284− let label1 = "aaaaa"
285− let label2 = "bbbbb"
286− let isValid l = l == label1 || l == label2
287− let agentLabel = "mxRegMon-agent"
288− let delay = 1000000
289− (regChan, regSink) <- newChan
290− (unRegChan, unRegSink) <- newChan
291− agent <- mxAgent (MxAgentId agentLabel) () [
292− mxSink $ \ev -> do
293− case ev of
294− MxRegistered pid label
295− | isValid label -> liftMX $ sendChan regChan (label, pid)
296− MxUnRegistered pid label
297− | isValid label -> liftMX $ sendChan unRegChan (label, pid)
298− _ -> return ()
299− mxReady
300− ]
301−
302− (sp, rp) <- newChan
303− liftIO $ forkProcess remoteNode $ do
304− getSelfPid >>= sendChan sp
305− expect :: Process ()
306−
307− p1 <- receiveChan rp
308−
309− register label1 p1
310− reg1 <- receiveChanTimeout delay regSink
311− reg1 `shouldBe` equalTo (Just (label1, p1))
312−
313− register label2 p1
314− reg2 <- receiveChanTimeout delay regSink
315− reg2 `shouldBe` equalTo (Just (label2, p1))
316−
317− n1 <- whereis label1
318− n1 `shouldBe` equalTo (Just p1)
319−
320− n2 <- whereis label2
321− n2 `shouldBe` equalTo (Just p1)
322−
323− kill p1 "goodbye"
324−
325− unreg1 <- receiveChanTimeout delay unRegSink
326− unreg2 <- receiveChanTimeout delay unRegSink
327−
328− let evts = [unreg1, unreg2]
329− -- we can't rely on the order of the values in the node controller's
330− -- map (it's either racy to do so, or no such guarantee exists for Data.Map),
331− -- so we simply verify that we received the un-registration events we expect
332− evts `shouldContain` (Just (label1, p1))
333− evts `shouldContain` (Just (label2, p1))
334−
335− kill agent "test-complete"
336−
337−ensure :: Process () -> Process () -> Process ()
338−ensure = flip finally
339−
340−testNSend :: (String -> () -> Process ())
341− -> Maybe LocalNode
342− -> Process ()
343−testNSend op n = do
344− us <- getSelfPid
345− let delay = 5000000
346− let label = "testMxSend" ++ (show us)
347− let isValid = isValidLabel n label
348−
349− testMxSend n label $ \p1 sink -> do
350− register label p1
351− reg1 <- receiveChanTimeout delay sink
352− case reg1 of
353− Just (MxRegistered pd lb)
354− | pd == p1 && isValid lb -> return ()
355− _ -> die $ "Reg-Failed: " ++ show reg1
356−
357− op label ()
358−
359− sent <- receiveChanTimeout delay sink
360− case sent of
361− Just (MxSentToName lb by _)
362− | by == us && isValid lb -> return True
363− _ -> die $ "Send-Failed: " ++ show sent
364−
365− where
366− isValidLabel nd l1 l2
367− | l2 == l2 = True
368− | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)
369− | otherwise = False
370−
371−testSend :: (ProcessId -> () -> Process ())
372− -> Maybe LocalNode
373− -> Process ()
374−testSend op n = do
375− us <- getSelfPid
376− let label = "testMxSend" ++ (show us)
377− testMxSend n label $ \p1 sink -> do
378− -- initiate a send
379− op p1 ()
380−
381− -- verify the management event
382− sent <- receiveChanTimeout 5000000 sink
383− case sent of
384− Just (MxSent pidTo pidFrom _)
385− | pidTo == p1 && pidFrom == us -> return True
386− _ -> return False
387−
388−testChan :: (SendPort () -> () -> Process ())
389− -> Maybe LocalNode
390− -> Process ()
391−testChan op n = testMxSend n "" $ \p1 sink -> do
392−
393− us <- getSelfPid
394− send p1 us
395−
396− cleared <- receiveChanTimeout 2000000 sink
397− case cleared of
398− Just (MxSent pidTo pidFrom _)
399− | pidTo == p1 && pidFrom == us -> return ()
400− _ -> die "Received uncleared Mx Event"
401−
402− chan <- receiveTimeout 5000000 [ match return ]
403− let ch' = fromMaybe (error "No reply chan received") chan
404−
405− -- initiate a send
406− op ch' ()
407−
408− -- verify the management event
409− sent <- receiveChanTimeout 5000000 sink
410− case sent of
411− Just (MxSentToPort sId spId _)
412− | sId == us && spId == sendPortId ch' -> return True
413− _ -> return False
414−
415−type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
416−
417−testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()
418−testMxSend mNode label test = do
419− us <- getSelfPid
420− (sp, rp) <- newChan
421− (chan, sink) <- newChan
422− agent <- mxAgent (MxAgentId $ agentLabel us) () [
423− mxSink $ \ev -> do
424− case ev of
425− m@(MxSentToPort _ cid _)
426− | cid /= sendPortId chan
427− && cid /= sendPortId sp -> liftMX $ sendChan chan m
428− m@(MxSent _ fromPid _)
429− | fromPid == us -> liftMX $ sendChan chan m
430− m@(MxSentToName _ fromPid _)
431− | fromPid == us -> liftMX $ sendChan chan m
432− m@(MxRegistered _ name)
433− | name == label -> liftMX $ sendChan chan m
434− _ -> return ()
435− mxReady
436− ]
437−
438− case mNode of
439− Nothing -> void $ spawnLocal (proc sp)
440− Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp
441−
442− p1 <- receiveChanTimeout 2000000 rp
443− unless (isJust p1) $ die "Timed out waiting for ProcessId"
444− res <- try $ test (fromJust p1) sink
445−
446− kill agent "bye"
447− kill (fromJust p1) "bye"
448−
449− case res of
450− Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m
451− Right tr -> tr `shouldBe` equalTo True
452−
453−
454− where
455− agentLabel s = "mx-unsafe-check-agent-" ++ show s
456− proc sp' = getSelfPid >>= sendChan sp' >> go Nothing
457−
458− go :: Maybe (ReceivePort ()) -> Process ()
459− go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go
460− go c@(Just c') = receiveWait [ matchChan c' return ] >> go c
461−
462− replyChannel p' = do
463− (s, r) <- newChan
464− send p' s
465− return r
466−
467−tests :: TestTransport -> IO [Test]
468−tests TestTransport{..} = do
469− node1 <- newLocalNode testTransport initRemoteTable
470− node2 <- newLocalNode testTransport initRemoteTable
471− return [
472− testGroup "MxAgents" [
473− testCase "EventHandling"
474− (delayedAssertion
475− "expected True, but events where not as expected"
476− node1 True testAgentEventHandling)
477− , testCase "InterAgentBroadcast"
478− (delayedAssertion
479− "expected (), but no broadcast was received"
480− node1 (Just ()) testAgentBroadcast)
481− , testCase "AgentMailboxHandling"
482− (delayedAssertion
483− "expected (Just ()), but no regular (mailbox) input was handled"
484− node1 (Just ()) testAgentMailboxHandling)
485− , testCase "AgentDualInputHandling"
486− (delayedAssertion
487− "expected sum = 15, but the result was Nothing"
488− node1 (Just 15 :: Maybe Int) testAgentDualInput)
489− , testCase "AgentInputPrioritisation"
490− (delayedAssertion
491− "expected [first, second, third, fourth, fifth], but result diverged"
492− node1 (sort ["first", "second",
493− "third", "fourth",
494− "fifth"]) testAgentPrioritisation)
495− ]
496− , testGroup "MxEvents" [
497− testCase "NameRegistrationEvents"
498− (delayedAssertion
499− "expected registration events to map to the correct ProcessId"
500− node1 () testMxRegEvents)
501− , testCase "PostDeathNameUnRegistrationEvents"
502− (delayedAssertion
503− "expected process deaths to result in unregistration events"
504− node1 () (testMxRegMon node2))
505− , testGroup "SendEvents" $ buildTestCases node1 node2
506− ]
507− ]
508− where
509− buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [
510− ("NSend", [
511− ("nsend", testNSend nsend)
512− , ("Unsafe.nsend", testNSend Unsafe.nsend)
513− , ("nsendRemote", testNSend (nsendRemote nid))
514− , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))
515− ])
516− , ("Send", [
517− ("send", testSend send)
518− , ("Unsafe.send", testSend Unsafe.send)
519− , ("usend", testSend usend)
520− , ("Unsafe.usend", testSend Unsafe.usend)
521− , ("sendChan", testChan sendChan)
522− , ("Unsafe.sendChan", testChan Unsafe.sendChan)
523− ])
524− , ("Forward", [
525− ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))
526− , ("uforward", testSend (\p m -> uforward (unsafeCreateUnencodedMessage m) p))
527− ])
528− ]
529−
530− build :: LocalNode
531− -> LocalNode
532− -> [(String, [(String, (Maybe LocalNode -> Process ()))])]
533− -> [Test]
534− build n ln specs =
535− [ testGroup (intercalate "-" [groupName, caseSuffix]) [
536− testCase (intercalate "-" [caseName, caseSuffix])
537− (runProcess n (caseImpl caseNode))
538− | (caseName, caseImpl) <- groupCases
539− ]
540− | (groupName, groupCases) <- specs
541− , (caseSuffix, caseNode) <- [("RemotePid", Just ln), ("LocalPid", Nothing)]
542− ]
distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hsdeleted−154
@@ -1,154 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# OPTIONS_GHC -Wall #-}
3−
4−-- | XXX test doesn't work, because failure exceptions don't get propagated. The
5−-- test always claims to succeed, even if it failed.
6−
7−module Control.Distributed.Process.Tests.Receive (tests) where
8−
9−import Network.Transport.Test (TestTransport(..))
10−
11−import Network.Transport (Transport)
12−import Control.Distributed.Process
13−import Control.Distributed.Process.Node
14−
15−import Control.Monad
16−
17−import Test.HUnit (Assertion, (@?=))
18−import Test.Framework (Test)
19−import Test.Framework.Providers.HUnit (testCase)
20−
21−-- Tests:
22−
23−-- 1. 2 matchChans, receive on each one
24−-- 2. matchChan/matchIf, receive on each one
25−-- 3. matchIf/matchChan, receive on each one
26−-- 4. matchIf/matchChan/matchIf, receive on each one
27−
28−recTest1 :: ReceivePort ()
29− -> SendPort String
30− -> ReceivePort String -> ReceivePort String
31− -> Process ()
32−recTest1 wait sync r1 r2 = do
33− forever $ do
34− receiveChan wait
35− r <- receiveWait
36− [ matchChan r1 $ \s -> return ("received1 " ++ s)
37− , matchChan r2 $ \s -> return ("received2 " ++ s)
38− ]
39− sendChan sync r
40−
41−recTest2 :: ReceivePort ()
42− -> SendPort String
43− -> ReceivePort String -> ReceivePort String
44− -> Process ()
45−recTest2 wait sync r1 _ = do
46− forever $ do
47− receiveChan wait
48− r <- receiveWait
49− [ matchChan r1 $ \s -> return ("received1 " ++ s)
50− , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
51− ]
52− sendChan sync r
53−
54−recTest3 :: ReceivePort ()
55− -> SendPort String
56− -> ReceivePort String -> ReceivePort String
57− -> Process ()
58−recTest3 wait sync r1 _ = do
59− forever $ do
60− receiveChan wait
61− r <- receiveWait
62− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
63− , matchChan r1 $ \s -> return ("received2 " ++ s)
64− ]
65− sendChan sync r
66−
67−recTest4 :: ReceivePort ()
68− -> SendPort String
69− -> ReceivePort String -> ReceivePort String
70− -> Process ()
71−recTest4 wait sync r1 _ = do
72− forever $ do
73− receiveChan wait
74− r <- receiveWait
75− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
76− , matchChan r1 $ \s -> return ("received2 " ++ s)
77− , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
78− ]
79− sendChan sync r
80−
81−master :: Process ()
82−master = do
83− (waits,waitr) <- newChan
84− (syncs,syncr) <- newChan
85− let go expected = do
86− sendChan waits ()
87− r <- receiveChan syncr
88− liftIO $ print (r, expected, r == expected)
89− liftIO $ r @?= expected
90−
91− liftIO $ putStrLn "---- Test 1 ----"
92− (s1,r1) <- newChan
93− (s2,r2) <- newChan
94− p <- spawnLocal (recTest1 waitr syncs r1 r2)
95−
96− sendChan s1 "a" >> go "received1 a"
97− sendChan s2 "b" >> go "received2 b"
98− sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
99− go "received2 b"
100−
101− kill p "BANG"
102−
103− liftIO $ putStrLn "\n---- Test 2 ----"
104− (s1,r1) <- newChan
105− (s2,r2) <- newChan
106− p <- spawnLocal (recTest2 waitr syncs r1 r2)
107−
108− sendChan s1 "a" >> go "received1 a"
109− send p "foo" >> go "received2 foo"
110− sendChan s1 "a" >> send p "foo" >> go "received1 a"
111− sendChan s1 "a" >> send p "bar" >> go "received1 a"
112− go "received2 foo"
113−
114− kill p "BANG"
115−
116− liftIO $ putStrLn "\n---- Test 3 ----"
117− (s1,r1) <- newChan
118− (s2,r2) <- newChan
119− p <- spawnLocal (recTest3 waitr syncs r1 r2)
120−
121− sendChan s1 "a" >> go "received2 a"
122− send p "foo" >> go "received1 foo"
123− sendChan s1 "a" >> send p "foo" >> go "received1 foo"
124− sendChan s1 "a" >> send p "bar" >> go "received2 a"
125− go "received2 a"
126−
127− kill p "BANG"
128−
129− liftIO $ putStrLn "\n---- Test 4 ----"
130− (s1,r1) <- newChan
131− (s2,r2) <- newChan
132− p <- spawnLocal (recTest4 waitr syncs r1 r2)
133−
134− sendChan s1 "a" >> go "received2 a"
135− send p "foo" >> go "received1 foo"
136− send p "bar" >> go "received3 bar"
137− sendChan s1 "a" >> send p "foo" >> go "received1 foo"
138− send p "bar" >> go "received2 a"
139− send p "foo" >> go "received1 foo" >> go "received3 bar"
140−
141− kill p "BANG"
142−
143− terminate
144−
145−testReceive :: Transport -> RemoteTable -> Assertion
146−testReceive transport rtable = do
147− node <- newLocalNode transport rtable
148− runProcess node $ master
149−
150−tests :: TestTransport -> IO [Test]
151−tests TestTransport{..} = do
152− let rtable = initRemoteTable
153− return
154− [ testCase "testReceive" (testReceive testTransport rtable) ]
distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hsdeleted−129
@@ -1,129 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Tests.Stats (tests) where
4−
5−import Control.Distributed.Process.Tests.Internal.Utils
6−import Network.Transport.Test (TestTransport(..))
7−
8−import Control.Concurrent.MVar
9− ( MVar
10− , newEmptyMVar
11− , putMVar
12− , takeMVar
13− )
14−import Control.Distributed.Process
15−import Control.Distributed.Process.Node
16−import Data.Binary ()
17−import Data.Typeable ()
18−
19−#if ! MIN_VERSION_base(4,6,0)
20−import Prelude hiding (catch)
21−#endif
22−
23−import Test.Framework
24− ( Test
25− , testGroup
26− )
27−import Test.HUnit (Assertion)
28−import Test.Framework.Providers.HUnit (testCase)
29−
30−testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
31−testLocalDeadProcessInfo result = do
32− pid <- spawnLocal $ do (_ :: String) <- expect; return ()
33− mref <- monitor pid
34− send pid "finish"
35− _ <- receiveWait [
36− matchIf (\(ProcessMonitorNotification ref' pid' r) ->
37− ref' == mref && pid' == pid && r == DiedNormal)
38− (\p -> return p)
39− ]
40− getProcessInfo pid >>= stash result
41−
42−testLocalLiveProcessInfo :: TestResult Bool -> Process ()
43−testLocalLiveProcessInfo result = do
44− self <- getSelfPid
45− node <- getSelfNode
46− register "foobar" self
47−
48− mon <- liftIO $ newEmptyMVar
49− -- TODO: we can't get the mailbox's length
50− -- mapM (send self) ["hello", "there", "mr", "process"]
51− pid <- spawnLocal $ do
52− link self
53− mRef <- monitor self
54− stash mon mRef
55− res <- expect
56− case res of
57− "die" -> return ()
58− _ -> die $ "unexpected message received: " ++ res
59−
60− monRef <- liftIO $ takeMVar mon
61−
62− mpInfo <- getProcessInfo self
63− case mpInfo of
64− Nothing -> stash result False
65− Just p -> verifyPInfo p pid monRef node
66− where verifyPInfo :: ProcessInfo
67− -> ProcessId
68− -> MonitorRef
69− -> NodeId
70− -> Process ()
71− verifyPInfo pInfo pid mref node =
72− stash result $ infoNode pInfo == node &&
73− infoLinks pInfo == [pid] &&
74− infoMonitors pInfo == [(pid, mref)] &&
75−-- infoMessageQueueLength pInfo == Just 4 &&
76− infoRegisteredNames pInfo == ["foobar"]
77−
78−testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion
79−testRemoteLiveProcessInfo TestTransport{..} node1 = do
80− serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
81− liftIO $ launchRemote serverAddr
82− serverPid <- liftIO $ takeMVar serverAddr
83− withActiveRemote node1 $ \result -> do
84− self <- getSelfPid
85− link serverPid
86− -- our send op shouldn't overtake link or monitor requests AFAICT
87− -- so a little table tennis should get us synchronised properly
88− send serverPid (self, "ping")
89− pong <- expect
90− pInfo <- getProcessInfo serverPid
91− stash result $ pong == "pong" && pInfo /= Nothing
92− where
93− launchRemote :: MVar ProcessId -> IO ()
94− launchRemote locMV = do
95− node2 <- liftIO $ newLocalNode testTransport initRemoteTable
96− _ <- liftIO $ forkProcess node2 $ do
97− self <- getSelfPid
98− liftIO $ putMVar locMV self
99− _ <- receiveWait [
100− match (\(pid, "ping") -> send pid "pong")
101− ]
102− res <- expect
103− case res of
104− "stop" -> return ()
105− _ -> die $ "unexpected message received: " ++ res
106− return ()
107−
108− withActiveRemote :: LocalNode
109− -> ((TestResult Bool -> Process ()) -> Assertion)
110− withActiveRemote n = do
111− a <- delayedAssertion "getProcessInfo remotePid failed" n True
112− return a
113−
114−tests :: TestTransport -> IO [Test]
115−tests testtrans@TestTransport{..} = do
116− node1 <- newLocalNode testTransport initRemoteTable
117− return [
118− testGroup "Process Info" [
119− testCase "testLocalDeadProcessInfo"
120− (delayedAssertion
121− "expected dead process-info to be ProcessInfoNone"
122− node1 (Nothing) testLocalDeadProcessInfo)
123− , testCase "testLocalLiveProcessInfo"
124− (delayedAssertion
125− "expected process-info to be correctly populated"
126− node1 True testLocalLiveProcessInfo)
127− , testCase "testRemoveLiveProcessInfo"
128− (testRemoteLiveProcessInfo testtrans node1)
129− ] ]
distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hsdeleted−431
@@ -1,431 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module Control.Distributed.Process.Tests.Tracing (tests) where
4−
5−import Control.Distributed.Process.Tests.Internal.Utils
6−import Network.Transport.Test (TestTransport(..))
7−
8−import Control.Applicative ((<*))
9−import Control.Concurrent (threadDelay)
10−import Control.Concurrent.MVar
11− ( MVar
12− , newEmptyMVar
13− , newMVar
14− , putMVar
15− , takeMVar
16− )
17−import Control.Distributed.Process
18−import Control.Distributed.Process.Node
19−import Control.Distributed.Process.Debug
20−import Control.Distributed.Process.Management
21− ( MxEvent(..)
22− )
23−import qualified Control.Exception as IO (bracket)
24−import Data.List (isPrefixOf, isSuffixOf)
25−
26−#if ! MIN_VERSION_base(4,6,0)
27−import Prelude hiding (catch, log)
28−#else
29−import Prelude hiding ((<*))
30−#endif
31−
32−import Test.Framework
33− ( Test
34− , testGroup
35− )
36−import Test.Framework.Providers.HUnit (testCase)
37−import System.Environment (getEnvironment)
38−-- These are available in System.Environment only since base 4.7
39−import System.SetEnv (setEnv, unsetEnv)
40−
41−
42−testSpawnTracing :: TestResult Bool -> Process ()
43−testSpawnTracing result = do
44− setTraceFlags defaultTraceFlags {
45− traceSpawned = (Just TraceAll)
46− , traceDied = (Just TraceAll)
47− }
48−
49− evSpawned <- liftIO $ newEmptyMVar
50− evDied <- liftIO $ newEmptyMVar
51− tracer <- startTracer $ \ev -> do
52− case ev of
53− (MxSpawned p) -> liftIO $ putMVar evSpawned p
54− (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)
55− _ -> return ()
56−
57− (sp, rp) <- newChan
58− pid <- spawnLocal $ sendChan sp ()
59− () <- receiveChan rp
60−
61− tracedAlive <- liftIO $ takeMVar evSpawned
62− (tracedDead, tracedReason) <- liftIO $ takeMVar evDied
63−
64− mref <- monitor tracer
65− stopTracer -- this is asynchronous, so we need to wait...
66− receiveWait [
67− matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)
68− ((\_ -> return ()))
69− ]
70− setTraceFlags defaultTraceFlags
71− stash result (tracedAlive == pid &&
72− tracedDead == pid &&
73− tracedReason == DiedNormal)
74−
75−testTraceRecvExplicitPid :: TestResult Bool -> Process ()
76−testTraceRecvExplicitPid result = do
77− res <- liftIO $ newEmptyMVar
78− pid <- spawnLocal $ do
79− self <- getSelfPid
80− expect >>= (flip sendChan) self
81− withFlags defaultTraceFlags {
82− traceRecv = traceOnly [pid]
83− } $ do
84− withTracer
85− (\ev ->
86− case ev of
87− (MxReceived pid' _) -> stash res (pid == pid')
88− _ -> return ()) $ do
89− (sp, rp) <- newChan
90− send pid sp
91− p <- receiveChan rp
92− res' <- liftIO $ takeMVar res
93− stash result (res' && (p == pid))
94− return ()
95−
96−testTraceRecvNamedPid :: TestResult Bool -> Process ()
97−testTraceRecvNamedPid result = do
98− res <- liftIO $ newEmptyMVar
99− pid <- spawnLocal $ do
100− self <- getSelfPid
101− register "foobar" self
102− expect >>= (flip sendChan) self
103− withFlags defaultTraceFlags {
104− traceRecv = traceOnly ["foobar"]
105− } $ do
106− withTracer
107− (\ev ->
108− case ev of
109− (MxReceived pid' _) -> stash res (pid == pid')
110− _ -> return ()) $ do
111− (sp, rp) <- newChan
112− send pid sp
113− p <- receiveChan rp
114− res' <- liftIO $ takeMVar res
115− stash result (res' && (p == pid))
116− return ()
117−
118−testTraceSending :: TestResult Bool -> Process ()
119−testTraceSending result = do
120− pid <- spawnLocal $ (expect :: Process String) >> return ()
121− self <- getSelfPid
122− res <- liftIO $ newEmptyMVar
123− withFlags defaultTraceFlags { traceSend = traceOn } $ do
124− withTracer
125− (\ev ->
126− case ev of
127− (MxSent to from msg) -> do
128− mS <- unwrapMessage msg :: Process (Maybe String)
129− case mS of
130− (Just s) -> do stash res (to == pid && from == self && s == "hello there")
131− stash res (to == pid && from == self)
132− _ -> die "failed state invariant, message type unmatched..."
133− _ ->
134− return ()) $ do
135− send pid "hello there"
136− res' <- liftIO $ takeMVar res
137− stash result res'
138−
139−testTraceRegistration :: TestResult Bool -> Process ()
140−testTraceRegistration result = do
141− (sp, rp) <- newChan
142− pid <- spawnLocal $ do
143− self <- getSelfPid
144− () <- expect
145− register "foobar" self
146− sendChan sp ()
147− () <- expect
148− return ()
149− res <- liftIO $ newEmptyMVar
150− withFlags defaultTraceFlags { traceRegistered = traceOn } $ do
151− withTracer
152− (\ev ->
153− case ev of
154− MxRegistered p s ->
155− stash res (p == pid && s == "foobar")
156− _ ->
157− return ()) $ do
158− _ <- monitor pid
159− send pid ()
160− () <- receiveChan rp
161− send pid ()
162− receiveWait [
163− match (\(ProcessMonitorNotification _ _ _) -> return ())
164− ]
165− res' <- liftIO $ takeMVar res
166− stash result res'
167−
168−testTraceUnRegistration :: TestResult Bool -> Process ()
169−testTraceUnRegistration result = do
170− pid <- spawnLocal $ do
171− () <- expect
172− unregister "foobar"
173− () <- expect
174− return ()
175− register "foobar" pid
176− res <- liftIO $ newEmptyMVar
177− withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do
178− withTracer
179− (\ev ->
180− case ev of
181− MxUnRegistered p n -> do
182− stash res (p == pid && n == "foobar")
183− send pid ()
184− _ ->
185− return ()) $ do
186− mref <- monitor pid
187− send pid ()
188− receiveWait [
189− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
190− (\_ -> return ())
191− ]
192− res' <- liftIO $ takeMVar res
193− stash result res'
194−
195−testTraceLayering :: TestResult () -> Process ()
196−testTraceLayering result = do
197− pid <- spawnLocal $ do
198− getSelfPid >>= register "foobar"
199− () <- expect
200− traceMessage ("traceMsg", 123 :: Int)
201− return ()
202− withFlags defaultTraceFlags {
203− traceDied = traceOnly [pid]
204− , traceRecv = traceOnly ["foobar"]
205− } $ doTest pid result
206− return ()
207− where
208− doTest :: ProcessId -> MVar () -> Process ()
209− doTest pid result' = do
210− -- TODO: this is pretty gross, even for a test case
211− died <- liftIO $ newEmptyMVar
212− withTracer
213− (\ev ->
214− case ev of
215− MxProcessDied _ _ -> liftIO $ putMVar died ()
216− _ -> return ())
217− ( do {
218− recv <- liftIO $ newEmptyMVar
219− ; withTracer
220− (\ev' ->
221− case ev' of
222− MxReceived _ _ -> liftIO $ putMVar recv ()
223− _ -> return ())
224− ( do {
225− user <- liftIO $ newEmptyMVar
226− ; withTracer
227− (\ev'' ->
228− case ev'' of
229− MxUser _ -> liftIO $ putMVar user ()
230− _ -> return ())
231− (send pid () >> (liftIO $ takeMVar user))
232− ; liftIO $ takeMVar recv
233− })
234− ; liftIO $ takeMVar died
235− })
236− liftIO $ putMVar result' ()
237−
238−testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()
239−testRemoteTraceRelay TestTransport{..} result =
240− let flags = defaultTraceFlags { traceSpawned = traceOn }
241− in do
242− node2 <- liftIO $ newLocalNode testTransport initRemoteTable
243− mvNid <- liftIO $ newEmptyMVar
244−
245− -- As well as needing node2's NodeId, we want to
246− -- redirect all its logs back here, to avoid generating
247− -- garbage on stderr for the duration of the test run.
248− -- Here we set up that relay, and then wait for a signal
249− -- that the tracer (on node1) has seen the expected
250− -- MxSpawned message, at which point we're finished
251−
252− pid <- splinchLogger node2 mvNid
253− nid <- liftIO $ takeMVar mvNid
254− mref <- monitor pid
255− observedPid <- liftIO $ newEmptyMVar
256− spawnedPid <- liftIO $ newEmptyMVar
257− setTraceFlagsRemote flags nid
258−
259− withFlags defaultTraceFlags { traceSpawned = traceOn } $ do
260− withTracer
261− (\ev ->
262− case ev of
263− MxSpawned p -> stash observedPid p >> send pid ()
264− _ -> return ()) $ do
265− relayPid <- startTraceRelay nid
266− liftIO $ threadDelay 1000000
267− p <- liftIO $ forkProcess node2 $ do
268− expectTimeout 1000000 :: Process (Maybe ())
269− return ()
270− stash spawnedPid p
271−
272− -- Now we wait for (the outer) pid to exit. This won't happen until
273− -- our tracer has seen the trace event for `p' and sent `p' the
274− -- message it's waiting for prior to exiting
275− receiveWait [
276− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
277− (\_ -> return ())
278− ]
279−
280− relayRef <- monitor relayPid
281− kill relayPid "stop"
282− receiveWait [
283− matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)
284− (\_ -> return ())
285− ]
286− observed <- liftIO $ takeMVar observedPid
287− expected <- liftIO $ takeMVar spawnedPid
288− stash result (observed == expected)
289− -- and just to be polite...
290− liftIO $ closeLocalNode node2
291−
292− where
293− splinchLogger n2 mv = do
294− mLog <- whereis "logger"
295− case mLog of
296− Nothing -> die "no logger registered"
297− Just log' -> do liftIO $ forkProcess n2 $ do
298− logRelay <- spawnLocal $ relay log'
299− reregister "logger" logRelay
300− getSelfNode >>= stash mv >> (expect :: Process ())
301−
302−
303−-- | Sets the value of an environment variable while executing the given IO
304−-- computation and restores the preceeding value upon completion.
305−withEnv :: String -> String -> IO a -> IO a
306−withEnv var val =
307− IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)
308− (maybe (unsetEnv var) (setEnv var))
309− . const
310−
311−-- | Tests that one and only one interesting trace message is produced when a
312−-- given action is performed. A message is considered interesting when the given
313−-- function return @True@.
314−testSystemLoggerMsg :: TestTransport
315− -> Process a
316− -> (a -> String -> Bool)
317− -> IO ()
318−testSystemLoggerMsg t action interestingMessage =
319− withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $
320− withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do
321− n <- newLocalNode (testTransport t) initRemoteTable
322−
323− runProcess n $ do
324− self <- getSelfPid
325− reregister "trace.logger" self
326− a <- action
327− let interestingMessage' (_ :: String, msg) = interestingMessage a msg
328− -- Wait for the trace message.
329− receiveWait [ matchIf interestingMessage' $ const $ return () ]
330− -- Only one interesting message should arrive.
331− expectedTimeout <- receiveTimeout
332− 100000
333− [ matchIf interestingMessage' $ const $ return () ]
334− case expectedTimeout of
335− Nothing -> return ()
336− Just _ -> die "Unexpected message arrived..."
337−
338−
339−-- | Tests that one and only one trace message is produced when a message is
340−-- received.
341−testSystemLoggerMxReceive :: TestTransport -> IO ()
342−testSystemLoggerMxReceive t = testSystemLoggerMsg t
343− (getSelfPid >>= flip send ())
344− (\_ msg -> "MxReceived" `isPrefixOf` msg
345− -- discard traces of internal messages
346− && not (":: RegisterReply" `isSuffixOf` msg)
347− )
348−
349−-- | Tests that one and only one trace message is produced when a message is
350−-- sent.
351−testSystemLoggerMxSent :: TestTransport -> IO ()
352−testSystemLoggerMxSent t = testSystemLoggerMsg t
353− (getSelfPid >>= flip send ())
354− (const $ isPrefixOf "MxSent")
355−
356−-- | Tests that one and only one trace message is produced when a process dies.
357−testSystemLoggerMxProcessDied :: TestTransport -> IO ()
358−testSystemLoggerMxProcessDied t = testSystemLoggerMsg t
359− (spawnLocal $ return ())
360− (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)
361−
362−-- | Tests that one and only one trace message appears when a process spawns.
363−testSystemLoggerMxSpawned :: TestTransport -> IO ()
364−testSystemLoggerMxSpawned t = testSystemLoggerMsg t
365− (spawnLocal $ return ())
366− (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)
367−
368−-- | Tests that one and only one trace message appears when a process is
369−-- registered.
370−testSystemLoggerMxRegistered :: TestTransport -> IO ()
371−testSystemLoggerMxRegistered t = testSystemLoggerMsg t
372− (getSelfPid >>= register "a" >> getSelfPid)
373− (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")
374−
375−-- | Tests that one and only one trace message appears when a process is
376−-- unregistered.
377−testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
378−testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t
379− (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)
380− (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")
381−
382−tests :: TestTransport -> IO [Test]
383−tests testtrans@TestTransport{..} = do
384− node1 <- newLocalNode testTransport initRemoteTable
385− -- if we execute the test cases in parallel, the
386− -- various tracers will race with one another and
387− -- we'll get garbage results (or worse, deadlocks)
388− lock <- liftIO $ newMVar ()
389− return [
390− testGroup "Tracing" [
391− testCase "Spawn Tracing"
392− (synchronisedAssertion
393− "expected dead process-info to be ProcessInfoNone"
394− node1 True testSpawnTracing lock)
395− , testCase "Recv Tracing (Explicit Pid)"
396− (synchronisedAssertion
397− "expected a recv trace for the supplied pid"
398− node1 True testTraceRecvExplicitPid lock)
399− , testCase "Recv Tracing (Named Pid)"
400− (synchronisedAssertion
401− "expected a recv trace for the process registered as 'foobar'"
402− node1 True testTraceRecvNamedPid lock)
403− , testCase "Trace Send(er)"
404− (synchronisedAssertion
405− "expected a 'send' trace with the requisite fields set"
406− node1 True testTraceSending lock)
407− , testCase "Trace Registration"
408− (synchronisedAssertion
409− "expected a 'registered' trace"
410− node1 True testTraceRegistration lock)
411− , testCase "Trace Unregistration"
412− (synchronisedAssertion
413− "expected an 'unregistered' trace"
414− node1 True testTraceUnRegistration lock)
415− , testCase "Trace Layering"
416− (synchronisedAssertion
417− "expected blah"
418− node1 () testTraceLayering lock)
419− , testCase "Remote Trace Relay"
420− (synchronisedAssertion
421− "expected blah"
422− node1 True (testRemoteTraceRelay testtrans) lock)
423− , testGroup "SystemLoggerTracer"
424− [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans
425− , testCase "MxSent" $ testSystemLoggerMxSent testtrans
426− , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans
427− , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans
428− , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans
429− , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans
430− ]
431− ] ]
distributed-process-tests/src/Network/Transport/Test.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Network.Transport.Test where
2−
3−import qualified Network.Transport as NT
4−import Data.Typeable (Typeable)
5−
6−-- | Extra operations required of transports for the purposes of testing.
7−data TestTransport = TestTransport
8− { -- | The transport to use for testing.
9− testTransport :: NT.Transport
10− -- | IO action to perform to simulate losing a connection.
11− , testBreakConnection :: NT.EndPointAddress -> NT.EndPointAddress -> IO ()
12− } deriving (Typeable)
distributed-process-tests/tests/runInMemory.hsdeleted−30
@@ -1,30 +0,0 @@
1−-- Run tests using the TCP transport.
2−
3−module Main where
4−
5−import TEST_SUITE_MODULE (tests)
6−
7−import Network.Transport.Test (TestTransport(..))
8−import Network.Transport.InMemory
9−import Test.Framework (defaultMainWithArgs)
10−
11−import System.Environment (getArgs)
12−
13−main :: IO ()
14−main = do
15− (transport, internals) <- createTransportExposeInternals
16− ts <- tests TestTransport
17− { testTransport = transport
18− , testBreakConnection = \addr1 addr2 -> breakConnection internals addr1 addr2 "user error"
19− }
20− args <- getArgs
21− -- Tests are time sensitive. Running the tests concurrently can slow them
22− -- down enough that threads using threadDelay would wake up later than
23− -- expected, thus changing the order in which messages were expected.
24− -- Therefore we run the tests sequentially by passing "-j 1" to
25− -- test-framework. This does not solve the issue but makes it less likely.
26− --
27− -- The problem was first detected with
28− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'
29− -- in particular.
30− defaultMainWithArgs ts ("-j" : "1" : args)
distributed-process-tests/tests/runTCP.hsdeleted−47
@@ -1,47 +0,0 @@
1−-- Run tests using the TCP transport.
2−--
3−module Main where
4−
5−import TEST_SUITE_MODULE (tests)
6−
7−import Network.Transport.Test (TestTransport(..))
8−import Network.Socket (sClose)
9−import Network.Transport.TCP
10− ( createTransportExposeInternals
11− , TransportInternals(socketBetween)
12− , defaultTCPParameters
13− , defaultTCPAddr
14− , TCPParameters(..)
15− )
16−import Test.Framework (defaultMainWithArgs)
17−
18−import Control.Concurrent (threadDelay)
19−import Control.Exception (IOException, try)
20−import System.Environment (getArgs)
21−import System.IO
22−
23−main :: IO ()
24−main = do
25− hSetBuffering stdout LineBuffering
26− hSetBuffering stderr LineBuffering
27− Right (transport, internals) <-
28− createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")
29− defaultTCPParameters { transportConnectTimeout = Just 3000000 }
30− ts <- tests TestTransport
31− { testTransport = transport
32− , testBreakConnection = \addr1 addr2 -> do
33− esock <- try $ socketBetween internals addr1 addr2
34− either (\e -> const (return ()) (e :: IOException)) sClose esock
35− threadDelay 10000
36− }
37− args <- getArgs
38− -- Tests are time sensitive. Running the tests concurrently can slow them
39− -- down enough that threads using threadDelay would wake up later than
40− -- expected, thus changing the order in which messages were expected.
41− -- Therefore we run the tests sequentially by passing "-j 1" to
42− -- test-framework. This does not solve the issue but makes it less likely.
43− --
44− -- The problem was first detected with
45− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'
46− -- in particular.
47− defaultMainWithArgs ts ("-j" : "1" : args)
distributed-process.cabaldeleted−168
@@ -1,168 +0,0 @@
1−Name: distributed-process
2−Version: 0.7.4
3−Cabal-Version: >=1.8
4−Build-Type: Simple
5−License: BSD3
6−License-File: LICENSE
7−Copyright: Well-Typed LLP, Tweag I/O Limited
8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9−Maintainer: Tim Watson <watson.timothy@gmail.com>
10−Stability: experimental
11−Homepage: http://haskell-distributed.github.com/
12−Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues
13−Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell
14−Description: This is an implementation of Cloud Haskell, as described in
15− /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,
16− and Simon Peyton Jones
17− (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
18− although some of the details are different. The precise message
19− passing semantics are based on /A unified semantics for future Erlang/
20− by Hans Svensson, Lars-&#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-tests/LICENSE → distributed-process/LICENSErenamed+1−1
@@ -1,4 +1,4 @@
1−Copyright Well-Typed LLP, 2011-2012
1+Copyright Well-Typed LLP, 2011
22
33All rights reserved.
44
Setup.hs → distributed-process/Setup.hsrenamed

The content is the same.

distributed-process/distributed-process.cabalnew file+21
@@ -0,0 +1,21 @@
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.hsnew file+230
@@ -0,0 +1,230 @@
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.txtnew file+181
@@ -0,0 +1,181 @@
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.txtnew file+81
@@ -0,0 +1,81 @@
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.pngnew file

Binary file not shown.

doc/NetworkTCP.svgnew file+630
@@ -0,0 +1,630 @@
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.texdeleted−706
@@ -1,706 +0,0 @@
1−\documentclass{article}
2−\usepackage[margin=2.5cm]{geometry}
3−\usepackage{amsmath, amssymb, stmaryrd}
4−\usepackage{mathpazo, times}
5−\usepackage{float}
6−\usepackage{listings}
7−
8−\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
9−\newcommand{\sApp}[2]{{#1} {#2}}
10−\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
11−\newcommand{\sReturn}{\mathtt{return}}
12−\newcommand{\sThrow}[1]{\mathtt{throw} \; {#1}}
13−\newcommand{\sCatch}[2]{\mathtt{catch} \; {#1} \; {#2}}
14−
15−\newcommand{\sExpect}{\mathtt{expect}}
16−\newcommand{\sSend}{\mathtt{send}}
17−\newcommand{\sSpawn}{\mathtt{spawn}}
18−\newcommand{\sLink}{\mathtt{link}}
19−\newcommand{\sReconnect}{\mathtt{reconnect}}
20−\newcommand{\sNewChan}{\mathtt{newChan}}
21−\newcommand{\sSendChan}{\mathtt{sendChan}}
22−\newcommand{\sReceiveChan}{\mathtt{receiveChan}}
23−\newcommand{\sMonitor}{\mathtt{monitor}}
24−
25−\DeclareMathOperator{\sNodeOf}{node}
26−\DeclareMathOperator{\sProcessOf}{process}
27−
28−\newcommand{\sSpawned}{\mathtt{spawned}}
29−
30−\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}}
31−
32−\newcommand{\sPar}{\mathrel{\parallel}}
33−\newcommand{\sProc}[2]{{#1}_{#2}}
34−
35−\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
36−\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
37−\newcommand{\sCid}{\ensuremath{\mathit{cid}}}
38−
39−\newcommand{\sId}{\ensuremath{\mathit{id}}}
40−\newcommand{\sRef}{\ensuremath{\mathit{ref}}}
41−
42−\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
43−\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
44−\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle}
45−\newcommand{\sNodes}{\mathcal{N}}
46−\newcommand{\sQueue}{\mathcal{Q}}
47−\newcommand{\sProcesses}{\mathcal{P}}
48−\newcommand{\sBlacklist}{\mathcal{B}}
49−\newcommand{\sMonitors}{\mathcal{M}}
50−
51−\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
52−\newcommand{\sNothing}{\mathtt{Nothing}}
53−
54−\newcommand{\sCtxt}[1]{\mathbb{#1}}
55−
56−\newcommand{\sSenders}{\mathit{senders}}
57−
58−\newcommand{\OR}{\mathrel{|}}
59−\newcommand{\where}{\mathrel{|}}
60−
61−\floatstyle{boxed}
62−\restylefloat{figure}
63−
64−\lstset{basicstyle=\ttfamily\small}
65−
66−\begin{document}
67−
68−\title{Cloud Haskell Semantics (DRAFT)}
69−\author{Well-Typed LLP}
70−\date{\today}
71−
72−\maketitle
73−
74−\section{Introduction}
75−
76−Cloud Haskell brings Erlang-style concurrency to Haskell in the form of a
77−library.\footnote{\texttt{http://hackage.haskell.org/package/distributed-process}}
78−The original publication \cite{cloudhaskell} is a good introduction to Cloud
79−Haskell, and is accompanied by an ever-growing number of resouces, collected on
80−the Haskell
81−Wiki.\footnote{\texttt{http://www.haskell.org/haskellwiki/Cloud\_Haskell}} The
82−current document augments the original publication about Cloud Haskell by
83−giving a precise semantics to the Cloud Haskell primitives. It is meant as a
84−reference, not an introduction.
85−
86−The original Cloud Haskell paper stipulates that messages are ``asynchronous,
87−reliable, and buffered'', but does not describe how this can be achieved.
88−Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),
89−the reliability of message delivery comes from the reliability of the
90−underlying network protocol---up to a point.
91−
92−The problem is that the underlying network protocol is connection-oriented, but
93−Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a
94−reliable-ordered connection from $P$ to $Q$. Reliability of message delivery
95−now follows from reliability of the network protocol, until $P$ somehow gets
96−disconnected from $Q$. If $P$ now sends another message to $Q$, the
97−implementation cannot simply reconnect: after all, some messages that were sent
98−on the first connection might not have been delivered. This means that $P$
99−might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1,
100−m_3$.\footnote{Indeed, message passing in Erlang is ordered but unreliable for
101−the same reason \cite{erlang}.}
102−
103−One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and
104−remove messages from this buffer only when $Q$ acknowledges that it received
105−them. On a reconnect $P$ must ask which message $Q$ last received, and
106−retransmit the rest. This means that when $P$ gets disconnected from $Q$, it
107−must infinitely buffer all messages sent to $Q$ (until a connection is
108−reestablished). However, infinite buffering is too strong a requirement;
109−moreover, this is unsatisfactory because it means implementing a reliable
110−protocol on top of the underlying reliable network protocol. We would like a
111−different solution.
112−
113−Instead, Cloud Haskell does \emph{not} attempt to reconnect automatically, but
114−provides a $\sReconnect$ primitive which gives programmers the option of
115−reconnecting manually. This is an explicit acknowledgement from the programmer
116−that message loss might occur, and forces them to consider how such loss might
117−be dealt with.
118−
119−The semantics we present is based on \cite{unified}, which we will refer to the
120−as the ``Unified'' semantics. However, we will present the semantics in a more
121−``Haskell'' style following the semantics for STM \cite{stm}. It differs from
122−the Unified semantics in that
123−%
124−\begin{enumerate}
125−\item We introduce an explicit notion of \textit{reconnecting} (with potential
126−message loss)
127−\item We simplify the semantics: we ``flatten'' sets of nodes of processes as
128−sets of processes (but assume a mapping from process identifiers to node
129−identifiers), do not have per-process mailboxes (but only the system queue or
130−``ether'') and do not have an explicit concept of node controllers
131−\end{enumerate}
132−%
133−Our semantics differs from the STM semantics in that we pretend that the Cloud
134−Haskell \texttt{Process} monad is the top-level monad, and do not consider the
135−\texttt{IO} monad at all. Current imprecisions with respect to the ``real''
136−Cloud Haskell are
137−%
138−\begin{enumerate}
139−\item We ignore the issue of serializability, other than to say that the
140−semantics will get stuck when trying to send a non-serializable payload;
141−consequently, we do not formalize $\mathtt{static}$
142−\item We do not formalize all Cloud Haskell primitives (merging of ports,
143−``advanced messaging'', and others)
144−\item Some of the concepts that we do formalize are lower-level concepts; for
145−instance, the primitive $\sSpawn$ that we formalize is asynchronous (following
146−the Unified semantics); a synchronous construct can be derived.
147−\end{enumerate}
148−
149−\section{Preliminaries}
150−
151−Cloud Haskell Processes run on \emph{nodes}. Processes communicate by sending
152−messages to each other (directly or using typed channels). Processes can also
153−send messages to nodes (for instance, a request to spawn or monitor a process).
154−
155−We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and
156−$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively,
157−and representing process identifiers, node identifiers, and (typed) channel
158−identifiers. We assume the existence of total functions
159−%
160−\begin{equation*}
161−\begin{array}{r@{\;:\;}l}
162−\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\
163−\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId}
164−\end{array}
165−\end{equation*}
166−%
167−and define
168−$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$
169−and let $\sId$ range over $\mathtt{Identifier}$.
170−
171−We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process
172−ID $\sPid$. We will denote a set of processes as
173−%
174− $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$
175−%
176−A \emph{system}
177− $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$
178−is a tuple containing a set $\sProcesses$ of processes, a \emph{system
179−queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors
180−$\sMonitors$.
181−The set of monitors $\sMonitors$ is a set of tuples
182− $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$
183−which records that node \sNid{} knows that process $\sPid_\mathit{fr}$ is
184−monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor reference). The system
185−queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr},
186−\mathit{message})$ of messages that have been sent but not yet processed. The
187−blacklist records disconnections and is represented as a of pairs
188−$(\sId_\mathit{to}, \sId_\mathit{fr})$.
189−
190−\section{Semantics}
191−
192−We follow the STM semantics as closely as possible. The language is the same
193−except for the primitives considered, and we use the same concept of evaluation
194−contexts:
195−
196−\begin{equation*}
197−\begin{array}{llll}
198−\text{value} & V & ::= & \sId \OR
199− \sLam{x}{M} \OR
200− \sReturn \; M \OR
201− \sBind{M}{N} \OR
202− \sThrow{M} \OR \sCatch{M}{N} \OR \\
203− &&& \sExpect \OR
204− \sSend \; \sPid \; M \OR
205− \sSpawn \; \sNid \; M \OR
206− \sMonitor \; \sId
207−\\
208−\text{term} & M, N & ::= & x \OR
209− V \OR
210− \sApp{M}{N} \OR
211− \cdots \\
212−\\
213−\text{Evaluation} & \sCtxt{E} & ::= & [] \OR \sBind{\sCtxt{E}}{M} \OR \sCatch{\sCtxt{E}}{M} \\
214−\text{context} & \sCtxt{P}_\sPid & ::= & \sCtxt{E}[]_\sPid \sPar \sProcesses
215−\end{array}
216−\end{equation*}
217−%
218−Indeed, the ``administrative'' transitions are identical
219−(Figure~\ref{fig:administrative}).
220−
221−\begin{figure}
222−\small
223−\begin{equation*}
224−\frac{
225− \llbracket M \rrbracket = V \qquad
226− M \neq V
227−}{
228− M \rightarrow V
229−} \textsc{Eval}
230−\qquad
231−\frac{
232− M \rightarrow N
233−}{
234− \sSystem{\sCtxt{P}[M]_\sPid}
235− {\sQueue}
236− {\sBlacklist}
237− {\sMonitors}
238−\rightarrow
239− \sSystem{\sCtxt{P}[N]_\sPid}
240− {\sQueue}
241− {\sBlacklist}
242− {\sMonitors}
243−} \textsc{Admin}
244−\end{equation*}
245−%
246−\begin{equation*}
247−\begin{array}{r@{\;\rightarrow\;}ll@{\hspace{2em}}r@{\;\rightarrow\;}ll}
248−\sBind{\sReturn \; N}{M} & M \; N & \textsc{Bind} & \sCatch{(\sReturn \; M)}{N} & \sReturn \; M & \textsc{Catch}_1 \\
249−\sBind{\sThrow{N}}{M} & \sThrow{N} & \textsc{Throw} & \sCatch{(\sThrow M)}{N} & N \; M & \textsc{Catch}_2 \\
250−\end{array}
251−\end{equation*}
252−%
253−\caption{\label{fig:administrative}Administrative Transitions}
254−\end{figure}
255−
256−\subsection{Disconnect and Reconnect}
257−
258−Figure~\ref{fig:disconnect} gives the semantics for disconnecting and
259−reconnecting. Rule \textsc{Disconnect} models random network disconnect
260−between nodes $\sNid_1$ and $\sNid_2$. We assume that entire \emph{nodes} get
261−disconnected from each other, not individual processes. \emph{Reconnecting}
262−however is on a per connection basis (\textsc{Recon-Ex}). Connections to and
263−from node controllers can be implicitly reconnected ($\textsc{Recon-Im}_1$ and
264−$\textsc{Recon-Im}_2$).
265−
266−\begin{figure}
267−\small
268−\begin{equation*}
269−\frac{
270− \sNid_1 \neq \sNid_2
271−}{
272− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
273−\rightarrow
274− \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors}
275−} \textsc{Disconnect}
276−\end{equation*}
277−%
278−\begin{equation*}
279−\frac{
280−}{
281− \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
282− {\sQueue}
283− {\sBlacklist}
284− {\sMonitors}
285−\rightarrow
286− \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
287− {\sQueue}
288− {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})}
289− {\sMonitors}
290−} \textsc{Recon-Ex}
291−\end{equation*}
292−%
293−\begin{equation*}
294−\frac{
295−}{
296− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors}
297−\rightarrow
298− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
299−} \textsc{Recon-Im}_1
300−\qquad
301−\frac{
302−}{
303− \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors}
304−\rightarrow
305− \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}
306−} \textsc{Recon-Im}_2
307−\end{equation*}
308−%
309−where
310−%
311−\begin{equation*}
312−\overline{\sNid} \subset \mathtt{Identifier}
313− = \{ \sNid \} \cup
314− \{ \sPid \where \sNodeOf(\sPid) = \sNid \} \cup
315− \{ \sCid \where \sNodeOf(\sCid) = \sNid \}
316−\end{equation*}
317−\caption{\label{fig:disconnect}Disconnect and Reconnect}
318−\end{figure}
319−
320−\subsection{Communication}
321−
322−The semantics for the basic primitives are listed in Figure~\ref{fig:basic}.
323−Once a connection has been blacklisted, no further messages can be sent across
324−that connection (until an explicit or implicit reconnect).
325−
326−Message passing is ordered but only for a given sender and receiver; no
327−ordering guarantees exist between messages sent by different processes. For
328−that reason rules \textsc{Expect}, \textsc{ReceiveChan} and \textsc{Spawn-Exec}
329−choose the \emph{first} message of a \emph{randomly chosen} sender.
330−
331−Since the semantics is not type-driven, we represent typed channels simply as
332−an identifier with an annotation whether it is the send-end ($\sCid^s$) or the
333−receive end ($\sCid^r$) of the channel (rules \textsc{NewChan},
334−\textsc{SendChan} and \textsc{ReceiveChan}).
335−
336−Spawning finally is asynchronous. When process $P$ spawns process $Q$ on node
337−$\sNid$ (rule \textsc{Spawn-Async}) a message is sent to node $\sNid$ (which
338−may, of course, never arrive). When the remote node receives the message and
339−actually spawns $Q$ (rule \textsc{Spawn-Exec}) it sends a message back to $P$
340−with $Q$'s process ID. In Cloud Haskell this primitive is called
341−\texttt{spawnAsync}, and the Cloud Haskell \texttt{spawn} primitive is defined
342−in terms of \texttt{spawnAsync} (we do not consider the synchronous version in
343−this document).
344−
345−\begin{figure}
346−\small
347−\begin{equation*}
348−\frac{
349−}{
350− \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}}
351− {\sQueue}
352− {\sBlacklist}
353− {\sMonitors}
354−\rightarrow
355− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
356− {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)}
357− {\sBlacklist}
358− {\sMonitors}
359−} \textsc{Send}
360−\end{equation*}
361−%
362−\begin{equation*}
363−\frac{
364− \sId_{\mathit{fr}} \notin \sSenders(\sQueue)
365−}{
366− \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}}
367− {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'}
368− {\sBlacklist}
369− {\sMonitors}
370−\rightarrow
371− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}}
372− {\sQueue, \sQueue'}
373− {\sBlacklist}
374− {\sMonitors}
375−} \textsc{Expect}
376−\end{equation*}
377−%
378−\begin{equation*}
379−\frac{
380− \sCid \text{ fresh}
381−\qquad
382− \sProcessOf(\sCid) = \sPid
383−}{
384− \sSystem{\sCtxt{P}[\sNewChan]_\sPid}
385− {\sQueue}
386− {\sBlacklist}
387− {\sMonitors}
388−\rightarrow
389− \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid}
390− {\sQueue}
391− {\sBlacklist}
392− {\sMonitors}
393−} \textsc{NewChan}
394−\end{equation*}
395−
396−\begin{equation*}
397−\frac{
398−}{
399− \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}}
400− {\sQueue}
401− {\sBlacklist}
402− {\sMonitors}
403−\rightarrow
404− \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}}
405− {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)}
406− {\sBlacklist}
407− {\sMonitors}
408−} \textsc{SendChan}
409−\end{equation*}
410−
411−\begin{equation*}
412−\frac{
413− \sPid_{\mathit{fr}} \notin \sSenders(\sQueue)
414−}{
415− \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}}
416− {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'}
417− {\sBlacklist}
418− {\sMonitors}
419−\rightarrow
420− \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}}
421− {\sQueue, \sQueue'}
422− {\sBlacklist}
423− {\sMonitors}
424−} \textsc{ReceiveChan}
425−\end{equation*}
426−%
427−\begin{equation*}
428−\frac{
429− \sRef \text{ fresh}
430−}{
431− \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
432− {\sQueue}
433− {\sBlacklist}
434− {\sMonitors}
435−\rightarrow
436− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid}
437− {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)}
438− {\sBlacklist}
439− {\sMonitors}
440−} \textsc{Spawn-Async}
441−\end{equation*}
442−%
443−\begin{equation*}
444−\frac{
445− \sPid \notin \sSenders(\sQueue)
446−\qquad
447− \sPid' \text{ fresh}
448−\qquad
449− \sNodeOf(\sPid') = \sNid
450−}{
451− \sSystem{\sProcesses}
452− {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'}
453− {\sBlacklist}
454− {\sMonitors}
455−\rightarrow
456− \sSystem{\sProcesses \sPar M_{\sPid'}}
457− {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')}
458− {\sBlacklist}
459− {\sMonitors}
460−} \textsc{Spawn-Exec}
461−\end{equation*}
462−%
463−where
464−%
465−\begin{equation*}
466−\begin{array}{l@{\;=\;}l@{\hspace{3em}}l}
467− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
468−&
469− \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M)
470−&
471− \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist
472−\\
473− \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M)
474−&
475− \sQueue
476−&
477− \text{otherwise}
478−\end{array}
479−\end{equation*}
480−%
481−$(\sExtend{\sBlacklist})$ is only defined for serializable payloads.
482−\caption{\label{fig:basic}Basic Primitives}
483−\end{figure}
484−
485−\subsection{Monitoring}
486−
487−When process $P$ on node $\sNid_P$ wants to monitor process $Q$ on node
488−$\sNid_Q$ \emph{both} nodes must be notified. The local node it notified
489−immediately, and a message is sent to to the remote node (rules
490−\textsc{Mon-Loc} and \textsc{Mon-Rem}). As with all messages, the
491−message to the remote node might be lost. When $P$ is disconnected from $Q$ it
492−is the responsibility of $P$'s local node $\sNid_P$ to notify $P$
493−(\textsc{Mon-Dis}); when $Q$ terminates (\textsc{Mon-Ret}) or crashes
494−(\textsc{Mon-Throw}) it is the responsibility of the remote node $\sNid_Q$ to
495−notify $P$.
496−
497−\begin{figure}
498−\small
499−\begin{equation*}
500−\frac{
501− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
502−\qquad
503− \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to})
504−\qquad
505− \sRef \text{ fresh}
506−}{
507−\sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}}
508− {\sQueue}
509− {\sBlacklist}
510− {\sMonitors}
511−\rightarrow
512− \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}}
513− {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})}
514− {\sBlacklist}
515− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
516−} \textsc{Mon-Loc}
517−\end{equation*}
518−%
519−\begin{equation*}
520−\frac{
521− \sPid_\mathit{fr} \notin \sSenders(\sQueue)
522−}{
523− \sSystem{\sProcesses}
524− {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'}
525− {\sBlacklist}
526− {\sMonitors}
527−\rightarrow
528− \sSystem{\sProcesses}
529− {\sQueue, \sQueue'}
530− {\sBlacklist}
531− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)}
532−} \textsc{Mon-Rem}
533−\end{equation*}
534−%
535−\begin{equation*}
536−\frac{
537− \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr})
538−\qquad
539− (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist
540−}{
541− \sSystem{\sProcesses}
542− {\sQueue}
543− {\sBlacklist}
544− {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)}
545−\rightarrow
546− \sSystem{\sProcesses}
547− {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)}
548− {\sBlacklist}
549− {\sMonitors}
550−} \textsc{Mon-Dis}
551−\end{equation*}
552−%
553−\begin{equation*}
554−\frac{
555− \sNodeOf(\sPid) = \sNid
556−}{
557− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
558− {\sQueue}
559− {\sBlacklist}
560− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
561−\rightarrow
562− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
563− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{died} \; \sRef)}
564− {\sBlacklist}
565− {\sMonitors}
566−} \textsc{Mon-Ret}
567−\end{equation*}
568−%
569−\begin{equation*}
570−\frac{
571− \sNodeOf(\sPid) = \sNid
572−}{
573− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
574− {\sQueue}
575− {\sBlacklist}
576− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
577−\rightarrow
578− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
579− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{exc} \; \sRef \; M)}
580− {\sBlacklist}
581− {\sMonitors}
582−} \textsc{Mon-Throw}
583−\end{equation*}
584−%
585−\begin{equation*}
586−\frac{
587− \sNodeOf(\sPid) = \sNid
588−\qquad
589− \sPid \notin \sProcesses
590−}{
591− \sSystem{\sProcesses}
592− {\sQueue}
593− {\sBlacklist}
594− {\sMonitors, (\sPid, \sPid', \sNid, \sRef)}
595−\rightarrow
596− \sSystem{\sProcesses}
597− {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{unknown} \; \sRef)}
598− {\sBlacklist}
599− {\sMonitors}
600−} \textsc{Mon-Unknown}
601−\end{equation*}
602−%
603−\caption{Monitoring}
604−\end{figure}
605−
606−\subsection{Process Termination}
607−
608−The rules for normal and abnormal process termination are defined in
609−Figure~\ref{fig:termination}. When a process crashes it dies
610−silently, unless monitors are setup.
611−
612−\begin{figure}
613−\small
614−%
615−\begin{equation*}
616−\frac{
617− \sNodeOf(\sPid) = \sNid
618−\qquad
619− \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
620−}{
621− \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses}
622− {\sQueue}
623− {\sBlacklist}
624− {\sMonitors}
625−\rightarrow
626− \sSystem{\sProcesses}
627− {\sQueue}
628− {\sBlacklist}
629− {\sMonitors}
630−} \textsc{TermRet}
631−\end{equation*}
632−%
633−\begin{equation*}
634−\frac{
635− \sNodeOf(\sPid) = \sNid
636−\qquad
637− \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors
638−}{
639− \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses}
640− {\sQueue}
641− {\sBlacklist}
642− {\sMonitors}
643−\rightarrow
644− \sSystem{\sProcesses}
645− {\sQueue}
646− {\sBlacklist}
647− {\sMonitors}
648−} \textsc{TermThrow}
649−\end{equation*}
650−%
651−\caption{\label{fig:termination}Process Termination}
652−\end{figure}
653−
654−\section{Open Issues}
655−
656−\subsection{Ordering of Monitor/Link Notifications}
657−
658−The semantics as described above, like the original Unified semantics, does not
659−guarantee that messages send from process $P$ to process $Q$ (\textsc{Send})
660−are ordered with respect to the link or monitor notification sent when process
661−$P$ terminates normally or abnormally (\textsc{Mon-Ret}, \textsc{Mon-Throw}). This means that if process $P$ does
662−
663−\begin{lstlisting}
664−receiveWait [
665− match $ \(Reply reply) -> ...
666− , match $ \(ProcessMonitorNotification ..) -> ...
667− ]
668−\end{lstlisting}
669−
670−and process $Q$ does
671−
672−\begin{lstlisting}
673−send pidA (Reply reply)
674−// terminate or indeed throw an exception
675−\end{lstlisting}
676−
677−then the semantics does not guarantee that the reply from process $Q$ will
678−arrive at process $P$ before the monitor notification; hence, this results in
679−an (artificial) race condition in process $P$.
680−
681−One possible solution is to regard such a link notification as a message from
682−process $Q$ to process $P$, which should be ordered along with the other
683−messages.
684−
685−\subsection{Ordering and Typed Channels}
686−
687−The situation is more tricky still than sketched above because we of typed
688−channels. The semantics does not provide ordering guarantees between messages
689−sent directly to the process and messages sent on typed channels. That means
690−that even if we consider a link or monitor notification as a message sent to
691−the process, to be ordered with other messages sent to that process, it is
692−still unordered with respect to messages sent on typed channels. This means
693−that we have similar race conditions\footnote{Even ignoring the fact that we
694−currently don't even provide a way to wait for a message on a typed channel
695−\emph{or} a direct message.}
696−
697−A possible solution is to insist that \emph{all} messages from process $P$ to
698−process $Q$ are ordered, no matter how they are sent. From a implementation
699−point of view, this would entail the use of a single ordered network connection
700−for all messages from $P$ to $Q$, rather than using an ordered connection per
701−typed channel plus one for direct messages.
702−
703−\bibliographystyle{apalike}
704−\bibliography{references}
705−
706−\end{document}
doc/semantics/Makefiledeleted−11
@@ -1,11 +0,0 @@
1−CloudHaskellSemantics.pdf: *.tex *.bib
2− pdflatex CloudHaskellSemantics
3− bibtex CloudHaskellSemantics
4− pdflatex CloudHaskellSemantics
5− pdflatex CloudHaskellSemantics
6−
7−.PHONY: clean
8−clean:
9− rm -f *.aux *.bbl *.blg *.log
10−
11−# vi:set noexpandtab:
doc/semantics/references.bibdeleted−72
@@ -1,72 +0,0 @@
1−@inproceedings{cloudhaskell,
2− author = {Epstein, Jeff and Black, Andrew P. and Peyton-Jones, Simon},
3− title = {Towards {H}askell in the cloud},
4− booktitle = {Proceedings of the 4th ACM symposium on Haskell},
5− series = {Haskell '11},
6− year = {2011},
7− isbn = {978-1-4503-0860-1},
8− location = {Tokyo, Japan},
9− pages = {118--129},
10− numpages = {12},
11− url = {http://doi.acm.org/10.1145/2034675.2034690},
12− doi = {10.1145/2034675.2034690},
13− acmid = {2034690},
14− publisher = {ACM},
15− address = {New York, NY, USA},
16− keywords = {erlang, haskell, message-passing},
17−}
18−
19−@inproceedings{unified,
20− author = {Svensson, Hans and Fredlund, Lars-{\AA}ke and Benac Earle, Clara},
21− title = {A unified semantics for future {E}rlang},
22− booktitle = {Proceedings of the 9th ACM SIGPLAN workshop on Erlang},
23− series = {Erlang '10},
24− year = {2010},
25− isbn = {978-1-4503-0253-1},
26− location = {Baltimore, Maryland, USA},
27− pages = {23--32},
28− numpages = {10},
29− url = {http://doi.acm.org/10.1145/1863509.1863514},
30− doi = {10.1145/1863509.1863514},
31− acmid = {1863514},
32− publisher = {ACM},
33− address = {New York, NY, USA},
34− keywords = {erlang, semantics},
35−}
36−
37−@article{stm,
38− author = {Harris, Tim and Marlow, Simon and Jones, Simon Peyton and Herlihy, Maurice},
39− title = {Composable memory transactions},
40− journal = {Commun. ACM},
41− issue_date = {August 2008},
42− volume = {51},
43− number = {8},
44− month = aug,
45− year = {2008},
46− issn = {0001-0782},
47− pages = {91--100},
48− numpages = {10},
49− url = {http://doi.acm.org/10.1145/1378704.1378725},
50− doi = {10.1145/1378704.1378725},
51− acmid = {1378725},
52− publisher = {ACM},
53− address = {New York, NY, USA},
54−}
55−
56−@inproceedings{erlang,
57− author = {Svensson, Hans and Fredlund, Lars-\AAke},
58− title = {A more accurate semantics for distributed erlang},
59− booktitle = {Proceedings of the 2007 SIGPLAN workshop on ERLANG Workshop},
60− series = {ERLANG '07},
61− year = {2007},
62− isbn = {978-1-59593-675-2},
63− location = {Freiburg, Germany},
64− pages = {43--54},
65− numpages = {12},
66− url = {http://doi.acm.org/10.1145/1292520.1292528},
67− doi = {10.1145/1292520.1292528},
68− acmid = {1292528},
69− publisher = {ACM},
70− address = {New York, NY, USA},
71− keywords = {distributed systems, erlang, model checking, semantics, verification},
72−}
doc/tutorial/tutorial-client.hsnew file+20
@@ -0,0 +1,20 @@
1+import Network.Transport
2+import Network.Transport.TCP (createTransport)
3+import System.Environment
4+import Control.Monad
5+import Data.ByteString.Char8
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.hsnew file+52
@@ -0,0 +1,52 @@
1+import Network.Transport
2+import Network.Transport.TCP (createTransport)
3+import Control.Concurrent
4+import Data.Map
5+import Control.Exception
6+import System.Environment
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/.gitignorenew file+1
@@ -0,0 +1 @@
1+*.exe
examples/DemoProcess.hsnew file+36
@@ -0,0 +1,36 @@
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.hsnew file+113
@@ -0,0 +1,113 @@
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.hsnew file+192
@@ -0,0 +1,192 @@
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/Makefilenew file+20
@@ -0,0 +1,20 @@
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.shnew file+18
@@ -0,0 +1,18 @@
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 $*
LICENSE → network-transport-pipes/LICENSErenamed+1−2
@@ -1,5 +1,4 @@
1−Copyright Well-Typed LLP, 2011-2012
2−Copyright Tweag I/O Limited, 2015
1+Copyright Ryan Newton, 2011
32
43All rights reserved.
54
network-transport-pipes/network-transport-pipes.cabalnew file+33
@@ -0,0 +1,33 @@
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.hsnew file+264
@@ -0,0 +1,264 @@
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/LICENSEnew file+31
@@ -0,0 +1,31 @@
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+
distributed-process-tests/Setup.hs → network-transport/Setup.hsrenamed

The content is the same.

network-transport/network-transport.cabalnew file+71
@@ -0,0 +1,71 @@
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.hsnew file+198
@@ -0,0 +1,198 @@
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.hsnew file+150
@@ -0,0 +1,150 @@
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.hsnew file+93
@@ -0,0 +1,93 @@
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.hsnew file+102
@@ -0,0 +1,102 @@
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.hsnew file+1138
@@ -0,0 +1,1138 @@
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.hsnew file+24
@@ -0,0 +1,24 @@
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.hsnew file+82
@@ -0,0 +1,82 @@
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.hsnew file+8
@@ -0,0 +1,8 @@
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.hsnew file+72
@@ -0,0 +1,72 @@
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.hsnew file+7
@@ -0,0 +1,7 @@
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.hsnew file+487
@@ -0,0 +1,487 @@
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.hsnew file+734
@@ -0,0 +1,734 @@
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.hsnew file+191
@@ -0,0 +1,191 @@
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.hsnew file+107
@@ -0,0 +1,107 @@
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.hsnew file+28
@@ -0,0 +1,28 @@
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.hsnew file+44
@@ -0,0 +1,44 @@
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.hsnew file+52
@@ -0,0 +1,52 @@
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.shnew file+20
@@ -0,0 +1,20 @@
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.hsdeleted−447
@@ -1,447 +0,0 @@
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.hsdeleted−244
@@ -1,244 +0,0 @@
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.hsdeleted−288
@@ -1,288 +0,0 @@
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.hsdeleted−135
@@ -1,135 +0,0 @@
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.hsdeleted−300
@@ -1,300 +0,0 @@
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.hsdeleted−320
@@ -1,320 +0,0 @@
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.hsdeleted−147
@@ -1,147 +0,0 @@
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.hsdeleted−330
@@ -1,330 +0,0 @@
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.hsdeleted−207
@@ -1,207 +0,0 @@
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.hsdeleted−1363
@@ -1,1363 +0,0 @@
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.hsdeleted−165
@@ -1,165 +0,0 @@
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.hsdeleted−21
@@ -1,21 +0,0 @@
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.hsdeleted−27
@@ -1,27 +0,0 @@
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.hsdeleted−93
@@ -1,93 +0,0 @@
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.hsdeleted−887
@@ -1,887 +0,0 @@
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.hsdeleted−107
@@ -1,107 +0,0 @@
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.hsdeleted−509
@@ -1,509 +0,0 @@
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.hsdeleted−157
@@ -1,157 +0,0 @@
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.hsdeleted−21
@@ -1,21 +0,0 @@
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.hsdeleted−179
@@ -1,179 +0,0 @@
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.hsdeleted−61
@@ -1,61 +0,0 @@
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.hsdeleted−354

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Types.hsdeleted−159

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Types.hsdeleted−141

This diff is too big to show here.

src/Control/Distributed/Process/Node.hsdeleted−1304

This diff is too big to show here.

src/Control/Distributed/Process/Serializable.hsdeleted−73

This diff is too big to show here.

src/Control/Distributed/Process/UnsafePrimitives.hsdeleted−200

This diff is too big to show here.

stack-ghc-7.10.3.yamldeleted−21

This diff is too big to show here.

stack-ghc-8.0.2.yamldeleted−23

This diff is too big to show here.

stack-ghc-8.2.2.yamldeleted−21

This diff is too big to show here.

stack-ghc-8.4.4.yamldeleted−20

This diff is too big to show here.

stack-nightly.yamldeleted−26

This diff is too big to show here.

stack.yamldeleted−22

This diff is too big to show here.