git.iko.soy/distributed-process
on 9c7ff1e help sign in
660d554
swap
0 ahead, 870 behind
.gitignore+11−3
since splitsnapshots
unifiedsplit
@@ -1,4 +1,12 @@
1+tags
2+TAGS
1dist/
3dist/
2−.cabal-sandbox
4+\#*#
3−cabal.sandbox.config
5+*~
4−.stack*
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
1+Haskell Distributed Project
2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)
2+===========================
3−[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)
4
3
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.
6
6
7−See http://haskell-distributed.github.com for documentation, user guides,
7+At present, this repository hosts two packages:
8−tutorials and assistance.
9
8
10−## Getting Help / Raising Issues
9+* distributed-process
10+* network-transport
11
11
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].
13
14
14−## License
15+Examples
16+--------
15
17
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
21+import Network.Transport.TCP
22+
23+main :: IO ()
24+main = do
25+ [pingsStr] <- getArgs
26+ serverAddr <- newEmptyMVar
27+ clientAddr <- newEmptyMVar
28+ clientDone <- newEmptyMVar
29+
30+ -- Start the server
31+ forkIO $ do
32+ -- establish transport and endpoint
33+ putStrLn "server: creating TCP connection"
34+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35+ Right endpoint <- newEndPoint transport
36+ putMVar serverAddr (address endpoint)
37+
38+ -- Connect to the client so that we can reply
39+ theirAddr <- takeMVar clientAddr
40+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
41+
42+ -- reply to pings with pongs
43+ putStrLn "server: awaiting client connection"
44+ ConnectionOpened _ _ _ <- receive endpoint
45+ pong endpoint conn
46+
47+ -- Start the client
48+ forkIO $ do
49+ let pings = read pingsStr
50+
51+ -- establish transport and endpoint
52+ Right transport <- createTransport "127.0.0.1" "8081" defaultTCPParameters
53+ Right endpoint <- newEndPoint transport
54+ putMVar clientAddr (address endpoint)
55+
56+ -- Connect to the server to send pings
57+ theirAddr <- takeMVar serverAddr
58+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
59+
60+ -- Send pings, waiting for a reply after every ping
61+ ConnectionOpened _ _ _ <- receive endpoint
62+ ping endpoint conn pings
63+ putMVar clientDone ()
64+
65+ -- Wait for the client to finish
66+ takeMVar clientDone
67+
68+pingMessage :: [ByteString]
69+pingMessage = [pack "ping123"]
70+
71+ping :: EndPoint -> Connection -> Int -> IO ()
72+ping endpoint conn pings = go pings
73+ where
74+ go :: Int -> IO ()
75+ go 0 = do
76+ putStrLn $ "client did " ++ show pings ++ " pings"
77+ go !i = do
78+ before <- getCurrentTime
79+ send conn pingMessage
80+ Received _ _payload <- receive endpoint
81+ after <- getCurrentTime
82+ -- putStrLn $ "client received " ++ show _payload
83+ let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
84+ hPutStrLn stderr $ show i ++ " " ++ show latency
85+ go (i - 1)
86+
87+pong :: EndPoint -> Connection -> IO ()
88+pong endpoint conn = go
89+ where
90+ go = do
91+ msg <- receive endpoint
92+ case msg of
93+ Received _ payload -> send conn payload >> go
94+ ConnectionClosed _ -> return ()
95+ _ -> fail "Unexpected message"
benchmarks/JustPingTwoSocketPairs.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+52
@@ -0,0 +1,52 @@
1+# The "Just Ping" tests measure ping latency with as little overhead as possible
2+
3+NUMPINGS=100000
4+INCLUDES=-i../network-transport/src -i../network-transport-pipes/src
5+
6+# Enable for profiling
7+# PROF_GHC=-prof -fprof-auto
8+# PROF_EXE=+RTS -pa -RTS
9+
10+GCC=gcc -std=c99
11+GHC=ghc -rtsopts -XRankNTypes -XScopedTypeVariables -XDeriveDataTypeable
12+
13+NewTransport.ps: JustPingHaskell.data \
14+ JustPingTransport.data
15+ gnuplot ./NewTransport.gnuplot
16+
17+Indirection.ps: JustPingWithHeader.data \
18+ JustPingThroughChan.data \
19+ JustPingThroughMVar.data \
20+ JustPingTwoSocketPairs.data \
21+ JustPingTwoSocketPairsND.data \
22+ JustPingTransport.data
23+ gnuplot ./Indirection.gnuplot
24+
25+Headers.ps: JustPingC.data \
26+ JustPingHaskellNT.data \
27+ JustPingHaskell.data \
28+ JustPingWithHeader.data \
29+ JustPingOneRecv.data \
30+ JustPingCacheHeader.data
31+ gnuplot ./Headers.gnuplot
32+
33+JustPingC.exe: JustPingC.c
34+ $(GCC) -O2 -o JustPingC.exe JustPingC.c
35+
36+JustPingHaskellNT.exe: JustPingHaskell.hs
37+ $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs
38+
39+JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe
40+ time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@
41+
42+%.data : %.exe
43+ time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@
44+
45+%.exe :: %.hs
46+ $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES)
47+
48+.PHONY: clean
49+clean:
50+ rm -f *.data *.ps *.pdf *.o *.hi *.exe
51+
52+# vi:set noexpandtab:
benchmarks/NewTransport.gnuplotnew file+8
@@ -0,0 +1,8 @@
1+set title "Roundtrip (us)"
2+set yrange [0:150]
3+plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
4+ "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
5+set terminal postscript color
6+set output "NewTransport.ps"
7+plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
8+ "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
benchmarks/PingPipes.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-simplelocalnet/ChangeLognew file+7
@@ -0,0 +1,7 @@
1+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
2+
3+* Bugfix: Documentation referred to old module name
4+
5+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
6+
7+* Initial release.
distributed-process-tests/LICENSE → distributed-process-simplelocalnet/LICENSErenamed

The content is the same.

Setup.hs → distributed-process-simplelocalnet/Setup.hsrenamed

The content is the same.

distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabalnew file+63
@@ -0,0 +1,63 @@
1+Name: distributed-process-simplelocalnet
2+Version: 0.2.0.1
3+Cabal-Version: >=1.8
4+Build-Type: Simple
5+License: BSD3
6+License-File: LICENSE
7+Copyright: Well-Typed LLP
8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10+Stability: experimental
11+Homepage: http://github.com/haskell-distributed/distributed-process
12+Bug-Reports: mailto:edsko@well-typed.com
13+Synopsis: Simple zero-configuration backend for Cloud Haskell
14+Description: Simple backend based on the TCP transport which offers node
15+ discovery based on UDP multicast. This is a zero-configuration
16+ backend designed to get you going with Cloud Haskell quickly
17+ without imposing any structure on your application.
18+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
19+Category: Control
20+
21+Source-Repository head
22+ Type: git
23+ Location: https://github.com/haskell-distributed/distributed-process
24+ SubDir: distributed-process-simplelocalnet
25+
26+Library
27+ Build-Depends: base >= 4.4 && < 5,
28+ bytestring >= 0.9 && < 0.10,
29+ network >= 2.3 && < 2.4,
30+ network-multicast >= 0.0 && < 0.1,
31+ data-accessor >= 0.2 && < 0.3,
32+ binary >= 0.5 && < 0.6,
33+ containers >= 0.4 && < 0.5,
34+ transformers >= 0.2 && < 0.4,
35+ network-transport >= 0.2 && < 0.3,
36+ network-transport-tcp >= 0.2 && < 0.3,
37+ distributed-process >= 0.2 && < 0.3
38+ Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet,
39+ Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast
40+ Extensions: RankNTypes,
41+ DeriveDataTypeable
42+ ghc-options: -Wall
43+ HS-Source-Dirs: src
44+
45+-- Not a proper test, but we want to use cabal to compile it
46+Test-Suite TestSimpleLocalnet
47+ Type: exitcode-stdio-1.0
48+ Main-Is: TestSimpleLocalnet.hs
49+ Build-Depends: base >= 4.4 && < 5,
50+ bytestring >= 0.9 && < 0.10,
51+ network >= 2.3 && < 2.4,
52+ network-multicast >= 0.0 && < 0.1,
53+ data-accessor >= 0.2 && < 0.3,
54+ binary >= 0.5 && < 0.6,
55+ containers >= 0.4 && < 0.5,
56+ transformers >= 0.2 && < 0.4,
57+ network-transport >= 0.2 && < 0.3,
58+ network-transport-tcp >= 0.2 && < 0.3,
59+ distributed-process >= 0.2 && < 0.3
60+ Extensions: RankNTypes,
61+ DeriveDataTypeable
62+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
63+ HS-Source-Dirs: tests src
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hsnew file+291
@@ -0,0 +1,291 @@
1+-- | Simple backend based on the TCP transport which offers node discovery
2+-- based on UDP multicast. This is a zero-configuration backend designed to
3+-- get you going with Cloud Haskell quickly without imposing any structure
4+-- on your application.
5+--
6+-- To simplify getting started we provide special support for /master/ and
7+-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions
8+-- is completely optional; you can use the local backend without making use
9+-- of the predefined master and slave nodes.
10+--
11+-- [Minimal example]
12+--
13+-- > import System.Environment (getArgs)
14+-- > import Control.Distributed.Process
15+-- > import Control.Distributed.Process.Node (initRemoteTable)
16+-- > import Control.Distributed.Process.Backend.SimpleLocalnet
17+-- >
18+-- > master :: Backend -> [NodeId] -> Process ()
19+-- > master backend slaves = do
20+-- > -- Do something interesting with the slaves
21+-- > liftIO . putStrLn $ "Slaves: " ++ show slaves
22+-- > -- Terminate the slaves when the master terminates (this is optional)
23+-- > terminateAllSlaves backend
24+-- >
25+-- > main :: IO ()
26+-- > main = do
27+-- > args <- getArgs
28+-- >
29+-- > case args of
30+-- > ["master", host, port] -> do
31+-- > backend <- initializeBackend host port initRemoteTable
32+-- > startMaster backend (master backend)
33+-- > ["slave", host, port] -> do
34+-- > backend <- initializeBackend host port initRemoteTable
35+-- > startSlave backend
36+{-# OPTIONS_GHC -fno-warn-orphans #-}
37+module Control.Distributed.Process.Backend.SimpleLocalnet
38+ ( -- * Initialization
39+ Backend(..)
40+ , initializeBackend
41+ -- * Slave nodes
42+ , startSlave
43+ , terminateSlave
44+ , findSlaves
45+ , terminateAllSlaves
46+ -- * Master nodes
47+ , startMaster
48+ ) where
49+
50+import System.IO (fixIO)
51+import Data.Maybe (catMaybes)
52+import Data.Binary (Binary(get, put), getWord8, putWord8)
53+import Data.Accessor (Accessor, accessor, (^:), (^.))
54+import Data.Set (Set)
55+import qualified Data.Set as Set (insert, empty, toList)
56+import Data.Foldable (forM_)
57+import Data.Typeable (Typeable)
58+import Control.Applicative ((<$>))
59+import Control.Exception (throw)
60+import Control.Monad (forever, forM)
61+import Control.Monad.IO.Class (liftIO)
62+import Control.Concurrent (forkIO, threadDelay, ThreadId)
63+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
64+import Control.Distributed.Process
65+ ( RemoteTable
66+ , NodeId
67+ , Process
68+ , WhereIsReply(..)
69+ , whereis
70+ , whereisRemoteAsync
71+ , registerRemote
72+ , getSelfPid
73+ , register
74+ , expect
75+ , nsendRemote
76+ , receiveWait
77+ , matchIf
78+ , processNodeId
79+ )
80+import qualified Control.Distributed.Process.Node as Node
81+ ( LocalNode
82+ , newLocalNode
83+ , localNodeId
84+ , runProcess
85+ )
86+import qualified Network.Transport.TCP as NT
87+ ( createTransport
88+ , defaultTCPParameters
89+ )
90+import qualified Network.Transport as NT (Transport)
91+import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
92+import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)
93+
94+-- | Local backend
95+data Backend = Backend {
96+ -- | Create a new local node
97+ newLocalNode :: IO Node.LocalNode
98+ -- | @findPeers t@ sends out a /who's there?/ request, waits 't' msec,
99+ -- and then collects and returns the answers
100+ , findPeers :: Int -> IO [NodeId]
101+ -- | Make sure that all log messages are printed by the logger on the
102+ -- current node
103+ , redirectLogsHere :: Process ()
104+ }
105+
106+data BackendState = BackendState {
107+ _localNodes :: [Node.LocalNode]
108+ , _peers :: Set NodeId
109+ , discoveryDaemon :: ThreadId
110+ }
111+
112+-- | Initialize the backend
113+initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend
114+initializeBackend host port rtable = do
115+ mTransport <- NT.createTransport host port NT.defaultTCPParameters
116+ (recv, send) <- initMulticast "224.0.0.99" 9999 1024
117+ (_, backendState) <- fixIO $ \ ~(tid, _) -> do
118+ backendState <- newMVar BackendState
119+ { _localNodes = []
120+ , _peers = Set.empty
121+ , discoveryDaemon = tid
122+ }
123+ tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
124+ return (tid', backendState)
125+ case mTransport of
126+ Left err -> throw err
127+ Right transport ->
128+ let backend = Backend {
129+ newLocalNode = apiNewLocalNode transport rtable backendState
130+ , findPeers = apiFindPeers send backendState
131+ , redirectLogsHere = apiRedirectLogsHere backend
132+ }
133+ in return backend
134+
135+-- | Create a new local node
136+apiNewLocalNode :: NT.Transport
137+ -> RemoteTable
138+ -> MVar BackendState
139+ -> IO Node.LocalNode
140+apiNewLocalNode transport rtable backendState = do
141+ localNode <- Node.newLocalNode transport rtable
142+ modifyMVar_ backendState $ return . (localNodes ^: (localNode :))
143+ return localNode
144+
145+-- | Peer discovery
146+apiFindPeers :: (PeerDiscoveryMsg -> IO ())
147+ -> MVar BackendState
148+ -> Int
149+ -> IO [NodeId]
150+apiFindPeers send backendState delay = do
151+ send PeerDiscoveryRequest
152+ threadDelay delay
153+ Set.toList . (^. peers) <$> readMVar backendState
154+
155+data PeerDiscoveryMsg =
156+ PeerDiscoveryRequest
157+ | PeerDiscoveryReply NodeId
158+
159+instance Binary PeerDiscoveryMsg where
160+ put PeerDiscoveryRequest = putWord8 0
161+ put (PeerDiscoveryReply nid) = putWord8 1 >> put nid
162+ get = do
163+ header <- getWord8
164+ case header of
165+ 0 -> return PeerDiscoveryRequest
166+ 1 -> PeerDiscoveryReply <$> get
167+ _ -> fail "PeerDiscoveryMsg.get: invalid"
168+
169+-- | Respond to peer discovery requests sent by other nodes
170+peerDiscoveryDaemon :: MVar BackendState
171+ -> IO (PeerDiscoveryMsg, N.SockAddr)
172+ -> (PeerDiscoveryMsg -> IO ())
173+ -> IO ()
174+peerDiscoveryDaemon backendState recv send = forever go
175+ where
176+ go = do
177+ (msg, _) <- recv
178+ case msg of
179+ PeerDiscoveryRequest -> do
180+ nodes <- (^. localNodes) <$> readMVar backendState
181+ forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
182+ PeerDiscoveryReply nid ->
183+ modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
184+
185+--------------------------------------------------------------------------------
186+-- Back-end specific primitives --
187+--------------------------------------------------------------------------------
188+
189+-- | Make sure that all log messages are printed by the logger on this node
190+apiRedirectLogsHere :: Backend -> Process ()
191+apiRedirectLogsHere backend = do
192+ mLogger <- whereis "logger"
193+ forM_ mLogger $ \logger -> do
194+ nids <- liftIO $ findPeers backend 1000000
195+ forM_ nids $ \nid -> registerRemote nid "logger" logger
196+
197+--------------------------------------------------------------------------------
198+-- Slaves --
199+--------------------------------------------------------------------------------
200+
201+-- | Messages to slave nodes
202+--
203+-- This datatype is not exposed; instead, we expose primitives for dealing
204+-- with slaves.
205+data SlaveControllerMsg =
206+ SlaveTerminate
207+ deriving (Typeable, Show)
208+
209+instance Binary SlaveControllerMsg where
210+ put SlaveTerminate = putWord8 0
211+ get = do
212+ header <- getWord8
213+ case header of
214+ 0 -> return SlaveTerminate
215+ _ -> fail "SlaveControllerMsg.get: invalid"
216+
217+-- | Calling 'slave' sets up a new local node and then waits. You start
218+-- processes on the slave by calling 'spawn' from other nodes.
219+--
220+-- This function does not return. The only way to exit the slave is to CTRL-C
221+-- the process or call terminateSlave from another node.
222+startSlave :: Backend -> IO ()
223+startSlave backend = do
224+ node <- newLocalNode backend
225+ Node.runProcess node slaveController
226+
227+-- | The slave controller interprets 'SlaveControllerMsg's
228+slaveController :: Process ()
229+slaveController = do
230+ pid <- getSelfPid
231+ register "slaveController" pid
232+ go
233+ where
234+ go = do
235+ msg <- expect
236+ case msg of
237+ SlaveTerminate -> return ()
238+
239+-- | Terminate the slave at the given node ID
240+terminateSlave :: NodeId -> Process ()
241+terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate
242+
243+-- | Find slave nodes
244+findSlaves :: Backend -> Process [NodeId]
245+findSlaves backend = do
246+ nodes <- liftIO $ findPeers backend 1000000
247+ -- Fire of asynchronous requests for the slave controller
248+ forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController"
249+ -- Wait for the replies
250+ catMaybes <$> forM nodes (\_ ->
251+ receiveWait
252+ [ matchIf (\(WhereIsReply label _) -> label == "slaveController")
253+ (\(WhereIsReply _ mPid) -> return (processNodeId <$> mPid))
254+ ])
255+
256+-- | Terminate all slaves
257+terminateAllSlaves :: Backend -> Process ()
258+terminateAllSlaves backend = do
259+ slaves <- findSlaves backend
260+ forM_ slaves terminateSlave
261+ liftIO $ threadDelay 1000000
262+
263+--------------------------------------------------------------------------------
264+-- Master nodes
265+--------------------------------------------------------------------------------
266+
267+-- | 'startMaster' finds all slaves currently available on the local network
268+-- (which should therefore be started first), redirects all log messages to
269+-- itself, and then calls the specified process, passing the list of slaves
270+-- nodes.
271+--
272+-- Terminates when the specified process terminates. If you want to terminate
273+-- the slaves when the master terminates, you should manually call
274+-- 'terminateAllSlaves'.
275+startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()
276+startMaster backend proc = do
277+ node <- newLocalNode backend
278+ Node.runProcess node $ do
279+ slaves <- findSlaves backend
280+ redirectLogsHere backend
281+ proc slaves
282+
283+--------------------------------------------------------------------------------
284+-- Accessors --
285+--------------------------------------------------------------------------------
286+
287+localNodes :: Accessor BackendState [Node.LocalNode]
288+localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })
289+
290+peers :: Accessor BackendState (Set NodeId)
291+peers = accessor _peers (\ps st -> st { _peers = ps })
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hsnew file+126
@@ -0,0 +1,126 @@
1+-- | Multicast utilities
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) where
4+
5+import Data.Function (on)
6+import Data.Map (Map)
7+import qualified Data.Map as Map (empty)
8+import Data.Binary (Binary, decode, encode)
9+import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
10+import qualified Data.ByteString as BSS (ByteString, concat)
11+import qualified Data.ByteString.Lazy as BSL
12+ ( ByteString
13+ , empty
14+ , append
15+ , fromChunks
16+ , toChunks
17+ , length
18+ , splitAt
19+ )
20+import Data.Accessor (Accessor, (^:), (^.), (^=))
21+import qualified Data.Accessor.Container as DAC (mapDefault)
22+import Control.Applicative ((<$>))
23+import Network.Socket (HostName, PortNumber, Socket, SockAddr)
24+import qualified Network.Socket.ByteString as NBS (recvFrom, sendManyTo)
25+import Network.Transport.Internal (decodeInt32, encodeInt32)
26+import Network.Multicast (multicastSender, multicastReceiver)
27+
28+--------------------------------------------------------------------------------
29+-- Top-level API --
30+--------------------------------------------------------------------------------
31+
32+-- | Given a hostname and a port number, initialize the multicast system.
33+--
34+-- Note: it is important that you never send messages larger than the maximum
35+-- message size; if you do, all subsequent communication will probably fail.
36+--
37+-- Returns a reader and a writer.
38+--
39+-- NOTE: By rights the two functions should be "locally" polymorphic in 'a',
40+-- but this requires impredicative types.
41+initMulticast :: forall a. Binary a
42+ => HostName -- ^ Multicast IP
43+ -> PortNumber -- ^ Port number
44+ -> Int -- ^ Maximum message size
45+ -> IO (IO (a, SockAddr), a -> IO ())
46+initMulticast host port bufferSize = do
47+ (sendSock, sendAddr) <- multicastSender host port
48+ readSock <- multicastReceiver host port
49+ st <- newIORef Map.empty
50+ return (recvBinary readSock st bufferSize, writer sendSock sendAddr)
51+ where
52+ writer :: forall a. Binary a => Socket -> SockAddr -> a -> IO ()
53+ writer sock addr val = do
54+ let bytes = encode val
55+ len = encodeInt32 (BSL.length bytes)
56+ NBS.sendManyTo sock (len : BSL.toChunks bytes) addr
57+
58+--------------------------------------------------------------------------------
59+-- UDP multicast read, dealing with multiple senders --
60+--------------------------------------------------------------------------------
61+
62+type UDPState = Map SockAddr BSL.ByteString
63+
64+-- TODO: This is inefficient and an orphan instance.
65+-- Requested official instance (https://github.com/haskell/network/issues/38)
66+instance Ord SockAddr where
67+ compare = compare `on` show
68+
69+bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString
70+bufferFor = DAC.mapDefault BSL.empty
71+
72+bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState
73+bufferAppend addr bytes =
74+ bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])
75+
76+recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr)
77+recvBinary sock st bufferSize = do
78+ (bytes, addr) <- recvWithLength sock st bufferSize
79+ return (decode bytes, addr)
80+
81+recvWithLength :: Socket
82+ -> IORef UDPState
83+ -> Int
84+ -> IO (BSL.ByteString, SockAddr)
85+recvWithLength sock st bufferSize = do
86+ (len, addr) <- recvExact sock 4 st bufferSize
87+ let n = decodeInt32 . BSS.concat . BSL.toChunks $ len
88+ bytes <- recvExactFrom addr sock n st bufferSize
89+ return (bytes, addr)
90+
91+-- Receive all bytes currently in the buffer
92+recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr
93+recvAll sock st bufferSize = do
94+ (bytes, addr) <- NBS.recvFrom sock bufferSize
95+ modifyIORef st $ bufferAppend addr bytes
96+ return addr
97+
98+recvExact :: Socket
99+ -> Int
100+ -> IORef UDPState
101+ -> Int
102+ -> IO (BSL.ByteString, SockAddr)
103+recvExact sock n st bufferSize = do
104+ addr <- recvAll sock st bufferSize
105+ bytes <- recvExactFrom addr sock n st bufferSize
106+ return (bytes, addr)
107+
108+recvExactFrom :: SockAddr
109+ -> Socket
110+ -> Int
111+ -> IORef UDPState
112+ -> Int
113+ -> IO BSL.ByteString
114+recvExactFrom addr sock n st bufferSize = go
115+ where
116+ go :: IO BSL.ByteString
117+ go = do
118+ accAddr <- (^. bufferFor addr) <$> readIORef st
119+ if BSL.length accAddr >= fromIntegral n
120+ then do
121+ let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr
122+ modifyIORef st $ bufferFor addr ^= accAddr'
123+ return bytes
124+ else do
125+ _ <- recvAll sock st bufferSize
126+ go
distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hsnew file+24
@@ -0,0 +1,24 @@
1+import System.Environment (getArgs, getProgName)
2+import Control.Distributed.Process (NodeId, Process, liftIO)
3+import Control.Distributed.Process.Node (initRemoteTable)
4+import Control.Distributed.Process.Backend.SimpleLocalnet
5+
6+master :: Backend -> [NodeId] -> Process ()
7+master backend slaves = do
8+ liftIO . putStrLn $ "Slaves: " ++ show slaves
9+ terminateAllSlaves backend
10+
11+main :: IO ()
12+main = do
13+ prog <- getProgName
14+ args <- getArgs
15+
16+ case args of
17+ ["master", host, port] -> do
18+ backend <- initializeBackend host port initRemoteTable
19+ startMaster backend (master backend)
20+ ["slave", host, port] -> do
21+ backend <- initializeBackend host port initRemoteTable
22+ startSlave backend
23+ _ ->
24+ putStrLn $ "usage: " ++ prog ++ " (master | slave) host port"
distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hsnew file+11
@@ -0,0 +1,11 @@
1+#!/bin/bash
2+TestSimpleLocalnet=dist/build/TestSimpleLocalnet/TestSimpleLocalnet
3+$TestSimpleLocalnet slave 127.0.0.1 8080 &
4+sleep 1
5+$TestSimpleLocalnet slave 127.0.0.1 8081 &
6+sleep 1
7+$TestSimpleLocalnet slave 127.0.0.1 8082 &
8+sleep 1
9+$TestSimpleLocalnet slave 127.0.0.1 8083 &
10+sleep 1
11+$TestSimpleLocalnet master 127.0.0.1 8084
distributed-process-tests/.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/ChangeLognew file+7
@@ -0,0 +1,7 @@
1+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1
2+
3+* Bugfix: Continue processing messages when a connection breaks.
4+
5+2012-07-07 Edsko de Vries <edsko@well-typed.com>
6+
7+* Initial release.
LICENSE → distributed-process/LICENSErenamed−1
@@ -1,5 +1,4 @@
1Copyright Well-Typed LLP, 2011-2012
1Copyright Well-Typed LLP, 2011-2012
2−Copyright Tweag I/O Limited, 2015
3
2
4All rights reserved.
3All rights reserved.
5
4
distributed-process-tests/Setup.hs → distributed-process/Setup.hsrenamed

The content is the same.

distributed-process/distributed-process.cabalnew file+133
@@ -0,0 +1,133 @@
1+Name: distributed-process
2+Version: 0.2.0.1
3+Cabal-Version: >=1.8
4+Build-Type: Simple
5+License: BSD3
6+License-File: LICENSE
7+Copyright: Well-Typed LLP
8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10+Stability: experimental
11+Homepage: http://github.com/haskell-distributed/distributed-process
12+Bug-Reports: mailto:edsko@well-typed.com
13+Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell
14+Description: This is an implementation of Cloud Haskell, as described in
15+ /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,
16+ and Simon Peyton Jones
17+ (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
18+ although some of the details are different. The precise message
19+ passing semantics are based on /A unified semantics for future Erlang/
20+ by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.
21+
22+ You will probably also want to install a Cloud Haskell backend such
23+ as distributed-process-simplelocalnet.
24+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
25+Category: Control
26+
27+Source-Repository head
28+ Type: git
29+ Location: https://github.com/haskell-distributed/distributed-process
30+ SubDir: distributed-process
31+
32+Library
33+ Build-Depends: base >= 4.4 && < 5,
34+ binary >= 0.5 && < 0.6,
35+ network-transport >= 0.2 && < 0.3,
36+ stm >= 2.3 && < 2.5,
37+ transformers >= 0.2 && < 0.4,
38+ mtl >= 2.0 && < 2.2,
39+ data-accessor >= 0.2 && < 0.3,
40+ bytestring >= 0.9 && < 0.10,
41+ containers >= 0.4 && < 0.5,
42+ old-locale >= 1.0 && < 1.1,
43+ time >= 1.2 && < 1.3,
44+ template-haskell >= 2.6 && < 2.8,
45+ random >= 1.0 && < 1.1,
46+ ghc-prim >= 0.2 && < 0.3
47+ Exposed-modules: Control.Distributed.Process,
48+ Control.Distributed.Process.Serializable,
49+ Control.Distributed.Process.Closure,
50+ Control.Distributed.Process.Node,
51+ Control.Distributed.Process.Internal.Primitives,
52+ Control.Distributed.Process.Internal.CQueue,
53+ Control.Distributed.Process.Internal.Dynamic,
54+ Control.Distributed.Process.Internal.TypeRep,
55+ Control.Distributed.Process.Internal.MessageT,
56+ Control.Distributed.Process.Internal.Types,
57+ Control.Distributed.Process.Internal.Closure.Derived,
58+ Control.Distributed.Process.Internal.Closure.TH,
59+ Control.Distributed.Process.Internal.Closure.Resolution,
60+ Control.Distributed.Process.Internal.Node
61+ Extensions: RankNTypes,
62+ ScopedTypeVariables,
63+ FlexibleInstances,
64+ UndecidableInstances,
65+ ExistentialQuantification,
66+ GADTs,
67+ GeneralizedNewtypeDeriving,
68+ DeriveDataTypeable,
69+ TemplateHaskell
70+ ghc-options: -Wall
71+ HS-Source-Dirs: src
72+
73+Test-Suite TestCH
74+ Type: exitcode-stdio-1.0
75+ Main-Is: TestCH.hs
76+ Build-Depends: base >= 4.4 && < 5,
77+ binary >= 0.5 && < 0.6,
78+ network-transport >= 0.2 && < 0.3,
79+ network-transport-tcp >= 0.2 && < 0.3,
80+ stm >= 2.3 && < 2.5,
81+ transformers >= 0.2 && < 0.4,
82+ mtl >= 2.0 && < 2.2,
83+ data-accessor >= 0.2 && < 0.3,
84+ bytestring >= 0.9 && < 0.10,
85+ containers >= 0.4 && < 0.5,
86+ old-locale >= 1.0 && < 1.1,
87+ time >= 1.2 && < 1.3,
88+ template-haskell >= 2.6 && < 2.8,
89+ random >= 1.0 && < 1.1,
90+ ghc-prim >= 0.2 && < 0.3,
91+ ansi-terminal >= 0.5 && < 0.6
92+ Extensions: RankNTypes,
93+ ScopedTypeVariables,
94+ FlexibleInstances,
95+ UndecidableInstances,
96+ ExistentialQuantification,
97+ GADTs,
98+ GeneralizedNewtypeDeriving,
99+ DeriveDataTypeable,
100+ TemplateHaskell
101+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
102+ HS-Source-Dirs: tests src
103+
104+Test-Suite TestClosure
105+ Type: exitcode-stdio-1.0
106+ Main-Is: TestClosure.hs
107+ Build-Depends: base >= 4.4 && < 5,
108+ binary >= 0.5 && < 0.6,
109+ network-transport >= 0.2 && < 0.3,
110+ network-transport-tcp >= 0.2 && < 0.3,
111+ stm >= 2.3 && < 2.5,
112+ transformers >= 0.2 && < 0.4,
113+ mtl >= 2.0 && < 2.2,
114+ data-accessor >= 0.2 && < 0.3,
115+ bytestring >= 0.9 && < 0.10,
116+ containers >= 0.4 && < 0.5,
117+ old-locale >= 1.0 && < 1.1,
118+ time >= 1.2 && < 1.3,
119+ template-haskell >= 2.6 && < 2.8,
120+ random >= 1.0 && < 1.1,
121+ ghc-prim >= 0.2 && < 0.3,
122+ ansi-terminal >= 0.5 && < 0.6
123+ Extensions: RankNTypes,
124+ ScopedTypeVariables,
125+ FlexibleInstances,
126+ UndecidableInstances,
127+ ExistentialQuantification,
128+ GADTs,
129+ GeneralizedNewtypeDeriving,
130+ DeriveDataTypeable,
131+ TemplateHaskell
132+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
133+ HS-Source-Dirs: tests src
distributed-process/src/Control/Distributed/Process.hsnew file+334
@@ -0,0 +1,334 @@
1+-- | [Cloud Haskell]
2+--
3+-- This is an implementation of Cloud Haskell, as described in
4+-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon
5+-- Peyton Jones
6+-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
7+-- although some of the details are different. The precise message passing
8+-- semantics are based on /A unified semantics for future Erlang/ by Hans
9+-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.
10+{-# LANGUAGE TemplateHaskell #-}
11+module Control.Distributed.Process
12+ ( -- * Basic types
13+ ProcessId
14+ , NodeId
15+ , Process
16+ , SendPortId
17+ , processNodeId
18+ , sendPortProcessId
19+ , liftIO -- Reexported for convenience
20+ -- * Basic messaging
21+ , send
22+ , expect
23+ -- * Channels
24+ , ReceivePort
25+ , SendPort
26+ , sendPortId
27+ , newChan
28+ , sendChan
29+ , receiveChan
30+ , mergePortsBiased
31+ , mergePortsRR
32+ -- * Advanced messaging
33+ , Match
34+ , receiveWait
35+ , receiveTimeout
36+ , match
37+ , matchIf
38+ , matchUnknown
39+ -- * Process management
40+ , spawn
41+ , call
42+ , terminate
43+ , ProcessTerminationException(..)
44+ , SpawnRef
45+ , getSelfPid
46+ , getSelfNode
47+ -- * Monitoring and linking
48+ , link
49+ , linkNode
50+ , linkPort
51+ , unlink
52+ , unlinkNode
53+ , unlinkPort
54+ , monitor
55+ , monitorNode
56+ , monitorPort
57+ , unmonitor
58+ , ProcessLinkException(..)
59+ , NodeLinkException(..)
60+ , PortLinkException(..)
61+ , MonitorRef -- opaque
62+ , ProcessMonitorNotification(..)
63+ , NodeMonitorNotification(..)
64+ , PortMonitorNotification(..)
65+ , DiedReason(..)
66+ -- * Closures
67+ , Closure
68+ , Static
69+ , unClosure
70+ , RemoteTable
71+ -- * Logging
72+ , say
73+ -- * Registry
74+ , register
75+ , unregister
76+ , whereis
77+ , nsend
78+ , registerRemote
79+ , unregisterRemote
80+ , whereisRemote
81+ , whereisRemoteAsync
82+ , nsendRemote
83+ , WhereIsReply(..)
84+ -- * Auxiliary API
85+ , catch
86+ , expectTimeout
87+ , spawnAsync
88+ , spawnSupervised
89+ , spawnLink
90+ , spawnMonitor
91+ , DidSpawn(..)
92+ ) where
93+
94+import Prelude hiding (catch)
95+import Control.Monad.IO.Class (liftIO)
96+import Control.Distributed.Process.Internal.Types
97+ ( RemoteTable
98+ , NodeId(..)
99+ , ProcessId(..)
100+ , Process(..)
101+ , Closure(..)
102+ , Static(..)
103+ , MonitorRef(..)
104+ , ProcessMonitorNotification(..)
105+ , NodeMonitorNotification(..)
106+ , PortMonitorNotification(..)
107+ , ProcessLinkException(..)
108+ , NodeLinkException(..)
109+ , PortLinkException(..)
110+ , DiedReason(..)
111+ , SpawnRef(..)
112+ , DidSpawn(..)
113+ , Closure(..)
114+ , SendPort(..)
115+ , ReceivePort(..)
116+ , SerializableDict(..)
117+ , SendPortId(..)
118+ , WhereIsReply(..)
119+ )
120+import Control.Distributed.Process.Internal.Closure.Derived
121+ ( cpSeq
122+ , cpBind
123+ , cpSend
124+ , cpExpect
125+ , cpLink
126+ , cpUnlink
127+ , sdictUnit
128+ , sdictUnit__static
129+ )
130+import Control.Distributed.Process.Internal.Primitives
131+ ( -- Basic messaging
132+ send
133+ , expect
134+ -- Channels
135+ , newChan
136+ , sendChan
137+ , receiveChan
138+ , mergePortsBiased
139+ , mergePortsRR
140+ -- Advanced messaging
141+ , Match
142+ , receiveWait
143+ , receiveTimeout
144+ , match
145+ , matchIf
146+ , matchUnknown
147+ -- Process management
148+ , terminate
149+ , ProcessTerminationException(..)
150+ , getSelfPid
151+ , getSelfNode
152+ -- Monitoring and linking
153+ , link
154+ , linkNode
155+ , linkPort
156+ , unlink
157+ , unlinkNode
158+ , unlinkPort
159+ , monitor
160+ , monitorNode
161+ , monitorPort
162+ , unmonitor
163+ -- Logging
164+ , say
165+ -- Registry
166+ , register
167+ , unregister
168+ , whereis
169+ , nsend
170+ , registerRemote
171+ , unregisterRemote
172+ , whereisRemote
173+ , whereisRemoteAsync
174+ , nsendRemote
175+ -- Closures
176+ , unClosure
177+ -- Auxiliary API
178+ , catch
179+ , expectTimeout
180+ , spawnAsync
181+ )
182+import Control.Distributed.Process.Serializable (Serializable)
183+import Control.Distributed.Process.Internal.Closure.TH (mkStatic)
184+
185+-- INTERNAL NOTES
186+--
187+-- 1. 'send' never fails. If you want to know that the remote process received
188+-- your message, you will need to send an explicit acknowledgement. If you
189+-- want to know when the remote process failed, you will need to monitor
190+-- that remote process.
191+--
192+-- 2. 'send' may block (when the system TCP buffers are full, while we are
193+-- trying to establish a connection to the remote endpoint, etc.) but its
194+-- return does not imply that the remote process received the message (much
195+-- less processed it)
196+--
197+-- 3. Message delivery is reliable and ordered. That means that if process A
198+-- sends messages m1, m2, m3 to process B, B will either arrive all three
199+-- messages in order (m1, m2, m3) or a prefix thereof; messages will not be
200+-- 'missing' (m1, m3) or reordered (m1, m3, m2)
201+--
202+-- In order to guarantee (3), we stipulate that
203+--
204+-- 3a. We do not garbage collect connections because Network.Transport provides
205+-- ordering guarantees only *per connection*.
206+--
207+-- 3b. Once a connection breaks, we have no way of knowing which messages
208+-- arrived and which did not; hence, once a connection fails, we assume the
209+-- remote process to be forever unreachable. Otherwise we might sent m1 and
210+-- m2, get notified of the broken connection, reconnect, send m3, but only
211+-- m1 and m3 arrive.
212+--
213+-- 3c. As a consequence of (3b) we should not reuse PIDs. If a process dies,
214+-- we consider it forever unreachable. Hence, new processes should get new
215+-- IDs or they too would be considered unreachable.
216+--
217+-- Main reference for Cloud Haskell is
218+--
219+-- [1] "Towards Haskell in the Cloud", Jeff Epstein, Andrew Black and Simon
220+-- Peyton-Jones.
221+-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
222+--
223+-- The precise semantics for message passing is based on
224+--
225+-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund
226+-- and Clara Benac Earle (not freely available online, unfortunately)
227+--
228+-- Some pointers to related documentation about Erlang, for comparison and
229+-- inspiration:
230+--
231+-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",
232+-- Hans Svensson and Lars-Ake Fredlund
233+-- http://man.lupaworld.com/content/develop/p37-svensson.pdf
234+-- [4] The Erlang manual, sections "Message Sending" and "Send"
235+-- http://www.erlang.org/doc/reference_manual/processes.html#id82409
236+-- http://www.erlang.org/doc/reference_manual/expressions.html#send
237+-- [5] Questions "Is the order of message reception guaranteed?" and
238+-- "If I send a message, is it guaranteed to reach the receiver?" of
239+-- the Erlang FAQ
240+-- http://www.erlang.org/faq/academic.html
241+-- [6] "Delivery of Messages", post on erlang-questions
242+-- http://erlang.org/pipermail/erlang-questions/2012-February/064767.html
243+
244+--------------------------------------------------------------------------------
245+-- Primitives are defined in a separate module; here we only define derived --
246+-- constructs --
247+--------------------------------------------------------------------------------
248+
249+-- | Spawn a process
250+spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
251+spawn nid proc = do
252+ us <- getSelfPid
253+ -- Since we throw an exception when the remote node dies, we could use
254+ -- linkNode instead. However, we don't have a way of "scoped" linking so if
255+ -- we call linkNode here, and unlinkNode after, then we might remove a link
256+ -- that was already set up
257+ mRef <- monitorNode nid
258+ sRef <- spawnAsync nid $ cpLink us
259+ `cpSeq` cpExpect $(mkStatic 'sdictUnit)
260+ `cpSeq` cpUnlink us
261+ `cpSeq` proc
262+ mPid <- receiveWait
263+ [ matchIf (\(DidSpawn ref _) -> ref == sRef)
264+ (\(DidSpawn _ pid) -> return $ Just pid)
265+ , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)
266+ (\_ -> return Nothing)
267+ ]
268+ unmonitor mRef
269+ case mPid of
270+ Nothing -> fail "spawn: remote node failed"
271+ Just pid -> send pid () >> return pid
272+
273+-- | Spawn a process and link to it
274+--
275+-- Note that this is just the sequential composition of 'spawn' and 'link'.
276+-- (The "Unified" semantics that underlies Cloud Haskell does not even support
277+-- a synchronous link operation)
278+spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
279+spawnLink nid proc = do
280+ pid <- spawn nid proc
281+ link pid
282+ return pid
283+
284+-- | Like 'spawnLink', but monitor the spawned process
285+spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
286+spawnMonitor nid proc = do
287+ pid <- spawn nid proc
288+ ref <- monitor pid
289+ return (pid, ref)
290+
291+-- | Run a process remotely and wait for it to reply
292+--
293+-- We monitor the remote process; if it dies before it can send a reply, we die
294+-- too
295+call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
296+call dict nid proc = do
297+ us <- getSelfPid
298+ (_, mRef) <- spawnMonitor nid (proc `cpBind` cpSend dict us)
299+ -- We are guaranteed to receive the reply before the monitor notification
300+ -- (if a reply is sent at all)
301+ -- NOTE: This might not be true if we switch to unreliable delivery.
302+ mResult <- receiveWait
303+ [ match (return . Right)
304+ , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
305+ (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))
306+ ]
307+ case mResult of
308+ Right a -> unmonitor mRef >> return a
309+ Left err -> fail $ "call: remote process died: " ++ show err
310+
311+-- | Spawn a child process, have the child link to the parent and the parent
312+-- monitor the child
313+spawnSupervised :: NodeId
314+ -> Closure (Process ())
315+ -> Process (ProcessId, MonitorRef)
316+spawnSupervised nid proc = do
317+ us <- getSelfPid
318+ them <- spawn nid (cpLink us `cpSeq` proc)
319+ ref <- monitor them
320+ return (them, ref)
321+
322+{-
323+spawnChannel :: forall a. Typeable a
324+ => NodeId
325+ -> Closure (ReceivePort a -> Process ())
326+ -> Process (SendPort a)
327+spawnChannel nid proc = do
328+ us <- getSelfPid
329+ undefined
330+ where
331+ rproc :: ProcessId -> Closure (Process ((), ReceivePort a))
332+ rproc pid = newChanClosure
333+ `cpBind` cpFirst (sendClosure undefined pid)
334+-}
distributed-process/src/Control/Distributed/Process/Closure.hsnew file+152
@@ -0,0 +1,152 @@
1+-- | Implementation of 'Closure' that works around the absence of 'static'.
2+--
3+-- [User-defined monomorphic closures]
4+--
5+-- Suppose we have a monomorphic function
6+--
7+-- > addInt :: Int -> Int -> Int
8+-- > addInt x y = x + y
9+--
10+-- Then the Template Haskell splice
11+--
12+-- > remotable ['addInt]
13+--
14+-- creates a function
15+--
16+-- > $(mkClosure 'addInt) :: Int -> Closure (Int -> Int)
17+--
18+-- which can be used to partially apply 'addInt' and turn it into a 'Closure',
19+-- which can be sent across the network. Closures can be deserialized with
20+--
21+-- > unClosure :: Typeable a => Closure a -> Process a
22+--
23+-- In general, given a monomorphic function @f :: T1 -> T2@ the corresponding
24+-- function @$(mkClosure 'f)@ will have type @T1 -> Closure T2@.
25+--
26+-- The call to 'remotable' will also generate a function
27+--
28+-- > __remoteTable :: RemoteTable -> RemoteTable
29+--
30+-- which can be used to construct the 'RemoteTable' used to initialize
31+-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,
32+-- and compose all created functions when initializing Cloud Haskell:
33+--
34+-- > let rtable = M1.__remoteTable
35+-- > . M2.__remoteTable
36+-- > . ...
37+-- > . Mn.__remoteTable
38+-- > $ initRemoteTable
39+--
40+-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.
41+--
42+-- [User-defined polymorphic closures]
43+--
44+-- Suppose we have a polymorphic function
45+--
46+-- > first :: forall a b. (a, b) -> a
47+-- > first (x, _) = x
48+--
49+-- Then the Template Haskell splice
50+--
51+-- > remotable ['first]
52+--
53+-- creates a function
54+--
55+-- > $(mkClosure 'first) :: forall a b. (Typeable a, Typeable b)
56+-- > => Closure (a -> b -> a)
57+--
58+-- In general, given a polymorphic function @f :: forall a1 .. an. T@ the
59+-- corresponding function @$(mkClosure 'f)@ will have type
60+-- @forall a1 .. an. (Typeable a1, .., Typeable an) => Closure T@.
61+--
62+-- [Built-in closures]
63+--
64+-- We offer a number of standard commonly useful closures.
65+--
66+-- [Closure combinators]
67+--
68+-- Closures combinators allow to create closures from other closures. For
69+-- example, 'spawnSupervised' is defined as follows:
70+--
71+-- > spawnSupervised :: NodeId
72+-- > -> Closure (Process ())
73+-- > -> Process (ProcessId, MonitorRef)
74+-- > spawnSupervised nid proc = do
75+-- > us <- getSelfPid
76+-- > them <- spawn nid (linkClosure us `cpSeq` proc)
77+-- > ref <- monitor them
78+-- > return (them, ref)
79+--
80+-- [Serializable Dictionaries]
81+--
82+-- Some functions (such as 'sendClosure' or 'returnClosure') require an
83+-- explicit (reified) serializable dictionary. To create such a dictionary do
84+--
85+-- > sdictInt :: SerializableDict Int
86+-- > sdictInt = SerializableDict
87+--
88+-- and then pass @'sdictInt@ to 'remotable'. This will fail if the
89+-- type is not serializable.
90+module Control.Distributed.Process.Closure
91+ ( -- * User-defined closures
92+ remotable
93+ , mkStatic
94+ -- * Static functionals
95+ , staticConst
96+ , staticCompose
97+ , staticFirst
98+ , staticSecond
99+ , staticSplit
100+ -- * Creating closures
101+ , staticDecode
102+ , staticClosure
103+ , toClosure
104+ -- * Closure versions of CH primitives
105+ , cpLink
106+ , cpUnlink
107+ , cpSend
108+ , cpExpect
109+ -- * @Closure (Process a)@ as a not-quite-monad
110+ , cpReturn
111+ , cpBind
112+ , cpSeq
113+ -- * Serialization dictionaries (and their static versions)
114+ , SerializableDict(..)
115+ , staticApply
116+ , sdictUnit
117+ , sdictUnit__static
118+ , sdictProcessId
119+ , sdictProcessId__static
120+ ) where
121+
122+import Control.Distributed.Process.Internal.Types
123+ ( SerializableDict(..)
124+ , staticApply
125+ )
126+import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
127+import Control.Distributed.Process.Internal.Closure.Derived
128+ ( -- Static functionals
129+ staticConst
130+ , staticCompose
131+ , staticFirst
132+ , staticSecond
133+ , staticSplit
134+ -- Creating closures
135+ , staticDecode
136+ , staticClosure
137+ , toClosure
138+ -- Closure versions of CH primitives
139+ , cpLink
140+ , cpUnlink
141+ , cpSend
142+ , cpExpect
143+ -- @Closure (Process a)@ as a not-quite-monad
144+ , cpReturn
145+ , cpBind
146+ , cpSeq
147+ -- Serialization dictionaries (and their static versions)
148+ , sdictUnit
149+ , sdictUnit__static
150+ , sdictProcessId
151+ , sdictProcessId__static
152+ )
distributed-process/src/Control/Distributed/Process/Internal/CQueue.hsnew file+105
@@ -0,0 +1,105 @@
1+-- | Concurrent queue for single reader, single writer
2+module Control.Distributed.Process.Internal.CQueue
3+ ( CQueue
4+ , BlockSpec(..)
5+ , newCQueue
6+ , enqueue
7+ , dequeue
8+ ) where
9+
10+import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)
11+import Control.Concurrent.STM
12+ ( atomically
13+ , TChan
14+ , newTChan
15+ , writeTChan
16+ , readTChan
17+ , tryReadTChan
18+ )
19+import Control.Applicative ((<$>), (<*>))
20+import Control.Exception (mask, onException)
21+import System.Timeout (timeout)
22+
23+-- We use a TCHan rather than a Chan so that we have a non-blocking read
24+data CQueue a = CQueue (MVar [a]) -- Arrived
25+ (TChan a) -- Incoming
26+
27+newCQueue :: IO (CQueue a)
28+newCQueue = CQueue <$> newMVar [] <*> atomically newTChan
29+
30+enqueue :: CQueue a -> a -> IO ()
31+enqueue (CQueue _arrived incoming) a = atomically $ writeTChan incoming a
32+
33+data BlockSpec =
34+ NonBlocking
35+ | Blocking
36+ | Timeout Int
37+
38+-- | Dequeue an element
39+--
40+-- The timeout (if any) is applied only to waiting for incoming messages, not
41+-- to checking messages that have already arrived
42+dequeue :: forall a b.
43+ CQueue a -- ^ Queue
44+ -> BlockSpec -- ^ Blocking behaviour
45+ -> [a -> Maybe b] -- ^ List of matches
46+ -> IO (Maybe b) -- ^ 'Nothing' only on timeout
47+dequeue (CQueue arrived incoming) blockSpec matches = go
48+ where
49+ go :: IO (Maybe b)
50+ go = mask $ \restore -> do
51+ arr <- takeMVar arrived
52+ -- We first check the arrived messages. If we get interrupted during this
53+ -- search, we just put the MVar back (we haven't read from the Chan yet)
54+ (arr', mb) <- onException (restore (checkArrived [] arr))
55+ (putMVar arrived arr)
56+ case (mb, blockSpec) of
57+ (Just b, _) -> do
58+ putMVar arrived arr'
59+ return (Just b)
60+ (Nothing, NonBlocking) ->
61+ checkNonBlocking arr'
62+ (Nothing, Blocking) ->
63+ Just <$> checkBlocking arr'
64+ (Nothing, Timeout n) ->
65+ timeout n $ checkBlocking arr'
66+
67+ -- We reverse the accumulator on return only if we find a match
68+ checkArrived :: [a] -> [a] -> IO ([a], Maybe b)
69+ checkArrived acc [] = return (acc, Nothing)
70+ checkArrived acc (x:xs) =
71+ case check x of
72+ Just y -> return (reverse acc ++ xs, Just y)
73+ Nothing -> checkArrived (x:acc) xs
74+
75+ -- If we call checkBlocking there may or may not be a timeout
76+ checkBlocking :: [a] -> IO b
77+ checkBlocking acc = do
78+ -- readTChan is a blocking call, and hence is interruptable. If it is
79+ -- interrupted, we put the value of the accumulator in 'arrived'
80+ -- (as opposed to the original value), so that no messages get lost
81+ -- (hence the low-level structure using mask rather than modifyMVar)
82+ x <- onException (atomically $ readTChan incoming)
83+ (putMVar arrived $ reverse acc)
84+ case check x of
85+ Nothing -> checkBlocking (x:acc)
86+ Just y -> putMVar arrived (reverse acc) >> return y
87+
88+ -- checkNonBlocking is only called if there is no timeout
89+ checkNonBlocking :: [a] -> IO (Maybe b)
90+ checkNonBlocking acc = do
91+ -- tryReadTChan is *not* interruptible
92+ mx <- atomically $ tryReadTChan incoming
93+ case mx of
94+ Nothing -> putMVar arrived (reverse acc) >> return Nothing
95+ Just x -> case check x of
96+ Nothing -> checkNonBlocking (x:acc)
97+ Just y -> putMVar arrived (reverse acc) >> return (Just y)
98+
99+ check :: a -> Maybe b
100+ check = checkMatches matches
101+
102+ checkMatches :: [a -> Maybe b] -> a -> Maybe b
103+ checkMatches [] _ = Nothing
104+ checkMatches (m:ms) a = case m a of Nothing -> checkMatches ms a
105+ Just b -> Just b
distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hsnew file+338
@@ -0,0 +1,338 @@
1+-- | Derived (TH generated) closures
2+{-# LANGUAGE MagicHash #-}
3+module Control.Distributed.Process.Internal.Closure.Derived
4+ ( -- * Static functionals
5+ staticConst
6+ , staticCompose
7+ , staticFirst
8+ , staticSecond
9+ , staticSplit
10+ -- * Creating closures
11+ , staticDecode
12+ , staticClosure
13+ , toClosure
14+ -- * Closure versions of CH primitives
15+ , cpLink
16+ , cpUnlink
17+ , cpSend
18+ , cpExpect
19+ -- * @Closure (Process a)@ as a not-quite-monad
20+ , cpReturn
21+ , cpBind
22+ , cpSeq
23+ -- * Serialization dictionaries (and their static versions)
24+ , sdictUnit
25+ , sdictUnit__static
26+ , sdictProcessId
27+ , sdictProcessId__static
28+ -- * Runtime support
29+ , __remoteTable
30+ ) where
31+
32+import Data.Binary (encode, decode)
33+import Data.ByteString.Lazy (ByteString, empty)
34+import Data.Typeable (Typeable, typeOf, TypeRep, typeRepTyCon, TyCon)
35+import Control.Applicative ((<$>))
36+import Control.Monad (join)
37+import Control.Distributed.Process.Serializable (Serializable)
38+import Control.Distributed.Process.Internal.Types
39+ ( Closure(Closure)
40+ , SerializableDict(SerializableDict)
41+ , Static(Static)
42+ , StaticLabel
43+ , Process
44+ , staticApply
45+ , ProcessId
46+ , LocalNode(remoteTable)
47+ , procMsg
48+ )
49+import Control.Distributed.Process.Internal.Primitives
50+ ( link
51+ , unlink
52+ , send
53+ , expect
54+ )
55+import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
56+import Control.Distributed.Process.Internal.MessageT (getLocalNode)
57+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
58+import Control.Distributed.Process.Internal.Dynamic
59+ ( Dynamic(Dynamic)
60+ , dynBind
61+ , unsafeCoerce#
62+ , dynTypeRep
63+ )
64+import qualified Control.Arrow as Arrow (first, second, (***))
65+
66+--------------------------------------------------------------------------------
67+-- Setup: A number of functions that we will pass to 'remotable' --
68+--------------------------------------------------------------------------------
69+
70+---- Type specializations of monadic operations on Processes -------------------
71+
72+returnProcess :: a -> Process a
73+returnProcess = return
74+
75+bindProcess :: Process a -> (a -> Process b) -> Process b
76+bindProcess = (>>=)
77+
78+joinProcess :: Process (Process a) -> Process a
79+joinProcess = join
80+
81+---- Functionals ---------------------------------------------------------------
82+
83+compose :: (b -> c) -> (a -> b) -> a -> c
84+compose = (.)
85+
86+first :: (a -> b) -> (a, c) -> (b, c)
87+first = Arrow.first
88+
89+second :: (a -> b) -> (c, a) -> (c, b)
90+second = Arrow.second
91+
92+split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
93+split = (Arrow.***)
94+
95+---- Variations on standard or CH functions with an explicit dictionary arg ----
96+
97+decodeDict :: SerializableDict a -> ByteString -> a
98+decodeDict SerializableDict = decode
99+
100+sendDict :: SerializableDict a -> ProcessId -> a -> Process ()
101+sendDict SerializableDict = send
102+
103+expectDict :: SerializableDict a -> Process a
104+expectDict SerializableDict = expect
105+
106+---- Serialization dictionaries ------------------------------------------------
107+
108+-- | Serialization dictionary for '()'
109+--
110+-- Use @$(mkStatic sdictUnit)@ (instead of 'sdictUnit__static')
111+-- to refer to the static dictionary.
112+sdictUnit :: SerializableDict ()
113+sdictUnit = SerializableDict
114+
115+-- | Serialization dictionary for 'ProcessId'
116+--
117+-- Use @$(mkStatic sdictProcessId)@ (instead of 'sdictProcessId__static')
118+-- to refer to the static dictionary.
119+sdictProcessId :: SerializableDict ProcessId
120+sdictProcessId = SerializableDict
121+
122+-- | Specialized serialization dictionary required in 'cpBind'
123+sdictBind :: SerializableDict (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)
124+sdictBind = SerializableDict
125+
126+---- Some specialised processes necessary to implement the combinators ---------
127+
128+unClosure :: (StaticLabel, ByteString) -> Process Dynamic
129+unClosure (label, env) = do
130+ rtable <- remoteTable <$> procMsg getLocalNode
131+ case resolveClosure rtable label env of
132+ Nothing -> fail "Derived.unClosure: resolveClosure failed"
133+ Just dyn -> return dyn
134+
135+unDynamic :: (Process Dynamic, TypeRep) -> Process a
136+unDynamic (pdyn, typ) = do
137+ Dynamic typ' val <- pdyn
138+ if typ == typ'
139+ then return (unsafeCoerce# val)
140+ else fail $ "unDynamic: cannot match "
141+ ++ show typ'
142+ ++ " against expected type "
143+ ++ show typ
144+
145+bindDyn :: (Process Dynamic, Process Dynamic) -> Process Dynamic
146+bindDyn (px, pf) = do
147+ x <- px
148+ f <- pf
149+ case dynBind tyConProcess bindProcess x f of
150+ Just dyn -> return dyn
151+ Nothing -> fail $ "bindDyn: could not bind "
152+ ++ show (dynTypeRep x)
153+ ++ " to "
154+ ++ show (dynTypeRep f)
155+ where
156+ tyConProcess :: TyCon
157+ tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))
158+
159+---- Finally, the call to remotable --------------------------------------------
160+
161+remotable [ -- Monadic operations
162+ 'returnProcess
163+ , 'bindProcess
164+ , 'joinProcess
165+ -- Functionals (predefined)
166+ , 'const
167+ -- Functionals (defined above)
168+ , 'compose
169+ , 'first
170+ , 'second
171+ , 'split
172+ -- CH primitives
173+ , 'link
174+ , 'unlink
175+ -- Explicit dictionaries
176+ , 'decodeDict
177+ , 'sendDict
178+ , 'expectDict
179+ -- Serialization dictionaries
180+ , 'sdictUnit
181+ , 'sdictProcessId
182+ , 'sdictBind
183+ -- Specialized processes
184+ , 'unClosure
185+ , 'unDynamic
186+ , 'bindDyn
187+ ]
188+
189+--------------------------------------------------------------------------------
190+-- Static versions of the functionals --
191+-- (We give these explicit names because they are useful outside this module) --
192+--------------------------------------------------------------------------------
193+
194+-- | Static version of 'const'
195+staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)
196+staticConst = $(mkStatic 'const)
197+
198+-- | Static version of ('Prelude..')
199+staticCompose :: (Typeable a, Typeable b, Typeable c)
200+ => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
201+staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x
202+
203+-- | Static version of 'Control.Arrow.first'
204+staticFirst :: (Typeable a, Typeable b, Typeable c)
205+ => Static ((a -> b) -> (a, c) -> (b, c))
206+staticFirst = $(mkStatic 'first)
207+
208+-- | Static version of 'Control.Arrow.second'
209+staticSecond :: (Typeable a, Typeable b, Typeable c)
210+ => Static ((a -> b) -> (c, a) -> (c, b))
211+staticSecond = $(mkStatic 'second)
212+
213+-- | Static version of ('Control.Arrow.***')
214+staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
215+ => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))
216+staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g
217+
218+--------------------------------------------------------------------------------
219+-- Creating closures --
220+--------------------------------------------------------------------------------
221+
222+staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
223+staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
224+
225+staticClosure :: forall a. Typeable a => Static a -> Closure a
226+staticClosure static = Closure decoder empty
227+ where
228+ decoder :: Static (ByteString -> a)
229+ decoder = staticConst `staticApply` static
230+
231+toClosure :: forall a. Serializable a
232+ => Static (SerializableDict a) -> a -> Closure a
233+toClosure dict x = Closure decoder (encode x)
234+ where
235+ decoder :: Static (ByteString -> a)
236+ decoder = $(mkStatic 'decodeDict) `staticApply` dict
237+
238+--------------------------------------------------------------------------------
239+-- Closure versions of CH primitives --
240+--------------------------------------------------------------------------------
241+
242+-- | Closure version of 'link'
243+cpLink :: ProcessId -> Closure (Process ())
244+cpLink pid = Closure decoder (encode pid)
245+ where
246+ decoder :: Static (ByteString -> Process ())
247+ decoder = $(mkStatic 'link)
248+ `staticCompose`
249+ ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
250+
251+-- | Closure version of 'unlink'
252+cpUnlink :: ProcessId -> Closure (Process ())
253+cpUnlink pid = Closure decoder (encode pid)
254+ where
255+ decoder :: Static (ByteString -> Process ())
256+ decoder = $(mkStatic 'unlink)
257+ `staticCompose`
258+ ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
259+
260+-- | Closure version of 'send'
261+cpSend :: forall a. Typeable a
262+ => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())
263+cpSend dict pid = Closure decoder (encode pid)
264+ where
265+ decoder :: Static (ByteString -> a -> Process ())
266+ decoder = ($(mkStatic 'sendDict) `staticApply` dict)
267+ `staticCompose`
268+ ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
269+
270+-- | Closure version of 'expect'
271+cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
272+cpExpect dict = staticClosure ($(mkStatic 'expectDict) `staticApply` dict)
273+
274+--------------------------------------------------------------------------------
275+-- (Closure . Process) as a not-quite-monad --
276+--------------------------------------------------------------------------------
277+
278+-- | Not-quite-monadic 'return'
279+cpReturn :: forall a. Serializable a
280+ => Static (SerializableDict a) -> a -> Closure (Process a)
281+cpReturn dict x = Closure decoder (encode x)
282+ where
283+ decoder :: Static (ByteString -> Process a)
284+ decoder = $(mkStatic 'returnProcess)
285+ `staticCompose`
286+ ($(mkStatic 'decodeDict) `staticApply` dict)
287+
288+-- | Not-quite-monadic bind ('>>=')
289+cpBind :: forall a b. Typeable b
290+ => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
291+cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =
292+ let env :: (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)
293+ env = (((xlabel, xenv), (flabel, fenv)), typeOf (undefined :: Process b))
294+ in Closure decoder (encode env)
295+ where
296+ decoder :: Static (ByteString -> Process b)
297+ decoder = aux8
298+ `staticCompose`
299+ aux7
300+ `staticCompose`
301+ aux6
302+ `staticCompose`
303+ aux1
304+
305+ aux1 :: Static (ByteString -> (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep))
306+ aux1 = $(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictBind)
307+
308+ aux2 :: Static ((StaticLabel, ByteString) -> Process Dynamic)
309+ aux2 = $(mkStatic 'unClosure)
310+
311+ aux3 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> (Process Dynamic, Process Dynamic))
312+ aux3 = aux2 `staticSplit` aux2
313+
314+ aux4 :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
315+ aux4 = $(mkStatic 'bindDyn)
316+
317+ aux5 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> Process Dynamic)
318+ aux5 = aux4 `staticCompose` aux3
319+
320+ aux6 :: Static ((((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep) -> (Process Dynamic, TypeRep))
321+ aux6 = staticFirst `staticApply` aux5
322+
323+ aux7 :: Static ((Process Dynamic, TypeRep) -> Process (Process b))
324+ aux7 = $(mkStatic 'unDynamic)
325+
326+ aux8 :: Static (Process (Process b) -> Process b)
327+ aux8 = $(mkStatic 'joinProcess)
328+
329+cpIntro :: forall a b. (Typeable a, Typeable b)
330+ => Closure (Process b) -> Closure (a -> Process b)
331+cpIntro (Closure static env) = Closure decoder env
332+ where
333+ decoder :: Static (ByteString -> a -> Process b)
334+ decoder = staticConst `staticCompose` static
335+
336+-- | Monadic sequencing ('>>')
337+cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())
338+cpSeq p q = p `cpBind` cpIntro q
distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE MagicHash #-}
2+module Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure) where
3+
4+import Data.Accessor ((^.))
5+import Data.ByteString.Lazy (ByteString)
6+import Control.Distributed.Process.Internal.Types
7+ ( RemoteTable
8+ , remoteTableLabel
9+ , StaticLabel(..)
10+ )
11+import Control.Distributed.Process.Internal.Dynamic
12+ ( Dynamic(Dynamic)
13+ , toDyn
14+ , dynApply
15+ )
16+import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
17+
18+resolveStatic :: RemoteTable -> StaticLabel -> Maybe Dynamic
19+resolveStatic rtable (StaticLabel string typ) = do
20+ Dynamic _ val <- rtable ^. remoteTableLabel string
21+ return (Dynamic typ val)
22+resolveStatic rtable (StaticApply static1 static2) = do
23+ f <- resolveStatic rtable static1
24+ x <- resolveStatic rtable static2
25+ f `dynApply` x
26+
27+resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
28+resolveClosure rtable static env = do
29+ decoder <- resolveStatic rtable static
30+ decoder `dynApply` toDyn env
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hsnew file+223
@@ -0,0 +1,223 @@
1+-- | Template Haskell support
2+--
3+-- (In a separate file for convenience)
4+{-# LANGUAGE MagicHash #-}
5+module Control.Distributed.Process.Internal.Closure.TH
6+ ( -- * User-level API
7+ remotable
8+ , mkStatic
9+ ) where
10+
11+import Prelude hiding (lookup)
12+import Data.Accessor ((^=))
13+import Data.Typeable (typeOf)
14+import Control.Applicative ((<$>))
15+import Language.Haskell.TH
16+ ( -- Q monad and operations
17+ Q
18+ , reify
19+ -- Names
20+ , Name
21+ , mkName
22+ , nameBase
23+ -- Algebraic data types
24+ , Dec
25+ , Exp
26+ , Type(AppT, ForallT, VarT)
27+ , Info(VarI)
28+ , TyVarBndr(PlainTV, KindedTV)
29+ , Pred(ClassP)
30+ -- Lifted constructors
31+ -- .. Literals
32+ , stringL
33+ -- .. Patterns
34+ , normalB
35+ , clause
36+ -- .. Expressions
37+ , varE
38+ , litE
39+ -- .. Top-level declarations
40+ , funD
41+ , sigD
42+ )
43+import Control.Distributed.Process.Internal.Types
44+ ( RemoteTable
45+ , Static(..)
46+ , StaticLabel(..)
47+ , remoteTableLabel
48+ )
49+import Control.Distributed.Process.Internal.Dynamic
50+ ( Dynamic(..)
51+ , unsafeCoerce#
52+ )
53+
54+--------------------------------------------------------------------------------
55+-- User-level API --
56+--------------------------------------------------------------------------------
57+
58+-- | Create the closure, decoder, and metadata definitions for the given list
59+-- of functions
60+remotable :: [Name] -> Q [Dec]
61+remotable ns = do
62+ (closures, inserts) <- unzip <$> mapM generateDefs ns
63+ rtable <- createMetaData inserts
64+ return $ concat closures ++ rtable
65+
66+-- | Construct a static value
67+mkStatic :: Name -> Q Exp
68+mkStatic = varE . staticName
69+
70+{-
71+-- | Create a closure
72+--
73+-- See module documentation header for "Control.Distributed.Process.Closure"
74+-- for a detailed explanation and examples.
75+mkClosure :: Name -> Q Exp
76+mkClosure = varE . closureName
77+-}
78+
79+--------------------------------------------------------------------------------
80+-- Internal (Template Haskell) --
81+--------------------------------------------------------------------------------
82+
83+-- | Generate the code to add the metadata to the CH runtime
84+createMetaData :: [Q Exp] -> Q [Dec]
85+createMetaData is =
86+ [d| __remoteTable :: RemoteTable -> RemoteTable ;
87+ __remoteTable = $(compose is)
88+ |]
89+
90+generateDefs :: Name -> Q ([Dec], Q Exp)
91+generateDefs n = do
92+ mType <- getType n
93+ case mType of
94+ Just (origName, typ) -> do
95+ let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
96+ _ -> ([], typ)
97+ (static, label) <- generateStatic origName typVars typ'
98+ return (static, [| registerStatic $(stringE label) (Dynamic (error "Polymorphic value") (unsafeCoerce# $(varE origName))) |])
99+ _ ->
100+ fail $ "remotable: " ++ show n ++ " not found"
101+
102+registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
103+registerStatic label dyn = remoteTableLabel label ^= Just dyn
104+
105+-- | Generate a static value
106+generateStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], String)
107+generateStatic n xs typ = do
108+ staticTyp <- [t| Static |]
109+ closure <- sequence
110+ [ sigD (staticName n) (return (ForallT xs (map typeable xs) (staticTyp `AppT` typ)) )
111+ , sfnD (staticName n) [| Static (StaticLabel $(stringE label) (typeOf (undefined :: $(return typ)))) |]
112+ ]
113+ return (closure, label)
114+ where
115+ label :: String
116+ label = show n
117+
118+ typeable :: TyVarBndr -> Pred
119+ typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
120+ typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
121+
122+staticName :: Name -> Name
123+staticName n = mkName $ nameBase n ++ "__static"
124+
125+{-
126+-- | Generate the necessary definitions for one function
127+--
128+-- Given an (f :: a -> b) in module M, create:
129+-- 1. f__closure :: a -> Closure b,
130+-- 2. registerLabel "M.f" (toDyn ((f . enc) :: ByteString -> b))
131+--
132+-- Moreover, if b is of the form Process c, then additionally create
133+-- 3. registerSender (Process c) (send :: ProcessId -> c -> Process ())
134+generateDefs :: Name -> Q ([Dec], Q Exp)
135+generateDefs n = do
136+ serializableDict <- [t| SerializableDict |]
137+ mType <- getType n
138+ case mType of
139+ Just (origName, ArrowT `AppT` arg `AppT` res) -> do
140+ (closure, label) <- generateClosure origName (return arg) (return res)
141+ let decoder = generateDecoder origName (return res)
142+ insert = [| registerLabel $(stringE label) (toDyn $decoder) |]
143+ return (closure, insert)
144+ Just (origName, sdict `AppT` a) | sdict == serializableDict ->
145+ return ([], [| registerSerializableDict $(varE n) |])
146+ Just (origName, ForallT vars [] tp) -> do
147+ (closure, label) <- generatePolyClosure origName vars tp
148+ return (closure, [| registerLabel $(stringE label) (Dynamic (error "Polymorphic closure") (unsafeCoerce# $(varE origName))) |])
149+ _ ->
150+ fail $ "remotable: " ++ show n ++ " is not a function"
151+
152+-- | Generate the closure creator (see 'generateDefs')
153+generateClosure :: Name -> Q Type -> Q Type -> Q ([Dec], String)
154+generateClosure n arg res = do
155+ closure <- sequence
156+ [ sigD (closureName n) [t| $arg -> Closure $res |]
157+ , sfnD (closureName n) [| Closure (Static (UserStatic ($(stringE label)))) . encode |]
158+ ]
159+ return (closure, label)
160+ where
161+ label :: String
162+ label = show n
163+
164+-- | Generate a polymorphic closure
165+generatePolyClosure :: Name -> [TyVarBndr] -> Type -> Q ([Dec], String)
166+generatePolyClosure n xs typ = do
167+ closureTyp <- [t| Closure |]
168+ closure <- sequence
169+ [ sigD (closureName n) (return (ForallT xs (map typeable xs) (closureTyp `AppT` typ)) )
170+ , sfnD (closureName n) [| Closure (Static (PolyStatic ($(stringE label)))) (encode (typeOf (undefined :: $(return typ)))) |]
171+ ]
172+ return (closure, label)
173+ where
174+ label :: String
175+ label = show n
176+
177+ typeable :: TyVarBndr -> Pred
178+ typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
179+ typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
180+
181+-- | Generate the decoder (see 'generateDefs')
182+generateDecoder :: Name -> Q Type -> Q Exp
183+generateDecoder n res = [| $(varE n) . decode :: ByteString -> $res |]
184+
185+-- | The name for the function that generates the closure
186+closureName :: Name -> Name
187+closureName n = mkName $ nameBase n ++ "__closure"
188+
189+registerSerializableDict :: forall a. SerializableDict a -> RemoteTable -> RemoteTable
190+registerSerializableDict SerializableDict =
191+ let rss = RuntimeSerializableSupport {
192+ rssSend = toDyn (send :: ProcessId -> a -> Process ())
193+ , rssReturn = toDyn (return . decode :: ByteString -> Process a)
194+ , rssExpect = toDyn (expect :: Process a)
195+ }
196+ in remoteTableDict (typeOf (undefined :: a)) ^= Just rss
197+-}
198+
199+--------------------------------------------------------------------------------
200+-- Generic Template Haskell auxiliary functions --
201+--------------------------------------------------------------------------------
202+
203+-- | Compose a set of expressions
204+compose :: [Q Exp] -> Q Exp
205+compose [] = [| id |]
206+compose [e] = e
207+compose (e:es) = [| $e . $(compose es) |]
208+
209+-- | Literal string as an expression
210+stringE :: String -> Q Exp
211+stringE = litE . stringL
212+
213+-- | Look up the "original name" (module:name) and type of a top-level function
214+getType :: Name -> Q (Maybe (Name, Type))
215+getType name = do
216+ info <- reify name
217+ case info of
218+ VarI origName typ _ _ -> return $ Just (origName, typ)
219+ _ -> return Nothing
220+
221+-- | Variation on 'funD' which takes a single expression to define the function
222+sfnD :: Name -> Q Exp -> Q Dec
223+sfnD n e = funD n [clause [] (normalB e) []]
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hsnew file+81
@@ -0,0 +1,81 @@
1+-- | Reimplementation of Dynamic that supports dynBind
2+--
3+-- We don't have access to the internal representation of Dynamic, otherwise
4+-- we would not have to redefine it completely. Note that we use this only
5+-- internally, so the incompatibility with "our" Dynamic from the standard
6+-- Dynamic is not important.
7+{-# LANGUAGE MagicHash #-}
8+module Control.Distributed.Process.Internal.Dynamic
9+ ( Dynamic(..)
10+ , toDyn
11+ , fromDyn
12+ , fromDynamic
13+ , dynTypeRep
14+ , dynApply
15+ , dynApp
16+ , dynBind
17+ , dynBind'
18+ , GHC.unsafeCoerce#
19+ ) where
20+
21+import Data.Typeable
22+ ( Typeable
23+ , TypeRep
24+ , typeOf
25+ , funResultTy
26+ , TyCon
27+ , splitTyConApp
28+ )
29+import qualified GHC.Prim as GHC (Any, unsafeCoerce#)
30+import Data.Maybe (fromMaybe)
31+
32+data Dynamic = Dynamic TypeRep GHC.Any
33+ deriving Typeable
34+
35+toDyn :: Typeable a => a -> Dynamic
36+toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)
37+
38+fromDyn :: Typeable a => Dynamic -> a -> a
39+fromDyn (Dynamic rep val) a =
40+ if rep == typeOf a
41+ then GHC.unsafeCoerce# val
42+ else a
43+
44+fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a
45+fromDynamic (Dynamic rep val) =
46+ if rep == typeOf (undefined :: a)
47+ then Just (GHC.unsafeCoerce# val)
48+ else Nothing
49+
50+dynTypeRep :: Dynamic -> TypeRep
51+dynTypeRep (Dynamic t _) = t
52+
53+instance Show Dynamic where
54+ show = show . dynTypeRep
55+
56+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
57+dynApply (Dynamic t1 f) (Dynamic t2 x) =
58+ case funResultTy t1 t2 of
59+ Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))
60+ Nothing -> Nothing
61+
62+dynApp :: Dynamic -> Dynamic -> Dynamic
63+dynApp f x = fromMaybe (error typeError) (dynApply f x)
64+ where
65+ typeError = "Type error in dynamic application.\n"
66+ ++ "Can't apply function " ++ show f
67+ ++ " to argument " ++ show x
68+
69+dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic
70+dynBind m bind (Dynamic t1 x) (Dynamic t2 f) =
71+ case splitTyConApp t1 of
72+ (m', [a]) | m' == m ->
73+ case funResultTy t2 a of
74+ Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))
75+ _ -> Nothing
76+ _ -> Nothing
77+
78+dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic
79+dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)
80+ where
81+ typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f
distributed-process/src/Control/Distributed/Process/Internal/MessageT.hsnew file+130
@@ -0,0 +1,130 @@
1+-- | Add message sending capability to a monad
2+--
3+-- NOTE: Not thread-safe (you should not do concurrent sends within the same
4+-- monad).
5+module Control.Distributed.Process.Internal.MessageT
6+ ( MessageT
7+ , runMessageT
8+ , getLocalNode
9+ , sendPayload
10+ , sendBinary
11+ , sendMessage
12+ , payloadToMessage
13+ , createMessage
14+ ) where
15+
16+import Data.Binary (Binary, encode)
17+import qualified Data.ByteString as BSS (ByteString)
18+import qualified Data.ByteString.Lazy as BSL (toChunks)
19+import Data.Map (Map)
20+import qualified Data.Map as Map (empty)
21+import Data.Accessor (Accessor, accessor, (^=), (^.))
22+import qualified Data.Accessor.Container as DAC (mapMaybe)
23+import Control.Category ((>>>))
24+import Control.Monad (unless, liftM)
25+import Control.Monad.State (gets, modify, evalStateT)
26+import Control.Monad.IO.Class (MonadIO, liftIO)
27+import Control.Concurrent.Chan (writeChan)
28+import Control.Distributed.Process.Internal.Types
29+ ( Identifier(..)
30+ , nodeOf
31+ , NodeId(nodeAddress)
32+ , LocalNode(localCtrlChan, localEndPoint)
33+ , NCMsg(NCMsg, ctrlMsgSender, ctrlMsgSignal)
34+ , DiedReason(DiedDisconnect)
35+ , ProcessSignal(Died)
36+ , MessageT(..)
37+ , MessageState(..)
38+ , createMessage
39+ , messageToPayload
40+ , payloadToMessage
41+ )
42+import Control.Distributed.Process.Serializable (Serializable)
43+import qualified Network.Transport as NT
44+ ( EndPoint
45+ , Connection
46+ , connect
47+ , send
48+ , Reliability(ReliableOrdered)
49+ , defaultConnectHints
50+ )
51+
52+--------------------------------------------------------------------------------
53+-- API --
54+--------------------------------------------------------------------------------
55+
56+runMessageT :: Monad m => LocalNode -> MessageT m a -> m a
57+runMessageT localNode m =
58+ evalStateT (unMessageT m) $ initMessageState localNode
59+
60+getLocalNode :: Monad m => MessageT m LocalNode
61+getLocalNode = gets messageLocalNode
62+
63+sendPayload :: MonadIO m => Identifier -> [BSS.ByteString] -> MessageT m ()
64+sendPayload them payload = do
65+ mConn <- connTo them
66+ didSend <- case mConn of
67+ Just conn -> do
68+ didSend <- liftIO $ NT.send conn payload
69+ case didSend of
70+ Left _ -> return False
71+ Right _ -> return True
72+ Nothing -> return False
73+ unless didSend $ do
74+ node <- getLocalNode
75+ liftIO . writeChan (localCtrlChan node) $ NCMsg
76+ { ctrlMsgSender = them
77+ , ctrlMsgSignal = Died them DiedDisconnect
78+ }
79+
80+sendBinary :: (MonadIO m, Binary a) => Identifier -> a -> MessageT m ()
81+sendBinary them = sendPayload them . BSL.toChunks . encode
82+
83+sendMessage :: (MonadIO m, Serializable a) => Identifier -> a -> MessageT m ()
84+sendMessage them = sendPayload them . messageToPayload . createMessage
85+
86+--------------------------------------------------------------------------------
87+-- Internal --
88+--------------------------------------------------------------------------------
89+
90+initMessageState :: LocalNode -> MessageState
91+initMessageState localNode = MessageState {
92+ messageLocalNode = localNode
93+ , _messageConnections = Map.empty
94+ }
95+
96+setupConnTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
97+setupConnTo them = do
98+ endPoint <- localEndPoint `liftM` getLocalNode
99+ mConn <- liftIO $ NT.connect endPoint
100+ (nodeAddress . nodeOf $ them)
101+ NT.ReliableOrdered
102+ NT.defaultConnectHints
103+ case mConn of
104+ Right conn -> do
105+ didSend <- liftIO $ NT.send conn (BSL.toChunks . encode $ them)
106+ case didSend of
107+ Left _ ->
108+ return Nothing
109+ Right () -> do
110+ modify $ messageConnectionTo them ^= Just conn
111+ return $ Just conn
112+ Left _ ->
113+ return Nothing
114+
115+connTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
116+connTo them = do
117+ mConn <- gets (^. messageConnectionTo them)
118+ case mConn of
119+ Just conn -> return $ Just conn
120+ Nothing -> setupConnTo them
121+
122+--------------------------------------------------------------------------------
123+-- Accessors --
124+--------------------------------------------------------------------------------
125+
126+messageConnections :: Accessor MessageState (Map Identifier NT.Connection)
127+messageConnections = accessor _messageConnections (\conns st -> st { _messageConnections = conns })
128+
129+messageConnectionTo :: Identifier -> Accessor MessageState (Maybe NT.Connection)
130+messageConnectionTo them = messageConnections >>> DAC.mapMaybe them
distributed-process/src/Control/Distributed/Process/Internal/Node.hsnew file+16
@@ -0,0 +1,16 @@
1+module Control.Distributed.Process.Internal.Node
2+ ( runLocalProcess
3+ ) where
4+
5+import Control.Monad.Reader (runReaderT)
6+import Control.Distributed.Process.Internal.Types
7+ ( LocalNode
8+ , LocalProcess
9+ , Process(unProcess)
10+ )
11+import Control.Distributed.Process.Internal.MessageT (runMessageT)
12+
13+-- | Deconstructor for 'Process' (not exported to the public API)
14+runLocalProcess :: LocalNode -> Process a -> LocalProcess -> IO a
15+runLocalProcess node proc = runMessageT node . runReaderT (unProcess proc)
16+
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hsnew file+517
@@ -0,0 +1,517 @@
1+-- | Cloud Haskell primitives
2+--
3+-- We define these in a separate module so that we don't have to rely on
4+-- the closure combinators
5+module Control.Distributed.Process.Internal.Primitives
6+ ( -- * Basic messaging
7+ send
8+ , expect
9+ -- * Channels
10+ , newChan
11+ , sendChan
12+ , receiveChan
13+ , mergePortsBiased
14+ , mergePortsRR
15+ -- * Advanced messaging
16+ , Match
17+ , receiveWait
18+ , receiveTimeout
19+ , match
20+ , matchIf
21+ , matchUnknown
22+ -- * Process management
23+ , terminate
24+ , ProcessTerminationException(..)
25+ , getSelfPid
26+ , getSelfNode
27+ -- * Monitoring and linking
28+ , link
29+ , unlink
30+ , monitor
31+ , unmonitor
32+ -- * Logging
33+ , say
34+ -- * Registry
35+ , register
36+ , unregister
37+ , whereis
38+ , nsend
39+ , registerRemote
40+ , unregisterRemote
41+ , whereisRemote
42+ , whereisRemoteAsync
43+ , nsendRemote
44+ -- * Closures
45+ , unClosure
46+ -- * Auxiliary API
47+ , catch
48+ , expectTimeout
49+ , spawnAsync
50+ , linkNode
51+ , linkPort
52+ , unlinkNode
53+ , unlinkPort
54+ , monitorNode
55+ , monitorPort
56+ ) where
57+
58+import Prelude hiding (catch)
59+import Data.Binary (decode)
60+import Data.Typeable (Typeable, typeOf)
61+import Data.Time.Clock (getCurrentTime)
62+import Data.Time.Format (formatTime)
63+import System.Locale (defaultTimeLocale)
64+import Control.Monad.Reader (ask)
65+import Control.Monad.IO.Class (MonadIO, liftIO)
66+import Control.Applicative ((<$>))
67+import Control.Exception (Exception, throw)
68+import qualified Control.Exception as Exception (catch)
69+import Control.Concurrent.MVar (modifyMVar)
70+import Control.Concurrent.Chan (writeChan)
71+import Control.Concurrent.STM
72+ ( STM
73+ , atomically
74+ , orElse
75+ , newTChan
76+ , readTChan
77+ , newTVar
78+ , readTVar
79+ , writeTVar
80+ )
81+import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..))
82+import Control.Distributed.Process.Serializable (Serializable, fingerprint)
83+import Data.Accessor ((^.), (^:), (^=))
84+import Control.Distributed.Process.Internal.Types
85+ ( NodeId(..)
86+ , ProcessId(..)
87+ , LocalNode(..)
88+ , LocalProcess(..)
89+ , Process(..)
90+ , Closure(..)
91+ , Message(..)
92+ , MonitorRef(..)
93+ , SpawnRef(..)
94+ , NCMsg(..)
95+ , ProcessSignal(..)
96+ , monitorCounter
97+ , spawnCounter
98+ , Closure(..)
99+ , SendPort(..)
100+ , ReceivePort(..)
101+ , channelCounter
102+ , typedChannelWithId
103+ , TypedChannel(..)
104+ , SendPortId(..)
105+ , Identifier(..)
106+ , procMsg
107+ , DidUnmonitor(..)
108+ , DidUnlinkProcess(..)
109+ , DidUnlinkNode(..)
110+ , DidUnlinkPort(..)
111+ , WhereIsReply(..)
112+ , createMessage
113+ , Static(..)
114+ )
115+import Control.Distributed.Process.Internal.MessageT
116+ ( sendMessage
117+ , sendBinary
118+ , getLocalNode
119+ )
120+import Control.Distributed.Process.Internal.Node (runLocalProcess)
121+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
122+import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
123+
124+--------------------------------------------------------------------------------
125+-- Basic messaging --
126+--------------------------------------------------------------------------------
127+
128+-- | Send a message
129+send :: Serializable a => ProcessId -> a -> Process ()
130+-- This requires a lookup on every send. If we want to avoid that we need to
131+-- modify serializable to allow for stateful (IO) deserialization
132+send them msg = procMsg $ sendMessage (ProcessIdentifier them) msg
133+
134+-- | Wait for a message of a specific type
135+expect :: forall a. Serializable a => Process a
136+expect = receiveWait [match return]
137+
138+--------------------------------------------------------------------------------
139+-- Channels --
140+--------------------------------------------------------------------------------
141+
142+-- | Create a new typed channel
143+newChan :: Serializable a => Process (SendPort a, ReceivePort a)
144+newChan = do
145+ proc <- ask
146+ liftIO . modifyMVar (processState proc) $ \st -> do
147+ chan <- liftIO . atomically $ newTChan
148+ let lcid = st ^. channelCounter
149+ cid = SendPortId { sendPortProcessId = processId proc
150+ , sendPortLocalId = lcid
151+ }
152+ sport = SendPort cid
153+ rport = ReceivePortSingle chan
154+ tch = TypedChannel chan
155+ return ( (channelCounter ^: (+ 1))
156+ . (typedChannelWithId lcid ^= Just tch)
157+ $ st
158+ , (sport, rport)
159+ )
160+
161+-- | Send a message on a typed channel
162+sendChan :: Serializable a => SendPort a -> a -> Process ()
163+sendChan (SendPort cid) msg = procMsg $ sendBinary (SendPortIdentifier cid) msg
164+
165+-- | Wait for a message on a typed channel
166+receiveChan :: Serializable a => ReceivePort a -> Process a
167+receiveChan = liftIO . atomically . receiveSTM
168+ where
169+ receiveSTM :: ReceivePort a -> STM a
170+ receiveSTM (ReceivePortSingle c) =
171+ readTChan c
172+ receiveSTM (ReceivePortBiased ps) =
173+ foldr1 orElse (map receiveSTM ps)
174+ receiveSTM (ReceivePortRR psVar) = do
175+ ps <- readTVar psVar
176+ a <- foldr1 orElse (map receiveSTM ps)
177+ writeTVar psVar (rotate ps)
178+ return a
179+
180+ rotate :: [a] -> [a]
181+ rotate [] = []
182+ rotate (x:xs) = xs ++ [x]
183+
184+-- | Merge a list of typed channels.
185+--
186+-- The result port is left-biased: if there are messages available on more
187+-- than one port, the first available message is returned.
188+mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
189+mergePortsBiased = return . ReceivePortBiased
190+
191+-- | Like 'mergePortsBiased', but with a round-robin scheduler (rather than
192+-- left-biased)
193+mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
194+mergePortsRR ps = liftIO . atomically $ ReceivePortRR <$> newTVar ps
195+
196+--------------------------------------------------------------------------------
197+-- Advanced messaging --
198+--------------------------------------------------------------------------------
199+
200+-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
201+newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }
202+
203+-- | Test the matches in order against each message in the queue
204+receiveWait :: [Match b] -> Process b
205+receiveWait ms = do
206+ queue <- processQueue <$> ask
207+ Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
208+ proc
209+
210+-- | Like 'receiveWait' but with a timeout.
211+--
212+-- If the timeout is zero do a non-blocking check for matching messages. A
213+-- non-zero timeout is applied only when waiting for incoming messages (that is,
214+-- /after/ we have checked the messages that are already in the mailbox).
215+receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
216+receiveTimeout t ms = do
217+ queue <- processQueue <$> ask
218+ let blockSpec = if t == 0 then NonBlocking else Timeout t
219+ mProc <- liftIO $ dequeue queue blockSpec (map unMatch ms)
220+ case mProc of
221+ Nothing -> return Nothing
222+ Just proc -> Just <$> proc
223+
224+-- | Match against any message of the right type
225+match :: forall a b. Serializable a => (a -> Process b) -> Match b
226+match = matchIf (const True)
227+
228+-- | Match against any message of the right type that satisfies a predicate
229+matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
230+matchIf c p = Match $ \msg ->
231+ let decoded :: a
232+ decoded = decode . messageEncoding $ msg in
233+ if messageFingerprint msg == fingerprint (undefined :: a) && c decoded
234+ then Just $ p decoded
235+ else Nothing
236+
237+-- | Remove any message from the queue
238+matchUnknown :: Process b -> Match b
239+matchUnknown = Match . const . Just
240+
241+--------------------------------------------------------------------------------
242+-- Process management --
243+--------------------------------------------------------------------------------
244+
245+-- | Thrown by 'terminate'
246+data ProcessTerminationException = ProcessTerminationException
247+ deriving (Show, Typeable)
248+
249+instance Exception ProcessTerminationException
250+
251+-- | Terminate (throws a ProcessTerminationException)
252+terminate :: Process a
253+terminate = liftIO $ throw ProcessTerminationException
254+
255+-- | Our own process ID
256+getSelfPid :: Process ProcessId
257+getSelfPid = processId <$> ask
258+
259+-- | Get the node ID of our local node
260+getSelfNode :: Process NodeId
261+getSelfNode = localNodeId <$> procMsg getLocalNode
262+
263+--------------------------------------------------------------------------------
264+-- Monitoring and linking --
265+--------------------------------------------------------------------------------
266+
267+-- | Link to a remote process (asynchronous)
268+--
269+-- Note that 'link' provides unidirectional linking (see 'spawnSupervised').
270+-- Linking makes no distinction between normal and abnormal termination of
271+-- the remote process.
272+link :: ProcessId -> Process ()
273+link = sendCtrlMsg Nothing . Link . ProcessIdentifier
274+
275+-- | Monitor another process (asynchronous)
276+monitor :: ProcessId -> Process MonitorRef
277+monitor = monitor' . ProcessIdentifier
278+
279+-- | Remove a link (synchronous)
280+unlink :: ProcessId -> Process ()
281+unlink pid = do
282+ unlinkAsync pid
283+ receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
284+ (\_ -> return ())
285+ ]
286+
287+-- | Remove a node link (synchronous)
288+unlinkNode :: NodeId -> Process ()
289+unlinkNode nid = do
290+ unlinkNodeAsync nid
291+ receiveWait [ matchIf (\(DidUnlinkNode nid') -> nid' == nid)
292+ (\_ -> return ())
293+ ]
294+
295+-- | Remove a channel (send port) link (synchronous)
296+unlinkPort :: SendPort a -> Process ()
297+unlinkPort sport = do
298+ unlinkPortAsync sport
299+ receiveWait [ matchIf (\(DidUnlinkPort cid) -> cid == sendPortId sport)
300+ (\_ -> return ())
301+ ]
302+
303+-- | Remove a monitor (synchronous)
304+unmonitor :: MonitorRef -> Process ()
305+unmonitor ref = do
306+ unmonitorAsync ref
307+ receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)
308+ (\_ -> return ())
309+ ]
310+
311+--------------------------------------------------------------------------------
312+-- Auxiliary API --
313+--------------------------------------------------------------------------------
314+
315+-- | Catch exceptions within a process
316+catch :: Exception e => Process a -> (e -> Process a) -> Process a
317+catch p h = do
318+ node <- procMsg getLocalNode
319+ lproc <- ask
320+ let run :: Process a -> IO a
321+ run proc = runLocalProcess node proc lproc
322+ liftIO $ Exception.catch (run p) (run . h)
323+
324+-- | Like 'expect' but with a timeout
325+expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
326+expectTimeout timeout = receiveTimeout timeout [match return]
327+
328+-- | Asynchronous version of 'spawn'
329+--
330+-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
331+spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
332+spawnAsync nid proc = do
333+ spawnRef <- getSpawnRef
334+ sendCtrlMsg (Just nid) $ Spawn proc spawnRef
335+ return spawnRef
336+
337+-- | Monitor a node
338+monitorNode :: NodeId -> Process MonitorRef
339+monitorNode =
340+ monitor' . NodeIdentifier
341+
342+-- | Monitor a typed channel
343+monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
344+monitorPort (SendPort cid) =
345+ monitor' (SendPortIdentifier cid)
346+
347+-- | Remove a monitor (asynchronous)
348+unmonitorAsync :: MonitorRef -> Process ()
349+unmonitorAsync =
350+ sendCtrlMsg Nothing . Unmonitor
351+
352+-- | Link to a node
353+linkNode :: NodeId -> Process ()
354+linkNode = link' . NodeIdentifier
355+
356+-- | Link to a channel (send port)
357+linkPort :: SendPort a -> Process ()
358+linkPort (SendPort cid) =
359+ link' (SendPortIdentifier cid)
360+
361+-- | Remove a process link (asynchronous)
362+unlinkAsync :: ProcessId -> Process ()
363+unlinkAsync =
364+ sendCtrlMsg Nothing . Unlink . ProcessIdentifier
365+
366+-- | Remove a node link (asynchronous)
367+unlinkNodeAsync :: NodeId -> Process ()
368+unlinkNodeAsync =
369+ sendCtrlMsg Nothing . Unlink . NodeIdentifier
370+
371+-- | Remove a channel (send port) link (asynchronous)
372+unlinkPortAsync :: SendPort a -> Process ()
373+unlinkPortAsync (SendPort cid) =
374+ sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
375+
376+--------------------------------------------------------------------------------
377+-- Logging --
378+--------------------------------------------------------------------------------
379+
380+-- | Log a string
381+--
382+-- @say message@ sends a message (time, pid of the current process, message)
383+-- to the process registered as 'logger'. By default, this process simply
384+-- sends the string to 'stderr'. Individual Cloud Haskell backends might
385+-- replace this with a different logger process, however.
386+say :: String -> Process ()
387+say string = do
388+ now <- liftIO getCurrentTime
389+ us <- getSelfPid
390+ nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)
391+
392+--------------------------------------------------------------------------------
393+-- Registry --
394+--------------------------------------------------------------------------------
395+
396+-- | Register a process with the local registry (asynchronous).
397+--
398+-- The process to be registered does not have to be local itself.
399+register :: String -> ProcessId -> Process ()
400+register label pid =
401+ sendCtrlMsg Nothing (Register label (Just pid))
402+
403+-- | Register a process with a remote registry (asynchronous).
404+--
405+-- The process to be registered does not have to live on the same remote node.
406+registerRemote :: NodeId -> String -> ProcessId -> Process ()
407+registerRemote nid label pid =
408+ sendCtrlMsg (Just nid) (Register label (Just pid))
409+
410+-- | Remove a process from the local registry (asynchronous).
411+unregister :: String -> Process ()
412+unregister label =
413+ sendCtrlMsg Nothing (Register label Nothing)
414+
415+-- | Remove a process from a remote registry (asynchronous).
416+unregisterRemote :: NodeId -> String -> Process ()
417+unregisterRemote nid label =
418+ sendCtrlMsg (Just nid) (Register label Nothing)
419+
420+-- | Query the local process registry (synchronous).
421+whereis :: String -> Process (Maybe ProcessId)
422+whereis label = do
423+ sendCtrlMsg Nothing (WhereIs label)
424+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
425+ (\(WhereIsReply _ mPid) -> return mPid)
426+ ]
427+
428+-- | Query a remote process registry (synchronous)
429+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
430+whereisRemote nid label = do
431+ whereisRemoteAsync nid label
432+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')
433+ (\(WhereIsReply _ mPid) -> return mPid)
434+ ]
435+
436+-- | Query a remote process registry (asynchronous)
437+--
438+-- Reply will come in the form of a 'WhereIsReply' message
439+whereisRemoteAsync :: NodeId -> String -> Process ()
440+whereisRemoteAsync nid label =
441+ sendCtrlMsg (Just nid) (WhereIs label)
442+
443+-- | Named send to a process in the local registry (asynchronous)
444+nsend :: Serializable a => String -> a -> Process ()
445+nsend label msg =
446+ sendCtrlMsg Nothing (NamedSend label (createMessage msg))
447+
448+-- | Named send to a process in a remote registry (asynchronous)
449+nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
450+nsendRemote nid label msg =
451+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
452+
453+--------------------------------------------------------------------------------
454+-- Closures --
455+--------------------------------------------------------------------------------
456+
457+-- | Deserialize a closure
458+unClosure :: forall a. Typeable a => Closure a -> Process a
459+unClosure (Closure (Static label) env) = do
460+ rtable <- remoteTable <$> procMsg getLocalNode
461+ case resolveClosure rtable label env of
462+ Nothing -> throw . userError $ "Unregistered closure " ++ show label
463+ Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
464+ where
465+ typeError dyn = userError $ "lookupStatic type error: "
466+ ++ "cannot match " ++ show (dynTypeRep dyn)
467+ ++ " against " ++ show (typeOf (undefined :: a))
468+
469+--------------------------------------------------------------------------------
470+-- Auxiliary functions --
471+--------------------------------------------------------------------------------
472+
473+getMonitorRefFor :: Identifier -> Process MonitorRef
474+getMonitorRefFor ident = do
475+ proc <- ask
476+ liftIO $ modifyMVar (processState proc) $ \st -> do
477+ let counter = st ^. monitorCounter
478+ return ( monitorCounter ^: (+ 1) $ st
479+ , MonitorRef ident counter
480+ )
481+
482+getSpawnRef :: Process SpawnRef
483+getSpawnRef = do
484+ proc <- ask
485+ liftIO $ modifyMVar (processState proc) $ \st -> do
486+ let counter = st ^. spawnCounter
487+ return ( spawnCounter ^: (+ 1) $ st
488+ , SpawnRef counter
489+ )
490+
491+-- | Monitor a process/node/channel
492+monitor' :: Identifier -> Process MonitorRef
493+monitor' ident = do
494+ monitorRef <- getMonitorRefFor ident
495+ sendCtrlMsg Nothing $ Monitor monitorRef
496+ return monitorRef
497+
498+-- | Link to a process/node/channel
499+link' :: Identifier -> Process ()
500+link' = sendCtrlMsg Nothing . Link
501+
502+-- Send a control message
503+sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
504+ -> ProcessSignal -- ^ Message to send
505+ -> Process ()
506+sendCtrlMsg mNid signal = do
507+ us <- getSelfPid
508+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier us
509+ , ctrlMsgSignal = signal
510+ }
511+ case mNid of
512+ Nothing -> do
513+ ctrlChan <- localCtrlChan <$> procMsg getLocalNode
514+ liftIO $ writeChan ctrlChan msg
515+ Just nid ->
516+ procMsg $ sendBinary (NodeIdentifier nid) msg
517+
distributed-process/src/Control/Distributed/Process/Internal/TypeRep.hsnew file+21
@@ -0,0 +1,21 @@
1+-- | 'Binary' instances for 'TypeRep'
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module Control.Distributed.Process.Internal.TypeRep () where
4+
5+import Control.Applicative ((<$>), (<*>))
6+import Data.Binary (Binary(get, put))
7+import Data.Typeable.Internal (TypeRep(..), TyCon(..))
8+import GHC.Fingerprint.Type (Fingerprint(..))
9+
10+instance Binary Fingerprint where
11+ put (Fingerprint hi lo) = put hi >> put lo
12+ get = Fingerprint <$> get <*> get
13+
14+instance Binary TypeRep where
15+ put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts
16+ get = TypeRep <$> get <*> get <*> get
17+
18+instance Binary TyCon where
19+ put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name
20+ get = TyCon <$> get <*> get <*> get <*> get
21+
distributed-process/src/Control/Distributed/Process/Internal/Types.hsnew file+588
@@ -0,0 +1,588 @@
1+-- | Types used throughout the Cloud Haskell framework
2+--
3+-- We collect all types used internally in a single module because
4+-- many of these data types are mutually recursive and cannot be split across
5+-- modules.
6+{-# LANGUAGE MagicHash #-}
7+module Control.Distributed.Process.Internal.Types
8+ ( -- * Node and process identifiers
9+ NodeId(..)
10+ , LocalProcessId(..)
11+ , ProcessId(..)
12+ , Identifier(..)
13+ , nodeOf
14+ -- * Local nodes and processes
15+ , LocalNode(..)
16+ , LocalNodeState(..)
17+ , LocalProcess(..)
18+ , LocalProcessState(..)
19+ , Process(..)
20+ , procMsg
21+ -- * Typed channels
22+ , LocalSendPortId
23+ , SendPortId(..)
24+ , TypedChannel(..)
25+ , SendPort(..)
26+ , ReceivePort(..)
27+ -- * Closures
28+ , StaticLabel(..)
29+ , Static(..)
30+ , staticApply
31+ , Closure(..)
32+ , RemoteTable(..)
33+ , SerializableDict(..)
34+ -- * Messages
35+ , Message(..)
36+ , createMessage
37+ , messageToPayload
38+ , payloadToMessage
39+ -- * Node controller user-visible data types
40+ , MonitorRef(..)
41+ , ProcessMonitorNotification(..)
42+ , NodeMonitorNotification(..)
43+ , PortMonitorNotification(..)
44+ , ProcessLinkException(..)
45+ , NodeLinkException(..)
46+ , PortLinkException(..)
47+ , DiedReason(..)
48+ , DidUnmonitor(..)
49+ , DidUnlinkProcess(..)
50+ , DidUnlinkNode(..)
51+ , DidUnlinkPort(..)
52+ , SpawnRef(..)
53+ , DidSpawn(..)
54+ , WhereIsReply(..)
55+ -- * Node controller internal data types
56+ , NCMsg(..)
57+ , ProcessSignal(..)
58+ -- * MessageT monad
59+ , MessageT(..)
60+ , MessageState(..)
61+ -- * Accessors
62+ , localProcesses
63+ , localPidCounter
64+ , localPidUnique
65+ , localProcessWithId
66+ , monitorCounter
67+ , spawnCounter
68+ , channelCounter
69+ , typedChannels
70+ , typedChannelWithId
71+ , remoteTableLabels
72+ , remoteTableLabel
73+ ) where
74+
75+import Data.Map (Map)
76+import Data.Int (Int32)
77+import Data.Typeable (Typeable, TypeRep)
78+import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
79+import qualified Data.ByteString as BSS (ByteString, concat)
80+import qualified Data.ByteString.Lazy as BSL
81+ ( ByteString
82+ , toChunks
83+ , splitAt
84+ , fromChunks
85+ )
86+import Data.Accessor (Accessor, accessor)
87+import qualified Data.Accessor.Container as DAC (mapMaybe)
88+import Control.Category ((>>>))
89+import Control.Exception (Exception)
90+import Control.Concurrent (ThreadId)
91+import Control.Concurrent.MVar (MVar)
92+import Control.Concurrent.Chan (Chan)
93+import Control.Concurrent.STM (TChan, TVar)
94+import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
95+import Control.Applicative (Applicative, (<$>), (<*>))
96+import Control.Monad.Reader (MonadReader(..), ReaderT)
97+import Control.Monad.IO.Class (MonadIO)
98+import Control.Monad.State (MonadState, StateT)
99+import qualified Control.Monad.Trans.Class as Trans (lift)
100+import Control.Distributed.Process.Serializable
101+ ( Fingerprint
102+ , Serializable
103+ , fingerprint
104+ , encodeFingerprint
105+ , sizeOfFingerprint
106+ , decodeFingerprint
107+ , showFingerprint
108+ )
109+import Control.Distributed.Process.Internal.CQueue (CQueue)
110+import Control.Distributed.Process.Internal.Dynamic (Dynamic)
111+import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
112+
113+--------------------------------------------------------------------------------
114+-- Node and process identifiers --
115+--------------------------------------------------------------------------------
116+
117+-- | Node identifier
118+newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
119+ deriving (Eq, Ord, Binary)
120+
121+instance Show NodeId where
122+ show (NodeId addr) = "nid://" ++ show addr
123+
124+-- | A local process ID consists of a seed which distinguishes processes from
125+-- different instances of the same local node and a counter
126+data LocalProcessId = LocalProcessId
127+ { lpidUnique :: Int32
128+ , lpidCounter :: Int32
129+ }
130+ deriving (Eq, Ord, Typeable)
131+
132+instance Show LocalProcessId where
133+ show = show . lpidCounter
134+
135+-- | Process identifier
136+data ProcessId = ProcessId
137+ { -- | The ID of the node the process is running on
138+ processNodeId :: NodeId
139+ -- | Node-local identifier for the process
140+ , processLocalId :: LocalProcessId
141+ }
142+ deriving (Eq, Ord, Typeable)
143+
144+instance Show ProcessId where
145+ show (ProcessId (NodeId addr) (LocalProcessId _ lid))
146+ = "pid://" ++ show addr ++ ":" ++ show lid
147+
148+-- | Union of all kinds of identifiers
149+data Identifier =
150+ NodeIdentifier NodeId
151+ | ProcessIdentifier ProcessId
152+ | SendPortIdentifier SendPortId
153+ deriving (Eq, Ord)
154+
155+instance Show Identifier where
156+ show (NodeIdentifier nid) = show nid
157+ show (ProcessIdentifier pid) = show pid
158+ show (SendPortIdentifier cid) = show cid
159+
160+nodeOf :: Identifier -> NodeId
161+nodeOf (NodeIdentifier nid) = nid
162+nodeOf (ProcessIdentifier pid) = processNodeId pid
163+nodeOf (SendPortIdentifier cid) = processNodeId (sendPortProcessId cid)
164+
165+--------------------------------------------------------------------------------
166+-- Local nodes and processes --
167+--------------------------------------------------------------------------------
168+
169+-- | Local nodes
170+data LocalNode = LocalNode
171+ { -- | 'NodeId' of the node
172+ localNodeId :: NodeId
173+ -- | The network endpoint associated with this node
174+ , localEndPoint :: NT.EndPoint
175+ -- | Local node state
176+ , localState :: MVar LocalNodeState
177+ -- | Channel for the node controller
178+ , localCtrlChan :: Chan NCMsg
179+ -- | Runtime lookup table for supporting closures
180+ -- TODO: this should be part of the CH state, not the local endpoint state
181+ , remoteTable :: RemoteTable
182+ }
183+
184+-- | Local node state
185+data LocalNodeState = LocalNodeState
186+ { _localProcesses :: Map LocalProcessId LocalProcess
187+ , _localPidCounter :: Int32
188+ , _localPidUnique :: Int32
189+ }
190+
191+-- | Processes running on our local node
192+data LocalProcess = LocalProcess
193+ { processQueue :: CQueue Message
194+ , processId :: ProcessId
195+ , processState :: MVar LocalProcessState
196+ , processThread :: ThreadId
197+ }
198+
199+-- | Local process state
200+data LocalProcessState = LocalProcessState
201+ { _monitorCounter :: Int32
202+ , _spawnCounter :: Int32
203+ , _channelCounter :: Int32
204+ , _typedChannels :: Map LocalSendPortId TypedChannel
205+ }
206+
207+-- | The Cloud Haskell 'Process' type
208+newtype Process a = Process {
209+ unProcess :: ReaderT LocalProcess (MessageT IO) a
210+ }
211+ deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
212+
213+procMsg :: MessageT IO a -> Process a
214+procMsg = Process . Trans.lift
215+
216+--------------------------------------------------------------------------------
217+-- Typed channels --
218+--------------------------------------------------------------------------------
219+
220+type LocalSendPortId = Int32
221+
222+-- | A send port is identified by a SendPortId.
223+--
224+-- You cannot send directly to a SendPortId; instead, use 'newChan'
225+-- to create a SendPort.
226+data SendPortId = SendPortId {
227+ -- | The ID of the process that will receive messages sent on this port
228+ sendPortProcessId :: ProcessId
229+ -- | Process-local ID of the channel
230+ , sendPortLocalId :: LocalSendPortId
231+ }
232+ deriving (Eq, Ord)
233+
234+instance Show SendPortId where
235+ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
236+ = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
237+
238+data TypedChannel = forall a. Serializable a => TypedChannel (TChan a)
239+
240+-- | The send send of a typed channel (serializable)
241+newtype SendPort a = SendPort {
242+ -- | The (unique) ID of this send port
243+ sendPortId :: SendPortId
244+ }
245+ deriving (Typeable, Binary, Show, Eq, Ord)
246+
247+-- | The receive end of a typed channel (not serializable)
248+data ReceivePort a =
249+ -- | A single receive port
250+ ReceivePortSingle (TChan a)
251+ -- | A left-biased combination of receive ports
252+ | ReceivePortBiased [ReceivePort a]
253+ -- | A round-robin combination of receive ports
254+ | ReceivePortRR (TVar [ReceivePort a])
255+ deriving Typeable
256+
257+--------------------------------------------------------------------------------
258+-- Closures --
259+--------------------------------------------------------------------------------
260+
261+data StaticLabel =
262+ StaticLabel String TypeRep
263+ | StaticApply StaticLabel StaticLabel
264+ deriving (Typeable, Show)
265+
266+-- | A static value is top-level bound or the application of two static values
267+newtype Static a = Static StaticLabel
268+ deriving (Typeable, Show)
269+
270+-- | Apply two static values
271+staticApply :: Static (a -> b) -> Static a -> Static b
272+staticApply (Static f) (Static x) = Static (StaticApply f x)
273+
274+-- | A closure is a static value and an encoded environment
275+data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString
276+ deriving (Typeable, Show)
277+
278+-- | Runtime dictionary for 'unstatic' lookups
279+data RemoteTable = RemoteTable {
280+ _remoteTableLabels :: Map String Dynamic
281+ }
282+
283+-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")
284+data SerializableDict a where
285+ SerializableDict :: Serializable a => SerializableDict a
286+ deriving (Typeable)
287+
288+--------------------------------------------------------------------------------
289+-- Messages --
290+--------------------------------------------------------------------------------
291+
292+-- | Messages consist of their typeRep fingerprint and their encoding
293+data Message = Message
294+ { messageFingerprint :: Fingerprint
295+ , messageEncoding :: BSL.ByteString
296+ }
297+
298+instance Show Message where
299+ show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
300+
301+-- | Turn any serialiable term into a message
302+createMessage :: Serializable a => a -> Message
303+createMessage a = Message (fingerprint a) (encode a)
304+
305+-- | Serialize a message
306+messageToPayload :: Message -> [BSS.ByteString]
307+messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc
308+
309+-- | Deserialize a message
310+payloadToMessage :: [BSS.ByteString] -> Message
311+payloadToMessage payload = Message fp msg
312+ where
313+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
314+ $ BSL.fromChunks payload
315+ fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
316+
317+--------------------------------------------------------------------------------
318+-- Node controller user-visible data types --
319+--------------------------------------------------------------------------------
320+
321+-- | MonitorRef is opaque for regular Cloud Haskell processes
322+data MonitorRef = MonitorRef
323+ { -- | ID of the entity to be monitored
324+ monitorRefIdent :: Identifier
325+ -- | Unique to distinguish multiple monitor requests by the same process
326+ , monitorRefCounter :: Int32
327+ }
328+ deriving (Eq, Ord, Show)
329+
330+-- | Message sent by process monitors
331+data ProcessMonitorNotification =
332+ ProcessMonitorNotification MonitorRef ProcessId DiedReason
333+ deriving (Typeable, Show)
334+
335+-- | Message sent by node monitors
336+data NodeMonitorNotification =
337+ NodeMonitorNotification MonitorRef NodeId DiedReason
338+ deriving (Typeable, Show)
339+
340+-- | Message sent by channel (port) monitors
341+data PortMonitorNotification =
342+ PortMonitorNotification MonitorRef SendPortId DiedReason
343+ deriving (Typeable, Show)
344+
345+-- | Exceptions thrown when a linked process dies
346+data ProcessLinkException =
347+ ProcessLinkException ProcessId DiedReason
348+ deriving (Typeable, Show)
349+
350+-- | Exception thrown when a linked node dies
351+data NodeLinkException =
352+ NodeLinkException NodeId DiedReason
353+ deriving (Typeable, Show)
354+
355+-- | Exception thrown when a linked channel (port) dies
356+data PortLinkException =
357+ PortLinkException SendPortId DiedReason
358+ deriving (Typeable, Show)
359+
360+instance Exception ProcessLinkException
361+instance Exception NodeLinkException
362+instance Exception PortLinkException
363+
364+-- | Why did a process die?
365+data DiedReason =
366+ -- | Normal termination
367+ DiedNormal
368+ -- | The process exited with an exception
369+ -- (provided as 'String' because 'Exception' does not implement 'Binary')
370+ | DiedException String
371+ -- | We got disconnected from the process node
372+ | DiedDisconnect
373+ -- | The process node died
374+ | DiedNodeDown
375+ -- | Invalid (process/node/channel) identifier
376+ | DiedUnknownId
377+ deriving (Show, Eq)
378+
379+-- | (Asynchronous) reply from unmonitor
380+newtype DidUnmonitor = DidUnmonitor MonitorRef
381+ deriving (Typeable, Binary)
382+
383+-- | (Asynchronous) reply from unlink
384+newtype DidUnlinkProcess = DidUnlinkProcess ProcessId
385+ deriving (Typeable, Binary)
386+
387+-- | (Asynchronous) reply from unlinkNode
388+newtype DidUnlinkNode = DidUnlinkNode NodeId
389+ deriving (Typeable, Binary)
390+
391+-- | (Asynchronous) reply from unlinkPort
392+newtype DidUnlinkPort = DidUnlinkPort SendPortId
393+ deriving (Typeable, Binary)
394+
395+-- | 'SpawnRef' are used to return pids of spawned processes
396+newtype SpawnRef = SpawnRef Int32
397+ deriving (Show, Binary, Typeable, Eq)
398+
399+-- | (Asynchronius) reply from 'spawn'
400+data DidSpawn = DidSpawn SpawnRef ProcessId
401+ deriving (Show, Typeable)
402+
403+-- | (Asynchronous) reply from 'whereis'
404+data WhereIsReply = WhereIsReply String (Maybe ProcessId)
405+ deriving (Show, Typeable)
406+
407+--------------------------------------------------------------------------------
408+-- Node controller internal data types --
409+--------------------------------------------------------------------------------
410+
411+-- | Messages to the node controller
412+data NCMsg = NCMsg
413+ { ctrlMsgSender :: Identifier
414+ , ctrlMsgSignal :: ProcessSignal
415+ }
416+ deriving Show
417+
418+-- | Signals to the node controller (see 'NCMsg')
419+data ProcessSignal =
420+ Link Identifier
421+ | Unlink Identifier
422+ | Monitor MonitorRef
423+ | Unmonitor MonitorRef
424+ | Died Identifier DiedReason
425+ | Spawn (Closure (Process ())) SpawnRef
426+ | WhereIs String
427+ | Register String (Maybe ProcessId) -- Nothing to unregister
428+ | NamedSend String Message
429+ deriving Show
430+
431+--------------------------------------------------------------------------------
432+-- Binary instances --
433+--------------------------------------------------------------------------------
434+
435+instance Binary LocalProcessId where
436+ put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)
437+ get = LocalProcessId <$> get <*> get
438+
439+instance Binary ProcessId where
440+ put pid = put (processNodeId pid) >> put (processLocalId pid)
441+ get = ProcessId <$> get <*> get
442+
443+instance Binary ProcessMonitorNotification where
444+ put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason
445+ get = ProcessMonitorNotification <$> get <*> get <*> get
446+
447+instance Binary NodeMonitorNotification where
448+ put (NodeMonitorNotification ref pid reason) = put ref >> put pid >> put reason
449+ get = NodeMonitorNotification <$> get <*> get <*> get
450+
451+instance Binary PortMonitorNotification where
452+ put (PortMonitorNotification ref pid reason) = put ref >> put pid >> put reason
453+ get = PortMonitorNotification <$> get <*> get <*> get
454+
455+instance Binary NCMsg where
456+ put msg = put (ctrlMsgSender msg) >> put (ctrlMsgSignal msg)
457+ get = NCMsg <$> get <*> get
458+
459+instance Binary MonitorRef where
460+ put ref = put (monitorRefIdent ref) >> put (monitorRefCounter ref)
461+ get = MonitorRef <$> get <*> get
462+
463+instance Binary ProcessSignal where
464+ put (Link pid) = putWord8 0 >> put pid
465+ put (Unlink pid) = putWord8 1 >> put pid
466+ put (Monitor ref) = putWord8 2 >> put ref
467+ put (Unmonitor ref) = putWord8 3 >> put ref
468+ put (Died who reason) = putWord8 4 >> put who >> put reason
469+ put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
470+ put (WhereIs label) = putWord8 6 >> put label
471+ put (Register label pid) = putWord8 7 >> put label >> put pid
472+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
473+ get = do
474+ header <- getWord8
475+ case header of
476+ 0 -> Link <$> get
477+ 1 -> Unlink <$> get
478+ 2 -> Monitor <$> get
479+ 3 -> Unmonitor <$> get
480+ 4 -> Died <$> get <*> get
481+ 5 -> Spawn <$> get <*> get
482+ 6 -> WhereIs <$> get
483+ 7 -> Register <$> get <*> get
484+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
485+ _ -> fail "ProcessSignal.get: invalid"
486+
487+instance Binary DiedReason where
488+ put DiedNormal = putWord8 0
489+ put (DiedException e) = putWord8 1 >> put e
490+ put DiedDisconnect = putWord8 2
491+ put DiedNodeDown = putWord8 3
492+ put DiedUnknownId = putWord8 4
493+ get = do
494+ header <- getWord8
495+ case header of
496+ 0 -> return DiedNormal
497+ 1 -> DiedException <$> get
498+ 2 -> return DiedDisconnect
499+ 3 -> return DiedNodeDown
500+ 4 -> return DiedUnknownId
501+ _ -> fail "DiedReason.get: invalid"
502+
503+instance Binary (Closure a) where
504+ put (Closure (Static label) env) = put label >> put env
505+ get = Closure <$> (Static <$> get) <*> get
506+
507+instance Binary DidSpawn where
508+ put (DidSpawn ref pid) = put ref >> put pid
509+ get = DidSpawn <$> get <*> get
510+
511+instance Binary SendPortId where
512+ put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
513+ get = SendPortId <$> get <*> get
514+
515+instance Binary Identifier where
516+ put (ProcessIdentifier pid) = putWord8 0 >> put pid
517+ put (NodeIdentifier nid) = putWord8 1 >> put nid
518+ put (SendPortIdentifier cid) = putWord8 2 >> put cid
519+ get = do
520+ header <- getWord8
521+ case header of
522+ 0 -> ProcessIdentifier <$> get
523+ 1 -> NodeIdentifier <$> get
524+ 2 -> SendPortIdentifier <$> get
525+ _ -> fail "Identifier.get: invalid"
526+
527+instance Binary StaticLabel where
528+ put (StaticLabel string typ) = putWord8 0 >> put string >> put typ
529+ put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2
530+ get = do
531+ header <- getWord8
532+ case header of
533+ 0 -> StaticLabel <$> get <*> get
534+ 1 -> StaticApply <$> get <*> get
535+ _ -> fail "StaticLabel.get: invalid"
536+
537+instance Binary WhereIsReply where
538+ put (WhereIsReply label mPid) = put label >> put mPid
539+ get = WhereIsReply <$> get <*> get
540+
541+--------------------------------------------------------------------------------
542+-- Accessors --
543+--------------------------------------------------------------------------------
544+
545+localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)
546+localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs })
547+
548+localPidCounter :: Accessor LocalNodeState Int32
549+localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr })
550+
551+localPidUnique :: Accessor LocalNodeState Int32
552+localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
553+
554+localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
555+localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
556+
557+monitorCounter :: Accessor LocalProcessState Int32
558+monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
559+
560+spawnCounter :: Accessor LocalProcessState Int32
561+spawnCounter = accessor _spawnCounter (\cnt st -> st { _spawnCounter = cnt })
562+
563+channelCounter :: Accessor LocalProcessState LocalSendPortId
564+channelCounter = accessor _channelCounter (\cnt st -> st { _channelCounter = cnt })
565+
566+typedChannels :: Accessor LocalProcessState (Map LocalSendPortId TypedChannel)
567+typedChannels = accessor _typedChannels (\cs st -> st { _typedChannels = cs })
568+
569+typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel)
570+typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid
571+
572+remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)
573+remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })
574+
575+remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
576+remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label
577+
578+--------------------------------------------------------------------------------
579+-- MessageT monad --
580+--------------------------------------------------------------------------------
581+
582+newtype MessageT m a = MessageT { unMessageT :: StateT MessageState m a }
583+ deriving (Functor, Monad, MonadIO, MonadState MessageState, Applicative)
584+
585+data MessageState = MessageState {
586+ messageLocalNode :: LocalNode
587+ , _messageConnections :: Map Identifier NT.Connection
588+ }
distributed-process/src/Control/Distributed/Process/Node.hsnew file+698
@@ -0,0 +1,698 @@
1+-- | Local nodes
2+module Control.Distributed.Process.Node
3+ ( LocalNode
4+ , newLocalNode
5+ , closeLocalNode
6+ , forkProcess
7+ , runProcess
8+ , initRemoteTable
9+ , localNodeId
10+ ) where
11+
12+import Prelude hiding (catch)
13+import System.IO (fixIO, hPutStrLn, stderr)
14+import qualified Data.ByteString.Lazy as BSL (fromChunks)
15+import Data.Binary (decode)
16+import Data.Map (Map)
17+import qualified Data.Map as Map
18+ ( empty
19+ , lookup
20+ , insert
21+ , delete
22+ , toList
23+ , partitionWithKey
24+ , filterWithKey
25+ )
26+import qualified Data.List as List (delete, (\\))
27+import Data.Set (Set)
28+import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)
29+import Data.Foldable (forM_)
30+import Data.Maybe (isJust, fromMaybe)
31+import Data.Typeable (Typeable)
32+import Control.Category ((>>>))
33+import Control.Applicative ((<$>))
34+import Control.Monad (void, when, forever)
35+import Control.Monad.IO.Class (MonadIO, liftIO)
36+import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
37+import qualified Control.Monad.Trans.Class as Trans (lift)
38+import Control.Exception (throwIO, SomeException, Exception, throwTo)
39+import qualified Control.Exception as Exception (catch)
40+import Control.Concurrent (forkIO)
41+import Control.Concurrent.MVar
42+ ( newMVar
43+ , withMVar
44+ , modifyMVar
45+ , modifyMVar_
46+ , newEmptyMVar
47+ , putMVar
48+ , takeMVar
49+ )
50+import Control.Concurrent.Chan (newChan, writeChan, readChan)
51+import Control.Concurrent.STM (atomically, writeTChan)
52+import Control.Distributed.Process.Internal.CQueue (enqueue, newCQueue)
53+import qualified Network.Transport as NT
54+ ( Transport
55+ , EndPoint
56+ , newEndPoint
57+ , receive
58+ , Event(..)
59+ , EventErrorCode(..)
60+ , TransportError(..)
61+ , address
62+ , closeEndPoint
63+ , ConnectionId
64+ )
65+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
66+import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)
67+import System.Random (randomIO)
68+import Control.Distributed.Process.Internal.Types
69+ ( RemoteTable
70+ , NodeId(..)
71+ , LocalProcessId(..)
72+ , ProcessId(..)
73+ , LocalNode(..)
74+ , LocalNodeState(..)
75+ , LocalProcess(..)
76+ , LocalProcessState(..)
77+ , Process(..)
78+ , DiedReason(..)
79+ , NCMsg(..)
80+ , ProcessSignal(..)
81+ , localPidCounter
82+ , localPidUnique
83+ , localProcessWithId
84+ , MonitorRef(..)
85+ , ProcessMonitorNotification(..)
86+ , NodeMonitorNotification(..)
87+ , PortMonitorNotification(..)
88+ , ProcessLinkException(..)
89+ , NodeLinkException(..)
90+ , PortLinkException(..)
91+ , DidUnmonitor(..)
92+ , DidUnlinkProcess(..)
93+ , DidUnlinkNode(..)
94+ , DidUnlinkPort(..)
95+ , SpawnRef
96+ , DidSpawn(..)
97+ , Closure(..)
98+ , Static(..)
99+ , Message
100+ , MessageT
101+ , TypedChannel(..)
102+ , Identifier(..)
103+ , nodeOf
104+ , SendPortId(..)
105+ , typedChannelWithId
106+ , WhereIsReply(..)
107+ , messageToPayload
108+ , RemoteTable(..)
109+ )
110+import Control.Distributed.Process.Serializable (Serializable)
111+import Control.Distributed.Process.Internal.MessageT
112+ ( sendBinary
113+ , sendMessage
114+ , sendPayload
115+ , getLocalNode
116+ , runMessageT
117+ , payloadToMessage
118+ , createMessage
119+ )
120+import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
121+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
122+import Control.Distributed.Process.Internal.Node (runLocalProcess)
123+import Control.Distributed.Process.Internal.Primitives (expect, register)
124+import qualified Control.Distributed.Process.Internal.Closure.Derived as Derived (__remoteTable)
125+
126+--------------------------------------------------------------------------------
127+-- Initialization --
128+--------------------------------------------------------------------------------
129+
130+initRemoteTable :: RemoteTable
131+initRemoteTable = Derived.__remoteTable $ RemoteTable Map.empty
132+
133+-- | Initialize a new local node.
134+--
135+-- Note that proper Cloud Haskell initialization and configuration is still
136+-- to do.
137+newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode
138+newLocalNode transport rtable = do
139+ mEndPoint <- NT.newEndPoint transport
140+ case mEndPoint of
141+ Left ex -> throwIO ex
142+ Right endPoint -> do
143+ localNode <- createBareLocalNode endPoint rtable
144+ startServiceProcesses localNode
145+ return localNode
146+
147+-- | Create a new local node (without any service processes running)
148+createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
149+createBareLocalNode endPoint rtable = do
150+ unq <- randomIO
151+ state <- newMVar LocalNodeState
152+ { _localProcesses = Map.empty
153+ , _localPidCounter = 0
154+ , _localPidUnique = unq
155+ }
156+ ctrlChan <- newChan
157+ let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
158+ , localEndPoint = endPoint
159+ , localState = state
160+ , localCtrlChan = ctrlChan
161+ , remoteTable = rtable
162+ }
163+ void . forkIO $ runNodeController node
164+ void . forkIO $ handleIncomingMessages node
165+ return node
166+
167+-- | Start and register the service processes on a node
168+-- (for now, this is only the logger)
169+startServiceProcesses :: LocalNode -> IO ()
170+startServiceProcesses node = do
171+ logger <- forkProcess node . forever $ do
172+ (time, pid, string) <- expect :: Process (String, ProcessId, String)
173+ liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
174+ runProcess node $ register "logger" logger
175+
176+-- | Force-close a local node
177+--
178+-- TODO: for now we just close the associated endpoint
179+closeLocalNode :: LocalNode -> IO ()
180+closeLocalNode node =
181+ NT.closeEndPoint (localEndPoint node)
182+
183+-- | Run a process on a local node and wait for it to finish
184+runProcess :: LocalNode -> Process () -> IO ()
185+runProcess node proc = do
186+ done <- newEmptyMVar
187+ void $ forkProcess node (proc >> liftIO (putMVar done ()))
188+ takeMVar done
189+
190+-- | Spawn a new process on a local node
191+forkProcess :: LocalNode -> Process () -> IO ProcessId
192+forkProcess node proc = modifyMVar (localState node) $ \st -> do
193+ let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter
194+ , lpidUnique = st ^. localPidUnique
195+ }
196+ let pid = ProcessId { processNodeId = localNodeId node
197+ , processLocalId = lpid
198+ }
199+ pst <- newMVar LocalProcessState { _monitorCounter = 0
200+ , _spawnCounter = 0
201+ , _channelCounter = 0
202+ , _typedChannels = Map.empty
203+ }
204+ queue <- newCQueue
205+ (_, lproc) <- fixIO $ \ ~(tid, _) -> do
206+ let lproc = LocalProcess { processQueue = queue
207+ , processId = pid
208+ , processState = pst
209+ , processThread = tid
210+ }
211+ tid' <- forkIO $ do
212+ reason <- Exception.catch
213+ (runLocalProcess node proc lproc >> return DiedNormal)
214+ (return . DiedException . (show :: SomeException -> String))
215+ -- [Unified: Table 4, rules termination and exiting]
216+ modifyMVar_ (localState node) $
217+ return . (localProcessWithId lpid ^= Nothing)
218+ writeChan (localCtrlChan node) NCMsg
219+ { ctrlMsgSender = ProcessIdentifier pid
220+ , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
221+ }
222+ return (tid', lproc)
223+
224+ if lpidCounter lpid == maxBound
225+ then do
226+ newUnique <- randomIO
227+ return ( (localProcessWithId lpid ^= Just lproc)
228+ . (localPidCounter ^= 0)
229+ . (localPidUnique ^= newUnique)
230+ $ st
231+ , pid
232+ )
233+ else
234+ return ( (localProcessWithId lpid ^= Just lproc)
235+ . (localPidCounter ^: (+ 1))
236+ $ st
237+ , pid
238+ )
239+
240+handleIncomingMessages :: LocalNode -> IO ()
241+handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
242+ where
243+ go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know
244+ -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes
245+ -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels
246+ -> Set NT.ConnectionId -- ^ Connections to our controller
247+ -> IO ()
248+ go uninitConns procs chans ctrls = do
249+ event <- NT.receive endpoint
250+ case event of
251+ NT.ConnectionOpened cid _rel _theirAddr ->
252+ -- TODO: Check if _rel is ReliableOrdered, and if not, treat as
253+ -- (**) below.
254+ go (cid : uninitConns) procs chans ctrls
255+ NT.Received cid payload ->
256+ case ( Map.lookup cid procs
257+ , Map.lookup cid chans
258+ , cid `Set.member` ctrls
259+ , cid `elem` uninitConns
260+ ) of
261+ (Just proc, _, _, _) -> do
262+ let msg = payloadToMessage payload
263+ enqueue (processQueue proc) msg
264+ go uninitConns procs chans ctrls
265+ (_, Just (TypedChannel chan), _, _) -> do
266+ atomically $ writeTChan chan . decode . BSL.fromChunks $ payload
267+ go uninitConns procs chans ctrls
268+ (_, _, True, _) -> do
269+ let ctrlMsg = decode . BSL.fromChunks $ payload
270+ writeChan ctrlChan ctrlMsg
271+ go uninitConns procs chans ctrls
272+ (_, _, _, True) ->
273+ case decode (BSL.fromChunks payload) of
274+ ProcessIdentifier pid -> do
275+ let lpid = processLocalId pid
276+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)
277+ case mProc of
278+ Just proc ->
279+ go (List.delete cid uninitConns)
280+ (Map.insert cid proc procs)
281+ chans
282+ ctrls
283+ Nothing ->
284+ -- Request for an unknown process.
285+ --
286+ -- TODO: We should treat this as a fatal error on the
287+ -- part of the remote node. That is, we should report the
288+ -- remote node as having died, and we should close
289+ -- incoming connections (this requires a Transport layer
290+ -- extension). (**)
291+ go (List.delete cid uninitConns) procs chans ctrls
292+ SendPortIdentifier chId -> do
293+ let lcid = sendPortLocalId chId
294+ lpid = processLocalId (sendPortProcessId chId)
295+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)
296+ case mProc of
297+ Just proc -> do
298+ mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
299+ case mChannel of
300+ Just channel ->
301+ go (List.delete cid uninitConns)
302+ procs
303+ (Map.insert cid channel chans)
304+ ctrls
305+ Nothing ->
306+ -- Unknown typed channel
307+ -- TODO (**) above
308+ go (List.delete cid uninitConns) procs chans ctrls
309+ Nothing ->
310+ -- Unknown process
311+ -- TODO (**) above
312+ go (List.delete cid uninitConns) procs chans ctrls
313+ NodeIdentifier _ ->
314+ go (List.delete cid uninitConns)
315+ procs
316+ chans
317+ (Set.insert cid ctrls)
318+ _ ->
319+ -- Unexpected message
320+ -- TODO (**) above
321+ go uninitConns procs chans ctrls
322+ NT.ConnectionClosed cid ->
323+ go (List.delete cid uninitConns)
324+ (Map.delete cid procs)
325+ (Map.delete cid chans)
326+ (Set.delete cid ctrls)
327+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost (Just theirAddr) cids) _) -> do
328+ -- [Unified table 9, rule node_disconnect]
329+ let nid = NodeIdentifier $ NodeId theirAddr
330+ writeChan ctrlChan NCMsg
331+ { ctrlMsgSender = nid
332+ , ctrlMsgSignal = Died nid DiedDisconnect
333+ }
334+ go (uninitConns List.\\ cids)
335+ (Map.filterWithKey (\k _ -> k `notElem` cids) procs)
336+ (Map.filterWithKey (\k _ -> k `notElem` cids) chans)
337+ (ctrls Set.\\ Set.fromList cids)
338+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->
339+ -- TODO: We should treat an asymetrical connection loss (incoming
340+ -- connection broken, but outgoing connection still potentially ok)
341+ -- as a fatal error on the part of the remote node (like (**), above)
342+ fail "handleIncomingMessages: TODO"
343+ NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
344+ fail $ "Cloud Haskell fatal error: end point failed: " ++ str
345+ NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
346+ fail $ "Cloud Haskell fatal error: transport failed: " ++ str
347+ NT.EndPointClosed ->
348+ return ()
349+ NT.ReceivedMulticast _ _ ->
350+ -- If we received a multicast message, something went horribly wrong
351+ -- and we just give up
352+ fail "Cloud Haskell fatal error: received unexpected multicast"
353+
354+ state = localState node
355+ endpoint = localEndPoint node
356+ ctrlChan = localCtrlChan node
357+
358+--------------------------------------------------------------------------------
359+-- Top-level access to the node controller --
360+--------------------------------------------------------------------------------
361+
362+runNodeController :: LocalNode -> IO ()
363+runNodeController node =
364+ runMessageT node (evalStateT (unNC nodeController) initNCState)
365+
366+--------------------------------------------------------------------------------
367+-- Internal data types --
368+--------------------------------------------------------------------------------
369+
370+data NCState = NCState
371+ { -- Mapping from remote processes to linked local processes
372+ _links :: Map Identifier (Set ProcessId)
373+ -- Mapping from remote processes to monitoring local processes
374+ , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))
375+ -- Process registry
376+ , _registry :: Map String ProcessId
377+ }
378+
379+newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }
380+ deriving (Functor, Monad, MonadIO, MonadState NCState)
381+
382+ncMsg :: MessageT IO a -> NC a
383+ncMsg = NC . Trans.lift
384+
385+initNCState :: NCState
386+initNCState = NCState { _links = Map.empty
387+ , _monitors = Map.empty
388+ , _registry = Map.empty
389+ }
390+
391+--------------------------------------------------------------------------------
392+-- Core functionality --
393+--------------------------------------------------------------------------------
394+
395+-- [Unified: Table 7]
396+nodeController :: NC ()
397+nodeController = do
398+ node <- ncMsg getLocalNode
399+ forever $ do
400+ msg <- liftIO $ readChan (localCtrlChan node)
401+
402+ -- [Unified: Table 7, rule nc_forward]
403+ case destNid (ctrlMsgSignal msg) of
404+ Just nid' | nid' /= localNodeId node ->
405+ ncMsg $ sendBinary (NodeIdentifier nid') msg
406+ _ ->
407+ return ()
408+
409+ case msg of
410+ NCMsg (ProcessIdentifier from) (Link them) ->
411+ ncEffectMonitor from them Nothing
412+ NCMsg (ProcessIdentifier from) (Monitor ref) ->
413+ ncEffectMonitor from (monitorRefIdent ref) (Just ref)
414+ NCMsg (ProcessIdentifier from) (Unlink them) ->
415+ ncEffectUnlink from them
416+ NCMsg (ProcessIdentifier from) (Unmonitor ref) ->
417+ ncEffectUnmonitor from ref
418+ NCMsg _from (Died ident reason) ->
419+ ncEffectDied ident reason
420+ NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
421+ ncEffectSpawn from proc ref
422+ NCMsg _from (Register label pid) ->
423+ ncEffectRegister label pid
424+ NCMsg (ProcessIdentifier from) (WhereIs label) ->
425+ ncEffectWhereIs from label
426+ NCMsg from (NamedSend label msg') ->
427+ ncEffectNamedSend from label msg'
428+ unexpected ->
429+ error $ "nodeController: unexpected message " ++ show unexpected
430+
431+-- [Unified: Table 10]
432+ncEffectMonitor :: ProcessId -- ^ Who's watching?
433+ -> Identifier -- ^ Who's being watched?
434+ -> Maybe MonitorRef -- ^ 'Nothing' to link
435+ -> NC ()
436+ncEffectMonitor from them mRef = do
437+ node <- ncMsg getLocalNode
438+ shouldLink <-
439+ if not (isLocal node them)
440+ then return True
441+ else isValidLocalIdentifier them
442+ case (shouldLink, isLocal node (ProcessIdentifier from)) of
443+ (True, _) -> -- [Unified: first rule]
444+ case mRef of
445+ Just ref -> modify $ monitorsFor them ^: Set.insert (from, ref)
446+ Nothing -> modify $ linksFor them ^: Set.insert from
447+ (False, True) -> -- [Unified: second rule]
448+ notifyDied from them DiedUnknownId mRef
449+ (False, False) -> -- [Unified: third rule]
450+ ncMsg $ sendBinary (NodeIdentifier $ processNodeId from) NCMsg
451+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
452+ , ctrlMsgSignal = Died them DiedUnknownId
453+ }
454+
455+-- [Unified: Table 11]
456+ncEffectUnlink :: ProcessId -> Identifier -> NC ()
457+ncEffectUnlink from them = do
458+ node <- ncMsg getLocalNode
459+ when (isLocal node (ProcessIdentifier from)) $
460+ case them of
461+ ProcessIdentifier pid ->
462+ postAsMessage from $ DidUnlinkProcess pid
463+ NodeIdentifier nid ->
464+ postAsMessage from $ DidUnlinkNode nid
465+ SendPortIdentifier cid ->
466+ postAsMessage from $ DidUnlinkPort cid
467+ modify $ linksFor them ^: Set.delete from
468+
469+-- [Unified: Table 11]
470+ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
471+ncEffectUnmonitor from ref = do
472+ node <- ncMsg getLocalNode
473+ when (isLocal node (ProcessIdentifier from)) $
474+ postAsMessage from $ DidUnmonitor ref
475+ modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
476+
477+-- [Unified: Table 12]
478+ncEffectDied :: Identifier -> DiedReason -> NC ()
479+ncEffectDied ident reason = do
480+ node <- ncMsg getLocalNode
481+ (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
482+ (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
483+
484+ let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False
485+
486+ forM_ (Map.toList affectedLinks) $ \(them, uss) ->
487+ forM_ uss $ \us ->
488+ when (localOnly <= isLocal node (ProcessIdentifier us)) $
489+ notifyDied us them reason Nothing
490+
491+ forM_ (Map.toList affectedMons) $ \(them, refs) ->
492+ forM_ refs $ \(us, ref) ->
493+ when (localOnly <= isLocal node (ProcessIdentifier us)) $
494+ notifyDied us them reason (Just ref)
495+
496+ modify $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)
497+
498+-- [Unified: Table 13]
499+ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
500+ncEffectSpawn pid cProc ref = do
501+ mProc <- unClosure cProc
502+ -- If the closure does not exist, we spawn a process that throws an exception
503+ -- This allows the remote node to find out what's happening
504+ let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
505+ node <- ncMsg getLocalNode
506+ pid' <- liftIO $ forkProcess node proc
507+ ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
508+
509+-- Unified semantics does not explicitly describe how to implement 'register',
510+-- but mentions it's "very similar to nsend" (Table 14)
511+ncEffectRegister :: String -> Maybe ProcessId -> NC ()
512+ncEffectRegister label mPid =
513+ modify $ registryFor label ^= mPid
514+ -- An acknowledgement is not necessary. If we want a synchronous register,
515+ -- it suffices to send a whereis requiry immediately after the register
516+ -- (that may not suffice if we do decide for unreliable messaging instead)
517+
518+-- Unified semantics does not explicitly describe 'whereis'
519+ncEffectWhereIs :: ProcessId -> String -> NC ()
520+ncEffectWhereIs from label = do
521+ mPid <- gets (^. registryFor label)
522+ ncMsg $ sendMessage (ProcessIdentifier from) (WhereIsReply label mPid)
523+
524+-- [Unified: Table 14]
525+ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
526+ncEffectNamedSend _from label msg = do
527+ mPid <- gets (^. registryFor label)
528+ -- If mPid is Nothing, we just ignore the named send (as per Table 14)
529+ -- TODO: messages don't carry a "from", but if they do, we should set it
530+ -- to be the 'from' of the original named send, not this node controller
531+ forM_ mPid $ \pid ->
532+ ncMsg $ sendPayload (ProcessIdentifier pid) (messageToPayload msg)
533+
534+--------------------------------------------------------------------------------
535+-- Auxiliary --
536+--------------------------------------------------------------------------------
537+
538+notifyDied :: ProcessId -- ^ Who to notify?
539+ -> Identifier -- ^ Who died?
540+ -> DiedReason -- ^ How did they die?
541+ -> Maybe MonitorRef -- ^ 'Nothing' for linking
542+ -> NC ()
543+notifyDied dest src reason mRef = do
544+ node <- ncMsg getLocalNode
545+ case (isLocal node (ProcessIdentifier dest), mRef, src) of
546+ (True, Just ref, ProcessIdentifier pid) ->
547+ postAsMessage dest $ ProcessMonitorNotification ref pid reason
548+ (True, Just ref, NodeIdentifier nid) ->
549+ postAsMessage dest $ NodeMonitorNotification ref nid reason
550+ (True, Just ref, SendPortIdentifier cid) ->
551+ postAsMessage dest $ PortMonitorNotification ref cid reason
552+ (True, Nothing, ProcessIdentifier pid) ->
553+ throwException dest $ ProcessLinkException pid reason
554+ (True, Nothing, NodeIdentifier pid) ->
555+ throwException dest $ NodeLinkException pid reason
556+ (True, Nothing, SendPortIdentifier pid) ->
557+ throwException dest $ PortLinkException pid reason
558+ (False, _, _) ->
559+ -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
560+ -- (see [Unified: Table 10]
561+ ncMsg $ sendBinary (NodeIdentifier $ processNodeId dest) NCMsg
562+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
563+ , ctrlMsgSignal = Died src reason
564+ }
565+
566+-- | [Unified: Table 8]
567+destNid :: ProcessSignal -> Maybe NodeId
568+destNid (Link ident) = Just $ nodeOf ident
569+destNid (Unlink ident) = Just $ nodeOf ident
570+destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
571+destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
572+destNid (Spawn _ _) = Nothing
573+destNid (Register _ _) = Nothing
574+destNid (WhereIs _) = Nothing
575+destNid (NamedSend _ _) = Nothing
576+-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
577+-- then when a local process dies the monitoring/linking machinery will take
578+-- care of notifying remote nodes
579+destNid (Died _ _) = Nothing
580+
581+-- | Check if a process is local to our own node
582+isLocal :: LocalNode -> Identifier -> Bool
583+isLocal nid ident = nodeOf ident == localNodeId nid
584+
585+-- | Lookup a local closure
586+unClosure :: Typeable a => Closure a -> NC (Maybe a)
587+unClosure (Closure (Static label) env) = do
588+ rtable <- remoteTable <$> ncMsg getLocalNode
589+ return (resolveClosure rtable label env >>= fromDynamic)
590+
591+-- | Check if an identifier refers to a valid local object
592+isValidLocalIdentifier :: Identifier -> NC Bool
593+isValidLocalIdentifier ident = do
594+ node <- ncMsg getLocalNode
595+ liftIO . withMVar (localState node) $ \nSt ->
596+ case ident of
597+ NodeIdentifier nid ->
598+ return $ nid == localNodeId node
599+ ProcessIdentifier pid -> do
600+ let mProc = nSt ^. localProcessWithId (processLocalId pid)
601+ return $ isJust mProc
602+ SendPortIdentifier cid -> do
603+ let pid = sendPortProcessId cid
604+ mProc = nSt ^. localProcessWithId (processLocalId pid)
605+ case mProc of
606+ Nothing -> return False
607+ Just proc -> withMVar (processState proc) $ \pSt -> do
608+ let mCh = pSt ^. typedChannelWithId (sendPortLocalId cid)
609+ return $ isJust mCh
610+
611+--------------------------------------------------------------------------------
612+-- Messages to local processes --
613+--------------------------------------------------------------------------------
614+
615+postAsMessage :: Serializable a => ProcessId -> a -> NC ()
616+postAsMessage pid = postMessage pid . createMessage
617+
618+postMessage :: ProcessId -> Message -> NC ()
619+postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
620+
621+throwException :: Exception e => ProcessId -> e -> NC ()
622+throwException pid e = withLocalProc pid $ \p ->
623+ throwTo (processThread p) e
624+
625+withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
626+withLocalProc pid p = do
627+ node <- ncMsg getLocalNode
628+ liftIO $ do
629+ -- By [Unified: table 6, rule missing_process] messages to dead processes
630+ -- can silently be dropped
631+ let lpid = processLocalId pid
632+ mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
633+ forM_ mProc p
634+
635+--------------------------------------------------------------------------------
636+-- Accessors --
637+--------------------------------------------------------------------------------
638+
639+links :: Accessor NCState (Map Identifier (Set ProcessId))
640+links = accessor _links (\ls st -> st { _links = ls })
641+
642+monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))
643+monitors = accessor _monitors (\ms st -> st { _monitors = ms })
644+
645+registry :: Accessor NCState (Map String ProcessId)
646+registry = accessor _registry (\ry st -> st { _registry = ry })
647+
648+linksFor :: Identifier -> Accessor NCState (Set ProcessId)
649+linksFor ident = links >>> DAC.mapDefault Set.empty ident
650+
651+monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))
652+monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident
653+
654+registryFor :: String -> Accessor NCState (Maybe ProcessId)
655+registryFor ident = registry >>> DAC.mapMaybe ident
656+
657+-- | @splitNotif ident@ splits a notifications map into those
658+-- notifications that should trigger when 'ident' fails and those links that
659+-- should not.
660+--
661+-- There is a hierarchy between identifiers: failure of a node implies failure
662+-- of all processes on that node, and failure of a process implies failure of
663+-- all typed channels to that process. In other words, if 'ident' refers to a
664+-- node, then the /should trigger/ set will include
665+--
666+-- * the notifications for the node specifically
667+-- * the notifications for processes on that node, and
668+-- * the notifications for typed channels to processes on that node.
669+--
670+-- Similarly, if 'ident' refers to a process, the /should trigger/ set will
671+-- include
672+--
673+-- * the notifications for that process specifically and
674+-- * the notifications for typed channels to that process.
675+splitNotif :: Identifier
676+ -> Map Identifier a
677+ -> (Map Identifier a, Map Identifier a)
678+splitNotif ident = Map.partitionWithKey (const . impliesDeathOf ident)
679+
680+-- | Does the death of one entity (node, project, channel) imply the death
681+-- of another?
682+impliesDeathOf :: Identifier -- ^ Who died
683+ -> Identifier -- ^ Who's being watched
684+ -> Bool -- ^ Does this death implies the death of the watchee?
685+NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
686+ nid' == nid
687+NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
688+ processNodeId pid == nid
689+NodeIdentifier nid `impliesDeathOf` SendPortIdentifier cid =
690+ processNodeId (sendPortProcessId cid) == nid
691+ProcessIdentifier pid `impliesDeathOf` ProcessIdentifier pid' =
692+ pid' == pid
693+ProcessIdentifier pid `impliesDeathOf` SendPortIdentifier cid =
694+ sendPortProcessId cid == pid
695+SendPortIdentifier cid `impliesDeathOf` SendPortIdentifier cid' =
696+ cid' == cid
697+_ `impliesDeathOf` _ =
698+ False
src/Control/Distributed/Process/Serializable.hs → distributed-process/src/Control/Distributed/Process/Serializable.hsrenamed+16−32
@@ -1,9 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE UndecidableInstances #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE GADTs #-}
6−module Control.Distributed.Process.Serializable
1+module Control.Distributed.Process.Serializable
7 ( Serializable
2 ( Serializable
8 , encodeFingerprint
3 , encodeFingerprint
9 , decodeFingerprint
4 , decodeFingerprint
@@ -11,33 +6,22 @@ module Control.Distributed.Process.Serializable
11 , sizeOfFingerprint
6 , sizeOfFingerprint
12 , Fingerprint
7 , Fingerprint
13 , showFingerprint
8 , showFingerprint
14− , SerializableDict(SerializableDict)
15− , TypeableDict(TypeableDict)
16 ) where
9 ) where
17
10
18import Data.Binary (Binary)
11import Data.Binary (Binary)
19−
20−import Data.Typeable (Typeable, typeRepFingerprint, typeOf)
12+import Data.Typeable (Typeable(..))
21−
13+import Data.Typeable.Internal (TypeRep(TypeRep))
22import Numeric (showHex)
14import Numeric (showHex)
23import Control.Exception (throw)
15import Control.Exception (throw)
24import GHC.Fingerprint.Type (Fingerprint(..))
16import GHC.Fingerprint.Type (Fingerprint(..))
25import Data.ByteString (ByteString)
17import Data.ByteString (ByteString)
26import qualified Data.ByteString as BS
18import qualified Data.ByteString as BS
27−import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr )
19+import qualified Data.ByteString.Internal as BSI ( unsafeCreate
20+ , inlinePerformIO
21+ , toForeignPtr
22+ )
28import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)
23import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)
29import Foreign.ForeignPtr (withForeignPtr)
24import Foreign.ForeignPtr (withForeignPtr)
30−import System.IO.Unsafe (unsafePerformIO)
31−
32−-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")
33−data SerializableDict a where
34− SerializableDict :: Serializable a => SerializableDict a
35− deriving (Typeable)
36−
37−-- | Reification of 'Typeable'.
38−data TypeableDict a where
39− TypeableDict :: Typeable a => TypeableDict a
40− deriving (Typeable)
41
25
42-- | Objects that can be sent across the network
26-- | Objects that can be sent across the network
43class (Binary a, Typeable a) => Serializable a
27class (Binary a, Typeable a) => Serializable a
@@ -45,29 +29,29 @@ instance (Binary a, Typeable a) => Serializable a
45
29
46-- | Encode type representation as a bytestring
30-- | Encode type representation as a bytestring
47encodeFingerprint :: Fingerprint -> ByteString
31encodeFingerprint :: Fingerprint -> ByteString
48−encodeFingerprint fp =
32+encodeFingerprint fp =
49 -- Since all CH nodes will run precisely the same binary, we don't have to
33 -- Since all CH nodes will run precisely the same binary, we don't have to
50 -- worry about cross-arch issues here (like endianness)
34 -- worry about cross-arch issues here (like endianness)
51− BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp
35+ BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp
52
36
53−-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure
37+-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure
54decodeFingerprint :: ByteString -> Fingerprint
38decodeFingerprint :: ByteString -> Fingerprint
55decodeFingerprint bs
39decodeFingerprint bs
56− | BS.length bs /= sizeOfFingerprint =
40+ | BS.length bs /= sizeOfFingerprint =
57 throw $ userError "decodeFingerprint: Invalid length"
41 throw $ userError "decodeFingerprint: Invalid length"
58− | otherwise = unsafePerformIO $ do
42+ | otherwise = BSI.inlinePerformIO $ do
59 let (fp, offset, _) = BSI.toForeignPtr bs
43 let (fp, offset, _) = BSI.toForeignPtr bs
60− withForeignPtr fp $ \p -> peekByteOff p offset
44+ withForeignPtr fp $ \p -> peekByteOff p offset
61
45
62-- | Size of a fingerprint
46-- | Size of a fingerprint
63sizeOfFingerprint :: Int
47sizeOfFingerprint :: Int
64sizeOfFingerprint = sizeOf (undefined :: Fingerprint)
48sizeOfFingerprint = sizeOf (undefined :: Fingerprint)
65
49
66−-- | The fingerprint of the typeRep of the argument
50+-- | The fingerprint of the typeRep of the argument
67fingerprint :: Typeable a => a -> Fingerprint
51fingerprint :: Typeable a => a -> Fingerprint
68−fingerprint = typeRepFingerprint . typeOf
52+fingerprint a = let TypeRep fp _ _ = typeOf a in fp
69
53
70-- | Show fingerprint (for debugging purposes)
54-- | Show fingerprint (for debugging purposes)
71showFingerprint :: Fingerprint -> ShowS
55showFingerprint :: Fingerprint -> ShowS
72−showFingerprint (Fingerprint hi lo) =
56+showFingerprint (Fingerprint hi lo) =
73 showString "(" . showHex hi . showString "," . showHex lo . showString ")"
57 showString "(" . showHex hi . showString "," . showHex lo . showString ")"
distributed-process/tests/TestAuxiliary.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TestAuxiliary ( -- Running tests
3+ runTest
4+ , runTests
5+ -- Writing tests
6+ , forkTry
7+ , trySome
8+ , randomThreadDelay
9+ ) where
10+
11+import Prelude hiding (catch)
12+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
13+import Control.Monad (liftM2, unless)
14+import Control.Exception (SomeException, try, catch)
15+import System.Timeout (timeout)
16+import System.IO (stdout, hFlush)
17+import System.Console.ANSI ( SGR(SetColor, Reset)
18+ , Color(Red, Green)
19+ , ConsoleLayer(Foreground)
20+ , ColorIntensity(Vivid)
21+ , setSGR
22+ )
23+import System.Random (randomIO)
24+
25+-- | Like fork, but throw exceptions in the child thread to the parent
26+forkTry :: IO () -> IO ThreadId
27+forkTry p = do
28+ tid <- myThreadId
29+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
30+
31+-- | Like try, but specialized to SomeException
32+trySome :: IO a -> IO (Either SomeException a)
33+trySome = try
34+
35+-- | Run the given test, catching timeouts and exceptions
36+runTest :: String -> IO () -> IO Bool
37+runTest description test = do
38+ putStr $ "Running " ++ show description ++ ": "
39+ hFlush stdout
40+ done <- try . timeout 60000000 $ test -- 60 seconds
41+ case done of
42+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
43+ Right Nothing -> failed "(timeout)"
44+ Right (Just ()) -> ok
45+ where
46+ failed :: String -> IO Bool
47+ failed err = do
48+ setSGR [SetColor Foreground Vivid Red]
49+ putStr "failed "
50+ setSGR [Reset]
51+ putStrLn err
52+ return False
53+
54+ ok :: IO Bool
55+ ok = do
56+ setSGR [SetColor Foreground Vivid Green]
57+ putStrLn "ok"
58+ setSGR [Reset]
59+ return True
60+
61+-- | Run a bunch of tests and throw an exception if any fails
62+runTests :: [(String, IO ())] -> IO ()
63+runTests tests = do
64+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests
65+ unless success $ fail "Some tests failed"
66+
67+-- | Random thread delay between 0 and the specified max
68+randomThreadDelay :: Int -> IO ()
69+randomThreadDelay maxDelay = do
70+ delay <- randomIO :: IO Int
71+ threadDelay (delay `mod` maxDelay)
distributed-process/tests/TestCH.hsnew file+600
@@ -0,0 +1,600 @@
1+module Main where
2+
3+import Prelude hiding (catch)
4+import Data.Binary (Binary(..))
5+import Data.Typeable (Typeable)
6+import Data.Foldable (forM_)
7+import Control.Concurrent (forkIO, threadDelay)
8+import Control.Concurrent.MVar
9+ ( MVar
10+ , newEmptyMVar
11+ , putMVar
12+ , takeMVar
13+ , readMVar
14+ )
15+import Control.Monad (replicateM_, replicateM)
16+import Control.Exception (throwIO)
17+import Control.Applicative ((<$>), (<*>))
18+import qualified Network.Transport as NT (Transport, closeEndPoint)
19+import Network.Transport.TCP (createTransport, defaultTCPParameters)
20+import Control.Distributed.Process
21+import Control.Distributed.Process.Internal.Types (LocalNode(localEndPoint))
22+import Control.Distributed.Process.Node
23+import Control.Distributed.Process.Serializable (Serializable)
24+import TestAuxiliary
25+
26+newtype Ping = Ping ProcessId
27+ deriving (Typeable, Binary, Show)
28+
29+newtype Pong = Pong ProcessId
30+ deriving (Typeable, Binary, Show)
31+
32+-- | The ping server from the paper
33+ping :: Process ()
34+ping = do
35+ Pong partner <- expect
36+ self <- getSelfPid
37+ send partner (Ping self)
38+ ping
39+
40+-- | Basic ping test
41+testPing :: NT.Transport -> IO ()
42+testPing transport = do
43+ serverAddr <- newEmptyMVar
44+ clientDone <- newEmptyMVar
45+
46+ -- Server
47+ forkIO $ do
48+ localNode <- newLocalNode transport initRemoteTable
49+ addr <- forkProcess localNode ping
50+ putMVar serverAddr addr
51+
52+ -- Client
53+ forkIO $ do
54+ localNode <- newLocalNode transport initRemoteTable
55+ pingServer <- readMVar serverAddr
56+
57+ let numPings = 10000
58+
59+ runProcess localNode $ do
60+ pid <- getSelfPid
61+ replicateM_ numPings $ do
62+ send pingServer (Pong pid)
63+ Ping _ <- expect
64+ return ()
65+
66+ putMVar clientDone ()
67+
68+ takeMVar clientDone
69+
70+-- | Monitor or link to a remote node
71+monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
72+ -> ProcessId -- Process to monitor/link to
73+ -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
74+ -> Process (Maybe MonitorRef)
75+monitorOrLink mOrL pid mSignal = do
76+ result <- if mOrL then Just <$> monitor pid
77+ else link pid >> return Nothing
78+ -- Monitor is asynchronous, which usually does not matter but if we want a
79+ -- *specific* signal then it does. Therefore we wait an arbitrary delay and
80+ -- hope that this means the monitor has been set up
81+ forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
82+ return result
83+
84+monitorTestProcess :: ProcessId -- Process to monitor/link to
85+ -> Bool -- 'True' for monitor, 'False' for link
86+ -> Bool -- Should we unmonitor?
87+ -> DiedReason -- Expected cause of death
88+ -> Maybe (MVar ()) -- Signal for 'monitor set up'
89+ -> MVar () -- Signal for successful termination
90+ -> Process ()
91+monitorTestProcess theirAddr mOrL un reason monitorSetup done =
92+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
93+ case (un, mRef) of
94+ (True, Nothing) -> do
95+ unlink theirAddr
96+ liftIO $ putMVar done ()
97+ (True, Just ref) -> do
98+ unmonitor ref
99+ liftIO $ putMVar done ()
100+ (False, ref) -> do
101+ ProcessMonitorNotification ref' pid reason' <- expect
102+ True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
103+ liftIO $ putMVar done ()
104+ )
105+ (\(ProcessLinkException pid reason') -> do
106+ True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
107+ liftIO $ putMVar done ()
108+ )
109+
110+
111+-- | Monitor a process on an unreachable node
112+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
113+testMonitorUnreachable transport mOrL un = do
114+ deadProcess <- newEmptyMVar
115+ done <- newEmptyMVar
116+
117+ forkIO $ do
118+ localNode <- newLocalNode transport initRemoteTable
119+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000
120+ closeLocalNode localNode
121+ putMVar deadProcess addr
122+
123+ forkIO $ do
124+ localNode <- newLocalNode transport initRemoteTable
125+ theirAddr <- readMVar deadProcess
126+ runProcess localNode $
127+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
128+
129+ takeMVar done
130+
131+-- | Monitor a process which terminates normally
132+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
133+testMonitorNormalTermination transport mOrL un = do
134+ monitorSetup <- newEmptyMVar
135+ monitoredProcess <- newEmptyMVar
136+ done <- newEmptyMVar
137+
138+ forkIO $ do
139+ localNode <- newLocalNode transport initRemoteTable
140+ addr <- forkProcess localNode $
141+ liftIO $ readMVar monitorSetup
142+ putMVar monitoredProcess addr
143+
144+ forkIO $ do
145+ localNode <- newLocalNode transport initRemoteTable
146+ theirAddr <- readMVar monitoredProcess
147+ runProcess localNode $
148+ monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
149+
150+ takeMVar done
151+
152+-- | Monitor a process which terminates abnormally
153+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
154+testMonitorAbnormalTermination transport mOrL un = do
155+ monitorSetup <- newEmptyMVar
156+ monitoredProcess <- newEmptyMVar
157+ done <- newEmptyMVar
158+
159+ let err = userError "Abnormal termination"
160+
161+ forkIO $ do
162+ localNode <- newLocalNode transport initRemoteTable
163+ addr <- forkProcess localNode . liftIO $ do
164+ readMVar monitorSetup
165+ throwIO err
166+ putMVar monitoredProcess addr
167+
168+ forkIO $ do
169+ localNode <- newLocalNode transport initRemoteTable
170+ theirAddr <- readMVar monitoredProcess
171+ runProcess localNode $
172+ monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
173+
174+ takeMVar done
175+
176+-- | Monitor a local process that is already dead
177+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
178+testMonitorLocalDeadProcess transport mOrL un = do
179+ processDead <- newEmptyMVar
180+ processAddr <- newEmptyMVar
181+ localNode <- newLocalNode transport initRemoteTable
182+ done <- newEmptyMVar
183+
184+ forkIO $ do
185+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()
186+ putMVar processAddr addr
187+
188+ forkIO $ do
189+ theirAddr <- readMVar processAddr
190+ readMVar processDead
191+ runProcess localNode $ do
192+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
193+
194+ takeMVar done
195+
196+-- | Monitor a remote process that is already dead
197+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
198+testMonitorRemoteDeadProcess transport mOrL un = do
199+ processDead <- newEmptyMVar
200+ processAddr <- newEmptyMVar
201+ done <- newEmptyMVar
202+
203+ forkIO $ do
204+ localNode <- newLocalNode transport initRemoteTable
205+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()
206+ putMVar processAddr addr
207+
208+ forkIO $ do
209+ localNode <- newLocalNode transport initRemoteTable
210+ theirAddr <- readMVar processAddr
211+ readMVar processDead
212+ runProcess localNode $ do
213+ monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done
214+
215+ takeMVar done
216+
217+-- | Monitor a process that becomes disconnected
218+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
219+testMonitorDisconnect transport mOrL un = do
220+ processAddr <- newEmptyMVar
221+ monitorSetup <- newEmptyMVar
222+ done <- newEmptyMVar
223+
224+ forkIO $ do
225+ localNode <- newLocalNode transport initRemoteTable
226+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000
227+ putMVar processAddr addr
228+ readMVar monitorSetup
229+ NT.closeEndPoint (localEndPoint localNode)
230+
231+ forkIO $ do
232+ localNode <- newLocalNode transport initRemoteTable
233+ theirAddr <- readMVar processAddr
234+ runProcess localNode $ do
235+ monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
236+
237+ takeMVar done
238+
239+data Add = Add ProcessId Double Double deriving (Typeable)
240+data Divide = Divide ProcessId Double Double deriving (Typeable)
241+data DivByZero = DivByZero deriving (Typeable)
242+
243+instance Binary Add where
244+ put (Add pid x y) = put pid >> put x >> put y
245+ get = Add <$> get <*> get <*> get
246+
247+instance Binary Divide where
248+ put (Divide pid x y) = put pid >> put x >> put y
249+ get = Divide <$> get <*> get <*> get
250+
251+instance Binary DivByZero where
252+ put DivByZero = return ()
253+ get = return DivByZero
254+
255+math :: Process ()
256+math = do
257+ receiveWait
258+ [ match (\(Add pid x y) -> send pid (x + y))
259+ , matchIf (\(Divide _ _ y) -> y /= 0)
260+ (\(Divide pid x y) -> send pid (x / y))
261+ , match (\(Divide pid _ _) -> send pid DivByZero)
262+ ]
263+ math
264+
265+-- | Test the math server (i.e., receiveWait)
266+testMath :: NT.Transport -> IO ()
267+testMath transport = do
268+ serverAddr <- newEmptyMVar
269+ clientDone <- newEmptyMVar
270+
271+ -- Server
272+ forkIO $ do
273+ localNode <- newLocalNode transport initRemoteTable
274+ addr <- forkProcess localNode math
275+ putMVar serverAddr addr
276+
277+ -- Client
278+ forkIO $ do
279+ localNode <- newLocalNode transport initRemoteTable
280+ mathServer <- readMVar serverAddr
281+
282+ runProcess localNode $ do
283+ pid <- getSelfPid
284+ send mathServer (Add pid 1 2)
285+ 3 <- expect :: Process Double
286+ send mathServer (Divide pid 8 2)
287+ 4 <- expect :: Process Double
288+ send mathServer (Divide pid 8 0)
289+ DivByZero <- expect
290+ liftIO $ putMVar clientDone ()
291+
292+ takeMVar clientDone
293+
294+-- | Send first message (i.e. connect) to an already terminated process
295+-- (without monitoring); then send another message to a second process on
296+-- the same remote node (we're checking that the remote node did not die)
297+testSendToTerminated :: NT.Transport -> IO ()
298+testSendToTerminated transport = do
299+ serverAddr1 <- newEmptyMVar
300+ serverAddr2 <- newEmptyMVar
301+ clientDone <- newEmptyMVar
302+
303+ forkIO $ do
304+ terminated <- newEmptyMVar
305+ localNode <- newLocalNode transport initRemoteTable
306+ addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
307+ addr2 <- forkProcess localNode $ ping
308+ readMVar terminated
309+ putMVar serverAddr1 addr1
310+ putMVar serverAddr2 addr2
311+
312+ forkIO $ do
313+ localNode <- newLocalNode transport initRemoteTable
314+ server1 <- readMVar serverAddr1
315+ server2 <- readMVar serverAddr2
316+ runProcess localNode $ do
317+ pid <- getSelfPid
318+ send server1 "Hi"
319+ send server2 (Pong pid)
320+ Ping pid' <- expect
321+ True <- return $ pid' == server2
322+ liftIO $ putMVar clientDone ()
323+
324+ takeMVar clientDone
325+
326+-- | Test (non-zero) timeout
327+testTimeout :: NT.Transport -> IO ()
328+testTimeout transport = do
329+ localNode <- newLocalNode transport initRemoteTable
330+ runProcess localNode $ do
331+ Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
332+ return ()
333+
334+-- | Test zero timeout
335+testTimeout0 :: NT.Transport -> IO ()
336+testTimeout0 transport = do
337+ serverAddr <- newEmptyMVar
338+ clientDone <- newEmptyMVar
339+ messagesSent <- newEmptyMVar
340+
341+ forkIO $ do
342+ localNode <- newLocalNode transport initRemoteTable
343+ addr <- forkProcess localNode $ do
344+ liftIO $ readMVar messagesSent >> threadDelay 1000000
345+ -- Variation on the venerable ping server which uses a zero timeout
346+ -- Since we wait for all messages to be sent before doing this receive,
347+ -- we should nevertheless find the right message immediately
348+ Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
349+ self <- getSelfPid
350+ send partner (Ping self)
351+ putMVar serverAddr addr
352+
353+ forkIO $ do
354+ localNode <- newLocalNode transport initRemoteTable
355+ server <- readMVar serverAddr
356+ runProcess localNode $ do
357+ pid <- getSelfPid
358+ -- Send a bunch of messages. A large number of messages that the server
359+ -- is not interested in, and then a single message that it wants
360+ replicateM_ 10000 $ send server "Irrelevant message"
361+ send server (Pong pid)
362+ liftIO $ putMVar messagesSent ()
363+ Ping _ <- expect
364+ liftIO $ putMVar clientDone ()
365+
366+ takeMVar clientDone
367+
368+-- | Test typed channels
369+testTypedChannels :: NT.Transport -> IO ()
370+testTypedChannels transport = do
371+ serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
372+ clientDone <- newEmptyMVar
373+
374+ forkIO $ do
375+ localNode <- newLocalNode transport initRemoteTable
376+ forkProcess localNode $ do
377+ (serverSendPort, rport) <- newChan
378+ liftIO $ putMVar serverChannel serverSendPort
379+ (clientSendPort, i) <- receiveChan rport
380+ sendChan clientSendPort (even i)
381+ return ()
382+
383+ forkIO $ do
384+ localNode <- newLocalNode transport initRemoteTable
385+ serverSendPort <- readMVar serverChannel
386+ runProcess localNode $ do
387+ (clientSendPort, rport) <- newChan
388+ sendChan serverSendPort (clientSendPort, 5)
389+ False <- receiveChan rport
390+ liftIO $ putMVar clientDone ()
391+
392+ takeMVar clientDone
393+
394+-- | Test merging receive ports
395+testMergeChannels :: NT.Transport -> IO ()
396+testMergeChannels transport = do
397+ localNode <- newLocalNode transport initRemoteTable
398+ testFlat localNode True "aaabbbccc"
399+ testFlat localNode False "abcabcabc"
400+ testNested localNode True True "aaabbbcccdddeeefffggghhhiii"
401+ testNested localNode True False "adgadgadgbehbehbehcficficfi"
402+ testNested localNode False True "abcabcabcdefdefdefghighighi"
403+ testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"
404+ testBlocked localNode True
405+ testBlocked localNode False
406+ where
407+ -- Single layer of merging
408+ testFlat :: LocalNode -> Bool -> String -> IO ()
409+ testFlat localNode biased expected =
410+ runProcess localNode $ do
411+ rs <- mapM charChannel "abc"
412+ m <- mergePorts biased rs
413+ xs <- replicateM 9 $ receiveChan m
414+ True <- return $ xs == expected
415+ return ()
416+
417+ -- Two layers of merging
418+ testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
419+ testNested localNode biasedInner biasedOuter expected =
420+ runProcess localNode $ do
421+ rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
422+ ms <- mapM (mergePorts biasedInner) rss
423+ m <- mergePorts biasedOuter ms
424+ xs <- replicateM (9 * 3) $ receiveChan m
425+ True <- return $ xs == expected
426+ return ()
427+
428+ -- Test that if no messages are (immediately) available, the scheduler makes no difference
429+ testBlocked :: LocalNode -> Bool -> IO ()
430+ testBlocked localNode biased = do
431+ vs <- replicateM 3 newEmptyMVar
432+
433+ forkProcess localNode $ do
434+ [sa, sb, sc] <- liftIO $ mapM readMVar vs
435+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
436+ [ -- a, b, c
437+ (sa, 'a')
438+ , (sb, 'b')
439+ , (sc, 'c')
440+ -- a, c, b
441+ , (sa, 'a')
442+ , (sc, 'c')
443+ , (sb, 'b')
444+ -- b, a, c
445+ , (sb, 'b')
446+ , (sa, 'a')
447+ , (sc, 'c')
448+ -- b, c, a
449+ , (sb, 'b')
450+ , (sc, 'c')
451+ , (sa, 'a')
452+ -- c, a, b
453+ , (sc, 'c')
454+ , (sa, 'a')
455+ , (sb, 'b')
456+ -- c, b, a
457+ , (sc, 'c')
458+ , (sb, 'b')
459+ , (sa, 'a')
460+ ]
461+
462+ runProcess localNode $ do
463+ (ss, rs) <- unzip <$> replicateM 3 newChan
464+ liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
465+ m <- mergePorts biased rs
466+ xs <- replicateM (6 * 3) $ receiveChan m
467+ True <- return $ xs == "abcacbbacbcacabcba"
468+ return ()
469+
470+ mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
471+ mergePorts True = mergePortsBiased
472+ mergePorts False = mergePortsRR
473+
474+ charChannel :: Char -> Process (ReceivePort Char)
475+ charChannel c = do
476+ (sport, rport) <- newChan
477+ replicateM_ 3 $ sendChan sport c
478+ liftIO $ threadDelay 10000 -- Make sure messages have been sent
479+ return rport
480+
481+testTerminate :: NT.Transport -> IO ()
482+testTerminate transport = do
483+ localNode <- newLocalNode transport initRemoteTable
484+
485+ pid <- forkProcess localNode $ do
486+ liftIO $ threadDelay 100000
487+ terminate
488+
489+ runProcess localNode $ do
490+ ref <- monitor pid
491+ ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
492+ True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
493+ return ()
494+
495+testMonitorNode :: NT.Transport -> IO ()
496+testMonitorNode transport = do
497+ [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
498+
499+ closeLocalNode node1
500+
501+ runProcess node2 $ do
502+ ref <- monitorNode (localNodeId node1)
503+ NodeMonitorNotification ref' nid DiedDisconnect <- expect
504+ True <- return $ ref == ref' && nid == localNodeId node1
505+ return ()
506+
507+testMonitorChannel :: NT.Transport -> IO ()
508+testMonitorChannel transport = do
509+ [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
510+ gotNotification <- newEmptyMVar
511+
512+ pid <- forkProcess node1 $ do
513+ sport <- expect :: Process (SendPort ())
514+ ref <- monitorPort sport
515+ PortMonitorNotification ref' port' DiedNormal <- expect
516+ return $ ref' == ref && port' == sendPortId sport
517+ liftIO $ putMVar gotNotification ()
518+
519+ runProcess node2 $ do
520+ (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())
521+ send pid sport
522+ liftIO $ threadDelay 100000
523+
524+ takeMVar gotNotification
525+
526+testRegistry :: NT.Transport -> IO ()
527+testRegistry transport = do
528+ node <- newLocalNode transport initRemoteTable
529+
530+ pingServer <- forkProcess node ping
531+
532+ runProcess node $ do
533+ register "ping" pingServer
534+ Just pid <- whereis "ping"
535+ True <- return $ pingServer == pid
536+ us <- getSelfPid
537+ nsend "ping" (Pong us)
538+ Ping pid' <- expect
539+ True <- return $ pingServer == pid'
540+ return ()
541+
542+testRemoteRegistry :: NT.Transport -> IO ()
543+testRemoteRegistry transport = do
544+ node1 <- newLocalNode transport initRemoteTable
545+ node2 <- newLocalNode transport initRemoteTable
546+
547+ pingServer <- forkProcess node1 ping
548+
549+ runProcess node2 $ do
550+ let nid1 = localNodeId node1
551+ registerRemote nid1 "ping" pingServer
552+ Just pid <- whereisRemote nid1 "ping"
553+ True <- return $ pingServer == pid
554+ us <- getSelfPid
555+ nsendRemote nid1 "ping" (Pong us)
556+ Ping pid' <- expect
557+ True <- return $ pingServer == pid'
558+ return ()
559+
560+main :: IO ()
561+main = do
562+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
563+ runTests
564+ [ ("Ping", testPing transport)
565+ , ("Math", testMath transport)
566+ , ("Timeout", testTimeout transport)
567+ , ("Timeout0", testTimeout0 transport)
568+ , ("SendToTerminated", testSendToTerminated transport)
569+ , ("TypedChannnels", testTypedChannels transport)
570+ , ("MergeChannels", testMergeChannels transport)
571+ , ("Terminate", testTerminate transport)
572+ , ("Registry", testRegistry transport)
573+ , ("RemoteRegistry", testRemoteRegistry transport)
574+ -- Monitoring processes
575+ --
576+ -- The "missing" combinations in the list below don't make much sense, as
577+ -- we cannot guarantee that the monitor reply or link exception will not
578+ -- happen before the unmonitor or unlink
579+ , ("MonitorUnreachable", testMonitorUnreachable transport True False)
580+ , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
581+ , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
582+ , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
583+ , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
584+ , ("MonitorDisconnect", testMonitorDisconnect transport True False)
585+ , ("LinkUnreachable", testMonitorUnreachable transport False False)
586+ , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
587+ , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
588+ , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
589+ , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
590+ , ("LinkDisconnect", testMonitorDisconnect transport False False)
591+ , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
592+ , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
593+ , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
594+ , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
595+ , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
596+ , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
597+ -- Monitoring nodes and channels
598+ , ("MonitorNode", testMonitorNode transport)
599+ , ("MonitorChannel", testMonitorChannel transport)
600+ ]
distributed-process/tests/TestClosure.hsnew file+312
@@ -0,0 +1,312 @@
1+module Main where
2+
3+import Data.ByteString.Lazy (ByteString, empty)
4+import Data.Typeable (Typeable, typeOf)
5+import Data.Binary (encode)
6+import Control.Monad (join, replicateM)
7+import Control.Exception (IOException, throw)
8+import Control.Concurrent (forkIO, threadDelay)
9+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, takeMVar, putMVar)
10+import Control.Applicative ((<$>))
11+import Network.Transport (Transport)
12+import Network.Transport.TCP (createTransport, defaultTCPParameters)
13+import Control.Distributed.Process
14+import Control.Distributed.Process.Closure
15+import Control.Distributed.Process.Node
16+import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))
17+import TestAuxiliary
18+
19+sdictInt :: SerializableDict Int
20+sdictInt = SerializableDict
21+
22+factorial :: Int -> Process Int
23+factorial 0 = return 1
24+factorial n = (n *) <$> factorial (n - 1)
25+
26+addInt :: Int -> Int -> Int
27+addInt x y = x + y
28+
29+putInt :: Int -> MVar Int -> IO ()
30+putInt = flip putMVar
31+
32+sendPid :: ProcessId -> Process ()
33+sendPid toPid = do
34+ fromPid <- getSelfPid
35+ send toPid fromPid
36+
37+wait :: Int -> Process ()
38+wait = liftIO . threadDelay
39+
40+remotable [ 'factorial
41+ , 'addInt
42+ , 'putInt
43+ , 'sendPid
44+ , 'sdictInt
45+ , 'wait
46+ ]
47+
48+factorialClosure :: Int -> Closure (Process Int)
49+factorialClosure n = Closure decoder (encode n)
50+ where
51+ decoder :: Static (ByteString -> Process Int)
52+ decoder = $(mkStatic 'factorial) `staticCompose` staticDecode $(mkStatic 'sdictInt)
53+
54+addIntClosure :: Int -> Closure (Int -> Int)
55+addIntClosure n = Closure decoder (encode n)
56+ where
57+ decoder :: Static (ByteString -> Int -> Int)
58+ decoder = $(mkStatic 'addInt) `staticCompose` staticDecode $(mkStatic 'sdictInt)
59+
60+putIntClosure :: Int -> Closure (MVar Int -> IO ())
61+putIntClosure n = Closure decoder (encode n)
62+ where
63+ decoder :: Static (ByteString -> MVar Int -> IO ())
64+ decoder = $(mkStatic 'putInt) `staticCompose` staticDecode $(mkStatic 'sdictInt)
65+
66+sendPidClosure :: ProcessId -> Closure (Process ())
67+sendPidClosure pid = Closure decoder (encode pid)
68+ where
69+ decoder :: Static (ByteString -> Process ())
70+ decoder = $(mkStatic 'sendPid) `staticCompose` staticDecode $(mkStatic 'sdictProcessId)
71+
72+sendFac :: Int -> ProcessId -> Closure (Process ())
73+sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid
74+
75+factorialOf :: Closure (Int -> Process Int)
76+factorialOf = staticClosure $(mkStatic 'factorial)
77+
78+factorial' :: Int -> Closure (Process Int)
79+factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf
80+
81+waitClosure :: Int -> Closure (Process ())
82+waitClosure n = Closure decoder (encode n)
83+ where
84+ decoder :: Static (ByteString -> Process ())
85+ decoder = $(mkStatic 'wait) `staticCompose` staticDecode $(mkStatic 'sdictInt)
86+
87+testUnclosure :: Transport -> RemoteTable -> IO ()
88+testUnclosure transport rtable = do
89+ node <- newLocalNode transport rtable
90+ runProcess node $ do
91+ 120 <- join . unClosure $ factorialClosure 5
92+ return ()
93+
94+testBind :: Transport -> RemoteTable -> IO ()
95+testBind transport rtable = do
96+ node <- newLocalNode transport rtable
97+ runProcess node $ do
98+ us <- getSelfPid
99+ join . unClosure $ sendFac 6 us
100+ (720 :: Int) <- expect
101+ return ()
102+
103+testSendPureClosure :: Transport -> RemoteTable -> IO ()
104+testSendPureClosure transport rtable = do
105+ serverAddr <- newEmptyMVar
106+ serverDone <- newEmptyMVar
107+
108+ forkIO $ do
109+ node <- newLocalNode transport rtable
110+ addr <- forkProcess node $ do
111+ cl <- expect
112+ fn <- unClosure cl :: Process (Int -> Int)
113+ 13 <- return $ fn 6
114+ liftIO $ putMVar serverDone ()
115+ putMVar serverAddr addr
116+
117+ forkIO $ do
118+ node <- newLocalNode transport rtable
119+ theirAddr <- readMVar serverAddr
120+ runProcess node $ send theirAddr (addIntClosure 7)
121+
122+ takeMVar serverDone
123+
124+testSendIOClosure :: Transport -> RemoteTable -> IO ()
125+testSendIOClosure transport rtable = do
126+ serverAddr <- newEmptyMVar
127+ serverDone <- newEmptyMVar
128+
129+ forkIO $ do
130+ node <- newLocalNode transport rtable
131+ addr <- forkProcess node $ do
132+ cl <- expect
133+ io <- unClosure cl :: Process (MVar Int -> IO ())
134+ liftIO $ do
135+ someMVar <- newEmptyMVar
136+ io someMVar
137+ 5 <- readMVar someMVar
138+ putMVar serverDone ()
139+ putMVar serverAddr addr
140+
141+ forkIO $ do
142+ node <- newLocalNode transport rtable
143+ theirAddr <- readMVar serverAddr
144+ runProcess node $ send theirAddr (putIntClosure 5)
145+
146+ takeMVar serverDone
147+
148+testSendProcClosure :: Transport -> RemoteTable -> IO ()
149+testSendProcClosure transport rtable = do
150+ serverAddr <- newEmptyMVar
151+ clientDone <- newEmptyMVar
152+
153+ forkIO $ do
154+ node <- newLocalNode transport rtable
155+ addr <- forkProcess node $ do
156+ cl <- expect
157+ pr <- unClosure cl :: Process (Int -> Process ())
158+ pr 5
159+ putMVar serverAddr addr
160+
161+ forkIO $ do
162+ node <- newLocalNode transport rtable
163+ theirAddr <- readMVar serverAddr
164+ runProcess node $ do
165+ pid <- getSelfPid
166+ send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
167+ 5 <- expect :: Process Int
168+ liftIO $ putMVar clientDone ()
169+
170+ takeMVar clientDone
171+
172+testSpawn :: Transport -> RemoteTable -> IO ()
173+testSpawn transport rtable = do
174+ serverNodeAddr <- newEmptyMVar
175+ clientDone <- newEmptyMVar
176+
177+ forkIO $ do
178+ node <- newLocalNode transport rtable
179+ putMVar serverNodeAddr (localNodeId node)
180+
181+ forkIO $ do
182+ node <- newLocalNode transport rtable
183+ nid <- readMVar serverNodeAddr
184+ runProcess node $ do
185+ pid <- getSelfPid
186+ pid' <- spawn nid (sendPidClosure pid)
187+ pid'' <- expect
188+ True <- return $ pid' == pid''
189+ liftIO $ putMVar clientDone ()
190+
191+ takeMVar clientDone
192+
193+testCall :: Transport -> RemoteTable -> IO ()
194+testCall transport rtable = do
195+ serverNodeAddr <- newEmptyMVar
196+ clientDone <- newEmptyMVar
197+
198+ forkIO $ do
199+ node <- newLocalNode transport rtable
200+ putMVar serverNodeAddr (localNodeId node)
201+
202+ forkIO $ do
203+ node <- newLocalNode transport rtable
204+ nid <- readMVar serverNodeAddr
205+ runProcess node $ do
206+ (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
207+ liftIO $ putMVar clientDone ()
208+
209+ takeMVar clientDone
210+
211+testCallBind :: Transport -> RemoteTable -> IO ()
212+testCallBind transport rtable = do
213+ serverNodeAddr <- newEmptyMVar
214+ clientDone <- newEmptyMVar
215+
216+ forkIO $ do
217+ node <- newLocalNode transport rtable
218+ putMVar serverNodeAddr (localNodeId node)
219+
220+ forkIO $ do
221+ node <- newLocalNode transport rtable
222+ nid <- readMVar serverNodeAddr
223+ runProcess node $ do
224+ (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
225+ liftIO $ putMVar clientDone ()
226+
227+ takeMVar clientDone
228+
229+testSeq :: Transport -> RemoteTable -> IO ()
230+testSeq transport rtable = do
231+ node <- newLocalNode transport rtable
232+ runProcess node $ do
233+ us <- getSelfPid
234+ join . unClosure $ sendFac 5 us `cpSeq` sendFac 6 us
235+ 120 :: Int <- expect
236+ 720 :: Int <- expect
237+ return ()
238+
239+-- Test 'spawnSupervised'
240+--
241+-- Set up a supervisor, spawn a child, then have a third process monitor the
242+-- child. The supervisor then throws an exception, the child dies because it
243+-- was linked to the supervisor, and the third process notices that the child
244+-- dies.
245+testSpawnSupervised :: Transport -> RemoteTable -> IO ()
246+testSpawnSupervised transport rtable = do
247+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
248+ [superPid, childPid] <- replicateM 2 $ newEmptyMVar
249+ thirdProcessDone <- newEmptyMVar
250+
251+ forkProcess node1 $ do
252+ us <- getSelfPid
253+ liftIO $ putMVar superPid us
254+ (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
255+ liftIO $ do
256+ putMVar childPid child
257+ threadDelay 500000 -- Give the child a chance to link to us
258+ throw supervisorDeath
259+
260+ forkProcess node2 $ do
261+ [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
262+ ref <- monitor child
263+ ProcessMonitorNotification ref' pid' (DiedException e) <- expect
264+ True <- return $ ref' == ref
265+ && pid' == child
266+ && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
267+ liftIO $ putMVar thirdProcessDone ()
268+
269+ takeMVar thirdProcessDone
270+ where
271+ supervisorDeath :: IOException
272+ supervisorDeath = userError "Supervisor died"
273+
274+testSpawnInvalid :: Transport -> RemoteTable -> IO ()
275+testSpawnInvalid transport rtable = do
276+ node <- newLocalNode transport rtable
277+ runProcess node $ do
278+ (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (StaticLabel "ThisDoesNotExist" (typeOf ()))) empty)
279+ ProcessMonitorNotification ref' pid' _reason <- expect
280+ -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
281+ True <- return $ ref' == ref && pid == pid'
282+ return ()
283+
284+testClosureExpect :: Transport -> RemoteTable -> IO ()
285+testClosureExpect transport rtable = do
286+ node <- newLocalNode transport rtable
287+ runProcess node $ do
288+ nodeId <- getSelfNode
289+ us <- getSelfPid
290+ them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `cpBind` cpSend $(mkStatic 'sdictInt) us
291+ send them (1234 :: Int)
292+ (1234 :: Int) <- expect
293+ return ()
294+
295+main :: IO ()
296+main = do
297+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
298+ let rtable = __remoteTable initRemoteTable
299+ runTests
300+ [ ("Unclosure", testUnclosure transport rtable)
301+ , ("Bind", testBind transport rtable)
302+ , ("SendPureClosure", testSendPureClosure transport rtable)
303+ , ("SendIOClosure", testSendIOClosure transport rtable)
304+ , ("SendProcClosure", testSendProcClosure transport rtable)
305+ , ("Spawn", testSpawn transport rtable)
306+ , ("Call", testCall transport rtable)
307+ , ("CallBind", testCallBind transport rtable)
308+ , ("Seq", testSeq transport rtable)
309+ , ("SpawnSupervised", testSpawnSupervised transport rtable)
310+ , ("SpawnInvalid", testSpawnInvalid transport rtable)
311+ , ("ClosureExpect", testClosureExpect transport rtable)
312+ ]
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+657
@@ -0,0 +1,657 @@
1+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
2+<!-- Created with Inkscape (http://www.inkscape.org/) -->
3+
4+<svg
5+ xmlns:dc="http://purl.org/dc/elements/1.1/"
6+ xmlns:cc="http://creativecommons.org/ns#"
7+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
8+ xmlns:svg="http://www.w3.org/2000/svg"
9+ xmlns="http://www.w3.org/2000/svg"
10+ xmlns:xlink="http://www.w3.org/1999/xlink"
11+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
12+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
13+ width="1024px"
14+ height="768px"
15+ id="svg4129"
16+ version="1.1"
17+ inkscape:version="0.48.2 r9819"
18+ sodipodi:docname="NetworkTCP.svg"
19+ inkscape:export-filename="/tmp/distributed-process/doc/NetworkTCP.png"
20+ inkscape:export-xdpi="90.040001"
21+ inkscape:export-ydpi="90.040001">
22+ <defs
23+ id="defs4131">
24+ <linearGradient
25+ id="linearGradient4726">
26+ <stop
27+ style="stop-color:#800000;stop-opacity:1;"
28+ offset="0"
29+ id="stop4728" />
30+ <stop
31+ style="stop-color:#ffffff;stop-opacity:1;"
32+ offset="1"
33+ id="stop4730" />
34+ </linearGradient>
35+ <linearGradient
36+ id="linearGradient4647">
37+ <stop
38+ style="stop-color:#008080;stop-opacity:1;"
39+ offset="0"
40+ id="stop4649" />
41+ <stop
42+ style="stop-color:#ffffff;stop-opacity:1;"
43+ offset="1"
44+ id="stop4651" />
45+ </linearGradient>
46+ <linearGradient
47+ inkscape:collect="always"
48+ xlink:href="#linearGradient4647-0"
49+ id="linearGradient4655-9"
50+ x1="-666.70703"
51+ y1="18.113195"
52+ x2="952.4931"
53+ y2="345.05661"
54+ gradientUnits="userSpaceOnUse"
55+ gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
56+ <linearGradient
57+ id="linearGradient4647-0">
58+ <stop
59+ style="stop-color:#008080;stop-opacity:1;"
60+ offset="0"
61+ id="stop4649-1" />
62+ <stop
63+ style="stop-color:#ffffff;stop-opacity:1;"
64+ offset="1"
65+ id="stop4651-0" />
66+ </linearGradient>
67+ <linearGradient
68+ inkscape:collect="always"
69+ xlink:href="#linearGradient4647-9"
70+ id="linearGradient4655-8"
71+ x1="-666.70703"
72+ y1="18.113195"
73+ x2="952.4931"
74+ y2="345.05661"
75+ gradientUnits="userSpaceOnUse"
76+ gradientTransform="matrix(0.43409118,0,0,1.0013813,19.021275,0.01045425)" />
77+ <linearGradient
78+ id="linearGradient4647-9">
79+ <stop
80+ style="stop-color:#008080;stop-opacity:1;"
81+ offset="0"
82+ id="stop4649-4" />
83+ <stop
84+ style="stop-color:#ffffff;stop-opacity:1;"
85+ offset="1"
86+ id="stop4651-7" />
87+ </linearGradient>
88+ <linearGradient
89+ inkscape:collect="always"
90+ xlink:href="#linearGradient4726-0"
91+ id="linearGradient4732-1"
92+ x1="484.52829"
93+ y1="88.754707"
94+ x2="18.113218"
95+ y2="336.90564"
96+ gradientUnits="userSpaceOnUse" />
97+ <linearGradient
98+ inkscape:collect="always"
99+ id="linearGradient4726-0">
100+ <stop
101+ style="stop-color:#800000;stop-opacity:1;"
102+ offset="0"
103+ id="stop4728-2" />
104+ <stop
105+ style="stop-color:#800000;stop-opacity:0;"
106+ offset="1"
107+ id="stop4730-5" />
108+ </linearGradient>
109+ <linearGradient
110+ gradientTransform="translate(539.26415,1.83019)"
111+ y2="336.90564"
112+ x2="18.113218"
113+ y1="88.754707"
114+ x1="484.52829"
115+ gradientUnits="userSpaceOnUse"
116+ id="linearGradient4755"
117+ xlink:href="#linearGradient4726-0"
118+ inkscape:collect="always" />
119+ <linearGradient
120+ inkscape:collect="always"
121+ xlink:href="#linearGradient4726-6"
122+ id="linearGradient4732-4"
123+ x1="484.52829"
124+ y1="88.754707"
125+ x2="18.113218"
126+ y2="336.90564"
127+ gradientUnits="userSpaceOnUse" />
128+ <linearGradient
129+ id="linearGradient4726-6">
130+ <stop
131+ style="stop-color:#800000;stop-opacity:1;"
132+ offset="0"
133+ id="stop4728-4" />
134+ <stop
135+ style="stop-color:#ffffff;stop-opacity:1;"
136+ offset="1"
137+ id="stop4730-53" />
138+ </linearGradient>
139+ <linearGradient
140+ inkscape:collect="always"
141+ xlink:href="#linearGradient4726-4"
142+ id="linearGradient4732-6"
143+ x1="484.52829"
144+ y1="88.754707"
145+ x2="18.113218"
146+ y2="336.90564"
147+ gradientUnits="userSpaceOnUse" />
148+ <linearGradient
149+ id="linearGradient4726-4">
150+ <stop
151+ style="stop-color:#800000;stop-opacity:1;"
152+ offset="0"
153+ id="stop4728-40" />
154+ <stop
155+ style="stop-color:#ffffff;stop-opacity:1;"
156+ offset="1"
157+ id="stop4730-7" />
158+ </linearGradient>
159+ <linearGradient
160+ inkscape:collect="always"
161+ xlink:href="#linearGradient4726-3"
162+ id="linearGradient4732-2"
163+ x1="484.52829"
164+ y1="88.754707"
165+ x2="18.113218"
166+ y2="336.90564"
167+ gradientUnits="userSpaceOnUse" />
168+ <linearGradient
169+ id="linearGradient4726-3">
170+ <stop
171+ style="stop-color:#800000;stop-opacity:1;"
172+ offset="0"
173+ id="stop4728-8" />
174+ <stop
175+ style="stop-color:#ffffff;stop-opacity:1;"
176+ offset="1"
177+ id="stop4730-1" />
178+ </linearGradient>
179+ </defs>
180+ <sodipodi:namedview
181+ id="base"
182+ pagecolor="#ffffff"
183+ bordercolor="#666666"
184+ borderopacity="1.0"
185+ inkscape:pageopacity="0.0"
186+ inkscape:pageshadow="2"
187+ inkscape:zoom="0.70710678"
188+ inkscape:cx="510.54885"
189+ inkscape:cy="435.44033"
190+ inkscape:current-layer="layer1"
191+ inkscape:document-units="px"
192+ showgrid="false"
193+ showguides="true"
194+ inkscape:guide-bbox="true"
195+ inkscape:window-width="1393"
196+ inkscape:window-height="789"
197+ inkscape:window-x="47"
198+ inkscape:window-y="3"
199+ inkscape:window-maximized="0">
200+ <sodipodi:guide
201+ orientation="1,0"
202+ position="984,175"
203+ id="guide4870" />
204+ </sodipodi:namedview>
205+ <metadata
206+ id="metadata4134">
207+ <rdf:RDF>
208+ <cc:Work
209+ rdf:about="">
210+ <dc:format>image/svg+xml</dc:format>
211+ <dc:type
212+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
213+ <dc:title />
214+ </cc:Work>
215+ </rdf:RDF>
216+ </metadata>
217+ <g
218+ id="layer1"
219+ inkscape:label="Layer 1"
220+ inkscape:groupmode="layer">
221+ <rect
222+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24376427999999994;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
223+ id="rect4137-5"
224+ width="412.79617"
225+ height="287.24374"
226+ x="571.56415"
227+ y="34.192436" />
228+ <rect
229+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.24167538000000000;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
230+ id="rect4137"
231+ width="412.79617"
232+ height="286.27966"
233+ x="33.567425"
234+ y="34.473083" />
235+ <rect
236+ style="fill:#41bff6;fill-opacity:1;stroke:#008080;stroke-width:1.89734482999999998;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
237+ id="rect4137-6"
238+ width="950.33942"
239+ height="290.35135"
240+ x="32.696255"
241+ y="448.07922" />
242+ <rect
243+ style="fill:#999999;stroke:none;stroke-width:1.97458196000000008;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
244+ id="rect4657-9"
245+ width="582.76776"
246+ height="145.3952"
247+ x="109.61612"
248+ y="-307.5813"
249+ transform="matrix(0,1,-1,0,0,0)" />
250+ <rect
251+ style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1;opacity:1"
252+ id="rect4657"
253+ width="582.76776"
254+ height="149.16254"
255+ x="256.99347"
256+ y="124.76707" />
257+ <text
258+ xml:space="preserve"
259+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
260+ x="36.887089"
261+ y="73.584908"
262+ id="text4659"
263+ sodipodi:linespacing="125%"><tspan
264+ sodipodi:role="line"
265+ id="tspan4661"
266+ x="36.887089"
267+ y="73.584908"
268+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
269+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
270+ id="tspan4038">1</tspan>:<tspan
271+ style="font-weight:normal;-inkscape-font-specification:Courier New;fill:#800000"
272+ id="tspan4036">1080</tspan></tspan></text>
273+ <text
274+ xml:space="preserve"
275+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
276+ x="574.88385"
277+ y="73.30426"
278+ id="text4659-2"
279+ sodipodi:linespacing="125%"><tspan
280+ sodipodi:role="line"
281+ id="tspan4661-9"
282+ x="574.88385"
283+ y="73.30426"
284+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
285+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
286+ id="tspan4042">1</tspan>:<tspan
287+ style="fill:#800000"
288+ id="tspan4044">1081</tspan></tspan></text>
289+ <rect
290+ style="fill:#999999;stroke:none;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
291+ id="rect4657-7"
292+ width="582.76776"
293+ height="149.16254"
294+ x="229.61612"
295+ y="535.4187" />
296+ <text
297+ xml:space="preserve"
298+ style="font-size:40px;font-style:normal;font-weight:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans"
299+ x="321.0159"
300+ y="488.19104"
301+ id="text4659-9"
302+ sodipodi:linespacing="125%"><tspan
303+ sodipodi:role="line"
304+ id="tspan4661-90"
305+ x="321.0159"
306+ y="488.19104"
307+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.<tspan
308+ style="font-weight:bold;-inkscape-font-specification:Courier New Bold"
309+ id="tspan4046">2</tspan>:<tspan
310+ style="fill:#800000"
311+ id="tspan4048">1080</tspan></tspan></text>
312+ <rect
313+ style="fill:#ffa23a;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none;fill-opacity:1"
314+ id="rect4724"
315+ width="366.79245"
316+ height="200.15094"
317+ x="54.339622"
318+ y="95.094337" />
319+ <text
320+ xml:space="preserve"
321+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
322+ x="62.264153"
323+ y="117.35849"
324+ id="text4734"
325+ sodipodi:linespacing="125%"><tspan
326+ sodipodi:role="line"
327+ id="tspan4736"
328+ x="62.264153"
329+ y="117.35849"
330+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1080:0</tspan></text>
331+ <rect
332+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
333+ id="rect4724-0"
334+ width="366.79245"
335+ height="200.15094"
336+ x="597.60376"
337+ y="98.92453" />
338+ <text
339+ xml:space="preserve"
340+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
341+ x="605.52832"
342+ y="121.18868"
343+ id="text4734-8"
344+ sodipodi:linespacing="125%"><tspan
345+ sodipodi:role="line"
346+ id="tspan4736-8"
347+ x="605.52832"
348+ y="121.18868"
349+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.1:1081:0</tspan></text>
350+ <rect
351+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
352+ id="rect4724-6"
353+ width="366.79245"
354+ height="200.15094"
355+ x="53.60376"
356+ y="511.92453" />
357+ <text
358+ xml:space="preserve"
359+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier New;-inkscape-font-specification:Courier New"
360+ x="63.52832"
361+ y="534.18872"
362+ id="text4734-0"
363+ sodipodi:linespacing="125%"><tspan
364+ sodipodi:role="line"
365+ id="tspan4736-9"
366+ x="63.52832"
367+ y="534.18872">198.51.100.2:1080:0</tspan></text>
368+ <rect
369+ style="fill:#ffa23a;fill-opacity:1;stroke:#340000;stroke-width:2;stroke-miterlimit:4;stroke-opacity:1;stroke-dasharray:none"
370+ id="rect4724-06"
371+ width="366.79245"
372+ height="200.15094"
373+ x="596.60376"
374+ y="510.92456" />
375+ <text
376+ xml:space="preserve"
377+ style="font-size:20px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;font-family:Sans;-inkscape-font-specification:Sans"
378+ x="604.52832"
379+ y="533.18872"
380+ id="text4734-02"
381+ sodipodi:linespacing="125%"><tspan
382+ sodipodi:role="line"
383+ id="tspan4736-4"
384+ x="604.52832"
385+ y="533.18872"
386+ style="-inkscape-font-specification:Courier New;font-family:Courier New;font-weight:normal;font-style:normal;font-stretch:normal;font-variant:normal">198.51.100.2:1080:1</tspan></text>
387+ <path
388+ sodipodi:type="arc"
389+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
390+ id="path5106"
391+ sodipodi:cx="215.5"
392+ sodipodi:cy="197.5"
393+ sodipodi:rx="14.5"
394+ sodipodi:ry="14.5"
395+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
396+ transform="translate(22.235847,-2.3301926)" />
397+ <path
398+ sodipodi:type="arc"
399+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
400+ id="path5106-0"
401+ sodipodi:cx="215.5"
402+ sodipodi:cy="197.5"
403+ sodipodi:rx="14.5"
404+ sodipodi:ry="14.5"
405+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
406+ transform="translate(565.49998,1.5)" />
407+ <path
408+ sodipodi:type="arc"
409+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
410+ id="path5106-7"
411+ sodipodi:cx="215.5"
412+ sodipodi:cy="197.5"
413+ sodipodi:rx="14.5"
414+ sodipodi:ry="14.5"
415+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
416+ transform="translate(564.49998,413.50003)" />
417+ <path
418+ sodipodi:type="arc"
419+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
420+ id="path5106-06"
421+ sodipodi:cx="215.5"
422+ sodipodi:cy="197.5"
423+ sodipodi:rx="14.5"
424+ sodipodi:ry="14.5"
425+ d="m 230,197.5 a 14.5,14.5 0 1 1 -29,0 14.5,14.5 0 1 1 29,0 z"
426+ transform="translate(21.499985,414.5)" />
427+ <path
428+ sodipodi:type="star"
429+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
430+ id="path5217"
431+ sodipodi:sides="3"
432+ sodipodi:cx="-58"
433+ sodipodi:cy="224"
434+ sodipodi:r1="15.033296"
435+ sodipodi:r2="7.5166483"
436+ sodipodi:arg1="-1.5707963"
437+ sodipodi:arg2="-0.52359878"
438+ inkscape:flatsided="true"
439+ inkscape:rounded="0"
440+ inkscape:randomized="0"
441+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
442+ inkscape:transform-center-y="-3.7583241"
443+ transform="translate(250,279.48335)" />
444+ <path
445+ sodipodi:type="star"
446+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
447+ id="path5217-1"
448+ sodipodi:sides="3"
449+ sodipodi:cx="-58"
450+ sodipodi:cy="224"
451+ sodipodi:r1="15.033296"
452+ sodipodi:r2="7.5166483"
453+ sodipodi:arg1="-1.5707963"
454+ sodipodi:arg2="-0.52359878"
455+ inkscape:flatsided="true"
456+ inkscape:rounded="0"
457+ inkscape:randomized="0"
458+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
459+ inkscape:transform-center-y="-3.7583241"
460+ transform="translate(336,278.75832)" />
461+ <path
462+ sodipodi:type="star"
463+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
464+ id="path5217-0"
465+ sodipodi:sides="3"
466+ sodipodi:cx="-58"
467+ sodipodi:cy="224"
468+ sodipodi:r1="15.033296"
469+ sodipodi:r2="7.5166483"
470+ sodipodi:arg1="-1.5707963"
471+ sodipodi:arg2="-0.52359878"
472+ inkscape:flatsided="true"
473+ inkscape:rounded="0"
474+ inkscape:randomized="0"
475+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
476+ inkscape:transform-center-y="-3.7583241"
477+ transform="translate(292,278.75832)" />
478+ <path
479+ sodipodi:type="star"
480+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
481+ id="path5217-7"
482+ sodipodi:sides="3"
483+ sodipodi:cx="-58"
484+ sodipodi:cy="224"
485+ sodipodi:r1="15.033296"
486+ sodipodi:r2="7.5166483"
487+ sodipodi:arg1="-1.5707963"
488+ sodipodi:arg2="-0.52359878"
489+ inkscape:flatsided="true"
490+ inkscape:rounded="0"
491+ inkscape:randomized="0"
492+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
493+ transform="matrix(0,1,-1,0,654,214.75832)"
494+ inkscape:transform-center-x="-3.7583239" />
495+ <path
496+ sodipodi:type="star"
497+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
498+ id="path5217-4"
499+ sodipodi:sides="3"
500+ sodipodi:cx="-58"
501+ sodipodi:cy="224"
502+ sodipodi:r1="15.033296"
503+ sodipodi:r2="7.5166483"
504+ sodipodi:arg1="-1.5707963"
505+ sodipodi:arg2="-0.52359878"
506+ inkscape:flatsided="true"
507+ inkscape:rounded="0"
508+ inkscape:randomized="0"
509+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
510+ transform="matrix(0,1,-1,0,653,299.75832)"
511+ inkscape:transform-center-x="-3.7583239" />
512+ <path
513+ sodipodi:type="star"
514+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
515+ id="path5217-49"
516+ sodipodi:sides="3"
517+ sodipodi:cx="-58"
518+ sodipodi:cy="224"
519+ sodipodi:r1="15.033296"
520+ sodipodi:r2="7.5166483"
521+ sodipodi:arg1="-1.5707963"
522+ sodipodi:arg2="-0.52359878"
523+ inkscape:flatsided="true"
524+ inkscape:rounded="0"
525+ inkscape:randomized="0"
526+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
527+ transform="matrix(0,-1,1,0,365,140.75832)"
528+ inkscape:transform-center-x="3.7583235" />
529+ <path
530+ sodipodi:type="star"
531+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
532+ id="path5217-70"
533+ sodipodi:sides="3"
534+ sodipodi:cx="-58"
535+ sodipodi:cy="224"
536+ sodipodi:r1="15.033296"
537+ sodipodi:r2="7.5166483"
538+ sodipodi:arg1="-1.5707963"
539+ sodipodi:arg2="-0.52359878"
540+ inkscape:flatsided="true"
541+ inkscape:rounded="0"
542+ inkscape:randomized="0"
543+ d="m -58,208.9667 13.019216,22.54995 -26.038432,0 z"
544+ transform="matrix(0,1,-1,0,653,665.75832)"
545+ inkscape:transform-center-x="-3.7583239" />
546+ <path
547+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
548+ id="path5272"
549+ d="m 193.68926,500.34844 c -0.0623,-0.011 -3.1352,-0.097 -2.77128,-1.41324 0.2615,-0.94576 1.83318,-1.37784 1.76404,-2.35665 -0.0476,-0.67399 -2.3566,0.0555 -1.96552,-0.49551 3.61436,-5.09213 7.40016,-2.72086 3.75441,-4.53186 -1.02814,0.14511 -2.14021,0.86727 -3.08442,0.43531 -0.51327,-0.2348 0.48469,-1.05111 0.89792,-1.43558 1.1048,-1.02792 2.49187,-1.72109 3.59807,-2.74751 0.46707,-0.43338 1.70248,-1.66102 1.07001,-1.58392 -5.6701,0.69128 -9.05745,4.75136 -4.37921,0.0443 -0.70285,-0.0451 -1.58092,0.33122 -2.10855,-0.13529 -0.36515,-0.32287 0.13779,-0.98089 0.34974,-1.41981 0.746,-1.54482 2.04183,-2.71312 3.1089,-4.00945 0.4506,-0.54741 1.18336,-0.99124 1.28844,-1.69243 0.0528,-0.35257 -0.64405,-0.30591 -0.96608,-0.45886 -0.29448,-0.23467 -0.54733,-0.53426 -0.88345,-0.704 -4.59528,-2.32065 4.03029,4.51864 2.22179,-3.3353 -0.30962,-1.34461 -4.25255,2.34931 -4.01941,0.98936 0.49925,-2.91216 11.67979,-5.28818 -0.97921,-1.80297 2.24958,4.51807 3.74218,-3.55163 2.31947,-3.58424 -1.2249,-0.0281 -2.37028,0.65039 -3.58472,0.8125 -0.52552,0.0702 -1.82785,0.34942 -1.58584,-0.1223 0.5628,-1.09696 1.92657,-1.54028 2.85501,-2.35149 0.70996,-0.62032 1.37164,-1.29381 2.05746,-1.94071 -0.89522,0.15512 -1.79044,0.31024 -2.68566,0.46535 0.40052,-0.43099 1.78504,-1.21739 1.20156,-1.29297 -1.00554,-0.13025 -3.61463,1.73864 -2.84352,1.08028 2.61678,-2.23416 7.40375,-3.51247 2.7139,-2.27363 -0.68863,-0.56914 -4.0411,1.72327 -3.46573,0.69506 6.10702,-10.91337 6.03578,15.71084 15.20135,-9.25342 1.34953,-3.67571 -7.11657,3.28455 -10.78034,4.66617 -0.56483,0.21299 -1.20609,0.0542 -1.80913,0.0813 0.76568,-2.82657 9.84801,-2.83331 8.08522,-5.59671 -1.3756,-2.15643 -4.67918,2.20115 -7.19335,2.67169 -0.59179,0.11076 0.56857,-1.08069 0.98997,-1.51069 0.9071,-0.92561 3.07293,-1.22924 2.96045,-2.52034 -0.0925,-1.06133 -2.0796,0.46382 -3.1194,0.69573 -1.9254,-1.61777 -0.23831,-2.25512 1.24604,-3.92389 0.51908,-0.58358 2.26263,-1.8224 1.48163,-1.81517 -4.72816,0.0437 -15.68126,8.0904 3.31529,-3.96387 -2.08474,0.72265 -4.12918,1.57418 -6.25422,2.16795 -6.19352,1.73056 1.93855,-2.61924 2.43539,-3.11862 0.23788,-0.23911 -1.011,-0.39289 -0.78275,-0.64119 1.19525,-1.30024 3.85496,-1.42731 4.26366,-3.14549 0.29345,-1.23365 -2.47514,0.55288 -3.71271,0.82932 -0.47093,1.29702 -2.86607,-0.7275 -2.30369,-1.43649 1.13698,-1.43339 6.00313,-3.6915 4.17835,-3.55914 -3.87338,0.28095 -7.04111,4.03354 -10.92463,4.04848 -2.19049,0.008 3.44176,-2.71129 5.19354,-4.02643 2.07031,-1.55429 4.18104,-3.054 6.27156,-4.581 -2.38158,0.72626 -4.66588,1.94492 -7.14472,2.17878 -0.53269,0.0503 0.25632,-1.04063 0.43321,-1.5456 0.96518,-2.7553 0.80112,-1.64828 3.58926,-4.46916 0.67747,-0.68544 2.91667,-2.22292 1.95765,-2.12762 -2.73974,0.27225 -5.202,1.80566 -7.80301,2.70849 -8.68307,1.74603 11.86244,-6.07092 8.35137,-7.01022 -1.96335,-0.52524 -6.69769,3.57812 -5.84576,1.73289 1.22888,-2.6617 5.30375,-2.7549 7.30622,-4.89614 0.68666,-0.73425 -2.00109,0.19549 -3.00164,0.29323 0.87732,-0.86011 1.75464,-1.72023 2.63196,-2.58035 -9.58228,3.08729 -5.78397,4.19264 -6.58589,0.97012 -0.0902,-0.3624 -0.0624,-0.93313 -0.42075,-1.03836 -0.91483,-0.26865 -3.5847,0.69399 -2.8594,0.0751 8.61485,-7.35105 17.70344,-8.79375 5.26595,-5.85043 1.60054,-3.41758 1.28401,-1.02057 -0.60908,-2.58794 -0.3464,-0.2868 -0.289,-0.89839 -0.62771,-1.19424 -0.43227,-0.37759 -1.86567,-0.23189 -1.56403,-0.7202 2.34987,-3.80416 8.10292,-4.17851 0.0503,-2.68926 -1.15677,-3.65997 -0.0599,1.01346 5.25047,-5.42269 0.33771,-0.40931 -1.12483,-0.33282 -1.37625,-0.80012 -0.22134,-0.4114 0.2271,-0.9209 0.19939,-1.38724 -0.20588,-3.46551 -0.71496,1.54991 -0.16416,-2.39216 -5.64005,3.38956 6.40177,-4.28155 4.35608,-4.32495 -1.7082,-0.0362 -3.23754,1.16492 -4.92891,1.40681 -0.55643,0.0796 -2.04039,-0.0979 -1.61937,-0.47032 2.59221,-2.29286 6.19284,-3.30617 8.64724,-5.74599 0.70785,-0.70364 -1.99446,0.0827 -2.99169,0.12404 -0.76412,-0.0589 -2.58888,0.52999 -2.29238,-0.17673 0.62545,-1.49077 4.87787,-2.0553 3.688,-3.14973 -1.3995,-1.28723 -3.63271,1.17661 -5.51093,1.47304 -0.6753,0.10658 -1.96892,0.39814 -2.03141,-0.28266 2.03577,-2.47367 2.13582,-1.3059 1.42131,-3.21609 0.58154,-2.04915 3.24163,-2.36974 4.11535,-4.097 -0.79817,-0.13876 -2.2949,0.11553 -1.46683,-1.35383 0.38381,-0.68104 2.31695,-1.56406 1.55829,-1.75265 -1.35197,-0.33608 -2.68049,0.76035 -4.02074,1.14053 10.77595,-7.1105 3.36075,-1.66253 -0.19448,-1.41063 -0.80754,0.0572 1.50647,-0.94746 1.70133,-1.73322 0.0991,-0.39958 -0.87355,-0.0758 -1.18632,-0.34348 -0.22941,-0.19634 -0.44034,-0.65146 -0.2367,-0.87442 1.11915,-1.22532 2.58807,-2.07788 3.88211,-3.11681 0.46226,-0.59368 2.13907,-1.7945 1.38677,-1.78102 -14.87693,0.26652 -1.27125,4.70958 -2.16014,-1.06114 -0.19906,-1.29234 -2.99053,1.78966 -3.84104,0.79648 -2.43359,-2.8418 7.84171,-2.59072 -0.18106,-2.32196 1.26696,-1.11062 2.53393,-2.22125 3.80089,-3.33188 -0.37381,-0.36169 -1.34521,-0.61552 -1.12142,-1.08506 0.6859,-1.4391 2.50279,-2.08411 3.29206,-3.46921 0.30719,-0.53911 0.33063,-1.66965 -0.26531,-1.84246 -1.52437,-0.44204 -4.51329,1.95947 -4.74554,0.38939 -0.28847,-1.95008 2.79003,-2.78566 4.18504,-4.17849 -2.84688,0.77924 -5.61536,1.94441 -8.54064,2.33772 -0.86059,0.11571 -2.88311,-0.10077 -2.4594,-0.85871 1.22634,-2.19374 3.76055,-3.33687 5.69902,-4.93647 2.28197,-1.88304 5.17285,-3.1505 6.95922,-5.5089 0.48483,-0.64009 -1.53136,-0.56213 -2.33353,-0.59804 -1.34734,-0.0603 -2.6893,0.20862 -4.03395,0.31293 0.68463,-0.93535 1.93126,-1.65341 2.0539,-2.80605 0.14342,-1.34792 -3.60803,-0.10431 -3.67727,-1.17576 -0.0618,-0.95616 1.17488,-1.51652 1.82059,-2.22442 3.91139,-4.28816 5.04581,-3.35568 -6.18155,0.79961 3.2876,-2.35602 5.31447,-2.73015 6.79781,-5.80474 0.18346,-0.38028 0.74816,-1.16656 0.32973,-1.223 -1.22167,-0.16479 -2.80483,1.70893 -3.61503,0.77985 -0.71461,-0.81948 1.69757,-1.45353 2.17622,-2.42979 0.17131,-0.3494 -0.3057,-0.71572 -0.45855,-1.07358 0.20589,-0.53947 1.0395,-1.22409 0.61769,-1.61843 -0.59794,-0.559 -1.71607,0.25692 -2.45368,-0.098 -0.35235,-0.16954 -0.12335,-0.77263 -0.16402,-1.16153 -0.35068,-3.35404 1.76007,-2.61899 -2.06169,-3.55371 0.97288,-0.96358 6.7044,-6.50628 7.49127,-7.802 0.42498,-0.6998 1.09682,-2.25813 0.2981,-2.43805 -2.14748,-0.48373 -4.40681,1.64541 -6.52208,1.03607 -0.89757,-0.25856 0.33999,-1.8897 0.85608,-2.66825 0.97958,-1.47772 2.36172,-2.64483 3.54258,-3.96725 0.0597,-0.68098 0.49091,-1.4346 0.17912,-2.04295 -1.44492,-2.81925 -3.89682,2.01552 0.0472,-3.44476 0.58877,-0.81511 2.85288,-2.38727 1.84737,-2.38469 -5.49626,0.0141 -12.52399,6.39939 -2.52177,-1.41194 0.1794,-0.46573 0.24889,-0.99051 0.53821,-1.39719 4.68594,-6.58674 -0.51929,4.47458 -3.32287,-0.5112 -0.864,-1.53652 3.5875,-1.65903 4.094,-3.34747 0.30845,-1.02819 -2.13504,0.50427 -3.19953,0.36577 -0.41883,-0.0545 -0.59573,-0.59889 -0.8936,-0.89833 0.92251,-0.92192 1.84502,-1.84384 2.76752,-2.76576 -1.55796,0.31564 -5.53053,2.28596 -4.67389,0.94692 1.58563,-2.47854 5.13653,-2.97992 7.27047,-5.00568 0.39453,-0.37453 -1.07912,-0.19012 -1.5841,-0.39242 -2.59907,-1.04122 1.45702,-1.10305 -3.99527,-0.0413 0.23249,-0.50921 2.4381,-3.75255 2.14815,-3.95163 -0.6386,-0.43846 -1.56195,0.16288 -2.3238,0.0227 -0.41951,-0.0772 -0.73377,-0.43517 -1.10066,-0.65276 -1.05703,0.094 -2.11405,0.18798 -3.17108,0.28197 14.56659,-10.91162 6.60855,-1.66215 5.19861,-5.97316 -0.7148,-2.18559 1.24321,-1.65251 -0.51252,-3.60095 -0.48504,-0.53828 -1.8482,-0.40764 -1.85561,-1.13218 -0.0121,-1.18458 1.20852,-2.03788 1.81278,-3.05682 -9.27694,-0.46414 -0.43422,1.04567 -1.03621,-3.77995 -0.14103,-1.13058 -2.45562,0.40168 -3.41099,-0.2191 -0.53557,-0.348 -0.27624,-1.42029 0.13193,-1.91155 1.52211,-1.83192 3.75639,-2.96142 5.37142,-4.71197 0.69547,-0.75384 0.97981,-1.80216 1.46971,-2.70325 -0.96071,-0.0793 -1.91817,-0.23172 -2.88212,-0.23794 -8.55832,-0.0551 2.30363,2.43158 5.84613,-5.75478 1.04199,-2.40794 -6.05494,4.67811 -7.47329,2.47082 -1.97994,-3.08124 13.63059,-6.08404 2.2912,-3.51859 -0.25021,-0.2252 -0.8741,-0.36244 -0.75064,-0.67561 0.33861,-0.85888 1.28474,-1.33325 1.8349,-2.07463 0.3234,-0.4358 1.30072,-1.54508 0.76935,-1.4348 -2.61741,0.54321 -4.9249,2.12483 -7.50279,2.83224 -0.26475,0.0727 -0.6308,-0.3697 -0.53436,-0.62673 0.22699,-0.60501 0.87117,-0.95461 1.30676,-1.43191 8.33195,-4.95149 5.03236,-1.13737 6.11797,-4.3184 0.10381,-0.30416 0.66881,-0.79561 0.36265,-0.89337 -0.70346,-0.22461 -2.72427,0.82235 -2.19373,0.30871 3.86981,-3.74657 7.01351,-2.20799 4.21301,-3.35731 6.47296,-4.28612 -2.20647,1.73687 -2.12215,-0.0258 0.0771,-1.61222 3.0843,-1.12915 4.34522,-2.13676 0.70337,-0.56207 -1.70011,0.66929 -2.59767,0.74027 -0.317,0.0251 0.78281,-0.5597 2.49822,-1.51137 0.46567,-0.53737 0.66407,-0.83263 1.36374,-1.22722 0.98725,-0.55676 2.06782,-0.93963 3.04281,-1.51759 0.0706,-0.0419 -0.0426,-0.23655 -0.12151,-0.21413 -5.29503,1.50384 -4.40257,3.36258 -5.22385,1.37394 3.06387,-1.38383 6.12774,-2.76767 9.1916,-4.1515 -1.02417,0.2612 -2.73589,1.78554 -3.07252,0.78362 -0.34305,-1.02104 2.16911,-0.75459 2.7855,-1.63792 0.3836,-0.54973 -1.31058,0.6231 -1.95917,0.45373 -0.38527,-0.1006 0.60234,-0.53362 0.95654,-0.71554 1.47371,-0.75691 3.00581,-1.3943 4.50871,-2.09145 -0.63184,0.1759 -1.24071,0.5651 -1.89552,0.52772 -0.3639,-0.0208 0.62135,-0.38155 0.92504,-0.58312 3.01431,-2.00081 5.71058,-4.58179 9.02869,-6.02384 1.54675,-0.67223 -4.64784,3.89499 -4.52219,5.19822 0.0355,0.36779 0.73819,0.0341 1.10729,0.0512 4.32563,-0.80488 7.35768,-4.13082 11.1,-6.17039 0.43499,-0.23707 -1.10983,0.83769 -0.82002,1.23946 0.2765,0.38331 0.88036,-0.35243 1.29073,-0.58691 0.67659,-0.38659 1.30782,-0.84766 1.96173,-1.27149 -5.61569,3.81123 5.847,-4.12908 4.57733,-2.85552 -1.45264,1.4571 -6.72903,3.75042 -4.68856,4.01464 2.53042,0.32765 4.77089,-2.05254 6.66849,-3.75827 1.18442,-1.06466 -3.01765,1.13692 -4.60412,1.27648 -0.49565,0.11429 -1.88012,0.66559 -1.48695,0.34287 0.77429,-0.63555 1.7993,-0.88123 2.69333,-1.33308 0.97151,-0.49102 1.95644,-0.95806 2.9031,-1.49543 2.92382,-1.0436 -0.19707,-0.51294 -0.0215,-0.62582 1.25048,-0.80387 2.65543,-1.33729 3.98314,-2.00593 0,0 4.7807,-1.95243 4.7807,-1.95243 l 0,0 c -1.85659,1.05808 -3.72243,2.42084 -5.65484,3.34966 -9.08762,4.36805 -8.0472,3.12416 2.63095,-0.35854 0.20723,-0.0676 -0.32075,0.29522 -0.48112,0.44283 -2.06995,0.87954 -4.1399,1.75908 -6.20986,2.63862 0.9538,-0.27297 3.69622,-1.35491 2.86139,-0.81891 -2.24338,1.44037 -4.80919,2.30726 -7.15434,3.57521 -0.84863,0.45883 -2.71756,2.51318 -2.41323,1.5977 0.55196,-1.66044 2.99692,-2.07528 3.70559,-3.71809 2.47079,-5.12674 -0.15677,0.50283 -12.08956,8.85874 -0.3399,0.23801 0.52938,-0.68968 0.57986,-1.10155 0.0246,-0.20093 -0.29494,-0.28758 -0.38754,-0.4676 -0.11097,-0.21572 -0.0206,-0.54638 -0.21125,-0.69644 -0.23265,-0.18316 -0.58274,-0.10535 -0.8741,-0.15803 -1.08077,0.53197 -2.16154,1.06394 -3.2423,1.59591 0.61123,-0.74052 2.73074,-2.56403 1.8337,-2.22155 -2.15024,0.82093 -3.72623,2.75117 -5.80559,3.73796 -0.98272,0.46636 -3.62463,1.55286 -3.21762,0.54411 0.0771,-0.19114 4.26615,-1.34033 5.19748,-1.60123 -0.002,0.84843 0.0797,0.35024 -1.54628,1.13776 -2.43685,1.18026 -4.9713,2.16361 -7.35391,3.44985 -0.17851,0.0964 0.36821,0.22917 0.57035,0.21223 0.76295,-0.0639 2.88998,-0.87285 2.25259,-0.44871 -1.73923,1.15733 -3.76736,1.80676 -5.65104,2.71013 10.64971,-3.49618 2.1377,-0.93772 0.0559,0.71953 -0.87207,0.69424 4.11786,-1.63073 3.18387,-1.02234 -2.76085,1.79836 -4.83888,1.37533 -6.50296,3.57948 0.91407,-0.27289 1.78835,-0.80636 2.74221,-0.81867 0.91196,-0.0118 -3.46726,1.47612 -1.8579,1.29003 0.88484,-0.10231 1.72074,-1.001 2.56995,-0.7322 1.4859,0.47035 -9.20657,3.22381 1.57572,0.11558 -2.36017,1.26735 -4.72034,2.53469 -7.08052,3.80204 0.11469,0.19623 0.51051,0.43392 0.34406,0.58869 -1.0316,0.95918 -4.91768,2.38029 -3.50929,2.35433 2.37641,-0.0438 4.3475,-2.14947 6.70962,-2.41333 0.99204,-0.11081 -4.76651,2.1144 -1.8757,2.33444 -2.47051,2.27022 -1.40706,0.62544 -0.30171,1.4434 0.23656,0.17505 0.58096,0.61391 0.35865,0.80673 -10.38418,9.00668 -4.16531,0.51016 -6.4293,6.51935 2.63048,-0.9705 5.18095,-2.19421 7.89145,-2.91149 0.52827,-0.1398 2.01774,0.0636 1.58915,0.40263 -3.37773,2.67161 -8.32186,3.49544 -10.88911,6.95316 -1.61096,2.16972 5.0682,-1.89717 7.67205,-2.62025 1.25504,-0.34852 2.5621,-0.62886 3.86383,-0.5832 0.65675,0.023 1.20643,0.52147 1.80965,0.7822 -3.46414,2.44363 -7.191,4.55195 -10.39243,7.33089 -0.58409,0.50701 -1.35877,1.98436 -0.62675,2.2341 1.58563,0.54094 3.29876,-0.62716 4.96942,-0.75257 1.2209,-0.0917 4.12945,-1.03159 3.67154,0.10389 -2.69944,6.69376 -9.76124,4.11086 -2.82461,5.80978 6.90857,0.95619 0.9429,-0.72532 -1.57226,5.00935 -0.34511,0.78688 2.32093,-0.12806 2.47595,0.71707 0.20152,1.09859 -1.35608,1.79559 -1.82949,2.80722 -0.6057,1.2943 -0.13837,2.97783 -1.37315,4.06119 6.75468,-0.97119 2.63252,-1.01551 -0.36648,2.73408 -0.22941,0.28683 0.44063,0.77321 0.80719,0.75004 1.40095,-0.0885 4.53648,-2.38467 4.07603,-1.05858 -1.26042,3.62998 -8.23101,3.63354 -3.0188,3.37711 -1.05416,3.23385 -0.10913,-0.73895 4.56561,-0.24918 0.70549,0.0739 -0.68816,1.25315 -1.15449,1.78768 -0.64077,0.73448 -4.96366,4.6973 -5.48665,5.53109 -0.22878,0.36475 0.0942,0.85596 0.14131,1.28395 6.80006,0.91876 -1.15929,-0.83571 1.30873,1.95101 0.51573,0.58233 2.76862,-0.57122 2.33248,0.0729 -1.14053,1.68436 -4.05337,1.81352 -4.87103,3.67613 -0.54479,1.24101 4.28517,-2.52858 4.06555,0.0598 -0.63833,0.76458 -1.43148,1.42297 -1.915,2.29376 -0.0769,0.1384 -0.3511,2.69941 -0.12976,2.8934 0.56558,0.4957 2.22633,-0.20159 2.18825,0.54951 -0.064,1.2629 -1.57761,1.97665 -2.36641,2.96498 -0.019,0.66037 -0.0381,1.32074 -0.0571,1.98111 0.94651,0.22022 2.00211,0.1676 2.83952,0.66067 1.70887,1.0062 0.93959,2.64925 0.89198,4.10584 -0.0661,2.02294 0.18274,3.87611 1.1481,5.67875 -1.06661,1.09941 -2.13322,2.19882 -3.19983,3.29823 0.2676,0.37359 1.04509,0.73029 0.80279,1.12077 -0.8266,1.33216 -3.21601,1.62884 -3.46899,3.17607 -0.16227,0.99251 2.62242,-1.24441 3.00082,-0.31263 1.09046,2.68514 -8.21468,3.66408 1.80952,1.70153 -1.63218,1.29533 -4.86877,1.80245 -4.89653,3.88598 -0.0224,1.67689 3.19324,-1.46022 4.86198,-1.29358 0.65024,0.0649 -1.66078,1.77119 -1.014,1.67783 7.46951,-1.07821 11.3939,-6.41009 0.77149,1.84447 -0.88572,0.68828 -1.57915,1.5935 -2.36873,2.39026 1.30757,-0.26932 2.64879,-1.20722 3.92271,-0.80795 0.63932,0.20037 -0.58657,1.23688 -1.06824,1.70258 -1.32676,1.28278 -3.70274,1.74138 -4.29988,3.48758 -0.15335,0.44846 6.75296,-0.67501 6.46415,-0.24736 -1.58594,2.34843 -4.48718,3.46216 -6.73077,5.19323 1.3217,-0.0924 2.67555,-0.58142 3.96508,-0.27724 0.51852,0.1223 1.02338,0.92317 0.77805,1.39606 -0.77215,1.48839 -2.31758,2.42555 -3.41729,3.69131 -0.96138,1.10654 -2.78709,1.9559 -2.76247,3.42152 0.0163,0.96872 1.93043,0.30116 2.83102,0.65839 0.65744,0.26079 1.18121,0.77827 1.77181,1.16741 -2.81262,4.75928 -2.80872,3.10652 4.67589,1.64938 -1.26041,3.25333 -6.0635,3.67638 -8.34922,6.31233 -0.54709,0.63092 1.63108,0.59247 2.45866,0.48082 6.96578,-0.93979 6.8916,-4.14914 6.40783,-0.21327 -1.18995,1.02522 -2.55904,1.87345 -3.56986,3.07565 -0.54677,0.6503 0.29383,1.66499 0.74286,1.93962 0.0538,0.0329 2.28883,0.36373 1.51653,1.38907 -0.74758,0.99254 -1.85029,1.65906 -2.77544,2.48858 -2.01492,4.0117 0.0735,-1.05844 4.36134,-0.0885 1.08359,0.24512 -1.77515,1.36522 -2.48925,2.21628 -0.52276,0.62303 0.058,4.29809 2.41131,0.37226 -1.92105,1.23721 -3.8421,2.47441 -5.76316,3.71162 0.3956,0.10122 0.79231,0.40919 1.18678,0.30368 2.2344,-0.59765 5.44044,-4.40981 6.52306,-2.36587 3.53427,6.67249 -6.90959,1.38524 -6.55868,5.44393 0.0324,0.37432 0.7442,0.19661 1.04558,0.42095 0.25204,0.18763 0.3661,0.51079 0.54915,0.76618 0.0712,0.37017 -0.10001,0.90141 0.21364,1.11051 0.53553,0.35702 2.28266,-0.21938 1.90691,0.30318 -1.19701,1.66473 -3.90255,1.96694 -4.84762,3.78655 -0.45816,0.88212 2.94486,-1.17713 2.97633,-0.18363 0.0919,2.90267 -10.32021,4.68553 2.55412,1.32332 -13.88816,10.05064 -4.21703,1.92319 -0.25957,2.91804 1.17513,0.29542 -1.99914,1.5097 -2.55359,2.58711 -0.16659,0.32374 0.84505,0.2375 0.91628,0.59456 0.15946,0.79941 -1.27266,1.48463 -0.45859,2.40209 -0.70281,0.75107 -2.11627,1.22464 -2.10843,2.25323 0.027,3.53852 5.53042,-3.86509 0.87871,2.07078 -0.73188,0.93392 -3.50631,2.521 -2.33181,2.68947 4.62982,0.66407 18.02038,-9.23088 -2.55995,4.0518 0.41314,0.23165 0.79809,0.52297 1.23941,0.69496 0.55373,0.2158 1.74031,-0.13462 1.72268,0.45941 -0.03,1.01163 -1.4099,1.50852 -1.80872,2.4387 -0.19008,0.44335 0.29109,0.9798 0.14581,1.43979 -0.89241,2.82552 -2.35877,1.39391 0.18581,2.80361 1.15576,-0.0399 2.31084,-0.1194 3.4673,-0.11973 0.91829,-2.6e-4 2.02747,-0.44581 2.75234,0.11795 1.24736,0.97013 -3.54168,3.86915 -2.35717,3.83563 5.02162,-0.14213 14.14556,-7.29822 -0.0472,2.40961 2.98489,1.23449 0.18921,-0.41624 -0.68824,2.82616 -0.60033,2.21837 4.83753,-1.87475 0.42281,2.20368 -5.8186,5.37536 -11.65517,6.41542 5.10315,0.15479 -0.74735,0.80324 -1.36046,1.75663 -2.24204,2.40972 -2.59356,1.92134 -5.97818,2.8581 -8.12378,5.26942 -0.94007,1.05648 3.87672,-2.20293 4.1629,-0.81801 0.32872,1.59077 -5.29356,3.22403 -3.66927,3.20683 9.34954,-0.099 9.14109,-6.9726 8.95016,-1.77383 -0.66494,0.80063 -1.18496,1.74821 -1.99481,2.40188 -2.30911,1.8638 -6.64809,2.20309 -7.2977,5.09856 -0.49714,2.2159 4.34211,-1.35479 6.56359,-1.82642 1.09779,-0.23306 4.03951,-1.16883 3.35516,-0.27937 -5.32352,6.9192 -9.26326,2.75287 -6.07651,5.70641 1.67414,2.04701 0.30461,0.84469 5.41887,-0.72561 0.11184,0.1144 -6.91012,5.41422 -6.9318,5.49711 -0.24616,0.94113 1.90254,-0.44718 2.87321,-0.5114 0.52816,-0.0349 1.04869,0.14483 1.57303,0.21724 -1.52161,1.1575 -3.3167,2.0243 -4.56482,3.47251 -0.44671,0.51832 2.2492,0.46712 1.74568,1.2988 -0.6216,1.02671 -3.07583,1.37328 -2.61071,2.47971 1.65123,3.92793 4.90473,-3.87333 2.6877,0.77006 -6.66072,5.56962 0.36798,-0.83336 4.28539,-0.27792 1.1079,0.15709 -5.53866,3.34557 -5.46553,4.78461 0.037,0.72743 2.02338,-0.83333 2.15168,0.38075 4.12173,0.99404 -0.0563,-0.29498 -6.22292,4.83789 -0.56224,0.46799 1.47621,-0.0627 2.178,-0.26914 1.64502,-0.48384 3.21416,-1.19582 4.82264,-1.78991 1.49947,-0.55383 4.24314,-3.23134 4.50121,-1.65384 0.27342,1.67132 -2.893,1.76151 -4.3395,2.64227 -1.95306,2.20485 -4.62765,2.88503 -7.18354,4.55102 -0.27259,0.17768 0.66562,-0.2445 0.96818,-0.12476 0.19028,0.0753 0.12726,0.38899 0.19089,0.58349 1.80537,-0.61886 3.61073,-1.23772 5.4161,-1.85658 -0.84041,0.72567 -1.82938,1.30856 -2.52124,2.17702 -0.1752,0.21991 0.033,0.56791 0.12198,0.83464 0.96367,2.88967 4.76481,-1.02093 4.14926,2.23243 -2.60527,1.74858 -5.40667,3.23551 -7.81581,5.24574 -0.25305,0.21115 0.40301,0.70659 0.73015,0.66667 1.61028,-0.1965 3.11405,-0.91185 4.68222,-1.32713 5.53619,-1.46608 4.75726,-1.80858 1.75589,1.30793 -0.67715,0.70314 -1.3174,1.4409 -1.97611,2.16135 0.34892,0.13924 1.05014,0.0421 1.04674,0.41771 -0.003,0.31093 -2.48306,3.33637 -2.38036,3.44466 1.97496,2.08253 2.7307,-1.87751 3.63602,0.61954 0.13879,0.38282 -0.0124,0.81431 -0.0186,1.22147 -0.72121,0.73268 -1.83167,1.22502 -2.16363,2.19804 -0.14402,0.42214 0.92361,0.15463 1.26175,0.44549 0.23821,0.2049 0.0682,0.67886 0.29638,0.89481 1.89225,1.79045 3.97497,-3.22614 -2.61618,3.25198 -0.37523,0.3688 -0.44084,0.95545 -0.66126,1.43318 -0.74546,2.83605 -0.90252,1.57357 3.71736,0.86489 0.008,0.42841 -6.88909,5.34977 -7.0881,6.42457 -0.14836,0.80124 1.73679,-0.14013 2.42695,0.2931 0.35611,0.22354 0.032,0.84032 0.048,1.26048 0,0 0.60987,-0.29215 0.60987,-0.29215 z"
550+ inkscape:connector-curvature="0" />
551+ <path
552+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
553+ id="path5274"
554+ d="m 235.10087,494.853 c -1.72477,0.26384 -3.45101,1.06486 -5.1743,0.79153 -0.6595,-0.1046 -1.35563,-1.23186 -0.95104,-1.76306 1.85598,-2.43682 6.54502,-3.01774 6.90875,-6.05919 0.24847,-2.0776 -4.22104,1.06972 -6.25171,0.56521 -0.73743,-0.18322 -0.89283,-1.60823 -0.45989,-2.23268 1.45131,-2.09329 3.73816,-3.46105 5.60724,-5.19158 -1.30165,-0.0397 -3.61704,1.15104 -3.90497,-0.11899 -0.346,-1.52615 2.44277,-2.11658 3.07345,-3.54874 0.21772,-0.49443 -0.40056,-1.19952 -0.92452,-1.33116 -2.9824,-0.74933 -3.35447,1.04728 -6.00663,-0.1243 -0.44177,-0.19515 -0.59317,-0.76231 -0.88975,-1.14347 -1.62467,-2.19337 7.01252,-3.6846 6.03097,-6.4629 -0.35181,-0.99579 -2.82628,0.69214 -3.15292,-0.31219 -0.38064,-1.1704 1.77768,-1.8691 2.05342,-3.06855 0.13841,-0.60205 -0.6583,-1.04553 -0.98745,-1.56829 0.30475,-0.89097 0.60949,-1.78193 0.91424,-2.67289 -7.53264,-2.23618 2.38396,1.59728 1.54227,-5.15805 -0.19963,-1.60228 -4.7333,1.91176 -4.83467,0.30028 -0.13257,-2.10718 3.96145,-2.35795 4.5782,-4.3772 0.30919,-1.0123 -2.1105,-0.1648 -3.16575,-0.24721 1.05904,-1.13455 2.11809,-2.26911 3.17714,-3.40366 -0.0107,-0.005 -2.87769,-1.00308 -2.64038,-1.81722 0.28175,-0.96659 2.02632,-1.34668 1.90262,-2.34586 -0.0907,-0.7326 -2.66456,0.44301 -2.21022,-0.13879 4.30542,-5.51324 7.1961,-2.12072 4.55559,-4.73091 -10.33839,2.77071 -4.13255,1.83896 0.36955,-2.9086 0.29783,-0.31407 -0.57517,-0.86256 -1.00599,-0.821 -1.92044,0.18526 -4.33153,2.91099 -5.60131,1.45839 4.33291,-3.89435 5.22082,-2.41149 2.30678,-4.64367 -0.95622,-0.209 -2.72732,0.34155 -2.86867,-0.62699 -0.18982,-1.30072 1.45602,-2.19689 2.31084,-3.19549 1.82796,-2.13542 4.60067,-3.91377 5.39003,-6.85628 0.1612,-0.60094 0.29581,-1.49754 -0.21396,-1.85426 -0.8024,-0.56149 -1.9457,-0.22517 -2.91855,-0.33776 13.2084,-10.64887 -4.15898,2.78139 1.32237,-6.03641 0.64361,-1.03536 2.37686,-1.74659 2.16556,-2.94724 -3.43454,-0.58468 -2.63967,0.45586 -3.04384,-2.48312 -1.56436,2.8e-4 -3.65465,1.17085 -4.69308,8.6e-4 -0.85123,-0.95908 0.86545,-2.44305 1.58105,-3.50717 1.18764,-1.76606 2.96115,-3.10066 4.08003,-4.91106 5.48924,-8.88184 -2.19873,1.44113 -2.88812,-4.43772 -0.21626,-1.84413 2.23606,-2.96484 3.35409,-4.44726 -0.43526,2.04932 -5.52153,-1.4114 -4.49527,-2.86108 1.54224,-2.17853 4.97434,-2.83829 6.00046,-5.30235 0.48638,-1.16795 -3.85006,1.27155 -3.79552,0.008 0.29225,-6.77243 6.68102,-1.96905 2.60362,-4.63478 -1.03744,0.0157 -3.37206,1.05159 -3.11233,0.0471 0.4629,-1.79031 2.90142,-2.33554 4.07379,-3.76559 0.6145,-0.74957 0.86383,-1.74051 1.18878,-2.65368 0.33006,-0.92755 1.7161,-2.57839 0.77018,-2.8514 -7.79155,-2.2488 -8.87812,5.07596 -6.27386,-2.9532 -0.19249,-5.38304 7.51347,-6.23842 8.35735,-10.67915 0.32218,-1.6954 -4.83804,1.06359 -5.13804,-0.63588 -0.37881,-2.14591 3.18898,-3.10151 4.13147,-5.06624 0.37314,-0.77786 -0.50218,-1.68058 -0.48124,-2.54306 0.0239,-0.98457 0.40879,-1.92683 0.61318,-2.89025 -13.08296,-3e-5 0.34211,1.32306 -2.48426,-3.42912 -0.72627,-1.22112 -2.99658,0.75682 -4.26095,0.10876 -0.63537,-0.32567 0.43448,-1.404 0.35062,-2.11303 -0.59735,-5.05055 -8.30722,4.38127 5.7127,-6.54936 -0.0182,-1.2e-4 -4.80445,0.71053 -5.00217,-1.19016 -0.0931,-0.89458 1.35621,-1.63297 1.05882,-2.48178 -0.26951,-0.7692 -2.36655,-0.1317 -2.25749,-0.93942 0.21104,-1.56284 1.93828,-2.48832 2.89013,-3.74569 0.93981,-1.24147 1.8564,-2.50034 2.7846,-3.75051 -2.76858,-2.34245 -1.68916,-0.49431 -0.42062,-4.50395 0.27132,-0.8576 0.13894,-1.83132 0.51325,-2.64924 0.0839,-0.18345 4.09283,-3.81873 1.03007,-4.56276 -1.17187,-0.28469 -2.40782,0.1402 -3.61173,0.2103 0.44344,-0.69241 1.62548,-1.3098 1.33032,-2.07723 -0.27912,-0.72573 -1.74502,0.12468 -2.29333,-0.42664 -2.14536,-2.1571 2.94322,-3.721 4.63358,-7.16098 0.43562,-0.88652 -0.5755,-1.88984 -0.86326,-2.83476 1.38204,-1.92046 2.76407,-3.84091 4.1461,-5.76136 -1.12321,-2.72543 -5.51508,-1.70553 -6.87835,-3.97595 -0.64832,-1.07972 0.6824,-2.56943 0.29228,-3.76689 -0.32662,-1.00257 -2.37342,-1.18153 -2.24537,-2.22816 0.2216,-1.8113 4.5249,-3.42652 3.07232,-4.53103 -2.03388,-1.54653 -5.05737,0.73258 -7.58605,1.09887 3.45501,-4.83392 2.38586,-3.59475 6.51263,-8.25392 1.30105,-1.46891 3.68816,-2.41085 3.96198,-4.3539 0.1544,-1.09559 -3.26799,0.49128 -3.26173,-0.61512 0.0295,-5.20775 9.08516,-4.03102 -1.61053,-3.94352 1.95939,-1.79801 4.27984,-3.26861 5.87816,-5.39403 0.5383,-0.71582 1.049,-2.4148 0.1935,-2.67992 -2.17746,-0.6748 -4.83656,1.77094 -6.80983,0.62951 -1.14404,-0.66177 0.90074,-2.53951 1.7331,-3.56613 5.14504,-6.34577 8.38621,-4.56052 2.51601,-6.13981 -0.85199,-0.32077 -2.4474,-0.0584 -2.55599,-0.96231 -0.15992,-1.33111 1.81714,-2.15158 2.02274,-3.47641 0.10406,-0.6705 -0.95976,-0.99901 -1.23172,-1.62066 -0.25041,-0.57238 0.0184,-1.30737 -0.28754,-1.8521 -0.28092,-0.5002 -1.61971,-0.55889 -1.35127,-1.06589 0.82116,-1.55092 2.55255,-2.40897 3.82883,-3.61345 0.68857,-0.86315 3.1386,-2.32855 2.06571,-2.58945 -10.65886,-2.59195 -5.5639,9.83091 1.19302,-3.59935 0.81945,-1.62876 -6.02054,2.91187 -5.33113,1.22396 2.10963,-5.16508 13.61278,-6.44046 1.79364,-4.30704 0.21403,-0.73136 0.91552,-1.4828 0.64208,-2.1941 -0.26442,-0.68781 -1.27472,-0.73968 -1.91207,-1.10953 1.76068,-1.5448 5.50805,-2.30302 5.28205,-4.63441 -0.18401,-1.89836 -4.58115,2.58145 -5.63515,0.99188 -2.44934,-3.69394 14.48858,-5.96488 -2.32442,-2.54757 -1.7179,-1.85348 6.47741,-4.03448 5.12419,-6.41256 -0.5953,-1.04614 -2.55849,0.49122 -3.60971,-0.095 -0.53027,-0.29573 -0.24018,-1.38425 0.19132,-1.81139 2.01047,-1.99013 4.52431,-3.3972 6.78646,-5.0958 0,0 0.68933,-0.35123 0.68933,-0.35123 l 0,0 c -1.6505,1.38695 -3.301,2.7739 -4.9515,4.16084 1.18084,-0.0304 3.93897,-1.20381 3.54252,-0.0911 -0.76705,2.15293 -7.26975,3.74376 -5.1306,4.54845 4.99319,1.8783 18.98607,-10.22151 2.1677,2.69716 4.46028,0.74689 2.96356,-0.31341 -0.0889,3.77723 -0.63494,0.85088 -2.69281,2.50424 -1.65372,2.72204 2.33328,0.48909 4.58505,-1.63653 6.96887,-1.60791 0.61976,0.007 1.18756,1.25976 0.75189,1.70062 -2.49496,2.5247 -5.74404,4.17153 -8.61606,6.2573 12.12981,-2.41278 3.30013,-1.95214 3.56234,1.57757 0.054,0.72705 2.55848,-0.20768 2.15087,0.39678 -1.23294,1.82837 -6.14542,2.11983 -5.18729,4.10604 2.15892,4.47548 10.45489,-6.74524 4.2017,0.92413 2.15257,3.5125 1.16422,0.95894 -5.41535,6.17669 1.26621,2.35461 6.76352,-4.43669 7.77661,-1.96259 8.28333,20.22899 -28.85471,-8.50838 3.09217,3.12802 1.84928,0.67359 -2.68677,2.87671 -4.03016,4.31506 -0.92921,1.24117 -1.85842,2.48233 -2.78763,3.7235 0.58132,0.56011 1.79929,0.87498 1.74397,1.68034 -0.0987,1.43783 -1.97261,2.33537 -2.11827,3.76921 -0.0857,0.8441 1.28221,1.22332 1.52863,2.03519 1.49261,4.91758 -5.97031,3.63582 7.4952,1.34569 -0.55001,0.45931 -10.77994,8.64592 -11.73418,10.56561 -0.32217,0.64811 2.10161,0.84706 1.64937,1.41214 -2.09388,2.61633 -7.66175,2.96102 -7.82786,6.30795 -0.16991,3.4234 8.56273,-4.46712 10.27927,-0.27127 -1.76159,1.81971 -3.52318,3.63942 -5.28477,5.45913 0.76622,0.59813 2.4346,0.8319 2.29867,1.79438 -0.27968,1.9803 -3.80714,3.11034 -3.26317,5.0349 0.46282,1.63743 4.21131,-0.43752 4.99021,1.07532 3.93398,7.64091 -10.83273,3.14159 3.44758,5.72402 -0.9151,1.68254 -1.83021,3.36508 -2.74532,5.04762 -0.11662,1.15096 0.18214,2.42561 -0.34986,3.45288 -0.92725,1.79049 -2.95622,2.85717 -3.85317,4.66303 -1.3412,2.70028 4.81416,2.32838 5.47911,2.30305 -0.3941,0.74413 -1.64975,1.53203 -1.18229,2.23241 0.55364,0.82952 3.61797,-0.31799 2.96056,0.43196 -2.55013,2.90915 -6.77897,3.98142 -9.35743,6.86548 -0.53751,0.60121 1.34054,0.89766 1.99237,1.3725 3.00597,2.18979 0.67181,0.85532 4.1958,2.58013 0.97743,0.27897 3.12712,-0.1607 2.93229,0.83692 -0.37108,1.90014 -2.58726,2.88188 -3.93077,4.27586 -1.41178,1.46482 -5.0521,2.39525 -4.3329,4.29829 0.66993,1.77268 4.05322,-1.99686 5.61067,-0.91724 2.00902,1.39265 -6.05121,4.28837 -4.30844,5.93449 8.79644,-0.97427 2.46458,-1.29009 1.54772,2.85609 -0.55951,2.53017 5.57675,-0.6921 4.65189,1.63694 -4.43479,11.16791 -5.60958,0.57178 -4.52068,6.97527 -1.01107,1.36804 -2.96739,2.40428 -3.03319,4.10412 -0.0404,1.04402 1.88097,0.91014 2.82145,1.36521 0.80303,0.59941 2.46039,0.79749 2.40909,1.79825 -0.0133,0.25895 -5.43921,8.7383 -5.29443,9.14273 0.52067,1.4545 3.02467,0.63085 4.53701,0.94627 -0.64141,1.38413 -0.99081,2.94575 -1.92422,4.15238 -1.68564,2.17903 -8.12235,4.34484 -5.82411,5.86392 2.99789,1.98153 6.81296,-3.05371 10.40013,-2.83928 1.37703,0.0823 -2.60327,1.93867 -2.48051,3.31268 0.0835,0.9342 1.86713,0.1807 2.80069,0.27105 -2.14561,1.60336 -4.29121,3.20672 -6.43682,4.81008 3.30783,4.57067 -4.3191,-6.77248 -4.22041,5.45487 0.0138,1.70811 3.38667,-0.86784 5.08198,-0.6587 2.45197,0.30248 2.15812,5.02735 1.95842,6.42304 -3.19404,2.52625 -8.52248,3.64671 -9.58211,7.57875 -0.68106,2.52726 6.18106,-3.00764 7.79494,-0.94699 1.4073,1.79689 -3.96866,2.95153 -4.48356,5.17508 -0.24512,1.05851 2.84501,0.24565 2.9786,1.32394 0.65218,5.26442 -11.20032,5.62551 5.28419,2.39953 -0.67702,1.06264 -1.40702,2.09332 -2.03106,3.18792 -0.45821,0.80372 -1.7507,1.74672 -1.21035,2.49769 0.61904,0.86033 2.63525,-0.68635 3.17151,0.22788 0.50566,0.86208 -1.0545,1.6999 -1.52286,2.58281 -2.38314,4.49245 0.66315,0.65249 -5.01938,6.11325 2.51835,3.02589 0.23004,-0.58326 -2.18819,4.90305 -0.24233,0.54978 0.86402,0.916 0.99629,1.50207 0.16072,0.71214 -0.80005,1.82496 -0.16437,2.18397 1.16036,0.65534 2.71959,-0.39573 3.99784,-0.0189 0.60248,0.17759 0.73877,1.01601 1.10815,1.52402 -1.36074,1.34979 -3.20063,2.34749 -4.08221,4.04936 -0.27139,0.52391 1.05543,0.7318 1.64139,0.66261 1.97114,-0.23275 3.95028,-2.36609 5.75307,-1.53572 1.23577,0.5692 -2.05672,1.79651 -2.93984,2.8315 -0.48863,0.57266 -0.71854,1.32576 -1.13976,1.94967 -0.51361,0.76074 -1.1066,1.46475 -1.6599,2.19713 0.33873,0.23814 1.19514,0.34101 1.01619,0.71442 -0.51118,1.06668 -1.77446,1.57558 -2.54408,2.4738 -3.23585,3.77652 -0.50318,0.34945 -0.55933,2.92637 -0.0502,2.30217 -3.339,4.40022 -4.37743,5.39298 18.27135,-5.79195 7.34887,-3.82125 5.07084,1.06134 -0.30011,0.64325 1.3829,0.55521 1.80963,1.12243 0.39639,0.52689 0.0574,1.41202 0.47866,1.91923 2.55384,3.07493 4.72612,-2.11248 -1.30905,5.03921 0.59055,0.43479 1.11486,0.97814 1.77163,1.30437 0.77872,0.38681 2.79133,-0.004 2.4803,0.80765 -0.73427,1.91687 -3.09181,2.72119 -4.42871,4.27883 -3.95484,4.60782 -1.14208,11.46892 8.83243,0.8083 -2.78274,1.95014 -5.79944,3.60312 -8.34822,5.85044 -0.32391,0.28561 -0.30561,2.75922 0.50582,2.9271 1.34444,0.27816 4.07556,-1.66363 4.10843,-0.29112 0.0607,2.53601 -5.62402,2.95619 -4.29713,6.28092 2.63484,-0.56434 7.72239,-4.38145 7.90451,-1.69301 0.22273,3.28781 -5.39696,3.87479 -7.59009,6.33435 -0.4392,0.49256 -1.07168,4.84516 -0.91018,5.62296 0.13638,0.65682 1.15889,1.0274 1.08607,1.69426 -0.11092,1.01582 -1.03951,1.7596 -1.55927,2.6394 0,0 1.72998,-0.88147 1.72998,-0.88147 z"
555+ inkscape:connector-curvature="0" />
556+ <path
557+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
558+ id="path5276"
559+ d="m 271.40967,500.0231 c 0.84361,-1.11502 2.99222,-2.02518 2.53083,-3.34505 -0.4382,-1.25354 -3.99371,0.67052 -3.92942,-0.65585 0.10731,-2.21366 3.58902,-3.01826 4.21063,-5.14555 0.29949,-1.02491 -2.43266,-1.56527 -1.96867,-2.52695 1.35708,-2.81273 4.53987,-4.32256 6.46127,-6.78454 1.08733,-1.39324 1.65843,-3.12142 2.48765,-4.68213 -7.46636,-0.79001 -5.08221,1.28307 -4.90812,-4.06826 0.0316,-0.97271 -0.27942,-1.93215 -0.28908,-2.90532 -0.01,-0.98605 1.13592,-2.55748 0.23099,-2.94925 -1.80824,-0.78284 -6.00039,2.46658 -5.89015,0.49924 0.15148,-2.70327 4.10594,-3.5304 6.15891,-5.2956 0.0863,-0.32458 1.27486,-3.51563 0.28596,-4.10661 -1.01075,-0.60403 -5.10035,0.971 -2.93296,-2.24553 0.98758,-1.46562 4.18347,-2.1455 3.66196,-3.8341 -0.47465,-1.53684 -3.21662,0.0457 -4.82493,0.0686 2.53225,-3.24957 8.12982,-9.92119 3.34362,-13.96697 -0.84971,-0.71826 -2.89316,-0.3958 -2.97925,-1.50507 -0.13245,-1.70646 1.67665,-2.98445 2.51498,-4.47667 -0.58297,-0.66933 -1.16594,-1.33865 -1.74891,-2.00798 0.6124,-1.11344 2.66426,-2.37557 1.8372,-3.34034 -0.96917,-1.13053 -3.04522,0.75237 -4.45833,0.28279 -0.57763,-0.19194 -0.54641,-1.34538 -0.16369,-1.81869 1.64069,-2.02908 4.24365,-3.14716 5.84497,-5.20745 0.62197,-0.80025 0.35302,-1.99609 0.52954,-2.99413 1.18656,-1.71414 5.51829,-4.42825 3.55968,-5.14242 -3.68312,-1.34296 -7.74476,3.18213 -11.54765,2.2298 -1.60687,-0.4024 0.40917,-3.40618 1.31691,-4.79181 2.25208,-3.43772 11.80529,-7.67655 4.00813,-10.58092 -2.01538,-0.75071 -4.26368,-0.56779 -6.39552,-0.85169 18.31556,-19.35763 6.94798,-2.12539 4.25278,-10.10937 -0.45617,-1.35131 1.87569,-2.93051 1.10826,-4.13267 -0.81412,-1.27531 -3.9706,0.39684 -4.41614,-1.04908 3.1689,-5.21567 3.70236,-3.03245 1.23334,-6.62861 -8.18188,-0.007 -4.8163,1.36305 -2.0755,-4.06271 0.36854,-0.72956 0.7691,-1.82926 0.22758,-2.4415 -0.65309,-0.73837 -3.47767,0.21889 -2.89987,-0.57977 6.09343,-8.42267 10.79235,-3.56777 5.91985,-7.57855 -12.25386,-1.1019 4.27779,1.54129 1.65438,-6.69263 -0.80029,-2.51183 -5.25694,0.40437 -7.88541,0.60655 4.24469,-3.40941 9.75453,-5.67149 12.73406,-10.22823 0.98096,-1.50023 -4.44943,0.36646 -5.23091,-1.24669 -0.79604,-1.6432 1.46396,-3.34544 2.19595,-5.01817 -0.44562,-1.0569 -0.89124,-2.11379 -1.33686,-3.17069 1.21842,-1.89661 4.4227,-3.57023 3.65526,-5.68983 -0.096,-0.26526 -11.48,-0.72332 -11.66559,-0.80844 -0.84802,-0.38896 -1.35245,-1.93441 -0.79604,-2.68331 2.10967,-2.83952 5.32265,-4.66087 7.98397,-6.99131 2.34226,-3.02177 -2.3457,-2.92502 -2.13068,-5.33277 0.0676,-0.75729 1.50987,-1.53029 0.96915,-2.06479 -2.53936,-2.51012 -10.63271,6.31581 2.37228,-4.61883 -6.19474,1.66146 -9.1703,5.00092 -7.46109,-0.21769 0.33443,-1.02109 0.72495,-2.03797 1.27773,-2.95934 0.83764,-1.39618 2.56915,-2.35267 2.86929,-3.95293 0.18473,-0.98495 -4.34465,-3.06502 -4.46788,-3.13006 -0.99349,-2.65488 2.28337,-4.28846 2.23274,-6.61519 -0.008,-0.38838 -3.79592,-3.07607 -3.34144,-3.91339 1.29663,-2.38888 5.23411,-3.12425 5.73612,-5.79557 0.28158,-1.49837 -3.02289,-0.39958 -4.53434,-0.59936 -0.73879,-0.56327 -2.69562,-0.89392 -2.21638,-1.6898 1.57771,-2.62017 4.86309,-3.77022 6.8856,-6.06454 0.60727,-0.68889 1.19228,-1.81559 0.7877,-2.64001 -0.39219,-0.79916 -1.88839,-0.25903 -2.51884,-0.88752 -3.52309,-3.51214 5.42905,-1.06978 -3.64123,-2.45646 -1.28883,-1.47023 4.42724,-4.22495 3.00729,-5.92455 -0.87349,-1.04551 -4.62824,0.79539 -4.06292,-0.44416 1.2864,-2.82067 5.3809,-3.45971 7.0382,-6.07971 0.48077,-0.76003 -2.25924,-0.53635 -2.2845,-1.43532 -0.0391,-1.39345 1.42887,-2.394 2.14331,-3.591 0.57897,-1.13977 2.39829,-2.3253 1.7369,-3.4193 -0.70437,-1.16508 -2.77891,0.0285 -4.06202,-0.42667 -4.36529,-1.54853 1.70005,-4.13301 2.00734,-5.56729 0.1857,-0.86677 -1.69451,-0.52131 -2.54176,-0.78196 1.09797,-1.11213 2.19594,-2.22425 3.29391,-3.33638 -7.62803,0.34657 -0.62323,0.76416 0.31659,-3.27246 0.22707,-0.97527 -1.99998,0.10431 -2.99997,0.15647 1.88627,-1.35807 4.42344,-2.10539 5.65881,-4.0742 0.6094,-0.9712 -2.25983,0.52665 -3.40556,0.48318 -0.49695,-0.0188 -0.89097,-0.44207 -1.33646,-0.6631 -5.22674,-0.89819 -1.26314,0.31771 4.36293,-5.17642 0.40557,-0.39606 0.69638,-1.64645 0.13163,-1.69553 -1.86658,-0.16222 -5.82482,3.07279 -5.48453,1.23034 0.86459,-4.68123 15.40434,-8.00968 -0.85374,-3.14014 -0.53032,-0.34481 -1.68223,-0.40848 -1.59097,-1.03442 0.19075,-1.30836 3.0586,-2.26352 2.22094,-3.2865 -0.93884,-1.14654 -2.98163,1.04666 -4.40173,0.62324 -0.64237,-0.19154 0.3747,-1.67926 -0.21416,-1.99954 -5.42716,-2.95183 -2.51001,2.85865 -4.39836,-2.21361 -1.0113,-2.24228 -4.57355,0.1204 -5.66196,-1.50056 -0.59485,-0.88591 1.78009,-2.58036 0.84181,-3.08859 -1.49807,-0.81144 -3.4198,1.31804 -5.04636,0.81115 -0.75563,-0.23548 0.0205,-1.5828 0.0307,-2.37421 -0.78514,-0.23306 -1.57029,-0.46613 -2.35544,-0.6992 -18.82244,6.26303 -1.07068,2.06578 -7.70098,1.1906 -1.1255,-0.14856 -3.19802,1.33749 -3.39866,0.22011 -0.0112,-0.0625 5.46172,-7.20216 5.52409,-7.28374 0,0 -1.31152,0.82398 -1.31152,0.82398 l 0,0 c 0.10548,0.55469 -0.0164,1.20797 0.31643,1.66406 1.996,2.73517 7.61323,-1.59563 8.31169,-1.60148 0.86632,-0.007 -0.60768,1.62267 -0.91151,2.43401 1.32261,-0.19648 2.64522,-0.39296 3.96783,-0.58944 0.98298,4.11711 -0.6215,0.21591 4.5331,1.56511 3.1779,0.83181 -0.81124,5.16423 -0.63379,5.49385 1.18549,2.20203 6.22576,-1.97788 7.49509,0.33556 0.0419,3.06555 -0.51194,2.13147 1.3249,4.21502 0.41138,0.46665 0.67506,1.34969 1.2971,1.34182 1.97297,-0.025 4.46542,-2.93396 5.74383,-1.43099 1.16055,1.36441 -4.40317,2.5692 -3.47341,4.10022 0.93565,1.54072 3.52951,-0.73456 5.29427,-1.10184 0.24843,0.52021 0.45786,1.06092 0.74531,1.56063 0.28443,0.49446 1.19772,0.89213 0.96528,1.41305 -0.6129,1.37359 -2.07256,2.18119 -3.071,3.30614 -0.81192,0.9148 -3.20997,1.93322 -2.35835,2.81118 1.02778,1.05958 2.91649,-1.02103 4.36594,-0.74149 0.51104,0.0986 -0.10293,1.03582 -0.15439,1.55373 -0.90402,0.90742 -2.11634,1.58835 -2.71205,2.72228 -0.18254,0.34745 0.46747,0.83858 0.85858,0.80575 1.71116,-0.14364 3.53033,-2.2076 4.98576,-1.29633 1.08463,0.6791 -1.95527,1.68725 -2.70466,2.72456 -0.3822,0.52905 -0.40546,1.24075 -0.6082,1.86113 -0.73879,0.89107 -1.47759,1.78213 -2.21639,2.6732 -2.6156,4.34603 -1.72804,1.25734 2.28963,2.6141 0.6603,0.22298 1.61939,0.89052 1.4007,1.55225 -0.52966,1.60271 -3.05305,2.23698 -3.20843,3.91777 -0.0904,0.97838 1.83173,0.71158 2.7476,1.06737 -0.14246,0.9235 -0.28492,1.84701 -0.42738,2.77052 -17.69737,16.4527 -0.29839,-1.93789 0.46659,4.845 0.29603,2.62482 -4.02236,3.45288 -5.75948,5.44278 -2.96193,3.39292 -2.80901,4.63463 0.58667,6.56553 -0.71195,3.37109 -1.32723,2.23656 2.17358,3.20427 -0.25398,1.70167 -3.37311,2.17554 -3.38566,3.89601 -0.009,1.22027 7.05377,-0.32166 6.38009,1.54413 -0.87889,2.4341 -3.60347,3.71541 -5.4052,5.57312 1.47272,0.21953 3.73062,-0.66216 4.41814,0.6586 1.2021,2.30926 -4.75905,5.20232 -5.26915,8.38805 -0.29809,1.8617 8.33922,2.21527 5.25308,5.58725 -2.34657,2.11623 -4.82208,4.0977 -7.03972,6.34868 -1.35667,1.37707 -4.99171,3.11027 -3.65263,4.50445 1.62643,1.69336 4.64369,-1.4155 6.96405,-1.05677 0.72132,0.11151 -0.0472,1.51283 0.26216,2.17392 1.59106,3.40017 3.61933,-1.30155 -1.31458,4.69517 1.74643,5.18425 -1.91013,-4.03341 4.14083,1.28591 0.65697,0.57753 -0.7704,1.59325 -1.34315,2.25439 -1.20653,1.39272 -3.31939,2.13238 -3.95537,3.86181 -0.27479,0.74726 1.97176,0.24327 2.16143,1.01653 0.26163,1.06662 -0.77015,2.05703 -1.15523,3.08554 0.46488,0.70316 1.66986,1.31273 1.39465,2.10948 -0.70049,2.02806 -5.77724,4.09808 -3.89369,5.12569 2.954,1.6116 6.67212,-2.6877 9.92708,-1.83407 1.38407,0.36298 -0.26721,3.00285 -1.1364,4.13947 -7.69167,10.05825 -11.30113,4.9757 -5.50453,10.47003 12.1809,2.58454 0.68305,-1.60595 1.50332,7.04834 0.15075,1.59053 3.7325,0.0369 4.58818,1.38612 0.74593,1.17615 -1.03929,2.62565 -1.16411,4.01279 -0.0314,0.34944 0.93404,4.71611 1.05781,5.28963 -1.3802,1.51721 -4.84437,2.62508 -4.14062,4.55164 0.63712,1.74412 3.69816,-1.18051 5.51394,-0.79214 0.65481,0.14005 0.6238,1.53115 0.149,2.00335 -2.81355,2.79816 -8.04318,3.53205 -9.44682,7.2436 -0.82141,2.17201 11.13635,-5.11164 6.76838,1.64927 0.091,0.92514 -0.0854,1.91766 0.27296,2.77541 0.35755,0.85586 1.9948,1.23647 1.78003,2.13881 -0.48142,2.02267 -3.23036,3.09296 -3.51545,5.15249 -0.15382,1.11121 1.86813,1.33099 2.48861,2.26557 2.10332,3.16805 0.92404,4.31695 0.06,7.89324 -10.57418,17.09201 -0.63343,-3.00266 3.38288,6.60571 0.99622,2.38331 -2.8287,4.32307 -4.24305,6.48461 -0.25211,1.50129 -1.38497,3.11742 -0.75634,4.50387 0.56327,1.24229 2.56202,1.0317 3.64324,1.86327 0.79588,0.6121 1.24,1.57949 1.86,2.36924 -8.39878,9.58005 -3.85858,2.27949 2.00132,3.93387 0.86536,0.24431 -0.51486,1.78055 -1.10053,2.46285 -1.42711,1.6626 -4.03733,2.4121 -4.83549,4.45265 -0.34986,0.89445 1.79295,0.68927 2.68943,1.03391 -1.31854,1.63819 -2.63708,3.27639 -3.95562,4.91458 0.66656,0.72544 1.92921,1.19368 1.99967,2.17633 0.0985,1.37395 -1.25826,2.48092 -1.56948,3.82278 -0.31391,1.35345 0.11788,4.84884 0.11683,6.22575 -8e-4,1.05328 -0.46388,2.14171 -0.17615,3.15493 0.24138,0.85002 1.10612,1.3783 1.65918,2.06746 7.82248,2.82758 -3.54352,-2.1669 -3.75729,6.27252 -0.0553,2.18496 4.23975,-1.72368 6.40311,-1.4122 0.77116,0.11103 -0.28142,1.56687 -0.68022,2.23618 -0.55535,0.93205 -4.91731,6.04302 -5.54138,6.78439 1.57917,-0.0855 3.18481,-0.55678 4.73749,-0.2564 0.79773,0.15433 2.07487,0.7473 1.89058,1.53864 -0.42269,1.81501 -2.92768,2.68693 -3.29992,4.51295 -0.18906,0.92743 1.54302,1.20422 1.96139,2.05324 1.93613,3.92917 -1.20747,5.21438 -3.71401,8.46144 0.47992,0.89368 0.58071,2.14155 1.43974,2.68104 1.34606,0.84534 4.13572,-0.37781 4.63211,1.13218 0.93525,2.84501 -5.60155,6.20062 -3.45815,8.29218 1.10289,1.07621 3.61454,-0.86631 4.61266,0.30772 0.75374,0.88657 -1.21106,1.98741 -1.81659,2.98112 0,0 -9.14493,4.65958 -9.14493,4.65958 z"
560+ inkscape:connector-curvature="0" />
561+ <path
562+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
563+ id="path5278"
564+ d="m 581.73672,201.15421 c -5.84049,0.0226 -12.46977,3.74174 -18.23522,1.43917 -0.92495,-0.3694 -1.5343,-1.27727 -2.36778,-1.82253 -0.87794,-0.57434 -1.83477,-1.01794 -2.75215,-1.52691 -7.8597,-0.6834 -0.70651,-0.5885 -11.70003,2.01168 -1.54963,0.36652 -3.24586,1.07687 -4.74618,0.54324 -1.59834,-0.5685 0.85485,-5.45684 0.64497,-5.42188 -3.26191,0.54332 -5.93446,2.91946 -8.90169,4.37918 -1.07703,0.12394 -2.49605,1.16872 -3.23111,0.37181 -0.67458,-0.73134 1.68867,-2.13419 0.97042,-2.82271 -0.88828,-0.85153 -2.51436,-0.15881 -3.68494,0.22051 -3.53501,1.14552 -6.56729,4.25069 -10.28286,4.30575 -1.41951,0.021 0.58867,-2.77764 0.88301,-4.16646 -2.91053,0.68366 -5.82106,1.36733 -8.73159,2.05099 -8.55726,-7.49791 7.12666,4.81414 -14.40115,1.39085 -1.87303,-0.29784 3.21179,-4.26845 1.70996,-5.42666 -1.91086,-1.47365 -4.74198,0.90779 -7.13129,1.24574 -10.05799,1.42263 -1.29042,-0.848 -12.92141,2.92188 5.75912,-7.83975 5.57265,-5.71046 -3.55664,-2.09752 -2.02766,0.80245 -4.06024,1.61861 -6.16523,2.18815 -1.4706,0.39791 -3.76794,2.02901 -4.51623,0.70196 -7.88504,-13.98369 9.26915,0.86687 0.0352,-6.49718 -3.10338,1.17026 -6.20676,2.34052 -9.31014,3.51078 -0.57567,-0.69237 -0.83006,-2.15625 -1.72699,-2.0771 -3.09746,0.27333 -5.72754,2.79919 -8.82997,3.00868 -0.91247,0.0616 -0.59156,-2.08023 -1.47605,-2.31278 -1.66146,-0.43682 -4.08937,1.95174 -5.12124,0.57823 -0.99973,-1.33072 1.45413,-2.99444 2.18119,-4.49166 -5.27131,3.01667 -10.21343,6.70024 -15.81393,9.05001 -0.70494,0.29576 0.0899,-1.64484 -0.3563,-2.26558 -0.50641,-0.70446 -1.36894,-1.2616 -2.23327,-1.33677 -1.86367,-0.16207 -3.74223,1.04035 -5.57342,0.65787 -1.06648,-0.22276 -1.54432,-1.53723 -2.31648,-2.30585 -2.11262,0.0407 -4.22524,0.0813 -6.33786,0.12201 -12.42253,2.1242 -6.53573,2.91676 -15.18382,-0.38034 -1.73617,-0.66191 -3.38695,-1.91563 -5.24481,-1.8878 -3.53288,0.0529 -6.89889,2.69571 -10.38526,2.12195 -1.37022,-0.2255 -0.74241,-2.67624 -1.11361,-4.01436 -1.88368,-0.006 -3.76736,-0.012 -5.65104,-0.018 -24.28983,7.62107 -2.5727,3.42937 -7.44036,-1.19304 -1.17426,-1.1151 -3.36042,0.76142 -4.85605,0.14059 -0.9471,-0.39314 -0.37753,-2.78281 -1.40202,-2.73831 -17.07323,0.74169 -4.68269,5.70713 -13.15884,1.68512 -13.47711,1.23798 -0.53507,0.38388 -11.61335,0.31509 -1.85578,-0.0115 -3.70698,0.21371 -5.56273,0.2289 -1.65286,0.0135 -3.33144,-0.4439 -4.95669,-0.14277 -2.69057,0.49853 -5.20719,1.68414 -7.81614,2.50939 -2.13831,0.67638 -4.28365,1.33032 -6.42547,1.99548 -0.9837,-2.83624 -11.06653,5.91354 -9.75378,2.79645 1.53204,-3.63777 6.99404,-4.59873 8.4956,-8.24918 0.86063,-2.09228 -4.2097,1.67823 -6.21979,2.71644 -3.72203,1.92244 -6.92828,5.00691 -10.95697,6.15539 -1.36693,0.38967 1.46202,-2.43801 2.19303,-3.65701 -1.17023,0.0909 -2.53198,0.92049 -3.51069,0.27257 -0.68695,-0.45477 0.96331,-2.14961 0.20152,-2.46328 -4.37993,-1.80347 -8.71503,6.31425 -13.28098,5.05394 -9.4835,-2.61768 17.38499,-9.14192 -0.38289,-4.16034 -0.53601,-0.28526 -1.00462,-0.92342 -1.60803,-0.85578 -1.6592,0.18598 -3.16377,1.06881 -4.75661,1.56922 -1.28969,0.40517 -2.59751,0.75066 -3.88989,1.14719 -1.27067,0.38987 -2.49478,0.95467 -3.7988,1.21188 -0.57067,0.11256 -1.73101,0.46238 -1.74093,-0.1192 -0.0174,-1.01834 1.13036,-1.69456 1.69554,-2.54183 1.13752,-1.49935 -4.63996,2.07583 -4.03582,0.84154 0.66217,-1.35285 4.65116,-3.58371 3.19622,-3.19408 -2.64341,0.70788 -4.51559,3.1669 -7.03997,4.22341 -0.68424,0.28637 0.85778,-1.21035 1.28667,-1.81553 -1.25078,0.65196 -2.50155,1.30391 -3.75232,1.95586 9.21621,-7.98762 6.18858,-4.83213 -0.87423,-0.87619 -0.72387,0.40544 -1.54218,0.6125 -2.31326,0.91875 0,0 2.61292,-1.89841 2.61292,-1.89841 l 0,0 c 1.14285,-0.57635 2.16869,-1.50316 3.42856,-1.72905 0.47365,-0.0849 -0.48687,0.83017 -0.73031,1.24525 0.72034,-0.25777 1.44068,-0.51554 2.16102,-0.77331 -0.0129,0.26612 0.11092,0.57784 -0.0386,0.79836 -0.61275,0.9037 -3.19334,2.83016 -2.16774,2.45563 2.58273,-0.94316 4.57145,-3.1023 7.07165,-4.24644 0.52365,-0.23963 -1.37048,1.87365 -0.20579,1.9951 0.74974,0.0782 1.47219,-0.32486 2.20828,-0.48729 1.12167,-0.37799 2.86257,-2.20567 3.36502,-1.13396 0.5616,1.19787 -1.995,1.89173 -2.42282,3.14363 -0.14298,0.41839 0.66423,0.8732 1.09039,0.75536 2.14236,-0.59239 4.04954,-1.83414 6.08018,-2.73811 7.30472,-3.2518 6.963,-5.26487 6.23711,-0.62098 2.93608,2.63023 -0.0453,0.63795 6.49918,-0.28738 0.87818,-0.12417 1.74981,0.3045 2.63356,0.3793 1.00939,0.0854 2.02969,0.20481 3.03732,0.10065 1.47374,-0.15233 3.07086,-1.5959 4.35975,-0.86523 0.8671,0.49155 -0.53804,1.91949 -0.80707,2.87923 1.97363,-0.76926 3.95449,-1.52021 5.92088,-2.30778 1.9543,-0.78272 3.79068,-1.92385 5.84067,-2.40289 0.58192,-0.13598 1.89487,0.0929 1.67184,0.64736 -0.76788,1.90882 -4.79687,2.97497 -3.86747,4.81058 1.48135,2.92575 7.32339,-5.50614 9.48936,-2.59649 1.42331,-0.13101 2.86231,-0.14485 4.26993,-0.39303 2.16768,-0.38218 4.23629,-1.34177 6.43214,-1.49385 1.38899,-0.0962 2.73015,0.97425 4.10649,0.76394 3.11854,-0.47655 5.9479,-3.356 9.04853,-2.77417 1.44152,0.2705 -2.0691,4.5208 -0.61155,4.35735 4.97883,-0.55833 9.23228,-3.89449 13.84842,-5.84174 2.70996,5.53973 -0.455,1.31529 7.32522,2.53772 1.08502,0.17048 1.78761,1.32193 2.81267,1.71639 3.87458,1.49101 7.92222,0.0734 11.83057,1.37936 2.68235,-0.56484 5.31262,-1.88683 8.04704,-1.69452 1.35852,0.0955 2.16027,1.65891 3.24041,2.48837 2.61456,-0.0998 5.22912,-0.19951 7.84368,-0.29927 4.64473,-0.95021 8.88553,-3.87351 13.62142,-4.09202 1.60186,-0.0739 2.33226,2.20143 3.49839,3.30214 2.94984,-0.29944 5.89968,-0.59888 8.84953,-0.89833 1.33758,0.50801 2.58403,1.44687 4.01276,1.52403 2.28088,0.12319 5.73312,-2.96689 6.78773,-0.94072 1.14605,2.20185 -6.4441,5.77702 -4.01202,6.27356 3.87161,0.79045 6.92622,-4.10745 10.7999,-4.88771 0.91737,-0.18479 -1.29282,2.74099 -0.35803,2.78445 2.40459,0.11179 4.52016,-1.65725 6.78024,-2.48588 1.31945,0.0101 2.75475,-0.51033 3.95836,0.0304 0.78176,0.35121 0.32942,2.27564 1.18643,2.28098 2.67859,0.0167 5.04481,-2.12584 7.72159,-2.22554 0.94208,-0.0351 1.26601,1.48553 2.13182,1.8585 3.60961,1.55491 6.53653,0.002 10.21237,-0.83478 20.52329,-6.74084 1.89226,-2.51045 4.15948,3.45256 0.73899,1.94361 4.01445,-1.09539 5.98399,-1.76219 2.23019,-0.75505 4.26124,-2.7115 6.60629,-2.50033 1.06227,0.0957 -1.16158,1.92736 -1.13013,2.99346 0.0199,0.67426 0.84334,1.05302 1.26501,1.57952 4.12862,-2.00822 7.89397,-5.07526 12.38586,-6.02468 1.10106,-0.23272 -0.91579,3.05361 0.16356,3.37219 2.3053,0.68043 4.7056,-1.09801 7.10578,-1.22658 1.70439,-0.0913 3.40092,0.83038 5.0883,0.57341 3.51787,-0.53576 6.7499,-3.43107 10.27034,-2.91244 1.4619,0.21537 0.033,2.95518 0.0495,4.43277 0.30181,1.19077 -0.20039,3.03734 0.90543,3.57231 1.66477,0.80539 3.68366,-0.33775 5.52901,-0.45944 5.57141,-0.36741 4.65262,0.33142 10.53807,-2.04259 2.8186,-1.13693 5.21399,-3.79318 8.25207,-3.87782 1.47239,-0.041 -1.59556,2.4764 -2.39334,3.7146 0.73439,-0.24086 6.01373,-2.85719 7.87461,-1.29776 0.0775,0.0649 0.89268,4.62211 1.49732,4.43526 14.78199,-4.56792 12.68988,-12.15571 13.93555,-3.63588 2.66352,6.81078 -1.20811,-0.39314 10.26637,-0.38966 1.05436,3.1e-4 -0.57443,2.7161 0.39151,3.13875 2.9451,1.28864 13.55718,-4.08658 14.2252,-4.14987 0.94238,-0.0893 -0.4954,1.82723 -0.7431,2.74084 0,0 -1.4256,1.03576 -1.4256,1.03576 z"
565+ inkscape:connector-curvature="0" />
566+ <path
567+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
568+ id="path5280"
569+ d="m 437.91913,154.10856 c 1.23619,-0.0682 2.47239,-0.13636 3.70859,-0.20454 1.58967,0.0869 3.17891,0.33934 4.76902,0.2608 2.60001,-0.1284 5.26923,-1.63681 7.75984,-0.87957 1.37606,0.41837 0.54192,3.9983 1.97124,3.83817 35.88963,-4.02092 2.82269,-7.22874 20.51937,-5.03347 3.69136,2.35282 7.48018,-1.04865 11.12799,-0.36496 0.89607,0.16795 0.44139,2.40963 1.35248,2.3772 3.04143,-0.10825 5.79477,-1.86385 8.71066,-2.73538 3.21228,-0.96013 6.53974,-3.95409 9.67225,-2.75912 1.88961,0.72083 -0.98785,3.92236 -1.48177,5.88355 7.4778,-2.6997 15.0486,-0.18493 22.64137,-0.87945 2.98582,-0.27312 5.86817,-1.42005 8.86462,-1.52519 0.64451,-0.0226 7.36205,1.74657 8.38695,2.01041 22.66233,-6.2164 -5.59406,-0.006 1.79508,4.88026 3.01566,1.99414 6.60785,-3.07778 10.1398,-3.84989 1.21885,-0.26645 2.41213,0.66777 3.64842,0.83569 1.51909,0.20634 3.07181,0.49347 4.59038,0.28337 2.64393,-0.36579 5.17049,-1.32765 7.75573,-1.99148 4.22728,5.71577 -1.93151,-1.13286 8.0372,1.02932 0.90762,0.19686 0.25793,1.83945 0.38689,2.75918 3.89585,-1.98477 7.40915,-5.05301 11.68754,-5.95432 1.46572,-0.30877 -2.98474,2.70083 -2.15115,3.94534 0.81315,1.21397 2.88525,-0.46374 4.32788,-0.69561 -0.19386,1.02948 -1.62892,3.11096 -0.58158,3.08846 3.16055,-0.0679 5.77676,-2.79974 8.90328,-3.26728 1.17277,-0.17538 2.07855,1.64352 3.24848,1.4501 3.6131,-0.59735 6.7766,-2.87648 10.3455,-3.69758 2.04298,-0.47003 7.74632,0.36486 9.92961,0.62392 1.54872,0.10745 3.32447,-0.49201 4.64618,0.32236 0.83502,0.51449 -0.41383,2.96447 0.56398,2.88785 3.16131,-0.24772 5.68039,-3.03528 8.79677,-3.62136 0.63863,-0.1201 -0.0278,2.00105 0.60497,1.85324 13.56341,-3.16818 3.77193,-4.72057 10.23057,-3.37752 1.24491,-0.0989 2.70181,-0.99864 3.73472,-0.29674 0.77133,0.52414 -0.93495,2.48789 -0.0552,2.79714 1.80758,0.63537 3.81902,-0.40231 5.6897,-0.81658 2.85096,-0.63135 5.54036,-2.05462 8.44881,-2.31443 1.41531,-0.12642 2.67478,1.09344 4.09215,1.19417 2.08296,0.14804 4.16519,-0.30621 6.24779,-0.45931 3.35928,-1.08463 6.71857,-2.16926 10.07785,-3.25389 0.55553,0.85196 0.64963,2.54065 1.6666,2.55589 2.67042,-0.80363 5.34085,-1.60725 8.01128,-2.41088 0.47122,0.60211 0.67697,1.60175 1.41368,1.80633 1.24445,0.34558 4.10822,-1.60936 3.85951,-0.34198 -0.48472,2.4701 -3.27807,3.82095 -4.91711,5.73142 5.70103,-1.33877 10.12612,-5.88484 15.70457,-7.45129 0.58355,-0.16386 -0.0962,1.23344 0.0671,1.81715 0.12902,0.46112 0.31209,1.10095 0.77906,1.20689 3.35426,0.76105 3.63331,-2.23898 2.23264,1.86594 4.56137,3.27917 -3.43228,-1.96059 10.56193,-4.51534 1.97581,-0.3607 -3.49921,2.45408 -4.17344,4.34599 -0.32903,0.92328 1.91845,-0.40858 2.86324,-0.66949 3.86803,-1.06818 2.71345,-2.07285 4.06916,-0.29377 0.65874,-0.0329 2.02115,-0.75681 1.97621,-0.0988 -0.0787,1.1527 -3.30667,2.8058 -2.15487,2.7149 2.30435,-0.18187 4.05842,-2.25648 6.23422,-3.03687 0.64315,-0.23067 1.38324,0.22087 2.04874,0.0661 5.51896,-1.28379 3.78688,-3.25824 5.50883,-0.19721 -1.46583,1.71812 -4.57212,2.90268 -4.39748,5.15437 0.0156,0.20143 8.67506,-2.31725 8.69122,-1.51312 0.0418,2.08276 -5.97008,4.93862 -3.88739,4.89336 7.80888,-0.16971 16.70616,-11.4037 6.31714,0.11757 0.90308,0.0651 1.80616,0.1302 2.70924,0.1953 0.27814,0.42273 0.34662,1.1336 0.83442,1.26817 0.95893,0.26455 2.42441,-1.04441 2.97636,-0.21683 0.53135,0.79669 -2.30924,1.98837 -1.47786,2.46364 3.33256,1.90507 5.5039,-3.90126 3.07872,1.08059 4.23139,0.93002 -3.61451,3.89543 -2.08482,4.59396 2.0287,0.9264 4.18748,-2.97245 6.29916,-2.25506 1.45192,0.49325 -4.18448,2.13801 -3.19514,3.30956 1.96861,2.33118 11.74376,-7.47434 0.389,2.57794 -0.0375,0.53551 -0.64336,1.68584 -0.11242,1.60654 9.29633,-1.38852 9.7283,-6.25852 2.73533,1.82238 -0.71864,0.83044 -2.31993,2.03153 -1.61359,2.87246 4.45015,-0.20547 3.30627,-1.34009 4.63554,1.36899 6.1752,-0.54264 -0.212,2.16231 3.94226,3.83059 0.70833,0.28445 2.2706,-0.38153 2.25791,0.38168 -0.0534,3.21284 -8.33635,4.79542 2.76754,1.28484 0.83075,1.91899 -2.55661,2.61469 -2.23156,4.1519 0.16395,0.77534 1.75121,-0.54192 2.37683,-0.0555 0.43233,0.33616 -0.62952,1.09756 -0.39821,1.59396 0.32296,0.69309 3.34908,0.74132 3.53405,0.75722 -6.37567,7.34986 -1.26749,0.14391 -0.0687,2.59487 0.35848,0.73292 -0.86775,1.38193 -1.30163,2.07289 0,0 2.83108,-1.71491 2.83108,-1.71491 l 0,0 c -1.62573,0.55271 -3.171,1.46474 -4.87719,1.65811 -1.86292,0.21113 3.92214,-13.77688 3.30994,-4.54751 -0.43697,-0.22138 -0.82145,-0.64501 -1.31093,-0.66414 -1.08331,-0.0423 -2.45436,1.25905 -3.21571,0.48724 -0.62898,-0.63763 1.2009,-1.38762 1.49202,-2.23463 0.1294,-0.37651 0.0634,-1.08308 -0.32938,-1.14805 -1.07257,-0.17743 -2.83327,1.58094 -3.21263,0.56213 -0.4318,-1.15963 1.56848,-1.91432 2.35272,-2.87148 -2.08529,0.77586 -4.04044,2.122 -6.25586,2.3276 -1.2483,0.11584 1.87343,-2.85833 0.13022,-3.36272 -1.25443,-0.36296 -2.64297,0.7181 -3.9005,0.36606 -1.98283,-0.5551 0.33136,-8.6675 2.44939,-5.67082 -0.11377,-0.59785 0.0423,-1.32107 -0.34132,-1.79354 -0.44536,-0.54858 -1.18502,-0.96523 -1.89156,-0.95682 -1.75728,0.0209 -4.10153,2.43729 -5.16845,1.04082 -0.97742,-1.27933 2.58059,-2.13226 3.19884,-3.6188 0.35667,-0.85759 -3.97088,-0.70327 -0.94285,-2.62205 -0.30912,-0.2909 -1.07662,-0.47532 -0.92737,-0.87269 0.41542,-1.10604 3.15171,-1.92448 2.27577,-2.71734 -1.06356,-0.9627 -2.76722,1.17347 -4.18937,0.98523 -0.50454,-0.0668 0.67442,-1.53777 0.16587,-1.5178 -2.00217,0.0786 -4.22172,3.02759 -5.75464,1.73723 -1.28523,-1.08186 2.27523,-2.47231 3.41284,-3.70846 1.69334,-3.79201 1.02434,-0.89294 -2.96887,-1.10444 -0.43164,-0.0229 -0.70644,-0.64888 -0.71619,-1.08101 -0.0159,-0.70575 1.25738,-1.66328 0.64632,-2.01675 -3.18866,-1.84449 -5.78111,4.03437 -1.35578,-2.85334 -2.21776,-1.64947 -1.21018,-1.37236 -4.79348,-1.13862 -1.39043,0.0907 -2.84666,0.9726 -4.15193,0.48495 -0.65871,-0.2461 0.41497,-1.72217 -0.17671,-2.10214 -1.42729,-0.91658 -3.70494,0.93947 -5.03484,-0.73883 -0.60299,-0.21393 -1.16997,-0.67416 -1.80895,-0.64178 -1.28889,0.0653 -2.74506,1.72143 -3.75975,0.924 -0.80647,-0.63381 2.20098,-1.84945 1.56159,-2.65151 -0.65242,-0.81839 -2.00917,1.00735 -3.03556,0.80256 -0.45187,-0.0902 0.14067,-0.91075 0.21101,-1.36613 -1.21839,0.43181 -2.43678,0.86363 -3.65517,1.29544 -0.25354,-0.22264 -0.62939,-0.35707 -0.76062,-0.66793 -0.17042,-0.40368 0.34819,-1.20015 -0.0754,-1.31238 -1.8936,-0.50174 -8.19894,3.49373 -8.31461,3.19586 -0.81569,-2.10049 4.56795,-2.57491 4.73782,-4.82182 0.12012,-1.58882 -2.99734,1.0822 -4.49601,1.6233 -2.08036,0.93553 -4.14334,1.9107 -6.24108,2.80658 -1.80069,0.76903 -4.53985,3.91984 -5.45174,2.18712 -0.97455,-1.85178 3.0537,-2.94119 4.10168,-4.75242 0.26628,-0.46021 0.0615,-1.507 -0.46996,-1.52428 -1.58559,-0.0515 -2.99345,1.11425 -4.56062,1.36077 -0.79363,0.12484 -1.59692,-0.17771 -2.39537,-0.26657 -4.2548,2.37378 -7.90174,6.81699 -12.7644,7.12133 -2.94666,0.18442 3.87288,-4.45736 5.80931,-6.68603 -0.48591,-0.59114 -0.69261,-1.78416 -1.45775,-1.77341 -2.51475,0.0353 -4.81733,1.51195 -7.30276,1.89646 -5.06126,0.783 -4.67311,0.33438 -8.50322,-1.66221 -3.47983,1.1729 -6.95966,2.3458 -10.43949,3.5187 -0.30549,-1.1707 0.29338,-3.52556 -0.91645,-3.51209 -3.62555,0.0404 -6.62575,3.65582 -10.25148,3.63642 -1.23853,-0.007 1.66672,-3.89226 0.44498,-3.68891 -4.09903,0.68224 -7.13798,4.59273 -11.19787,5.47861 -1.12856,0.24626 0.7464,-2.18633 1.1196,-3.2795 -2.70903,1.27901 -5.1708,4.32182 -8.12711,3.83702 -1.90269,-0.31201 3.59746,-2.66683 3.5158,-4.59321 -0.0525,-1.23781 -2.45976,0.30037 -3.69255,0.4234 -1.46662,0.14638 -2.9419,0.20626 -4.40496,0.38477 -10.62024,1.29579 -0.63827,0.54815 -11.1481,1.16065 -2.80818,0.75238 -5.61635,1.50477 -8.42453,2.25716 0.42608,-1.63775 2.96629,-5.03264 1.27824,-4.91325 -4.77994,0.33808 -8.7824,3.8364 -13.1736,5.7546 0.15542,-1.38489 1.85968,-4.17566 0.46625,-4.15467 -13.75571,0.20727 -7.80115,8.29755 -11.47942,2.48146 -2.33385,0.88589 -4.51172,2.47751 -7.00154,2.65765 -0.71542,0.0518 0.18093,-1.61481 -0.32031,-2.12791 -1.69982,-1.74004 -6.36894,-4.9e-4 -7.57099,-0.11103 -0.99157,-0.0912 -1.76798,-0.91671 -2.65197,-1.37507 -2.09073,0.3287 -4.18146,0.65741 -6.27219,0.98612 -4.18788,-0.43557 -4.06426,-0.009 -7.55836,-1.74909 -0.90521,-0.4509 -1.58091,-1.59702 -2.59199,-1.5767 -2.46011,0.0494 -4.7061,1.70603 -7.1658,1.77273 -0.85835,0.0233 -1.38548,-1.01473 -2.07822,-1.52209 -1.71767,0.15619 -3.43533,0.31238 -5.153,0.46857 -12.16079,-1.35046 6.81819,0.27799 -13.25426,1.47955 -1.76161,0.10546 -3.40987,-1.20637 -5.17287,-1.12741 -3.27207,0.14656 -6.39822,1.50844 -9.66129,1.79185 -5.95391,0.51713 -6.23671,-0.2208 -11.03836,-2.32483 -2.57098,0.27277 -5.14197,0.54555 -7.71295,0.81832 -0.91766,-0.76156 -1.56555,-2.3947 -2.75298,-2.28469 -3.40416,0.31538 -6.37271,2.50981 -9.66387,3.43505 -1.89983,0.5341 -3.88985,0.6772 -5.84762,0.9257 -1.86103,0.23622 -4.98041,2.29736 -5.60307,0.52776 -0.83546,-2.3744 2.2799,-4.48833 3.41985,-6.7325 -6.30568,3.02597 -12.28992,6.842 -18.91706,9.07792 -2.01786,0.6808 -5.02029,1.10316 -6.3653,-0.54796 -1.28614,-1.57885 3.01586,-5.66819 1.01096,-6.02496 -4.18293,-0.74434 -7.97301,2.98121 -12.08383,4.05456 -18.47256,4.82328 8.73927,-5.16607 -13.65645,3.68169 0,0 8.30503,-6.03396 8.30503,-6.03396 z"
570+ inkscape:connector-curvature="0" />
571+ <path
572+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
573+ id="path5282"
574+ d="m 439.33369,237.08082 c -5.47439,-2.96028 -3.28562,5.72694 -1.53636,5.2325 3.44066,-0.97252 6.23707,-3.74491 9.72747,-4.52016 0.75774,-0.16831 0.0633,2.07164 0.83265,2.17464 2.67303,0.35787 13.46994,-4.64024 14.14779,-4.92121 2.04586,-0.54266 4.02194,-1.56426 6.13758,-1.62798 8.26835,-0.24902 -5.3663,4.92975 0.63623,6.00394 3.33252,0.59637 6.26374,-2.88469 9.6326,-3.21942 1.2112,-0.12034 2.05563,1.30397 3.08344,1.95596 4.62785,-1.95699 9.2557,-3.91398 13.88356,-5.87097 1.74763,0.52552 7.10975,2.28627 8.91991,2.20657 4.91708,-0.21649 9.55324,-2.7245 14.4705,-2.93685 0.96534,-0.0417 2.29151,0.18143 2.6989,1.05758 0.48206,1.03674 -0.42687,2.24646 -0.6403,3.36969 0.42808,-0.18104 13.87161,-6.49543 16.43017,-5.66676 1.26258,0.40892 -0.86067,3.47065 0.37133,3.96409 2.45886,0.98481 5.28458,-0.37938 7.92014,-0.64321 15.4825,-1.54984 2.47234,-0.73607 17.32767,-1.44683 20.16342,-0.68595 -0.61738,-1.19219 12.25354,1.71416 1.88649,0.42598 3.86273,0.35948 5.79515,0.2814 2.08666,-0.0843 4.32689,-1.6528 6.21799,-0.76679 1.05283,0.49326 -0.32071,2.30308 -0.48106,3.45461 1.74185,-0.3169 3.4837,-0.6338 5.22556,-0.9507 6.48171,0.58028 11.31801,-5.02464 17.37162,-5.86508 1.21646,-0.16889 0.92241,2.46374 1.96105,3.11914 1.64086,1.0354 3.65432,1.44253 5.58426,1.64206 12.40919,-0.10851 6.3507,-0.44262 18.18031,0.91002 5.2457,-0.519 10.31623,3.10438 15.5601,2.66514 4.34908,-0.36429 8.39276,-3.24534 12.74907,-2.98106 1.44232,0.0875 0.87592,2.90366 1.94781,3.87268 5.51735,4.98789 4.48486,-2.50811 3.9798,6.33873 5.76444,2.19985 12.43819,-6.60952 18.41769,-4.55109 1.44645,0.49794 -1.68101,4.66965 -0.15351,4.58671 4.81321,-0.26138 8.63125,-5.36947 13.45116,-5.30882 1.86087,0.0234 -0.76563,3.64243 -1.14845,5.46364 2.80475,-0.55712 5.6095,-1.11423 8.41425,-1.67135 4.05645,-1.59233 7.85344,-4.17428 12.16934,-4.777 1.04286,-0.14563 0.82904,1.93593 1.24356,2.90389 1.42922,0.0469 2.87497,0.36245 4.28766,0.14068 2.12504,-0.33359 4.1136,-1.26683 6.20077,-1.78717 8.61601,-2.14799 -0.68024,1.02577 9.22492,-2.7096 0.72398,-0.0381 1.46437,-0.27231 2.17195,-0.11441 0.35929,0.0802 0.5247,0.51649 0.78706,0.77473 2.09582,-1.26276 4.09681,-2.69827 6.28745,-3.78827 0.18826,-0.0937 0.30755,0.28684 0.46132,0.43026 0.20897,0.0476 0.43874,0.24546 0.62691,0.14284 1.47903,-0.80655 2.81173,-1.85645 4.21759,-2.78467 10.09216,-6.69652 -1.79879,0.91257 -0.29335,1.23767 1.96082,0.42344 3.21705,-2.44369 5.02727,-3.30811 1.21936,-0.58227 -3.94065,3.52558 -2.67863,3.04268 1.34115,-0.51318 2.40022,-1.57706 3.60033,-2.36559 3.58809,-1.94003 -0.10481,0.10832 -3.22044,1.2596 -1.18007,0.43606 2.73229,-0.76526 2.43591,-1.6751 -0.28452,-0.87342 -1.83157,-0.28546 -2.74741,-0.21451 24.89401,-13.44905 10.98443,-4.78107 6.10519,-4.80799 -0.5874,-0.003 0.47601,-1.09001 0.84739,-1.54512 0.68406,-0.83828 1.57306,-1.49001 2.29035,-2.30005 0.57577,-0.65021 1.0537,-1.38089 1.58056,-2.07134 0.79967,-0.87436 1.59935,-1.74871 2.39902,-2.62307 0.20201,-0.60032 1.14138,-1.46243 0.60604,-1.80097 -0.9444,-0.59722 -2.26102,0.30833 -3.35154,0.0648 -0.4229,-0.0944 -1.12945,-0.68431 -0.83167,-0.9991 2.87301,-3.03713 7.29695,-4.22652 10.35349,-7.07887 0.23764,-0.22177 -0.41926,-0.49684 -0.62888,-0.74526 -1.4682,-0.57082 -1.26023,-0.042 -1.06626,-1.32997 0,0 3.02138,-1.27939 3.02138,-1.27939 l 0,0 c -7.61861,4.36787 -7.57924,3.76889 1.37583,1.16192 -2.79852,1.96211 -7.60545,5.05804 -9.695,7.79492 -0.10971,0.14368 -1.22351,2.57933 -0.59404,3.03807 0.67307,0.49052 1.63956,0.29393 2.45934,0.4409 -10.69683,7.76533 -6.46048,2.28777 -3.95825,4.66925 0.28022,0.26669 0.34086,0.73833 0.2949,1.12243 -0.0613,0.51213 -1.11159,1.36151 -0.59991,1.42631 3.44049,0.43571 7.18169,-3.194 1.54058,1.27161 0.51455,0.0832 1.85256,-0.17022 1.54366,0.24963 -0.42993,0.58435 -5.88925,3.82593 -6.64539,4.28618 -2.25283,1.37126 -4.25988,3.13349 -6.56145,4.42126 -0.57965,0.32433 0.91585,-0.96229 1.37377,-1.44343 -0.97832,0.61888 -1.77788,1.82089 -2.93498,1.85665 -0.84725,0.0262 1.25052,-1.15506 1.77523,-1.8208 0.14614,-0.18543 0.39428,-0.8091 0.19623,-0.68058 -2.95533,1.9178 -5.47115,4.52716 -8.60483,6.13714 -1.41463,0.7268 7.50902,-5.73994 3.22744,-3.51403 -1.94695,1.35889 -3.46817,4.16386 -5.84085,4.07668 -2.00788,-0.0738 5.80425,-2.70226 4.39051,-4.12997 -1.44757,-1.46188 -3.44965,2.24521 -5.22143,3.29084 -1.58833,0.93737 -3.17327,1.89624 -4.85411,2.65534 -3.03629,1.37125 -2.45211,1.51547 -3.62353,-0.19057 -1.2459,0.29401 -2.4918,0.58801 -3.7377,0.88202 -0.94895,-0.0594 -1.91563,-0.37033 -2.84684,-0.17826 -0.90464,0.18658 -13.69919,4.55903 -14.20983,4.39414 -1.42497,-0.46012 2.23239,-3.95305 0.80923,-4.41875 -2.71665,-0.88896 -5.56686,1.30075 -8.35029,1.95112 -18.56769,0.0793 13.70185,-0.82956 -20.27406,5.77609 -1.24209,0.24149 -1.79361,-1.8371 -2.90263,-2.44636 -1.29963,-0.71396 -2.72775,-1.30777 -4.20303,-1.45723 -7.88112,-0.79842 -5.93835,3.28036 -6.95179,-3.55661 -4.15903,1.41034 -8.31806,2.82068 -12.47709,4.23101 0.13929,-1.64904 2.02947,-4.5709 0.41789,-4.94714 -3.68032,-0.8592 -7.29587,2.22135 -11.06755,2.46089 -19.20033,1.21941 3.42849,-1.74287 -8.44928,-6.51391 -3.19359,-1.2828 -6.88148,0.1533 -10.32222,0.22994 -4.01012,0.4663 -8.02025,0.93261 -12.03037,1.39891 -1.70721,-1.01184 -3.14481,-2.86055 -5.12161,-3.03552 -3.42478,-0.30314 -6.76114,2.07637 -10.17655,1.68141 -1.21543,-0.14056 -0.76145,-3.11341 -1.98472,-3.08777 -3.40485,0.0714 -6.28097,2.89341 -9.65823,3.33189 -0.82541,0.10716 -1.10923,-1.24127 -1.66384,-1.86191 -1.46833,0.1182 -2.93216,0.38115 -4.405,0.3546 -1.20724,-0.0218 -2.40792,-0.75508 -3.5878,-0.49866 -3.40511,0.74001 -6.46807,4.14784 -9.87684,3.42487 -1.76071,-0.37343 2.8545,-4.90599 1.09548,-5.28732 -6.30413,-1.36664 -12.36869,6.47925 -19.07787,3.24381 -2.81278,-1.15043 -8.0235,-3.73838 -11.21616,-2.99339 -5.30446,1.23778 -9.81702,5.25422 -15.21947,5.94913 -1.30931,0.16841 0.63002,-3.1138 -0.3995,-3.94008 -0.96711,-0.77619 -8.78805,0.52726 -9.49794,0.62362 -2.43958,0.81492 -4.75139,2.60053 -7.31876,2.44474 -3.96541,-0.24062 4.43728,-6.06793 -2.4985,-4.79696 -4.07548,0.74683 -7.54039,3.65131 -11.60589,4.45071 -3.28335,0.64561 -6.23377,-5.00667 -9.93337,-1.45023 -2.69658,0.53612 -5.34039,1.61546 -8.08974,1.60836 -1.29308,-0.003 -2.27044,-1.2921 -3.5163,-1.63834 -1.44221,-0.40081 -2.95661,-0.56492 -4.45344,-0.57657 -7.07426,-0.0551 -4.52877,1.11419 -12.43282,2.68962 -1.29287,0.25769 -2.63653,0.0199 -3.9548,0.0298 -0.74509,-0.3974 -1.39082,-1.19305 -2.23527,-1.19222 -8.48298,0.008 -5.99334,5.38203 -16.7296,6.92971 -1.63516,0.23571 1.50781,-2.94003 2.26172,-4.41004 -1.14109,0.0362 -2.31128,-0.14996 -3.42328,0.10862 -1.6719,0.38879 -3.21432,1.20574 -4.82148,1.80861 0,0 6.59652,-4.79266 6.59652,-4.79266 z"
575+ inkscape:connector-curvature="0" />
576+ <path
577+ style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:1;stroke-miterlimit:1;stroke-opacity:1;stroke-dasharray:none"
578+ id="path5288"
579+ d="m 427.09099,608.80296 c -0.54536,0.88302 -2.59373,3.0492 -1.6361,2.64907 3.94655,-2.30416 7.89309,-4.60832 11.83964,-6.91247 -0.48068,0.95507 -2.45697,2.52886 -1.44204,2.86521 1.68661,0.55895 3.34268,-1.22337 5.06375,-1.66497 1.38771,-0.35607 2.85207,-1.08817 4.237,-0.72145 0.74384,0.19697 0.64163,1.39882 0.96244,2.09823 1.37197,0.0822 2.78072,0.57276 4.11592,0.24671 3.459,-0.84467 6.54045,-2.94826 10.02108,-3.69889 2.35754,-0.50843 6.11513,1.00569 8.24077,1.90515 1.08276,0.45817 2.01316,1.647 3.18215,1.5214 3.04137,-0.32679 5.82554,-1.86816 8.73831,-2.80223 0.0213,1.01023 -0.88531,2.68436 0.064,3.03068 1.6579,0.60487 3.51554,-0.518 5.17469,-1.11943 3.10954,-1.12717 5.90095,-3.06895 9.06232,-4.04132 1.11082,-0.34167 3.56487,-0.97615 3.48173,0.18305 -0.17139,2.38956 -5.60845,4.31354 -3.92661,6.01963 1.90254,1.92996 5.2515,-1.34136 7.87725,-2.01204 5.57129,2.09339 10.88855,-4.38851 16.19806,-2.9901 1.5161,0.39931 -1.91863,4.4988 -0.36246,4.68943 3.61195,0.44246 6.80584,-2.64975 10.35214,-3.4657 4.75582,-1.09424 4.54067,-0.5378 7.56802,1.586 2.7685,-1.48955 4.99284,1.99196 7.53405,1.61787 3.37273,-0.49649 6.43938,-2.27591 9.75173,-3.08218 2.40251,-0.5848 4.93371,-0.50568 7.33922,-1.078 3.43034,-0.81613 6.59584,-3.15152 10.12112,-3.07612 1.16193,0.0249 0.71886,2.21042 1.07829,3.31564 1.42789,0.26396 2.89169,0.37849 4.28369,0.79187 4.40179,1.3072 2.47933,2.85169 8.61077,1.10238 2.82423,-0.80575 18.5379,-8.0104 22.90225,-7.58044 1.38563,0.1365 1.07795,2.56757 1.61692,3.85135 6.71637,11.01182 -3.68387,-3.37038 21.00188,-5.1411 2.86377,-0.20542 -5.40592,5.18669 -3.94363,7.65753 1.31649,2.22446 5.10447,-0.84577 7.6179,-1.44914 2.83592,-0.68079 5.59821,-1.63981 8.41404,-2.39945 2.34076,-0.63148 4.70255,-1.18227 7.05383,-1.7734 1.89507,-0.27942 3.83635,-1.33931 5.68522,-0.83825 0.91429,0.24778 0.67699,1.76946 1.01548,2.65418 2.87065,-0.87358 5.62729,-2.92999 8.61194,-2.62073 1.19443,0.12376 -0.64239,3.23232 0.51114,3.56602 2.02002,0.58437 15.38587,-3.38686 16.41366,-3.66716 -0.15304,1.37971 -1.82071,3.86876 -0.45913,4.13912 2.88522,0.57288 5.56173,-1.98169 8.44725,-2.55301 1.49987,-0.29697 3.07716,0.21428 4.58688,-0.0277 2.14755,-0.34421 4.12553,-1.5628 6.29505,-1.71648 0.71473,-0.0506 1.11339,1.25168 1.8214,1.14155 2.30654,-0.35876 4.37463,-1.63033 6.56195,-2.4455 -0.44888,1.15735 -2.31073,2.69008 -1.34663,3.47204 1.24004,1.00577 3.13873,-0.68571 4.73492,-0.72386 1.27427,-0.0305 5.97531,0.93232 7.19325,1.37508 1.00412,0.36504 1.79765,1.62936 2.85276,1.46128 3.30399,-0.52634 6.29112,-2.27935 9.43668,-3.41903 2.16754,7.29671 -1.34009,-1.02626 10.2382,-0.42077 1.26673,0.0662 -0.89534,2.46826 -0.75751,3.7292 0.0842,0.77019 0.82031,1.33174 1.37033,1.87741 3.25333,3.22757 4.14722,0.43976 9.52911,-1.62234 -5.67229,9.9542 2.19189,-5.35859 6.0963,-0.33515 1.76843,2.27527 -6.50408,3.21284 -6.15274,6.07304 0.29151,2.37311 4.145,-2.92278 6.53572,-2.95529 -2.29854,3.66744 -2.94659,2.96902 0.93035,2.70267 23.98881,-12.56081 6.53151,-5.05582 6.71984,-1.35229 0.0562,1.10418 2.14953,-0.59987 3.2544,-0.64052 0.59071,-0.0217 1.14215,0.30517 1.71323,0.45776 1.24821,-0.35158 2.46907,-0.82114 3.74464,-1.05472 0.6566,-0.12024 1.33503,0.002 2.00255,0.002 -7.56212,7.4632 -4.80566,3.75696 0.51507,2.0828 0.278,-0.0875 0.83108,0.29605 0.68233,0.54666 -0.69786,1.17578 -1.86061,2.00398 -2.79092,3.00597 0,0 -1.07469,0.77304 -1.07469,0.77304 l 0,0 c 0.29688,-0.55013 0.49344,-1.16768 0.89064,-1.65039 0.97731,-1.18769 4.73458,-3.44842 3.20163,-3.32283 -3.51078,0.28763 -5.88837,4.42533 -9.63666,4.33697 -0.15241,-0.37159 -0.34842,-0.72816 -0.45725,-1.11477 -0.29714,-1.0556 -0.24534,-2.79779 -0.8748,-2.62026 -2.57218,0.72544 -4.57165,3.54585 -7.24208,3.44002 -1.52804,-0.0605 1.88309,-2.41005 2.82464,-3.61508 -2.57134,1.22873 -5.14267,2.45745 -7.71401,3.68618 2.38555,-2.2552 5.77328,-3.78851 7.15663,-6.76561 0.72913,-1.56914 -3.24014,1.21524 -4.86007,1.82323 -1.6775,0.62961 -3.30811,1.40187 -5.03222,1.88956 -1.02074,0.28874 -3.10209,1.48551 -3.15373,0.42598 -0.0805,-1.65221 4.01255,-2.67402 2.98116,-3.96728 -1.08235,-1.35717 -3.33942,0.94959 -5.00913,1.42439 -20.13729,8.35134 -2.69796,2.67973 -3.51754,-2.53363 -0.30637,-1.94883 -3.85411,1.58588 -5.79195,1.21634 -0.87346,-0.16656 -0.0847,-2.23403 -0.93357,-2.49888 -11.84288,-3.69529 -1.16733,3.90973 -7.75074,-1.30702 -2.41838,0.61135 -4.85237,1.16396 -7.25514,1.83405 -2.78931,0.77789 -5.42146,2.48551 -8.31711,2.50877 -0.92506,0.007 -0.55731,-1.9355 -1.33837,-2.43121 -1.00483,-0.63771 -2.41681,-0.17922 -3.51128,-0.64664 -5.17393,-2.20964 4.51953,-3.02699 -6.76187,-0.29747 -1.8717,0.0522 -5.62004,0.0639 -7.3367,0.54341 -2.69541,0.75295 -5.09849,2.65578 -7.88857,2.87404 -0.88863,0.0695 -0.97674,-1.50932 -1.61597,-2.13053 -2.88746,-2.80607 -2.96741,-1.82144 -7.53922,-1.91209 -5.60568,-1.00025 -5.2968,-1.462 -12.0296,0.4822 -3.77819,1.09101 -7.17546,4.70648 -11.06137,4.10258 -1.96748,-0.30576 3.75004,-3.90954 2.47312,-5.43726 -3.21419,-3.84551 -12.45489,8.124 -14.52498,3.88536 0.16133,-1.24054 1.72133,-3.53728 0.484,-3.72163 -2.94633,-0.43896 -5.68485,1.79467 -8.57499,2.51619 -2.56637,0.64068 -5.14051,1.38245 -7.77923,1.56659 -1.88811,0.13176 -3.76204,-0.41995 -5.64306,-0.62993 0.13071,-1.79104 2.18522,-5.47173 0.39212,-5.37312 -5.55708,0.30559 -10.33401,4.13599 -15.50101,6.20399 -10.66645,-2.44406 0.68895,-0.62357 -14.71365,0.88811 -1.68946,0.16581 -3.35352,-0.60601 -5.05038,-0.65553 -1.88826,-0.0551 -3.83509,0.84291 -5.65682,0.34302 -0.93454,-0.25644 -0.73557,-2.23638 -1.69663,-2.36085 -2.36483,-0.30628 -4.69832,0.81892 -7.04748,1.22838 -2.97423,0.81182 -5.94845,1.62365 -8.92268,2.43547 -0.86665,-0.8126 -1.41221,-2.41128 -2.59994,-2.43779 -5.34668,-0.11933 -13.32985,5.97106 -18.52181,1.51644 -0.70103,-0.60147 -0.94151,-1.58947 -1.41227,-2.38421 -0.71473,0.22765 -15.04458,4.94998 -16.29418,4.75369 -1.16619,-0.18319 0.32544,-3.32233 -0.84936,-3.43812 -3.23005,-0.31834 -6.18554,2.3471 -9.4303,2.42499 -1.28344,0.0308 -2.14298,-1.4143 -3.21447,-2.12145 -4.57791,1.88547 -9.15581,3.77095 -13.73372,5.65642 -0.35422,-0.97953 -0.25778,-2.27745 -1.06266,-2.9386 -0.88974,-0.73085 -3.03618,0.38783 -3.38033,-0.71096 -0.44745,-1.42861 3.36536,-4.26694 1.8802,-4.07862 -3.91526,0.49646 -7.09459,3.45974 -10.64188,5.18961 0.003,-0.88328 0.88856,-2.56291 0.01,-2.64984 -2.39024,-0.23638 -4.62168,1.31014 -6.93253,1.9652 -21.18125,5.49534 1.18422,1.02595 -11.44132,0.93616 -2.29045,-0.0163 -4.51443,1.00604 -6.80442,0.95784 -1.30262,-0.0274 -2.42374,-1.16009 -3.72651,-1.17953 -2.1489,-0.0321 -4.24554,1.38622 -6.36478,1.02898 -0.87305,-0.14717 -0.86226,-1.54661 -1.29339,-2.31992 -2.244,0.83914 -8.96653,3.77305 -12.27692,3.87067 -0.63692,0.0188 -1.13222,-0.59394 -1.73219,-0.80855 -1.88608,-0.67465 -2.71984,-0.38168 -3.36282,-2.56718 0,0 -2.59014,1.88185 -2.59014,1.88185 z"
580+ inkscape:connector-curvature="0" />
581+ <text
582+ xml:space="preserve"
583+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
584+ x="351"
585+ y="282"
586+ id="text4003"
587+ sodipodi:linespacing="125%"><tspan
588+ sodipodi:role="line"
589+ id="tspan4005"
590+ x="351"
591+ y="282"
592+ style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic">Endpoint</tspan></text>
593+ <text
594+ sodipodi:linespacing="125%"
595+ id="text4030"
596+ y="316"
597+ x="373"
598+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
599+ xml:space="preserve"><tspan
600+ style="font-size:16px;font-style:italic;font-family:Arial;-inkscape-font-specification:Arial Italic"
601+ y="316"
602+ x="373"
603+ id="tspan4032"
604+ sodipodi:role="line">Transport</tspan></text>
605+ <text
606+ xml:space="preserve"
607+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
608+ x="454.58578"
609+ y="292.34314"
610+ id="text4050"
611+ sodipodi:linespacing="125%"><tspan
612+ sodipodi:role="line"
613+ id="tspan4052"
614+ x="454.58578"
615+ y="292.34314"
616+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">TCP connection</tspan><tspan
617+ sodipodi:role="line"
618+ x="454.58578"
619+ y="312.34314"
620+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
621+ id="tspan4068">(bi-directional)</tspan></text>
622+ <path
623+ style="fill:#b3b3b3;stroke:#000000;stroke-width:1;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:2,1;stroke-dashoffset:0"
624+ d="m 554,248 86,108"
625+ id="path4054"
626+ inkscape:connector-curvature="0" />
627+ <text
628+ sodipodi:linespacing="125%"
629+ id="text4056"
630+ y="376"
631+ x="594"
632+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
633+ xml:space="preserve"><tspan
634+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
635+ y="376"
636+ x="594"
637+ id="tspan4058"
638+ sodipodi:role="line">Transport connection</tspan><tspan
639+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic"
640+ y="396"
641+ x="594"
642+ sodipodi:role="line"
643+ id="tspan4070">(uni-directional)</tspan></text>
644+ <text
645+ xml:space="preserve"
646+ style="font-size:40px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:125%;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;font-family:Courier;-inkscape-font-specification:Courier"
647+ x="794"
648+ y="226"
649+ id="text4062"
650+ sodipodi:linespacing="125%"><tspan
651+ sodipodi:role="line"
652+ id="tspan4064"
653+ x="794"
654+ y="226"
655+ style="font-size:16px;font-style:italic;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:Arial;-inkscape-font-specification:Arial Italic">Chan</tspan></text>
656+ </g>
657+</svg>
doc/reconnect/reconnect.texnew file+409
@@ -0,0 +1,409 @@
1+\documentclass[10pt]{article}
2+\usepackage[margin=2.5cm]{geometry}
3+\usepackage{listings}
4+\usepackage{amsmath,amssymb,stmaryrd}
5+\usepackage{mathpazo,times}
6+
7+\begin{document}
8+
9+\newcommand{\semNs}{\mathit{ns}}
10+\newcommand{\semEth}{\mathit{eth}}
11+\newcommand{\semPg}{\mathit{pg}}
12+\newcommand{\semNid}{\mathit{nid}}
13+\newcommand{\semNc}{\mathit{nc}}
14+\newcommand{\semRecon}{\mathrm{reconnect}}
15+\newcommand{\semDisconnect}{\mathrm{disconnect}}
16+\newcommand{\semDropped}{\mathrm{dropped}}
17+\newcommand{\semMessage}{\mathrm{message}}
18+\newcommand{\semPid}{\mathit{pid}}
19+
20+\newcommand{\semSystem}[2]{\llbracket #1, #2 \rrbracket}
21+\newcommand{\semNode}[3]{[ #1, #2, #3 ]}
22+\newcommand{\semStdNode}[1]{\semNode{\semPg_{#1}}{\semNid_{#1}}{\semNc_{#1}}}
23+\newcommand{\semProc}[3]{\langle #1, #2, #3 \rangle}
24+\newcommand{\semStdProc}[1]{\semProc{e}{\semPid}{q}}
25+
26+\newcommand{\semDied}[2]{\mathrm{died}(#1, #2)}
27+\newcommand{\semParN}{\mathrel{{\parallel}_N}}
28+\newcommand{\semParP}{\mathrel{{\parallel}_P}}
29+\newcommand{\semEthMatch}[3]{\mathrm{ethMatch}(#1, #2, #3)}
30+
31+\lstset{basicstyle=\ttfamily\small}
32+
33+\title{An Explicit $\semRecon$ Primitive for Cloud Haskell \\ (or a Future Erlang)}
34+\author{\small \begin{tabular}{ll}
35+Edsko de Vries & Duncan Coutts \\
36+Well-Typed LLP & Well-Typed LLP \\
37+\texttt{edsko@well-typed.com} & \texttt{duncan@well-typed.com}
38+\end{tabular}}
39+\maketitle
40+
41+\section*{Introduction}
42+
43+The original Cloud Haskell paper stipulates that messages are ``asynchronous,
44+reliable, and buffered'', but does not describe how this can be achieved.
45+Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''),
46+the reliability of message delivery comes from the reliability of the
47+underlying network protocol---up to a point.
48+
49+The problem is that the underlying network protocol is connection-oriented, but
50+Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a
51+reliable-ordered connection from $P$ to $Q$. Reliability of message delivery
52+now follows from reliability of the network protocol, until $P$ somehow gets
53+disconnected from $Q$. If $P$ now sends another message to $Q$, the
54+implementation cannot simply reconnect: after all, some messages that were sent
55+on the first connection might not have been delivered. This means that $P$
56+might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1, m_3$.
57+
58+One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and
59+remove messages from this buffer only when $Q$ acknowledges that it received
60+them. On a reconnect $P$ must ask which message $Q$ last received, and
61+retransmit the rest. This means that when $P$ gets disconnected from $Q$, it
62+must infinitely buffer all messages sent to $Q$ (until a connection is
63+reestablished). However, infinite buffering is too strong a requirement;
64+moreover, this is unsatisfactory because it means implementing a reliable
65+protocol on top of the underlying reliable network protocol. We would like a
66+different solution.
67+
68+But even more important than the exact solution we adopt is a precise
69+semantics of Cloud Haskell message delivery. A good starting point (one that
70+has been used in the new implementation of Cloud Haskell) is \textit{A
71+Unified Semantics for Future Erlang} by Hans Svensson, Lars-\AA{}ke Fredlund
72+and Clara Benac Earle (Erlang '10)---although this semantics leaves the issue
73+of reconnect open.
74+
75+Here we give an overview of the relevant aspects of the Unified semantics,
76+discuss where reconnect comes into the picture, and then propose a new
77+primitive for Cloud Haskell called $\semRecon$, which essentially gives the
78+programmer the ability to explicitly accept message loss.
79+
80+\section*{Overview of the original semantics}
81+
82+The top-level semantics is a labelled transition relation between
83+\textit{systems}
84+%
85+\begin{equation}
86+\semSystem{\semNs}{\semEth} \xrightarrow{\tilde{\mu}} \semSystem{\semNs'}{\semEth'}
87+\end{equation}
88+%
89+A system $\semSystem{\semNs}{\semEth}$ consists of a bunch of nodes $\semNs$
90+and an ``ether'' or system message queue $\semEth$. The ether models, globally,
91+all messages that have been sent but not yet delivered. The label $\tilde{\mu}$
92+is a list of actions, and is only used in the semantics to define fairness (see
93+below).
94+
95+A node is a triplet $\semStdNode{}$ consisting of a bunch of processes
96+$\semPg$, a node ID $\semNid$ and a node controller $\semNc$. The node
97+controller is responsible for all administrative actions on a node (spawning
98+new processes, establishing links, etc.).
99+A process $\semStdProc{}$ consists of an expression $e$, process ID $\semPid$
100+and message queue (mailbox) $q$. Finally, $(\semParN)$ is used for the parallel
101+composition of nodes, and $(\semParP)$ is used for the parallel composition of
102+processes.
103+
104+\subsubsection*{Ordering}
105+
106+The ether contains messages of the form
107+%
108+\begin{equation*}
109+(\mathit{recipient}, \mathit{sender}, \mathit{message})
110+\end{equation*}
111+%
112+where $\mathit{recipient}$ and $\mathit{sender}$ are process IDs or node IDs
113+(for messages to or from node controllers). Ordering of message delivery in
114+the semantics is embodied by a function
115+%
116+\begin{equation*}
117+\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}}
118+\end{equation*}
119+%
120+(Def.~11, p.~25) which selects the \emph{first} message in $\semEth$ from
121+$\mathit{from}$ to $\mathit{to}$. Many of the semantic rules look like
122+%
123+\begin{equation*}
124+\frac{%
125+\semEthMatch{\semEth}{\mathit{to}}{\mathit{from}} = \mathit{sig}
126+}{%
127+\semSystem{\semNs}{\semEth} \rightarrow \text{(do something with $\mathit{sig}$)}
128+}
129+\end{equation*}
130+
131+where $\mathit{to}$ and $\mathit{from}$ are universally quantified over the
132+rule. This means that messages between pairs of processes (or nodes) are
133+ordered, but there is no global ordering guarantee.
134+
135+\subsubsection*{Disconnects}
136+
137+Although the semantics is not connection oriented, it includes a
138+non-deterministic rule $\mathit{node}_\mathit{disconnect}$ which models
139+arbitrary disconnects (Table 9, p.~28):
140+%
141+{\small
142+\begin{equation*}
143+\frac{}{%
144+ \begin{array}{l}
145+ \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}{\semEth}
146+\xrightarrow{\semDisconnect(nid_1, nid_2)} \\[0.5em]
147+ \semSystem{\semStdNode{1} \semParN \semStdNode{2} \semParN \semNs}
148+ {\semEth \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})
149+ \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})
150+ }
151+ \end{array}
152+}
153+\end{equation*}
154+}
155+%
156+So at any one point a node controller may receive a message that it got
157+disconnected from another node controller. These messages are handled by the
158+bottom rule in Table 12 (p.~30): local processes that link to (or monitor)
159+processes on the disconnected remote node are killed (or notified).
160+
161+\subsubsection*{Node or process failure}
162+
163+When a process dies (throws an exception) a message is sent to its local node
164+controller (rule $\mathit{exiting}$, Table~4, p.~27). Failure of an entire
165+node is handled by a non-deterministic rule like the one above (rule
166+$\mathit{node}_\mathit{failure}$, Table~9, p.~28). The resulting message is
167+handled in a similar way to a disconnect (Table~12, p.~30).
168+
169+When a process or a node \emph{dies} (but \emph{not} when it gets disconnected)
170+messages to that process (or node) can be removed from the ether (rules
171+$\mathit{missing}_\mathit{process}$ and $\mathit{missing}_\mathit{node}$,
172+Table~6, p.~28).
173+
174+\subsubsection*{Fairness}
175+
176+Since the semantic rules pick an (more or less) arbitrary message from the
177+ether to process, the rules do not guarantee that all messages are eventually
178+delivered. In the paper this is added ``on top'' of the semantic rules by Def.~20
179+(p.~29), which essentially states that all messages that have been sent must be
180+delivered (or explicitly removed by rules $\mathit{missing}_\mathit{process}$
181+and $\mathit{missing}_\mathit{node}$).
182+
183+\section*{Reconnect}
184+
185+\subsubsection*{In the Unified semantics}
186+
187+The original semantics state that
188+
189+\begin{enumerate}
190+\item all messages sent must eventually be delivered or explicitly removed from the ether (fairness)
191+\item only messages to died (not disconnected) processes or nodes can be removed from the ether
192+\end{enumerate}
193+
194+From a practical perspective this means that messages sent from process $P$ to
195+process $Q$ must be infinitely buffered when $P$ gets disconnected to $Q$, and
196+the system should keep retrying to connect to $Q$ until it receives evidence
197+(for instance, from $Q$'s node controller) that $Q$ has died.
198+
199+For messages sent to node controllers (such as attempts to spawn new processes)
200+this is even more problematic: when process $P$ gets disconnected from node
201+$N$, all messages from $P$ to $N$ must be infinitely buffered until a
202+reconnection is established, or dropped when $P$ learns $N$ has died. However,
203+process $P$ might never be able to distinguish a (temporary) disconnect from
204+$N$ from a crash of $N$.
205+
206+\subsubsection*{Permanent disconnects}
207+
208+The simplest solution to avoid infinite buffering is to drop the fairness
209+requirement from the semantics. Now the implementation is free to attempt to
210+reconnect only a finite number of times---or indeed never---and then simply
211+drop all subsequent messages and never reconnect again. This is a correct
212+implementation of the semantics, because without the fairness requirement
213+messages sent from $P$ to $Q$ can be left in the ether forever.\footnote{From a
214+purely formal perspective, the semantics without the fairness guarantee is too
215+permissive: it would allow a message never to be sent even when no disconnect
216+occurs. If we wanted to fix this, we would have to remove messages from the
217+ether on a disconnect, so that fairness can be satisfied, and keep an explicit
218+history of disconnects.}
219+
220+\subsubsection*{Implicit reconnect with potential message loss (Erlang-style)}
221+
222+The solution adopted by Erlang is an implicit reconnect but without
223+buffering. As described in the introduction, this means that it is possible for
224+$P$ to send messages $m_1, m_2, m_3$ to $Q$ and for $Q$ to receive messages
225+$m_1$ and $m_3$, but not $m_2$. We could model this in the semantics by
226+modifying the rule for disconnect so that it removes messages from the ether.
227+
228+\subsubsection*{Explicit Reconnects}
229+
230+Erlang-style implicit reconnects are not very satisfying semantically because
231+it means we cannot really make any claims about the reliability of message
232+delivery. Permanent disconnects are nicer semantically, but might be too
233+limiting (some musings on that below). The solution we propose is to introduce
234+a new primitive called $\semRecon$. Here's the rule:
235+%
236+\begin{equation*}
237+\frac{%
238+e \xrightarrow{\semRecon(i)} e' \qquad
239+(\semEth_0, \semEth_1) = \mathrm{partition} \; (\lambda (\mathit{to}, \mathit{from}, \_) \rightarrow \mathit{to} = i \wedge \mathit{from} = \semPid) \; \semEth
240+}{%
241+ \semSystem{\semNode{\semProc{e}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth}
242+\xrightarrow{\semDropped(\semEth_0)}
243+ \semSystem{\semNode{\semProc{e'}{\semPid}{q} \semParP \semPg}{\semNid}{\semNc} \semParN \semNs}{\semEth_1}
244+}
245+\end{equation*}
246+%
247+Semantically, when process $P$ calls $\semRecon(Q)$ it explicitly accepts that
248+some the messages it sent to $Q$ might be lost. Note that this is the only
249+change we need to make the Unified semantics. In particular, the fairness
250+requirement stays: since the rule explicitly records that some messages have
251+been dropped, fairness now means:
252+
253+\begin{quote}
254+All messages sent must eventually be delivered, removed from the ether because
255+a process or a node died, or removed from the ether by an explicit $\semRecon$.
256+\end{quote}
257+
258+From an implementation point of view, once $P$'s connection to $Q$ breaks we do
259+not implicitly reconnect (because doing so would mean losing the reliability
260+guarantee). When $P$ calls $\semRecon(Q)$, however, the implementation is
261+free to reestablish a connection from $P$ to $Q$, either immediately or when
262+$P$ sends its next message to $Q$.
263+
264+\section*{Example}
265+
266+Suppose we start with two nodes, both of which run a single process. The system
267+ether and both process queues are empty ($\epsilon$):
268+%
269+\begin{equation*}
270+\semSystem
271+ {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}
272+ \semParN
273+ \underbrace{\semNode{\semProc{p_2}{\semPid_2}{\epsilon}}{\semNid_2}{\semNc_2}}_{N_2}
274+ }
275+ {\epsilon}
276+\end{equation*}
277+%
278+Now $p_1$ sends a message to $p_2$ (Rule $\mathit{output}$, Table~5, p.~28):
279+%
280+\begin{equation*}
281+\frac{%
282+ p_1 \xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)} p_1'
283+}{%
284+\semSystem
285+ {\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}
286+ \semParN
287+ N_2
288+ }
289+ {\epsilon}
290+\xrightarrow{\semPid_2 \; {!_{\semPid_1}} \; \semMessage(v)}
291+\semSystem
292+ {\underbrace{\semNode{\semProc{p_1}{\semPid_1}{\epsilon}}{\semNid_1}{\semNc_1}}_{N_1'}
293+ \semParN
294+ N_2
295+ }
296+ {\underbrace{(\semPid_2, \semPid_1, \semMessage(v))}_{M_1}}
297+}
298+\end{equation*}
299+%
300+Note that the message has been sent but not yet delivered (i.e., it is in the
301+ether, not in $p_2$'s queue). Now suppose that node $\semNid_1$ gets
302+disconnected from node $\semNid_2$ (Table~9, p.~28):
303+%
304+\begin{equation*}
305+\frac{%
306+}{%
307+\begin{array}{l}
308+\semSystem{N_1' \semParN N_2}{M_1}
309+\xrightarrow{\semDisconnect(\semNid_1, \semNid_2)} \\
310+\semSystem{N_1' \semParN N_2}{M_1 \cdot (nid_1, nid_2, \semDied{nid_2}{\semDisconnect})
311+ \cdot (nid_2, nid_1, \semDied{nid_1}{\semDisconnect})}
312+\end{array}
313+}
314+\end{equation*}
315+%
316+Assume that $p_1$ had previously set up monitoring for $p_2$. It gets notified of the disconnect (Table 12), and it receives the monitor message; at this point we're in a state
317+%
318+\begin{equation*}
319+\semSystem{N_1'' \semParN N_2}{M_1}
320+\end{equation*}
321+%
322+where the original message $M_1$ is still in the ether. If at this point $p_1$ sends another message to $p_2$ we end up with an ether
323+%
324+\begin{equation*}
325+M_1 \cdot \underbrace{(\semPid_2, \semPid_1, \semMessage(v_2))}_{M_2}
326+\end{equation*}
327+%
328+which implies that we must deliver $M_1$ before $M_2$. This is of course
329+precisely the ``ordered'' reliability guarantee. If however, $p_1$ calls
330+$\semRecon$ when it receives the monitor message, we remove $M_1$ from the ether;
331+when $p_1$ then sends the next message we can establish a new connection.
332+
333+\section*{The Need for Reconnect}
334+
335+Ordering guarantees are between pairs of processes/nodes. Thus, when $P$ gets
336+disconnected from $Q$, the easiest way to reestablish a connection is for $P$
337+to restart to become a new process $P'$. This will happen naturally when $P$
338+links to $Q$ and can be restarted by some supervisor process.
339+
340+However, if there are many processes connected to $P$, then $P$ might not want
341+to restart (breaking all connections with its own clients) simply in order to
342+be able to reconnect to Q. For instance, maybe $P$ is a webserver and $Q$ is a
343+domain name server; if $P$ gets temporarily disconnected from $Q$, it does not
344+make much sense to require $P$ to restart (and get a new process ID) before it
345+can send new domain name requests (indeed, in this particular example, lost
346+messages to a domain name server may not matter at all).
347+
348+The situation is even more severe for messages sent from processes to
349+\emph{nodes}. For instance, suppose process $P$ does
350+%
351+\begin{lstlisting}[mathescape,keywords={do}]
352+do spawnAsync nid p1 ; spawnAsync nid p2 ; spawnAsync nid p3
353+\end{lstlisting}
354+%
355+and receives a confirmation that $p_3$ was spawned successfully.\footnote{In
356+the unified paper spawn is asynchronous, which is why the new implementation of
357+Cloud Haskell offers \texttt{spawnAsync}; \texttt{spawn} is then implemented in
358+terms of \texttt{spawnAsync} and \texttt{expect}.} Intuitively this seems to
359+suggest that \emph{all} of $p_1$, $p_2$ and $p_3$ should have been spawned, and
360+this is guaranteed by the reliable-ordered guarantee for messages:
361+\texttt{spawnAsync} is nothing more than a message from the process to the node
362+controller of the node $\mathit{nid}$.
363+
364+But the same problem with reconnect occurs here, too. If the connection from
365+the process to the remote node controller is lost, we cannot guarantee ordered
366+delivery. Permanent disconnect would mean that the process would have to
367+restart before it can spawn new processes on this remote node; if the process
368+is some sort of supervisor process, then this might not be what we want to do.
369+Implicit reconnects means we lose the reliability guarantee; an explicit
370+reconnect (probably after a monitor notification about the disconnect from the
371+remote node) allows the process to reestablish a connection to the remote node
372+controller, and forces the programmer of the process to think about how to
373+handle the potential loss of messages.
374+
375+\section*{Alternative Solutions}
376+
377+\begin{itemize}
378+
379+\item A hybrid solution is possible, too. For instance, we might guarantee
380+reliable-ordered message passing for messages sent from process-to-process, but
381+not for process-to-node. In other words, no explicit call is necessary when
382+spawning a new process on a remote node after a disconnect from that remote
383+node. This might muddle the semantics (in particular, if processes don't
384+monitor remote nodes, programmers might get a false sense of security and rely
385+on non-existing ordering guarantees). On the other hand, requiring an explicit
386+reconnect to a remote node before a spawn (or similar primitive) might be
387+confusing.
388+
389+\item Another hybrid solution is to have an implicit reconnect when sending a
390+monitor notification. So, if $P$ monitors $Q$, and gets a monitor notification,
391+then it must expect potential message loss. If $P$ does not monitor $Q$ then
392+disconnects are permanent.
393+
394+\item Since Cloud Haskell supports typed channels as well as sending messages
395+directly to processes, we could decide not to offer any reliability guarantees
396+for messages sent directly to processes, but provide reliable-ordered message
397+delivery on typed channels. This is an attractive solution, because a typed
398+channel could be considered a connection. When $P$ wants to communicate with
399+$Q$, it sends a message to $Q$ requesting a send port. It then communicates
400+with $Q$ through this send port; when it gets disconnected, it could request a
401+\empty{new} typed channel. Importantly, the send port $P$ receives must indeed
402+be a \emph{new} channel (at least from $P$s perspective).
403+
404+\end{itemize}
405+
406+
407+
408+
409+\end{document}
doc/semantics/CloudHaskellSemantics.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 $*
network-transport-inmemory/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Well-Typed LLP, 2011-2012
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of the owner nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
network-transport-inmemory/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
network-transport-inmemory/network-transport-inmemory.cabalnew file+64
@@ -0,0 +1,64 @@
1+Name: network-transport-inmemory
2+Version: 0.2.0
3+Cabal-Version: >=1.8
4+Build-Type: Simple
5+License: BSD3
6+License-file: LICENSE
7+Copyright: Well-Typed LLP
8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10+Stability: experimental
11+Homepage: http://github.com/haskell-distributed/distributed-process
12+Bug-Reports: mailto:edsko@well-typed.com
13+Synopsis: In-memory instantation of Network.Transport
14+Description: In-memory instantation of Network.Transport
15+Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
16+Category: Network
17+
18+Library
19+ Build-Depends: base >= 4.3 && < 5,
20+ network-transport >= 0.2 && < 0.3,
21+ data-accessor >= 0.2 && < 0.3,
22+ bytestring >= 0.9 && < 0.10,
23+ containers >= 0.4 && < 0.5
24+ Exposed-modules: Network.Transport.Chan
25+ ghc-options: -Wall -fno-warn-unused-do-bind
26+ HS-Source-Dirs: src
27+
28+Test-Suite TestMulticastInMemory
29+ Type: exitcode-stdio-1.0
30+ Build-Depends: base >= 4.3 && < 5,
31+ network-transport >= 0.2 && < 0.3,
32+ data-accessor >= 0.2 && < 0.3,
33+ bytestring >= 0.9 && < 0.10,
34+ containers >= 0.4 && < 0.5,
35+ random >= 1.0 && < 1.1,
36+ ansi-terminal >= 0.5 && < 0.6
37+ Main-Is: TestMulticastInMemory.hs
38+ ghc-options: -Wall -fno-warn-unused-do-bind
39+ Extensions: ExistentialQuantification,
40+ FlexibleInstances,
41+ DeriveDataTypeable,
42+ RankNTypes,
43+ OverloadedStrings
44+ HS-Source-Dirs: tests src
45+
46+Test-Suite TestInMemory
47+ Type: exitcode-stdio-1.0
48+ Build-Depends: base >= 4.3 && < 5,
49+ network-transport >= 0.2 && < 0.3,
50+ data-accessor >= 0.2 && < 0.3,
51+ bytestring >= 0.9 && < 0.10,
52+ containers >= 0.4 && < 0.5,
53+ random >= 1.0 && < 1.1,
54+ ansi-terminal >= 0.5 && < 0.6,
55+ mtl >= 2.0 && < 2.2
56+ Main-Is: TestInMemory.hs
57+ ghc-options: -Wall -fno-warn-unused-do-bind
58+ Extensions: ExistentialQuantification,
59+ FlexibleInstances,
60+ DeriveDataTypeable,
61+ RankNTypes,
62+ OverloadedStrings,
63+ OverlappingInstances
64+ HS-Source-Dirs: tests src
network-transport-inmemory/src/Network/Transport/Chan.hsnew file+157
@@ -0,0 +1,157 @@
1+-- | In-memory implementation of the Transport API.
2+module Network.Transport.Chan (createTransport) where
3+
4+import Network.Transport
5+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
6+import Control.Applicative ((<$>))
7+import Control.Category ((>>>))
8+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)
9+import Control.Exception (throwIO)
10+import Control.Monad (forM_, when)
11+import Data.Map (Map)
12+import qualified Data.Map as Map (empty, insert, size, delete, findWithDefault)
13+import Data.Set (Set)
14+import qualified Data.Set as Set (empty, elems, insert, delete)
15+import Data.ByteString (ByteString)
16+import qualified Data.ByteString.Char8 as BSC (pack)
17+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
18+import qualified Data.Accessor.Container as DAC (mapMaybe)
19+
20+-- Global state: next available "address", mapping from addresses to channels and next available connection
21+data TransportState = State { _channels :: Map EndPointAddress (Chan Event)
22+ , _nextConnectionId :: Map EndPointAddress ConnectionId
23+ , _multigroups :: Map MulticastAddress (MVar (Set EndPointAddress))
24+ }
25+
26+-- | Create a new Transport.
27+--
28+-- Only a single transport should be created per Haskell process
29+-- (threads can, and should, create their own endpoints though).
30+createTransport :: IO Transport
31+createTransport = do
32+ state <- newMVar State { _channels = Map.empty
33+ , _nextConnectionId = Map.empty
34+ , _multigroups = Map.empty
35+ }
36+ return Transport { newEndPoint = apiNewEndPoint state
37+ , closeTransport = throwIO (userError "closeEndPoint not implemented")
38+ }
39+
40+-- | Create a new end point
41+apiNewEndPoint :: MVar TransportState -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
42+apiNewEndPoint state = do
43+ chan <- newChan
44+ addr <- modifyMVar state $ \st -> do
45+ let addr = EndPointAddress . BSC.pack . show . Map.size $ st ^. channels
46+ return ((channelAt addr ^= chan) . (nextConnectionIdAt addr ^= 1) $ st, addr)
47+ return . Right $ EndPoint { receive = readChan chan
48+ , address = addr
49+ , connect = apiConnect addr state
50+ , closeEndPoint = throwIO (userError "closeEndPoint not implemented")
51+ , newMulticastGroup = apiNewMulticastGroup state addr
52+ , resolveMulticastGroup = apiResolveMulticastGroup state addr
53+ }
54+
55+-- | Create a new connection
56+apiConnect :: EndPointAddress
57+ -> MVar TransportState
58+ -> EndPointAddress
59+ -> Reliability
60+ -> ConnectHints
61+ -> IO (Either (TransportError ConnectErrorCode) Connection)
62+apiConnect myAddress state theirAddress _reliability _hints = do
63+ (chan, conn) <- modifyMVar state $ \st -> do
64+ let chan = st ^. channelAt theirAddress
65+ let conn = st ^. nextConnectionIdAt theirAddress
66+ return (nextConnectionIdAt theirAddress ^: (+ 1) $ st, (chan, conn))
67+ writeChan chan $ ConnectionOpened conn ReliableOrdered myAddress
68+ connAlive <- newMVar True
69+ return . Right $ Connection { send = apiSend chan conn connAlive
70+ , close = apiClose chan conn connAlive
71+ }
72+
73+-- | Send a message over a connection
74+apiSend :: Chan Event -> ConnectionId -> MVar Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
75+apiSend chan conn connAlive msg =
76+ modifyMVar connAlive $ \alive ->
77+ if alive
78+ then do
79+ writeChan chan (Received conn msg)
80+ return (alive, Right ())
81+ else
82+ return (alive, Left (TransportError SendFailed "Connection closed"))
83+
84+-- | Close a connection
85+apiClose :: Chan Event -> ConnectionId -> MVar Bool -> IO ()
86+apiClose chan conn connAlive =
87+ modifyMVar_ connAlive $ \alive -> do
88+ when alive . writeChan chan $ ConnectionClosed conn
89+ return False
90+
91+-- | Create a new multicast group
92+apiNewMulticastGroup :: MVar TransportState -> EndPointAddress -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
93+apiNewMulticastGroup state ourAddress = do
94+ group <- newMVar Set.empty
95+ groupAddr <- modifyMVar state $ \st -> do
96+ let addr = MulticastAddress . BSC.pack . show . Map.size $ st ^. multigroups
97+ return (multigroupAt addr ^= group $ st, addr)
98+ return . Right $ createMulticastGroup state ourAddress groupAddr group
99+
100+-- | Construct a multicast group
101+--
102+-- When the group is deleted some endpoints may still receive messages, but
103+-- subsequent calls to resolveMulticastGroup will fail. This mimicks the fact
104+-- that some multicast messages may still be in transit when the group is
105+-- deleted.
106+createMulticastGroup :: MVar TransportState -> EndPointAddress -> MulticastAddress -> MVar (Set EndPointAddress) -> MulticastGroup
107+createMulticastGroup state ourAddress groupAddress group =
108+ MulticastGroup { multicastAddress = groupAddress
109+ , deleteMulticastGroup = modifyMVar_ state $ return . (multigroups ^: Map.delete groupAddress)
110+ , maxMsgSize = Nothing
111+ , multicastSend = \payload -> do
112+ cs <- (^. channels) <$> readMVar state
113+ es <- readMVar group
114+ forM_ (Set.elems es) $ \ep -> do
115+ let ch = cs ^. at ep "Invalid endpoint"
116+ writeChan ch (ReceivedMulticast groupAddress payload)
117+ , multicastSubscribe = modifyMVar_ group $ return . Set.insert ourAddress
118+ , multicastUnsubscribe = modifyMVar_ group $ return . Set.delete ourAddress
119+ , multicastClose = return ()
120+ }
121+
122+-- | Resolve a multicast group
123+apiResolveMulticastGroup :: MVar TransportState
124+ -> EndPointAddress
125+ -> MulticastAddress
126+ -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
127+apiResolveMulticastGroup state ourAddress groupAddress = do
128+ group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state
129+ case group of
130+ Nothing -> return . Left $ TransportError ResolveMulticastGroupNotFound ("Group " ++ show groupAddress ++ " not found")
131+ Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar
132+
133+--------------------------------------------------------------------------------
134+-- Lens definitions --
135+--------------------------------------------------------------------------------
136+
137+channels :: Accessor TransportState (Map EndPointAddress (Chan Event))
138+channels = accessor _channels (\ch st -> st { _channels = ch })
139+
140+nextConnectionId :: Accessor TransportState (Map EndPointAddress ConnectionId)
141+nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid })
142+
143+multigroups :: Accessor TransportState (Map MulticastAddress (MVar (Set EndPointAddress)))
144+multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })
145+
146+at :: Ord k => k -> String -> Accessor (Map k v) v
147+at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)
148+
149+channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)
150+channelAt addr = channels >>> at addr "Invalid channel"
151+
152+nextConnectionIdAt :: EndPointAddress -> Accessor TransportState ConnectionId
153+nextConnectionIdAt addr = nextConnectionId >>> at addr "Invalid connection ID"
154+
155+multigroupAt :: MulticastAddress -> Accessor TransportState (MVar (Set EndPointAddress))
156+multigroupAt addr = multigroups >>> at addr "Invalid multigroup"
157+
network-transport-inmemory/tests/TestAuxiliary.hsnew file+108
@@ -0,0 +1,108 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TestAuxiliary ( -- Running tests
3+ runTest
4+ , runTests
5+ -- Writing tests
6+ , forkTry
7+ , trySome
8+ , randomThreadDelay
9+ ) where
10+
11+import Prelude hiding (catch)
12+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
13+import Control.Concurrent.Chan (Chan)
14+import Control.Monad (liftM2, unless)
15+import Control.Exception (SomeException, try, catch)
16+import System.Timeout (timeout)
17+import System.IO (stdout, hFlush)
18+import System.Console.ANSI ( SGR(SetColor, Reset)
19+ , Color(Red, Green)
20+ , ConsoleLayer(Foreground)
21+ , ColorIntensity(Vivid)
22+ , setSGR
23+ )
24+import System.Random (randomIO)
25+import Network.Transport
26+import Traced (Traceable(..), traceShow)
27+
28+-- | Like fork, but throw exceptions in the child thread to the parent
29+forkTry :: IO () -> IO ThreadId
30+forkTry p = do
31+ tid <- myThreadId
32+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
33+
34+-- | Like try, but specialized to SomeException
35+trySome :: IO a -> IO (Either SomeException a)
36+trySome = try
37+
38+-- | Run the given test, catching timeouts and exceptions
39+runTest :: String -> IO () -> IO Bool
40+runTest description test = do
41+ putStr $ "Running " ++ show description ++ ": "
42+ hFlush stdout
43+ done <- try . timeout 60000000 $ test -- 60 seconds
44+ case done of
45+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
46+ Right Nothing -> failed $ "(timeout)"
47+ Right (Just ()) -> ok
48+ where
49+ failed :: String -> IO Bool
50+ failed err = do
51+ setSGR [SetColor Foreground Vivid Red]
52+ putStr "failed "
53+ setSGR [Reset]
54+ putStrLn err
55+ return False
56+
57+ ok :: IO Bool
58+ ok = do
59+ setSGR [SetColor Foreground Vivid Green]
60+ putStrLn "ok"
61+ setSGR [Reset]
62+ return True
63+
64+-- | Run a bunch of tests and throw an exception if any fails
65+runTests :: [(String, IO ())] -> IO ()
66+runTests tests = do
67+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
68+ unless success $ fail "Some tests failed"
69+
70+-- | Random thread delay between 0 and the specified max
71+randomThreadDelay :: Int -> IO ()
72+randomThreadDelay maxDelay = do
73+ delay <- randomIO :: IO Int
74+ threadDelay (delay `mod` maxDelay)
75+
76+--------------------------------------------------------------------------------
77+-- traceShow instances --
78+--------------------------------------------------------------------------------
79+
80+instance Traceable EndPoint where
81+ trace = const Nothing
82+
83+instance Traceable Transport where
84+ trace = const Nothing
85+
86+instance Traceable Connection where
87+ trace = const Nothing
88+
89+instance Traceable Event where
90+ trace = traceShow
91+
92+instance Show err => Traceable (TransportError err) where
93+ trace = traceShow
94+
95+instance Traceable EndPointAddress where
96+ trace = traceShow . endPointAddressToByteString
97+
98+instance Traceable SomeException where
99+ trace = traceShow
100+
101+instance Traceable ThreadId where
102+ trace = const Nothing
103+
104+instance Traceable (Chan a) where
105+ trace = const Nothing
106+
107+instance Traceable Float where
108+ trace = traceShow
network-transport-inmemory/tests/TestInMemory.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-inmemory/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-inmemory/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-inmemory/tests/TestTransport.hsnew file+956
@@ -0,0 +1,956 @@
1+{-# LANGUAGE RebindableSyntax #-}
2+module TestTransport where
3+
4+import Prelude hiding (catch, (>>=), (>>), return, fail)
5+import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)
6+import Control.Concurrent (forkIO, killThread, yield)
7+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar, modifyMVar_, newMVar)
8+import Control.Exception (evaluate, throw, throwIO, bracket)
9+import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless)
10+import Control.Monad.Error ()
11+import Control.Applicative ((<$>))
12+import Network.Transport
13+import Network.Transport.Internal (tlog, tryIO, timeoutMaybe)
14+import Network.Transport.Util (spawn)
15+import System.Random (randomIO)
16+import Data.ByteString (ByteString)
17+import Data.ByteString.Char8 (pack)
18+import Data.Map (Map)
19+import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
20+import Data.String (fromString)
21+import Data.List (permutations)
22+import Traced
23+
24+-- | Server that echoes messages straight back to the origin endpoint.
25+echoServer :: EndPoint -> IO ()
26+echoServer endpoint = do
27+ go Map.empty
28+ where
29+ go :: Map ConnectionId Connection -> IO ()
30+ go cs = do
31+ event <- receive endpoint
32+ case event of
33+ ConnectionOpened cid rel addr -> do
34+ tlog $ "Opened new connection " ++ show cid
35+ Right conn <- connect endpoint addr rel defaultConnectHints
36+ go (Map.insert cid conn cs)
37+ Received cid payload -> do
38+ send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
39+ go cs
40+ ConnectionClosed cid -> do
41+ tlog $ "Close connection " ++ show cid
42+ close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
43+ go (Map.delete cid cs)
44+ ReceivedMulticast _ _ ->
45+ -- Ignore
46+ go cs
47+ ErrorEvent _ ->
48+ putStrLn $ "Echo server received error event: " ++ show event
49+ EndPointClosed ->
50+ return ()
51+
52+-- | Ping client used in a few tests
53+ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
54+ping endpoint server numPings msg = do
55+ -- Open connection to the server
56+ tlog "Connect to echo server"
57+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
58+
59+ -- Wait for the server to open reply connection
60+ tlog "Wait for ConnectionOpened message"
61+ ConnectionOpened cid _ _ <- receive endpoint
62+
63+ -- Send pings and wait for reply
64+ tlog "Send ping and wait for reply"
65+ replicateM_ numPings $ do
66+ send conn [msg]
67+ Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg
68+ return ()
69+
70+ -- Close the connection
71+ tlog "Close the connection"
72+ close conn
73+
74+ -- Wait for the server to close its connection to us
75+ tlog "Wait for ConnectionClosed message"
76+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
77+
78+ -- Done
79+ tlog "Ping client done"
80+
81+-- | Basic ping test
82+testPingPong :: Transport -> Int -> IO ()
83+testPingPong transport numPings = do
84+ tlog "Starting ping pong test"
85+ server <- spawn transport echoServer
86+ result <- newEmptyMVar
87+
88+ -- Client
89+ forkTry $ do
90+ tlog "Ping client"
91+ Right endpoint <- newEndPoint transport
92+ ping endpoint server numPings "ping"
93+ putMVar result ()
94+
95+ takeMVar result
96+
97+-- | Test that endpoints don't get confused
98+testEndPoints :: Transport -> Int -> IO ()
99+testEndPoints transport numPings = do
100+ server <- spawn transport echoServer
101+ dones <- replicateM 2 newEmptyMVar
102+
103+ forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
104+ let name' :: ByteString
105+ name' = pack [name]
106+ Right endpoint <- newEndPoint transport
107+ tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)
108+ ping endpoint server numPings name'
109+ putMVar done ()
110+
111+ forM_ dones takeMVar
112+
113+-- Test that connections don't get confused
114+testConnections :: Transport -> Int -> IO ()
115+testConnections transport numPings = do
116+ server <- spawn transport echoServer
117+ result <- newEmptyMVar
118+
119+ -- Client
120+ forkTry $ do
121+ Right endpoint <- newEndPoint transport
122+
123+ -- Open two connections to the server
124+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
125+ ConnectionOpened serv1 _ _ <- receive endpoint
126+
127+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
128+ ConnectionOpened serv2 _ _ <- receive endpoint
129+
130+ -- One thread to send "pingA" on the first connection
131+ forkTry $ replicateM_ numPings $ send conn1 ["pingA"]
132+
133+ -- One thread to send "pingB" on the second connection
134+ forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
135+
136+ -- Verify server responses
137+ let verifyResponse 0 = putMVar result ()
138+ verifyResponse n = do
139+ event <- receive endpoint
140+ case event of
141+ Received cid [payload] -> do
142+ when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
143+ when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
144+ verifyResponse (n - 1)
145+ _ ->
146+ verifyResponse n
147+ verifyResponse (2 * numPings)
148+
149+ takeMVar result
150+
151+-- | Test that closing one connection does not close the other
152+testCloseOneConnection :: Transport -> Int -> IO ()
153+testCloseOneConnection transport numPings = do
154+ server <- spawn transport echoServer
155+ result <- newEmptyMVar
156+
157+ -- Client
158+ forkTry $ do
159+ Right endpoint <- newEndPoint transport
160+
161+ -- Open two connections to the server
162+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
163+ ConnectionOpened serv1 _ _ <- receive endpoint
164+
165+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
166+ ConnectionOpened serv2 _ _ <- receive endpoint
167+
168+ -- One thread to send "pingA" on the first connection
169+ forkTry $ do
170+ replicateM_ numPings $ send conn1 ["pingA"]
171+ close conn1
172+
173+ -- One thread to send "pingB" on the second connection
174+ forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
175+
176+ -- Verify server responses
177+ let verifyResponse 0 = putMVar result ()
178+ verifyResponse n = do
179+ event <- receive endpoint
180+ case event of
181+ Received cid [payload] -> do
182+ when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
183+ when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
184+ verifyResponse (n - 1)
185+ _ ->
186+ verifyResponse n
187+ verifyResponse (3 * numPings)
188+
189+ takeMVar result
190+
191+-- | Test that if A connects to B and B connects to A, B can still send to A after
192+-- A closes its connection to B (for instance, in the TCP transport, the socket pair
193+-- connecting A and B should not yet be closed).
194+testCloseOneDirection :: Transport -> Int -> IO ()
195+testCloseOneDirection transport numPings = do
196+ addrA <- newEmptyMVar
197+ addrB <- newEmptyMVar
198+ doneA <- newEmptyMVar
199+ doneB <- newEmptyMVar
200+
201+ -- A
202+ forkTry $ do
203+ tlog "A"
204+ Right endpoint <- newEndPoint transport
205+ tlog (show (address endpoint))
206+ putMVar addrA (address endpoint)
207+
208+ -- Connect to B
209+ tlog "Connect to B"
210+ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
211+
212+ -- Wait for B to connect to us
213+ tlog "Wait for B"
214+ ConnectionOpened cid _ _ <- receive endpoint
215+
216+ -- Send pings to B
217+ tlog "Send pings to B"
218+ replicateM_ numPings $ send conn ["ping"]
219+
220+ -- Close our connection to B
221+ tlog "Close connection"
222+ close conn
223+
224+ -- Wait for B's pongs
225+ tlog "Wait for pongs from B"
226+ replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
227+
228+ -- Wait for B to close it's connection to us
229+ tlog "Wait for B to close connection"
230+ ConnectionClosed cid' <- receive endpoint
231+ guard (cid == cid')
232+
233+ -- Done
234+ tlog "Done"
235+ putMVar doneA ()
236+
237+ -- B
238+ forkTry $ do
239+ tlog "B"
240+ Right endpoint <- newEndPoint transport
241+ tlog (show (address endpoint))
242+ putMVar addrB (address endpoint)
243+
244+ -- Wait for A to connect
245+ tlog "Wait for A to connect"
246+ ConnectionOpened cid _ _ <- receive endpoint
247+
248+ -- Connect to A
249+ tlog "Connect to A"
250+ Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
251+
252+ -- Wait for A's pings
253+ tlog "Wait for pings from A"
254+ replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
255+
256+ -- Wait for A to close it's connection to us
257+ tlog "Wait for A to close connection"
258+ ConnectionClosed cid' <- receive endpoint
259+ guard (cid == cid')
260+
261+ -- Send pongs to A
262+ tlog "Send pongs to A"
263+ replicateM_ numPings $ send conn ["pong"]
264+
265+ -- Close our connection to A
266+ tlog "Close connection to A"
267+ close conn
268+
269+ -- Done
270+ tlog "Done"
271+ putMVar doneB ()
272+
273+ mapM_ takeMVar [doneA, doneB]
274+
275+-- | Collect events and order them by connection ID
276+collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString]])]
277+collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
278+ where
279+ -- TODO: for more serious use of this function we'd need to make these arguments strict
280+ go (Just 0) open closed = finish open closed
281+ go n open closed = do
282+ mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint
283+ case mEvent of
284+ Left _ -> finish open closed
285+ Right event -> do
286+ let n' = (\x -> x - 1) <$> n
287+ case event of
288+ ConnectionOpened cid _ _ ->
289+ go n' (Map.insert cid [] open) closed
290+ ConnectionClosed cid ->
291+ let list = Map.findWithDefault (error "Invalid ConnectionClosed") cid open in
292+ go n' (Map.delete cid open) (Map.insert cid list closed)
293+ Received cid msg ->
294+ go n' (Map.adjust (msg :) cid open) closed
295+ ReceivedMulticast _ _ ->
296+ fail "Unexpected multicast"
297+ ErrorEvent _ ->
298+ fail "Unexpected error"
299+ EndPointClosed ->
300+ fail "Unexpected endpoint closure"
301+
302+ finish open closed =
303+ if Map.null open
304+ then return . Map.toList . Map.map reverse $ closed
305+ else fail $ "Open connections: " ++ show (map fst . Map.toList $ open)
306+
307+-- | Open connection, close it, then reopen it
308+-- (In the TCP transport this means the socket will be closed, then reopened)
309+--
310+-- Note that B cannot expect to receive all of A's messages on the first connection
311+-- before receiving the messages on the second connection. What might (and sometimes
312+-- does) happen is that finishes sending all of its messages on the first connection
313+-- (in the TCP transport, the first socket pair) while B is behind on reading _from_
314+-- this connection (socket pair) -- the messages are "in transit" on the network
315+-- (these tests are done on localhost, so there are in some OS buffer). Then when
316+-- A opens the second connection (socket pair) B will spawn a new thread for this
317+-- connection, and hence might start interleaving messages from the first and second
318+-- connection.
319+--
320+-- This is correct behaviour, however: the transport API guarantees reliability and
321+-- ordering _per connection_, but not _across_ connections.
322+testCloseReopen :: Transport -> Int -> IO ()
323+testCloseReopen transport numPings = do
324+ addrB <- newEmptyMVar
325+ doneB <- newEmptyMVar
326+
327+ let numRepeats = 2 :: Int
328+
329+ -- A
330+ forkTry $ do
331+ Right endpoint <- newEndPoint transport
332+
333+ forM_ [1 .. numRepeats] $ \i -> do
334+ tlog "A connecting"
335+ -- Connect to B
336+ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
337+
338+ tlog "A pinging"
339+ -- Say hi
340+ forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]
341+
342+ tlog "A closing"
343+ -- Disconnect again
344+ close conn
345+
346+ tlog "A finishing"
347+
348+ -- B
349+ forkTry $ do
350+ Right endpoint <- newEndPoint transport
351+ putMVar addrB (address endpoint)
352+
353+ eventss <- collect endpoint (Just (numRepeats * (numPings + 2))) Nothing
354+
355+ forM_ (zip [1 .. numRepeats] eventss) $ \(i, (_, events)) -> do
356+ forM_ (zip [1 .. numPings] events) $ \(j, event) -> do
357+ guard (event == [pack $ "ping" ++ show i ++ "/" ++ show j])
358+
359+ putMVar doneB ()
360+
361+ takeMVar doneB
362+
363+-- | Test lots of parallel connection attempts
364+testParallelConnects :: Transport -> Int -> IO ()
365+testParallelConnects transport numPings = do
366+ server <- spawn transport echoServer
367+ done <- newEmptyMVar
368+
369+ Right endpoint <- newEndPoint transport
370+
371+ -- Spawn lots of clients
372+ forM_ [1 .. numPings] $ \i -> forkTry $ do
373+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
374+ send conn [pack $ "ping" ++ show i]
375+ send conn [pack $ "ping" ++ show i]
376+ close conn
377+
378+ forkTry $ do
379+ eventss <- collect endpoint (Just (numPings * 4)) Nothing
380+ -- Check that no pings got sent to the wrong connection
381+ forM_ eventss $ \(_, [[ping1], [ping2]]) ->
382+ guard (ping1 == ping2)
383+ putMVar done ()
384+
385+ takeMVar done
386+
387+-- | Test that sending on a closed connection gives an error
388+testSendAfterClose :: Transport -> Int -> IO ()
389+testSendAfterClose transport numRepeats = do
390+ server <- spawn transport echoServer
391+ clientDone <- newEmptyMVar
392+
393+ forkTry $ do
394+ Right endpoint <- newEndPoint transport
395+
396+ -- We request two lightweight connections
397+ replicateM numRepeats $ do
398+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
399+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
400+
401+ -- Close the second, but leave the first open; then output on the second
402+ -- connection (i.e., on a closed connection while there is still another
403+ -- connection open)
404+ close conn2
405+ Left (TransportError SendClosed _) <- send conn2 ["ping2"]
406+
407+ -- Now close the first connection, and output on it (i.e., output while
408+ -- there are no lightweight connection at all anymore)
409+ close conn1
410+ Left (TransportError SendClosed _) <- send conn2 ["ping2"]
411+
412+ return ()
413+
414+ putMVar clientDone ()
415+
416+ takeMVar clientDone
417+
418+-- | Test that closing the same connection twice has no effect
419+testCloseTwice :: Transport -> Int -> IO ()
420+testCloseTwice transport numRepeats = do
421+ server <- spawn transport echoServer
422+ clientDone <- newEmptyMVar
423+
424+ forkTry $ do
425+ Right endpoint <- newEndPoint transport
426+
427+ replicateM numRepeats $ do
428+ -- We request two lightweight connections
429+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
430+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
431+
432+ -- Close the second one twice
433+ close conn2
434+ close conn2
435+
436+ -- Then send a message on the first and close that twice too
437+ send conn1 ["ping"]
438+ close conn1
439+
440+ -- Verify expected response from the echo server
441+ ConnectionOpened cid1 _ _ <- receive endpoint
442+ ConnectionOpened cid2 _ _ <- receive endpoint
443+ ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
444+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
445+ ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
446+
447+ return ()
448+
449+ putMVar clientDone ()
450+
451+ takeMVar clientDone
452+
453+-- | Test that we can connect an endpoint to itself
454+testConnectToSelf :: Transport -> Int -> IO ()
455+testConnectToSelf transport numPings = do
456+ done <- newEmptyMVar
457+ Right endpoint <- newEndPoint transport
458+
459+ tlog "Creating self-connection"
460+ Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
461+
462+ tlog "Talk to myself"
463+
464+ -- One thread to write to the endpoint
465+ forkTry $ do
466+ tlog $ "writing"
467+
468+ tlog $ "Sending ping"
469+ replicateM_ numPings $ send conn ["ping"]
470+
471+ tlog $ "Closing connection"
472+ close conn
473+
474+ -- And one thread to read
475+ forkTry $ do
476+ tlog $ "reading"
477+
478+ tlog "Waiting for ConnectionOpened"
479+ ConnectionOpened cid _ addr <- receive endpoint ; True <- return $ addr == address endpoint
480+
481+ tlog "Waiting for Received"
482+ replicateM_ numPings $ do
483+ Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
484+ return ()
485+
486+ tlog "Waiting for ConnectionClosed"
487+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
488+
489+ tlog "Done"
490+ putMVar done ()
491+
492+ takeMVar done
493+
494+-- | Test that we can connect an endpoint to itself multiple times
495+testConnectToSelfTwice :: Transport -> Int -> IO ()
496+testConnectToSelfTwice transport numPings = do
497+ done <- newEmptyMVar
498+ Right endpoint <- newEndPoint transport
499+
500+ tlog "Creating self-connection"
501+ Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
502+ Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
503+
504+ tlog "Talk to myself"
505+
506+ -- One thread to write to the endpoint using the first connection
507+ forkTry $ do
508+ tlog $ "writing"
509+
510+ tlog $ "Sending ping"
511+ replicateM_ numPings $ send conn1 ["pingA"]
512+
513+ tlog $ "Closing connection"
514+ close conn1
515+
516+ -- One thread to write to the endpoint using the second connection
517+ forkTry $ do
518+ tlog $ "writing"
519+
520+ tlog $ "Sending ping"
521+ replicateM_ numPings $ send conn2 ["pingB"]
522+
523+ tlog $ "Closing connection"
524+ close conn2
525+
526+ -- And one thread to read
527+ forkTry $ do
528+ tlog $ "reading"
529+
530+ [(_, events1), (_, events2)] <- collect endpoint (Just (2 * (numPings + 2))) Nothing
531+ True <- return $ events1 == replicate numPings ["pingA"]
532+ True <- return $ events2 == replicate numPings ["pingB"]
533+
534+ tlog "Done"
535+ putMVar done ()
536+
537+ takeMVar done
538+
539+-- | Test that we self-connections no longer work once we close our endpoint
540+-- or our transport
541+testCloseSelf :: IO (Either String Transport) -> IO ()
542+testCloseSelf newTransport = do
543+ Right transport <- newTransport
544+ Right endpoint1 <- newEndPoint transport
545+ Right endpoint2 <- newEndPoint transport
546+ Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
547+ Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
548+ Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
549+
550+ -- Close the conneciton and try to send
551+ close conn1
552+ Left (TransportError SendClosed _) <- send conn1 ["ping"]
553+
554+ -- Close the first endpoint. We should not be able to use the first
555+ -- connection anymore, or open more self connections, but the self connection
556+ -- to the second endpoint should still be fine
557+ closeEndPoint endpoint1
558+ Left (TransportError SendFailed _) <- send conn2 ["ping"]
559+ Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
560+ Right () <- send conn3 ["ping"]
561+
562+ -- Close the transport; now the second should no longer work
563+ closeTransport transport
564+ Left (TransportError SendFailed _) <- send conn3 ["ping"]
565+ Left (TransportError ConnectFailed _) <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
566+
567+ return ()
568+
569+-- | Test various aspects of 'closeEndPoint'
570+testCloseEndPoint :: Transport -> Int -> IO ()
571+testCloseEndPoint transport _ = do
572+ serverDone <- newEmptyMVar
573+ clientDone <- newEmptyMVar
574+ clientAddr1 <- newEmptyMVar
575+ clientAddr2 <- newEmptyMVar
576+ serverAddr <- newEmptyMVar
577+
578+ -- Server
579+ forkTry $ do
580+ Right endpoint <- newEndPoint transport
581+ putMVar serverAddr (address endpoint)
582+
583+ -- First test (see client)
584+ do
585+ theirAddr <- readMVar clientAddr1
586+ ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
587+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
588+ return ()
589+
590+ -- Second test
591+ do
592+ theirAddr <- readMVar clientAddr2
593+
594+ ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
595+ Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
596+
597+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
598+ send conn ["pong"]
599+
600+ ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''
601+ ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint ; True <- return $ addr' == theirAddr
602+
603+ Left (TransportError SendFailed _) <- send conn ["pong2"]
604+
605+ return ()
606+
607+ putMVar serverDone ()
608+
609+ -- Client
610+ forkTry $ do
611+ theirAddr <- readMVar serverAddr
612+
613+ -- First test: close endpoint with one outgoing but no incoming connections
614+ do
615+ Right endpoint <- newEndPoint transport
616+ putMVar clientAddr1 (address endpoint)
617+
618+ -- Connect to the server, then close the endpoint without disconnecting explicitly
619+ Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
620+ closeEndPoint endpoint
621+ EndPointClosed <- receive endpoint
622+ return ()
623+
624+ -- Second test: close endpoint with one outgoing and one incoming connection
625+ do
626+ Right endpoint <- newEndPoint transport
627+ putMVar clientAddr2 (address endpoint)
628+
629+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
630+ send conn ["ping"]
631+
632+ -- Reply from the server
633+ ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
634+ Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'
635+
636+ -- Close the endpoint
637+ closeEndPoint endpoint
638+ EndPointClosed <- receive endpoint
639+
640+ -- Attempt to send should fail with connection closed
641+ Left (TransportError SendFailed _) <- send conn ["ping2"]
642+
643+ -- An attempt to close the already closed connection should just return
644+ () <- close conn
645+
646+ -- And so should an attempt to connect
647+ Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
648+
649+ return ()
650+
651+ putMVar clientDone ()
652+
653+ mapM_ takeMVar [serverDone, clientDone]
654+
655+-- Test closeTransport
656+--
657+-- This tests many of the same things that testEndPoint does, and some more
658+testCloseTransport :: IO (Either String Transport) -> IO ()
659+testCloseTransport newTransport = do
660+ serverDone <- newEmptyMVar
661+ clientDone <- newEmptyMVar
662+ clientAddr1 <- newEmptyMVar
663+ clientAddr2 <- newEmptyMVar
664+ serverAddr <- newEmptyMVar
665+
666+ -- Server
667+ forkTry $ do
668+ Right transport <- newTransport
669+ Right endpoint <- newEndPoint transport
670+ putMVar serverAddr (address endpoint)
671+
672+ -- Client sets up first endpoint
673+ theirAddr1 <- readMVar clientAddr1
674+ ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
675+
676+ -- Client sets up second endpoint
677+ theirAddr2 <- readMVar clientAddr2
678+
679+ ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
680+ Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
681+
682+ Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints
683+ send conn ["pong"]
684+
685+ -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however)
686+ evs <- replicateM 3 $ receive endpoint
687+ let expected = [ ConnectionClosed cid1
688+ , ConnectionClosed cid2
689+ , ErrorEvent (TransportError (EventConnectionLost (Just theirAddr2) []) "")
690+ ]
691+ True <- return $ any (== expected) (permutations evs)
692+
693+ -- An attempt to send to the endpoint should now fail
694+ Left (TransportError SendFailed _) <- send conn ["pong2"]
695+
696+ putMVar serverDone ()
697+
698+ -- Client
699+ forkTry $ do
700+ Right transport <- newTransport
701+ theirAddr <- readMVar serverAddr
702+
703+ -- Set up endpoint with one outgoing but no incoming connections
704+ Right endpoint1 <- newEndPoint transport
705+ putMVar clientAddr1 (address endpoint1)
706+
707+ -- Connect to the server, then close the endpoint without disconnecting explicitly
708+ Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
709+
710+ -- Set up an endpoint with one outgoing and out incoming connection
711+ Right endpoint2 <- newEndPoint transport
712+ putMVar clientAddr2 (address endpoint2)
713+
714+ Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
715+ send conn ["ping"]
716+
717+ -- Reply from the server
718+ ConnectionOpened cid ReliableOrdered addr <- receive endpoint2 ; True <- return $ addr == theirAddr
719+ Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid'
720+
721+ -- Now shut down the entire transport
722+ closeTransport transport
723+
724+ -- Both endpoints should report that they have been closed
725+ EndPointClosed <- receive endpoint1
726+ EndPointClosed <- receive endpoint2
727+
728+ -- Attempt to send should fail with connection closed
729+ Left (TransportError SendFailed _) <- send conn ["ping2"]
730+
731+ -- An attempt to close the already closed connection should just return
732+ () <- close conn
733+
734+ -- And so should an attempt to connect on either endpoint
735+ Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
736+ Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
737+
738+ -- And finally, so should an attempt to create a new endpoint
739+ Left (TransportError NewEndPointFailed _) <- newEndPoint transport
740+
741+ putMVar clientDone ()
742+
743+ mapM_ takeMVar [serverDone, clientDone]
744+
745+-- | Remote node attempts to connect to a closed local endpoint
746+testConnectClosedEndPoint :: Transport -> IO ()
747+testConnectClosedEndPoint transport = do
748+ serverAddr <- newEmptyMVar
749+ serverClosed <- newEmptyMVar
750+ clientDone <- newEmptyMVar
751+
752+ -- Server
753+ forkTry $ do
754+ Right endpoint <- newEndPoint transport
755+ putMVar serverAddr (address endpoint)
756+
757+ closeEndPoint endpoint
758+ putMVar serverClosed ()
759+
760+ -- Client
761+ forkTry $ do
762+ Right endpoint <- newEndPoint transport
763+ readMVar serverClosed
764+
765+ Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
766+
767+ putMVar clientDone ()
768+
769+ takeMVar clientDone
770+
771+-- | We should receive an exception when doing a 'receive' after we have been
772+-- notified that an endpoint has been closed
773+testExceptionOnReceive :: IO (Either String Transport) -> IO ()
774+testExceptionOnReceive newTransport = do
775+ Right transport <- newTransport
776+
777+ -- Test one: when we close an endpoint specifically
778+ Right endpoint1 <- newEndPoint transport
779+ closeEndPoint endpoint1
780+ EndPointClosed <- receive endpoint1
781+ Left _ <- trySome (receive endpoint1 >>= evaluate)
782+
783+ -- Test two: when we close the entire transport
784+ Right endpoint2 <- newEndPoint transport
785+ closeTransport transport
786+ EndPointClosed <- receive endpoint2
787+ Left _ <- trySome (receive endpoint2 >>= evaluate)
788+
789+ return ()
790+
791+-- | Test what happens when the argument to 'send' is an exceptional value
792+testSendException :: IO (Either String Transport) -> IO ()
793+testSendException newTransport = do
794+ Right transport <- newTransport
795+ Right endpoint1 <- newEndPoint transport
796+ Right endpoint2 <- newEndPoint transport
797+
798+ -- Connect endpoint1 to endpoint2
799+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
800+ ConnectionOpened _ _ _ <- receive endpoint2
801+
802+ -- Send an exceptional value
803+ Left (TransportError SendFailed _) <- send conn (throw $ userError "uhoh")
804+
805+ -- This will have been as a failure to send by endpoint1, which will
806+ -- therefore have closed the socket. In turn this will have caused endpoint2
807+ -- to report that the connection was lost
808+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint1
809+ ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2
810+
811+ -- A new connection will re-establish the connection
812+ Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
813+ send conn2 ["ping"]
814+ close conn2
815+
816+ ConnectionOpened _ _ _ <- receive endpoint2
817+ Received _ ["ping"] <- receive endpoint2
818+ ConnectionClosed _ <- receive endpoint2
819+
820+ return ()
821+
822+-- | If threads get killed while executing a 'connect', 'send', or 'close', this
823+-- should not affect other threads.
824+--
825+-- The intention of this test is to see what happens when a asynchronous
826+-- exception happes _while executing a send_. This is exceedingly difficult to
827+-- guarantee, however. Hence we run a large number of tests and insert random
828+-- thread delays -- and even then it might not happen. Moreover, it will only
829+-- happen when we run on multiple cores.
830+testKill :: IO (Either String Transport) -> Int -> IO ()
831+testKill newTransport numThreads = do
832+ Right transport1 <- newTransport
833+ Right transport2 <- newTransport
834+ Right endpoint1 <- newEndPoint transport1
835+ Right endpoint2 <- newEndPoint transport2
836+
837+ threads <- replicateM numThreads . forkIO $ do
838+ randomThreadDelay 100
839+ bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)
840+ -- Note that we should not insert a randomThreadDelay into the
841+ -- exception handler itself as this means that the exception handler
842+ -- could be interrupted and we might not close
843+ (\(Right conn) -> close conn)
844+ (\(Right conn) -> do randomThreadDelay 100
845+ Right () <- send conn ["ping"]
846+ randomThreadDelay 100)
847+
848+ numAlive <- newMVar (0 :: Int)
849+
850+ -- Kill half of those threads
851+ forkIO . forM_ threads $ \tid -> do
852+ shouldKill <- randomIO
853+ if shouldKill
854+ then randomThreadDelay 600 >> killThread tid
855+ else modifyMVar_ numAlive (return . (+ 1))
856+
857+ -- Since it is impossible to predict when the kill exactly happens, we don't
858+ -- know how many connects were opened and how many pings were sent. But we
859+ -- should not have any open connections (if we do, collect will throw an
860+ -- error) and we should have at least the number of pings equal to the number
861+ -- of threads we did *not* kill
862+ eventss <- collect endpoint2 Nothing (Just 1000000)
863+ let actualPings = sum . map (length . snd) $ eventss
864+ expectedPings <- takeMVar numAlive
865+ unless (actualPings >= expectedPings) $
866+ throwIO (userError "Missing pings")
867+
868+-- print (actualPings, expectedPings)
869+
870+
871+-- | Set up conditions with a high likelyhood of "crossing" (for transports
872+-- that multiplex lightweight connections across heavyweight connections)
873+testCrossing :: Transport -> Int -> IO ()
874+testCrossing transport numRepeats = do
875+ [aAddr, bAddr] <- replicateM 2 newEmptyMVar
876+ [aDone, bDone] <- replicateM 2 newEmptyMVar
877+ [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar
878+ go <- newEmptyMVar
879+
880+ let hints = defaultConnectHints {
881+ connectTimeout = Just 5000000
882+ }
883+
884+ -- A
885+ forkTry $ do
886+ Right endpoint <- newEndPoint transport
887+ putMVar aAddr (address endpoint)
888+ theirAddress <- readMVar bAddr
889+
890+ replicateM_ numRepeats $ do
891+ takeMVar go >> yield
892+ -- Because we are creating lots of connections, it's possible that
893+ -- connect times out (for instance, in the TCP transport,
894+ -- Network.Socket.connect may time out). We shouldn't regard this as an
895+ -- error in the Transport, though.
896+ connectResult <- connect endpoint theirAddress ReliableOrdered hints
897+ case connectResult of
898+ Right conn -> close conn
899+ Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()
900+ Left (TransportError ConnectFailed _) -> readMVar bTimeout
901+ Left err -> throwIO . userError $ "testCrossed: " ++ show err
902+ putMVar aDone ()
903+
904+ -- B
905+ forkTry $ do
906+ Right endpoint <- newEndPoint transport
907+ putMVar bAddr (address endpoint)
908+ theirAddress <- readMVar aAddr
909+
910+ replicateM_ numRepeats $ do
911+ takeMVar go >> yield
912+ connectResult <- connect endpoint theirAddress ReliableOrdered hints
913+ case connectResult of
914+ Right conn -> close conn
915+ Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
916+ Left (TransportError ConnectFailed _) -> readMVar aTimeout
917+ Left err -> throwIO . userError $ "testCrossed: " ++ show err
918+ putMVar bDone ()
919+
920+ -- Driver
921+ forM_ [1 .. numRepeats] $ \_i -> do
922+ -- putStrLn $ "Round " ++ show _i
923+ tryTakeMVar aTimeout
924+ tryTakeMVar bTimeout
925+ putMVar go ()
926+ putMVar go ()
927+ takeMVar aDone
928+ takeMVar bDone
929+
930+-- Transport tests
931+testTransport :: IO (Either String Transport) -> IO ()
932+testTransport newTransport = do
933+ Right transport <- newTransport
934+ runTests
935+ [ ("PingPong", testPingPong transport numPings)
936+ , ("EndPoints", testEndPoints transport numPings)
937+ , ("Connections", testConnections transport numPings)
938+ , ("CloseOneConnection", testCloseOneConnection transport numPings)
939+ , ("CloseOneDirection", testCloseOneDirection transport numPings)
940+ , ("CloseReopen", testCloseReopen transport numPings)
941+ , ("ParallelConnects", testParallelConnects transport numPings)
942+ , ("SendAfterClose", testSendAfterClose transport 1000)
943+ , ("Crossing", testCrossing transport 100)
944+ , ("CloseTwice", testCloseTwice transport 100)
945+ , ("ConnectToSelf", testConnectToSelf transport numPings)
946+ , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
947+ , ("CloseSelf", testCloseSelf newTransport)
948+ , ("CloseEndPoint", testCloseEndPoint transport numPings)
949+ , ("CloseTransport", testCloseTransport newTransport)
950+ , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
951+ , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
952+ , ("SendException", testSendException newTransport)
953+ , ("Kill", testKill newTransport 10000)
954+ ]
955+ where
956+ numPings = 10000 :: Int
network-transport-inmemory/tests/Traced.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, throwIO, Exception(..), IOException)
56+import Control.Applicative ((<$>))
57+import Data.Typeable (Typeable)
58+import Data.Maybe (catMaybes)
59+import Data.ByteString (ByteString)
60+import Data.Int (Int32)
61+import Control.Concurrent.MVar (MVar)
62+
63+--------------------------------------------------------------------------------
64+-- MonadS class --
65+--------------------------------------------------------------------------------
66+
67+-- | Like 'Monad' but bind is only defined for 'Trace'able instances
68+class MonadS m where
69+ returnS :: a -> m a
70+ bindS :: Traceable a => m a -> (a -> m b) -> m b
71+ failS :: String -> m a
72+ seqS :: m a -> m b -> m b
73+
74+-- | Redefinition of 'Prelude.>>='
75+(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
76+(>>=) = bindS
77+
78+-- | Redefinition of 'Prelude.>>'
79+(>>) :: MonadS m => m a -> m b -> m b
80+(>>) = seqS
81+
82+-- | Redefinition of 'Prelude.return'
83+return :: MonadS m => a -> m a
84+return = returnS
85+
86+-- | Redefinition of 'Prelude.fail'
87+fail :: MonadS m => String -> m a
88+fail = failS
89+
90+--------------------------------------------------------------------------------
91+-- Trace typeclass (for adding elements to a trace --
92+--------------------------------------------------------------------------------
93+
94+data Showable = forall a. Show a => Showable a
95+
96+instance Show Showable where
97+ show (Showable x) = show x
98+
99+mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
100+mapShowable f (Showable x) = f x
101+
102+traceShow :: Show a => a -> Maybe Showable
103+traceShow = Just . Showable
104+
105+class Traceable a where
106+ trace :: a -> Maybe Showable
107+
108+instance (Traceable a, Traceable b) => Traceable (Either a b) where
109+ trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
110+ trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
111+
112+instance (Traceable a, Traceable b) => Traceable (a, b) where
113+ trace (x, y) = case (trace x, trace y) of
114+ (Nothing, Nothing) -> Nothing
115+ (Just t1, Nothing) -> traceShow t1
116+ (Nothing, Just t2) -> traceShow t2
117+ (Just t1, Just t2) -> traceShow (t1, t2)
118+
119+instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
120+ trace (x, y, z) = case (trace x, trace y, trace z) of
121+ (Nothing, Nothing, Nothing) -> Nothing
122+ (Just t1, Nothing, Nothing) -> traceShow t1
123+ (Nothing, Just t2, Nothing) -> traceShow t2
124+ (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
125+ (Nothing, Nothing, Just t3) -> traceShow t3
126+ (Just t1, Nothing, Just t3) -> traceShow (t1, t3)
127+ (Nothing, Just t2, Just t3) -> traceShow (t2, t3)
128+ (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
129+
130+instance Traceable a => Traceable (Maybe a) where
131+ trace Nothing = traceShow (Nothing :: Maybe ())
132+ trace (Just x) = mapShowable (Showable . Just) <$> trace x
133+
134+instance Traceable a => Traceable [a] where
135+ trace = traceShow . catMaybes . map trace
136+
137+instance Traceable () where
138+ trace = const Nothing
139+
140+instance Traceable Int where
141+ trace = traceShow
142+
143+instance Traceable Int32 where
144+ trace = traceShow
145+
146+instance Traceable Bool where
147+ trace = const Nothing
148+
149+instance Traceable ByteString where
150+ trace = traceShow
151+
152+instance Traceable (MVar a) where
153+ trace = const Nothing
154+
155+instance Traceable [Char] where
156+ trace = traceShow
157+
158+instance Traceable IOException where
159+ trace = traceShow
160+
161+--------------------------------------------------------------------------------
162+-- IO instance for MonadS --
163+--------------------------------------------------------------------------------
164+
165+data TracedException = TracedException [String] SomeException
166+ deriving Typeable
167+
168+instance Exception TracedException
169+
170+-- | Add tracing to 'IO' (see examples)
171+instance MonadS IO where
172+ returnS = Prelude.return
173+ bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
174+ failS = Prelude.fail
175+ seqS = (Prelude.>>)
176+
177+instance Show TracedException where
178+ show (TracedException ts ex) =
179+ show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))
180+
181+traceHandlers :: Traceable a => a -> [Handler b]
182+traceHandlers a = case trace a of
183+ Nothing -> [ Handler $ \ex -> throwIO (ex :: SomeException) ]
184+ Just t -> [ Handler $ \(TracedException ts ex) -> throwIO $ TracedException (show t : ts) ex
185+ , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)
186+ ]
187+
188+-- | Definition of 'ifThenElse' for use with RebindableSyntax
189+ifThenElse :: Bool -> a -> a -> a
190+ifThenElse True x _ = x
191+ifThenElse False _ y = y
network-transport-pipes/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Ryan Newton, 2011
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of the owner nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
network-transport-pipes/network-transport-pipes.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-tcp/ChangeLognew file+3
@@ -0,0 +1,3 @@
1+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0
2+
3+* Initial release.
network-transport-tcp/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Well-Typed LLP, 2011-2012
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of the owner nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
network-transport-tcp/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
network-transport-tcp/network-transport-tcp.cabalnew file+54
@@ -0,0 +1,54 @@
1+Name: network-transport-tcp
2+Version: 0.2.0
3+Cabal-Version: >=1.8
4+Build-Type: Simple
5+License: BSD3
6+License-file: LICENSE
7+Copyright: Well-Typed LLP
8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
10+Stability: experimental
11+Homepage: http://github.com/haskell-distributed/distributed-process
12+Bug-Reports: mailto:edsko@well-typed.com
13+Synopsis: TCP instantation of Network.Transport
14+Description: TCP instantation of Network.Transport
15+Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
16+Category: Network
17+
18+Source-Repository head
19+ Type: git
20+ Location: https://github.com/haskell-distributed/distributed-process
21+ SubDir: network-transport-tcp
22+
23+Library
24+ Build-Depends: base >= 4.3 && < 5,
25+ network-transport >= 0.2 && < 0.3,
26+ data-accessor >= 0.2 && < 0.3,
27+ containers >= 0.4 && < 0.5,
28+ bytestring >= 0.9 && < 0.10,
29+ network >= 2.3 && < 2.4
30+ Exposed-modules: Network.Transport.TCP,
31+ Network.Transport.TCP.Internal
32+ ghc-options: -Wall -fno-warn-unused-do-bind
33+ HS-Source-Dirs: src
34+
35+Test-Suite TestTCP
36+ Type: exitcode-stdio-1.0
37+ Main-Is: TestTCP.hs
38+ Build-Depends: base >= 4.3 && < 5,
39+ network-transport >= 0.2 && < 0.3,
40+ data-accessor >= 0.2 && < 0.3,
41+ containers >= 0.4 && < 0.5,
42+ bytestring >= 0.9 && < 0.10,
43+ network >= 2.3 && < 2.4,
44+ random >= 1.0 && < 1.1,
45+ ansi-terminal >= 0.5 && < 0.6,
46+ mtl >= 2.0 && < 2.2
47+ ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
48+ Extensions: ExistentialQuantification,
49+ FlexibleInstances,
50+ DeriveDataTypeable,
51+ RankNTypes,
52+ OverlappingInstances,
53+ OverloadedStrings
54+ HS-Source-Dirs: tests src
network-transport-tcp/src/Network/Transport/TCP.hsnew file+1649
@@ -0,0 +1,1649 @@
1+-- | TCP implementation of the transport layer.
2+--
3+-- The TCP implementation guarantees that only a single TCP connection (socket)
4+-- will be used between endpoints, provided that the addresses specified are
5+-- canonical. If /A/ connects to /B/ and reports its address as
6+-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as
7+-- @client1.local:http-alt@ then the transport layer will not realize that the
8+-- TCP connection can be reused.
9+--
10+-- Applications that use the TCP transport should use
11+-- 'Network.Socket.withSocketsDo' in their main function for Windows
12+-- compatibility (see "Network.Socket").
13+module Network.Transport.TCP ( -- * Main API
14+ createTransport
15+ , TCPParameters(..)
16+ , defaultTCPParameters
17+ -- * Internals (exposed for unit tests)
18+ , createTransportExposeInternals
19+ , TransportInternals(..)
20+ , EndPointId
21+ , encodeEndPointAddress
22+ , decodeEndPointAddress
23+ , ControlHeader(..)
24+ , ConnectionRequestResponse(..)
25+ , firstNonReservedConnectionId
26+ , socketToEndPoint
27+ -- * Design notes
28+ -- $design
29+ ) where
30+
31+import Prelude hiding (catch, mapM_)
32+import Network.Transport
33+import Network.Transport.TCP.Internal ( forkServer
34+ , recvWithLength
35+ , recvInt32
36+ , tryCloseSocket
37+ )
38+import Network.Transport.Internal ( encodeInt32
39+ , decodeInt32
40+ , prependLength
41+ , mapIOException
42+ , tryIO
43+ , tryToEnum
44+ , void
45+ , timeoutMaybe
46+ , asyncWhenCancelled
47+ )
48+import qualified Network.Socket as N ( HostName
49+ , ServiceName
50+ , Socket
51+ , getAddrInfo
52+ , socket
53+ , addrFamily
54+ , addrAddress
55+ , SocketType(Stream)
56+ , defaultProtocol
57+ , setSocketOption
58+ , SocketOption(ReuseAddr)
59+ , connect
60+ , sOMAXCONN
61+ , AddrInfo
62+ )
63+import Network.Socket.ByteString (sendMany)
64+import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
65+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
66+import Control.Concurrent.MVar ( MVar
67+ , newMVar
68+ , modifyMVar
69+ , modifyMVar_
70+ , readMVar
71+ , takeMVar
72+ , putMVar
73+ , newEmptyMVar
74+ , withMVar
75+ )
76+import Control.Category ((>>>))
77+import Control.Applicative ((<$>))
78+import Control.Monad (when, unless)
79+import Control.Exception ( IOException
80+ , SomeException
81+ , AsyncException
82+ , handle
83+ , throw
84+ , throwIO
85+ , try
86+ , bracketOnError
87+ , mask
88+ , onException
89+ , fromException
90+ )
91+import Data.IORef (IORef, newIORef, writeIORef, readIORef)
92+import Data.ByteString (ByteString)
93+import qualified Data.ByteString as BS (concat)
94+import qualified Data.ByteString.Char8 as BSC (pack, unpack, split)
95+import Data.Int (Int32)
96+import Data.IntMap (IntMap)
97+import qualified Data.IntMap as IntMap (empty)
98+import Data.IntSet (IntSet)
99+import qualified Data.IntSet as IntSet ( empty
100+ , insert
101+ , elems
102+ , singleton
103+ , null
104+ , delete
105+ , member
106+ )
107+import Data.Map (Map)
108+import qualified Data.Map as Map (empty)
109+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
110+import qualified Data.Accessor.Container as DAC (mapMaybe, intMapMaybe)
111+import Data.Foldable (forM_, mapM_)
112+
113+-- $design
114+--
115+-- [Goals]
116+--
117+-- The TCP transport maps multiple logical connections between /A/ and /B/ (in
118+-- either direction) to a single TCP connection:
119+--
120+-- > +-------+ +-------+
121+-- > | A |==========================| B |
122+-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
123+-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q |
124+-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
125+-- > | |==========================| |
126+-- > +-------+ +-------+
127+--
128+-- Ignoring the complications detailed below, the TCP connection is set up is
129+-- when the first lightweight connection is created (in either direction), and
130+-- torn down when the last lightweight connection (in either direction) is
131+-- closed.
132+--
133+-- [Connecting]
134+--
135+-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to
136+-- connect to /B/, it locally records that it is trying to connect to /B/ and
137+-- sends a request to /B/. As part of the request /A/ sends its own endpoint
138+-- address to /B/ (so that /B/ can reuse the connection in the other direction).
139+--
140+-- When /B/ receives the connection request it first checks if it did not
141+-- already initiate a connection request to /A/. If not it will acknowledge the
142+-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record
143+-- that it has a TCP connection to /A/.
144+--
145+-- The tricky case arises when /A/ sends a connection request to /B/ and /B/
146+-- finds that it had already sent a connection request to /A/. In this case /B/
147+-- will accept the connection request from /A/ if /A/s endpoint address is
148+-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects
149+-- it, it sends a 'ConnectionRequestCrossed' message to /A/. (The
150+-- lexicographical ordering is an arbitrary but convenient way to break the
151+-- tie.)
152+--
153+-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that
154+-- initiated the request just needs to wait until the /A/ thread that is dealing
155+-- with /B/'s connection request completes.
156+--
157+-- [Disconnecting]
158+--
159+-- The TCP connection is created as soon as the first logical connection from
160+-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
161+-- spawned that listens for incoming connections from /B/:
162+--
163+-- > +-------+ +-------+
164+-- > | A |==========================| B |
165+-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ |
166+-- > | | | Q |
167+-- > | #| | |
168+-- > | |==========================| |
169+-- > +-------+ +-------+
170+--
171+-- The question is when the TCP connection can be closed again. Conceptually,
172+-- we want to do reference counting: when there are no logical connections left
173+-- between /A/ and /B/ we want to close the socket (possibly after some
174+-- timeout).
175+--
176+-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
177+-- might happen that /B/ sends a connection request over the existing socket at
178+-- the same time that /A/ closes its logical connection to /B/ and closes the
179+-- socket. This will cause a failure in /B/ (which will have to retry) which is
180+-- not caused by a network failure, which is unfortunate. (Note that the
181+-- connection request from /B/ might succeed even if /A/ closes the socket.)
182+--
183+-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
184+-- request to /B/ and records that its connection to /B/ is closing. If /A/
185+-- receives a new connection request from /B/ after having sent the
186+-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
187+-- and increments the reference count of the connection again.
188+--
189+-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
190+-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
191+-- and then actually close the socket. /A/ meanwhile will not send any more
192+-- requests to /B/ after having sent a 'CloseSocket' request, and will actually
193+-- close its end of the socket only when receiving the 'CloseSocket' message
194+-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
195+-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
196+-- reciprocal 'CloseSocket' message.)
197+--
198+-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
199+-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
200+-- whether to reuse the old socket (if /B/ sends a new connection request
201+-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
202+
203+--------------------------------------------------------------------------------
204+-- Internal datatypes --
205+--------------------------------------------------------------------------------
206+
207+-- We use underscores for fields that we might update (using accessors)
208+--
209+-- All data types follow the same structure:
210+--
211+-- * A top-level data type describing static properties (TCPTransport,
212+-- LocalEndPoint, RemoteEndPoint)
213+-- * The 'static' properties include an MVar containing a data structure for
214+-- the dynamic properties (TransportState, LocalEndPointState,
215+-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
216+-- * For the case of "valid" we use third data structure to give more details
217+-- about the state (ValidTransportState, ValidLocalEndPointState,
218+-- ValidRemoteEndPointState).
219+
220+data TCPTransport = TCPTransport
221+ { transportHost :: N.HostName
222+ , transportPort :: N.ServiceName
223+ , transportState :: MVar TransportState
224+ , transportParams :: TCPParameters
225+ }
226+
227+data TransportState =
228+ TransportValid ValidTransportState
229+ | TransportClosed
230+
231+data ValidTransportState = ValidTransportState
232+ { _localEndPoints :: Map EndPointAddress LocalEndPoint
233+ , _nextEndPointId :: EndPointId
234+ }
235+
236+data LocalEndPoint = LocalEndPoint
237+ { localAddress :: EndPointAddress
238+ , localChannel :: Chan Event
239+ , localState :: MVar LocalEndPointState
240+ }
241+
242+data LocalEndPointState =
243+ LocalEndPointValid ValidLocalEndPointState
244+ | LocalEndPointClosed
245+
246+data ValidLocalEndPointState = ValidLocalEndPointState
247+ { _nextConnectionId :: !ConnectionId
248+ , _localConnections :: Map EndPointAddress RemoteEndPoint
249+ , _nextRemoteId :: !Int
250+ }
251+
252+-- REMOTE ENDPOINTS
253+--
254+-- Remote endpoints (basically, TCP connections) have the following lifecycle:
255+--
256+-- Init ---+---> Invalid
257+-- |
258+-- +-------------------------------\
259+-- | |
260+-- | /----------\ |
261+-- | | | |
262+-- | v | v
263+-- +---> Valid ---> Closing ---> Closed
264+-- | | | |
265+-- | | | v
266+-- \-------+----------+--------> Failed
267+--
268+-- Init: There are two places where we create new remote endpoints: in
269+-- requestConnectionTo (in response to an API 'connect' call) and in
270+-- handleConnectionRequest (when a remote node tries to connect to us).
271+-- 'Init' carries an MVar () 'resolved' which concurrent threads can use to
272+-- wait for the remote endpoint to finish initialization. We record who
273+-- requested the connection (the local endpoint or the remote endpoint).
274+--
275+-- Invalid: We put the remote endpoint in invalid state only during
276+-- requestConnectionTo when we fail to connect.
277+--
278+-- Valid: This is the "normal" state for a working remote endpoint.
279+--
280+-- Closing: When we detect that a remote endpoint is no longer used, we send a
281+-- CloseSocket request across the connection and put the remote endpoint in
282+-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which
283+-- concurrent threads can use to wait for the remote endpoint to either be
284+-- closed fully (if the communication parnet responds with another
285+-- CloseSocket) or be put back in 'Valid' state if the remote endpoint denies
286+-- the request.
287+--
288+-- We also put the endpoint in Closed state, directly from Init, if we our
289+-- outbound connection request crossed an inbound connection request and we
290+-- decide to keep the inbound (i.e., the remote endpoint sent us a
291+-- ConnectionRequestCrossed message).
292+--
293+-- Closed: The endpoint is put in Closed state after a successful garbage
294+-- collection.
295+--
296+-- Failed: If the connection to the remote endpoint is lost, or the local
297+-- endpoint (or the whole transport) is closed manually, the remote endpoint is
298+-- put in Failed state, and we record the reason.
299+--
300+-- Invariants for dealing with remote endpoints:
301+--
302+-- INV-SEND: Whenever we send data the remote endpoint must be locked (to avoid
303+-- interleaving bits of payload).
304+--
305+-- INV-CLOSE: Local endpoints should never point to remote endpoint in closed
306+-- state. Whenever we put an endpoint in Closed state we remove that
307+-- endpoint from localConnections first, so that if a concurrent thread reads
308+-- the MVar, finds RemoteEndPointClosed, and then looks up the endpoint in
309+-- localConnections it is guaranteed to either find a different remote
310+-- endpoint, or else none at all (if we don't insist in this order some
311+-- threads might start spinning).
312+--
313+-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is
314+-- locked, and the remote endpoint must be in Valid or Closed state once
315+-- unlocked. This guarantees that there will not be two threads attempting to
316+-- both signal on 'resolved'.
317+--
318+-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we
319+-- first put the remote endpoint in Closed state, and then send a
320+-- EventConnectionLost event. This guarantees that we only send this event
321+-- once.
322+--
323+-- INV-CLOSING: An endpoint in closing state is for all intents and purposes
324+-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
325+-- acceptable, of course -- as we are waiting for the remote endpoint to
326+-- confirm or deny the request).
327+--
328+-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints.
329+-- In other words: it is okay to call modifyMVar on a local endpoint inside a
330+-- modifyMVar on a remote endpoint, but not the other way around. In
331+-- particular, it is okay to call removeRemoteEndPoint inside
332+-- modifyRemoteState.
333+
334+data RemoteEndPoint = RemoteEndPoint
335+ { remoteAddress :: EndPointAddress
336+ , remoteState :: MVar RemoteState
337+ , remoteId :: Int
338+ }
339+
340+data RequestedBy = RequestedByUs | RequestedByThem
341+ deriving (Eq, Show)
342+
343+data RemoteState =
344+ -- | Invalid remote endpoint (for example, invalid address)
345+ RemoteEndPointInvalid (TransportError ConnectErrorCode)
346+ -- | The remote endpoint is being initialized
347+ | RemoteEndPointInit (MVar ()) RequestedBy
348+ -- | "Normal" working endpoint
349+ | RemoteEndPointValid ValidRemoteEndPointState
350+ -- | The remote endpoint is being closed (garbage collected)
351+ | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
352+ -- | The remote endpoint has been closed (garbage collected)
353+ | RemoteEndPointClosed
354+ -- | The remote endpoint has failed, or has been forcefully shutdown
355+ -- using a closeTransport or closeEndPoint API call
356+ | RemoteEndPointFailed IOException
357+
358+data ValidRemoteEndPointState = ValidRemoteEndPointState
359+ { _remoteOutgoing :: !Int
360+ , _remoteIncoming :: IntSet
361+ , remoteSocket :: N.Socket
362+ , sendOn :: [ByteString] -> IO ()
363+ , _pendingCtrlRequests :: IntMap (MVar (Either IOException [ByteString]))
364+ , _nextCtrlRequestId :: !ControlRequestId
365+ }
366+
367+-- | Local identifier for an endpoint within this transport
368+type EndPointId = Int32
369+
370+-- | Control request ID
371+--
372+-- Control requests are asynchronous; the request ID makes it possible to match
373+-- requests and replies
374+type ControlRequestId = Int32
375+
376+-- | Pair of local and a remote endpoint (for conciseness in signatures)
377+type EndPointPair = (LocalEndPoint, RemoteEndPoint)
378+
379+-- | Control headers
380+data ControlHeader =
381+ -- | Request a new connection ID from the remote endpoint
382+ RequestConnectionId
383+ -- | Tell the remote endpoint we will no longer be using a connection
384+ | CloseConnection
385+ -- | Respond to a control request /from/ the remote endpoint
386+ | ControlResponse
387+ -- | Request to close the connection (see module description)
388+ | CloseSocket
389+ deriving (Enum, Bounded, Show)
390+
391+-- | Response sent by /B/ to /A/ when /A/ tries to connect
392+data ConnectionRequestResponse =
393+ -- | /B/ accepts the connection
394+ ConnectionRequestAccepted
395+ -- | /A/ requested an invalid endpoint
396+ | ConnectionRequestInvalid
397+ -- | /A/s request crossed with a request from /B/ (see protocols)
398+ | ConnectionRequestCrossed
399+ deriving (Enum, Bounded, Show)
400+
401+-- | Parameters for setting up the TCP transport
402+data TCPParameters = TCPParameters {
403+ -- | Backlog for 'listen'.
404+ -- Defaults to SOMAXCONN.
405+ tcpBacklog :: Int
406+ -- | Should we set SO_REUSEADDR on the server socket?
407+ -- Defaults to True.
408+ , tcpReuseServerAddr :: Bool
409+ -- | Should we set SO_REUSEADDR on client sockets?
410+ -- Defaults to True.
411+ , tcpReuseClientAddr :: Bool
412+ }
413+
414+-- | Internal functionality we expose for unit testing
415+data TransportInternals = TransportInternals
416+ { -- | The ID of the thread that listens for new incoming connections
417+ transportThread :: ThreadId
418+ -- | Find the socket between a local and a remote endpoint
419+ , socketBetween :: EndPointAddress
420+ -> EndPointAddress
421+ -> IO N.Socket
422+ }
423+
424+--------------------------------------------------------------------------------
425+-- Top-level functionality --
426+--------------------------------------------------------------------------------
427+
428+-- | Create a TCP transport
429+createTransport :: N.HostName
430+ -> N.ServiceName
431+ -> TCPParameters
432+ -> IO (Either IOException Transport)
433+createTransport host port params =
434+ either Left (Right . fst) <$> createTransportExposeInternals host port params
435+
436+-- | You should probably not use this function (used for unit testing only)
437+createTransportExposeInternals
438+ :: N.HostName
439+ -> N.ServiceName
440+ -> TCPParameters
441+ -> IO (Either IOException (Transport, TransportInternals))
442+createTransportExposeInternals host port params = do
443+ state <- newMVar . TransportValid $ ValidTransportState
444+ { _localEndPoints = Map.empty
445+ , _nextEndPointId = 0
446+ }
447+ let transport = TCPTransport { transportState = state
448+ , transportHost = host
449+ , transportPort = port
450+ , transportParams = params
451+ }
452+ tryIO $ bracketOnError (forkServer
453+ host
454+ port
455+ (tcpBacklog params)
456+ (tcpReuseServerAddr params)
457+ (terminationHandler transport)
458+ (handleConnectionRequest transport))
459+ killThread
460+ (mkTransport transport)
461+ where
462+ mkTransport :: TCPTransport
463+ -> ThreadId
464+ -> IO (Transport, TransportInternals)
465+ mkTransport transport tid = return
466+ ( Transport
467+ { newEndPoint = apiNewEndPoint transport
468+ , closeTransport = let evs = [ EndPointClosed
469+ , throw $ userError "Transport closed"
470+ ] in
471+ apiCloseTransport transport (Just tid) evs
472+ }
473+ , TransportInternals
474+ { transportThread = tid
475+ , socketBetween = internalSocketBetween transport
476+ }
477+ )
478+
479+ terminationHandler :: TCPTransport -> SomeException -> IO ()
480+ terminationHandler transport ex = do
481+ let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))
482+ , throw $ userError "Transport closed"
483+ ]
484+ apiCloseTransport transport Nothing evs
485+
486+-- | Default TCP parameters
487+defaultTCPParameters :: TCPParameters
488+defaultTCPParameters = TCPParameters {
489+ tcpBacklog = N.sOMAXCONN
490+ , tcpReuseServerAddr = True
491+ , tcpReuseClientAddr = True
492+ }
493+
494+--------------------------------------------------------------------------------
495+-- API functions --
496+--------------------------------------------------------------------------------
497+
498+-- | Close the transport
499+apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()
500+apiCloseTransport transport mTransportThread evs =
501+ asyncWhenCancelled return $ do
502+ mTSt <- modifyMVar (transportState transport) $ \st -> case st of
503+ TransportValid vst -> return (TransportClosed, Just vst)
504+ TransportClosed -> return (TransportClosed, Nothing)
505+ forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
506+ -- This will invoke the termination handler, which in turn will call
507+ -- apiCloseTransport again, but then the transport will already be closed
508+ -- and we won't be passed a transport thread, so we terminate immmediate
509+ forM_ mTransportThread killThread
510+
511+-- | Create a new endpoint
512+apiNewEndPoint :: TCPTransport
513+ -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
514+apiNewEndPoint transport =
515+ try . asyncWhenCancelled closeEndPoint $ do
516+ ourEndPoint <- createLocalEndPoint transport
517+ return EndPoint
518+ { receive = readChan (localChannel ourEndPoint)
519+ , address = localAddress ourEndPoint
520+ , connect = apiConnect (transportParams transport) ourEndPoint
521+ , closeEndPoint = let evs = [ EndPointClosed
522+ , throw $ userError "Endpoint closed"
523+ ] in
524+ apiCloseEndPoint transport evs ourEndPoint
525+ , newMulticastGroup = return . Left $ newMulticastGroupError
526+ , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
527+ }
528+ where
529+ newMulticastGroupError =
530+ TransportError NewMulticastGroupUnsupported "Multicast not supported"
531+ resolveMulticastGroupError =
532+ TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
533+
534+-- | Connnect to an endpoint
535+apiConnect :: TCPParameters -- ^ Parameters
536+ -> LocalEndPoint -- ^ Local end point
537+ -> EndPointAddress -- ^ Remote address
538+ -> Reliability -- ^ Reliability (ignored)
539+ -> ConnectHints -- ^ Hints
540+ -> IO (Either (TransportError ConnectErrorCode) Connection)
541+apiConnect params ourEndPoint theirAddress _reliability hints =
542+ try . asyncWhenCancelled close $
543+ if localAddress ourEndPoint == theirAddress
544+ then connectToSelf ourEndPoint
545+ else do
546+ resetIfBroken ourEndPoint theirAddress
547+ (theirEndPoint, connId) <-
548+ requestConnectionTo params ourEndPoint theirAddress hints
549+ -- connAlive can be an IORef rather than an MVar because it is protected
550+ -- by the remoteState MVar. We don't need the overhead of locking twice.
551+ connAlive <- newIORef True
552+ return Connection
553+ { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
554+ , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
555+ }
556+
557+-- | Close a connection
558+apiClose :: EndPointPair -> ConnectionId -> IORef Bool -> IO ()
559+apiClose (ourEndPoint, theirEndPoint) connId connAlive =
560+ void . tryIO . asyncWhenCancelled return $ do
561+ modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
562+ { caseValid = \vst -> do
563+ alive <- readIORef connAlive
564+ if alive
565+ then do
566+ writeIORef connAlive False
567+ sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
568+ return ( RemoteEndPointValid
569+ . (remoteOutgoing ^: (\x -> x - 1))
570+ $ vst
571+ )
572+ else
573+ return (RemoteEndPointValid vst)
574+ }
575+ closeIfUnused (ourEndPoint, theirEndPoint)
576+
577+-- | Send data across a connection
578+apiSend :: EndPointPair -- ^ Local and remote endpoint
579+ -> ConnectionId -- ^ Connection ID (supplied by remote endpoint)
580+ -> IORef Bool -- ^ Is the connection still alive?
581+ -> [ByteString] -- ^ Payload
582+ -> IO (Either (TransportError SendErrorCode) ())
583+apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
584+ -- We don't need the overhead of asyncWhenCancelled here
585+ try . mapIOException sendFailed $
586+ withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
587+ { caseInvalid = \_ ->
588+ relyViolation (ourEndPoint, theirEndPoint) "apiSend"
589+ , caseInit = \_ _ ->
590+ relyViolation (ourEndPoint, theirEndPoint) "apiSend"
591+ , caseValid = \vst -> do
592+ alive <- readIORef connAlive
593+ if alive
594+ then sendOn vst (encodeInt32 connId : prependLength payload)
595+ else throwIO $ TransportError SendClosed "Connection closed"
596+ , caseClosing = \_ _ -> do
597+ alive <- readIORef connAlive
598+ if alive
599+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
600+ else throwIO $ TransportError SendClosed "Connection closed"
601+ , caseClosed = do
602+ alive <- readIORef connAlive
603+ if alive
604+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
605+ else throwIO $ TransportError SendClosed "Connection closed"
606+ , caseFailed = \err -> do
607+ alive <- readIORef connAlive
608+ if alive
609+ then throwIO $ TransportError SendFailed (show err)
610+ else throwIO $ TransportError SendClosed "Connection closed"
611+ }
612+ where
613+ sendFailed = TransportError SendFailed . show
614+
615+-- | Force-close the endpoint
616+apiCloseEndPoint :: TCPTransport -- ^ Transport
617+ -> [Event] -- ^ Events used to report closure
618+ -> LocalEndPoint -- ^ Local endpoint
619+ -> IO ()
620+apiCloseEndPoint transport evs ourEndPoint =
621+ asyncWhenCancelled return $ do
622+ -- Remove the reference from the transport state
623+ removeLocalEndPoint transport ourEndPoint
624+ -- Close the local endpoint
625+ mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
626+ case st of
627+ LocalEndPointValid vst ->
628+ return (LocalEndPointClosed, Just vst)
629+ LocalEndPointClosed ->
630+ return (LocalEndPointClosed, Nothing)
631+ forM_ mOurState $ \vst -> do
632+ forM_ (vst ^. localConnections) tryCloseRemoteSocket
633+ forM_ evs $ writeChan (localChannel ourEndPoint)
634+ where
635+ -- Close the remote socket and return the set of all incoming connections
636+ tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
637+ tryCloseRemoteSocket theirEndPoint = do
638+ -- We make an attempt to close the connection nicely
639+ -- (by sending a CloseSocket first)
640+ let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"
641+ modifyMVar_ (remoteState theirEndPoint) $ \st ->
642+ case st of
643+ RemoteEndPointInvalid _ ->
644+ return st
645+ RemoteEndPointInit resolved _ -> do
646+ putMVar resolved ()
647+ return closed
648+ RemoteEndPointValid conn -> do
649+ tryIO $ sendOn conn [encodeInt32 CloseSocket]
650+ tryCloseSocket (remoteSocket conn)
651+ return closed
652+ RemoteEndPointClosing resolved conn -> do
653+ putMVar resolved ()
654+ tryCloseSocket (remoteSocket conn)
655+ return closed
656+ RemoteEndPointClosed ->
657+ return st
658+ RemoteEndPointFailed err ->
659+ return $ RemoteEndPointFailed err
660+
661+--------------------------------------------------------------------------------
662+-- As soon as a remote connection fails, we want to put notify our endpoint --
663+-- and put it into a closed state. Since this may happen in many places, we --
664+-- provide some abstractions. --
665+--------------------------------------------------------------------------------
666+
667+data RemoteStatePatternMatch a = RemoteStatePatternMatch
668+ { caseInvalid :: TransportError ConnectErrorCode -> IO a
669+ , caseInit :: MVar () -> RequestedBy -> IO a
670+ , caseValid :: ValidRemoteEndPointState -> IO a
671+ , caseClosing :: MVar () -> ValidRemoteEndPointState -> IO a
672+ , caseClosed :: IO a
673+ , caseFailed :: IOException -> IO a
674+ }
675+
676+remoteStateIdentity :: RemoteStatePatternMatch RemoteState
677+remoteStateIdentity =
678+ RemoteStatePatternMatch
679+ { caseInvalid = return . RemoteEndPointInvalid
680+ , caseInit = (return .) . RemoteEndPointInit
681+ , caseValid = return . RemoteEndPointValid
682+ , caseClosing = (return .) . RemoteEndPointClosing
683+ , caseClosed = return RemoteEndPointClosed
684+ , caseFailed = return . RemoteEndPointFailed
685+ }
686+
687+-- | Like modifyMVar, but if an I/O exception occurs don't restore the remote
688+-- endpoint to its original value but close it instead
689+modifyRemoteState :: EndPointPair
690+ -> RemoteStatePatternMatch (RemoteState, a)
691+ -> IO a
692+modifyRemoteState (ourEndPoint, theirEndPoint) match =
693+ mask $ \restore -> do
694+ st <- takeMVar theirState
695+ case st of
696+ RemoteEndPointValid vst -> do
697+ mResult <- try $ restore (caseValid match vst)
698+ case mResult of
699+ Right (st', a) -> do
700+ putMVar theirState st'
701+ return a
702+ Left ex -> do
703+ case fromException ex of
704+ Just ioEx -> handleIOException ioEx vst
705+ Nothing -> putMVar theirState st
706+ throwIO ex
707+ -- The other cases are less interesting, because unless the endpoint is
708+ -- in Valid state we're not supposed to do any IO on it
709+ RemoteEndPointInit resolved origin -> do
710+ (st', a) <- onException (restore $ caseInit match resolved origin)
711+ (putMVar theirState st)
712+ putMVar theirState st'
713+ return a
714+ RemoteEndPointClosing resolved vst -> do
715+ (st', a) <- onException (restore $ caseClosing match resolved vst)
716+ (putMVar theirState st)
717+ putMVar theirState st'
718+ return a
719+ RemoteEndPointInvalid err -> do
720+ (st', a) <- onException (restore $ caseInvalid match err)
721+ (putMVar theirState st)
722+ putMVar theirState st'
723+ return a
724+ RemoteEndPointClosed -> do
725+ (st', a) <- onException (restore $ caseClosed match)
726+ (putMVar theirState st)
727+ putMVar theirState st'
728+ return a
729+ RemoteEndPointFailed err -> do
730+ (st', a) <- onException (restore $ caseFailed match err)
731+ (putMVar theirState st)
732+ putMVar theirState st'
733+ return a
734+ where
735+ theirState :: MVar RemoteState
736+ theirState = remoteState theirEndPoint
737+
738+ handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()
739+ handleIOException ex vst = do
740+ tryCloseSocket (remoteSocket vst)
741+ putMVar theirState (RemoteEndPointFailed ex)
742+ let incoming = IntSet.elems $ vst ^. remoteIncoming
743+ code = EventConnectionLost (Just $ remoteAddress theirEndPoint) incoming
744+ err = TransportError code (show ex)
745+ writeChan (localChannel ourEndPoint) $ ErrorEvent err
746+
747+-- | Like 'modifyRemoteState' but without a return value
748+modifyRemoteState_ :: EndPointPair
749+ -> RemoteStatePatternMatch RemoteState
750+ -> IO ()
751+modifyRemoteState_ (ourEndPoint, theirEndPoint) match =
752+ modifyRemoteState (ourEndPoint, theirEndPoint)
753+ RemoteStatePatternMatch
754+ { caseInvalid = u . caseInvalid match
755+ , caseInit = \resolved origin -> u $ caseInit match resolved origin
756+ , caseValid = u . caseValid match
757+ , caseClosing = \resolved vst -> u $ caseClosing match resolved vst
758+ , caseClosed = u $ caseClosed match
759+ , caseFailed = u . caseFailed match
760+ }
761+ where
762+ u :: IO a -> IO (a, ())
763+ u p = p >>= \a -> return (a, ())
764+
765+-- | Like 'modifyRemoteState' but without the ability to change the state
766+withRemoteState :: EndPointPair
767+ -> RemoteStatePatternMatch a
768+ -> IO a
769+withRemoteState (ourEndPoint, theirEndPoint) match =
770+ modifyRemoteState (ourEndPoint, theirEndPoint)
771+ RemoteStatePatternMatch
772+ { caseInvalid = \err -> do
773+ a <- caseInvalid match err
774+ return (RemoteEndPointInvalid err, a)
775+ , caseInit = \resolved origin -> do
776+ a <- caseInit match resolved origin
777+ return (RemoteEndPointInit resolved origin, a)
778+ , caseValid = \vst -> do
779+ a <- caseValid match vst
780+ return (RemoteEndPointValid vst, a)
781+ , caseClosing = \resolved vst -> do
782+ a <- caseClosing match resolved vst
783+ return (RemoteEndPointClosing resolved vst, a)
784+ , caseClosed = do
785+ a <- caseClosed match
786+ return (RemoteEndPointClosed, a)
787+ , caseFailed = \err -> do
788+ a <- caseFailed match err
789+ return (RemoteEndPointFailed err, a)
790+ }
791+
792+--------------------------------------------------------------------------------
793+-- Incoming requests --
794+--------------------------------------------------------------------------------
795+
796+-- | Handle a connection request (that is, a remote endpoint that is trying to
797+-- establish a TCP connection with us)
798+--
799+-- 'handleConnectionRequest' runs in the context of the transport thread, which
800+-- can be killed asynchronously by 'closeTransport'. We fork a separate thread
801+-- as soon as we have located the lcoal endpoint that the remote endpoint is
802+-- interested in. We cannot fork any sooner because then we have no way of
803+-- storing the thread ID and hence no way of killing the thread when we take
804+-- the transport down. We must be careful to close the socket when a (possibly
805+-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
806+-- handleConnectionRequest the transport will be shut down.)
807+handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
808+handleConnectionRequest transport sock = handle handleException $ do
809+ ourEndPointId <- recvInt32 sock
810+ theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
811+ let ourAddress = encodeEndPointAddress (transportHost transport)
812+ (transportPort transport)
813+ ourEndPointId
814+ ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
815+ TransportValid vst ->
816+ case vst ^. localEndPointAt ourAddress of
817+ Nothing -> do
818+ sendMany sock [encodeInt32 ConnectionRequestInvalid]
819+ throwIO $ userError "handleConnectionRequest: Invalid endpoint"
820+ Just ourEndPoint ->
821+ return ourEndPoint
822+ TransportClosed ->
823+ throwIO $ userError "Transport closed"
824+ void . forkIO $ go ourEndPoint theirAddress
825+ where
826+ go :: LocalEndPoint -> EndPointAddress -> IO ()
827+ go ourEndPoint theirAddress = do
828+ -- This runs in a thread that will never be killed
829+ mEndPoint <- handle ((>> return Nothing) . handleException) $ do
830+ resetIfBroken ourEndPoint theirAddress
831+ (theirEndPoint, isNew) <-
832+ findRemoteEndPoint ourEndPoint theirAddress RequestedByThem
833+
834+ if not isNew
835+ then do
836+ tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
837+ tryCloseSocket sock
838+ return Nothing
839+ else do
840+ let vst = ValidRemoteEndPointState
841+ { remoteSocket = sock
842+ , _remoteOutgoing = 0
843+ , _remoteIncoming = IntSet.empty
844+ , sendOn = sendMany sock
845+ , _pendingCtrlRequests = IntMap.empty
846+ , _nextCtrlRequestId = 0
847+ }
848+ sendMany sock [encodeInt32 ConnectionRequestAccepted]
849+ resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
850+ return (Just theirEndPoint)
851+ -- If we left the scope of the exception handler with a return value of
852+ -- Nothing then the socket is already closed; otherwise, the socket has
853+ -- been recorded as part of the remote endpoint. Either way, we no longer
854+ -- have to worry about closing the socket on receiving an asynchronous
855+ -- exception from this point forward.
856+ forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
857+
858+ handleException :: SomeException -> IO ()
859+ handleException ex = do
860+ tryCloseSocket sock
861+ rethrowIfAsync (fromException ex)
862+
863+ rethrowIfAsync :: Maybe AsyncException -> IO ()
864+ rethrowIfAsync = mapM_ throwIO
865+
866+-- | Handle requests from a remote endpoint.
867+--
868+-- Returns only if the remote party closes the socket or if an error occurs.
869+-- This runs in a thread that will never be killed.
870+handleIncomingMessages :: EndPointPair -> IO ()
871+handleIncomingMessages (ourEndPoint, theirEndPoint) = do
872+ mSock <- withMVar theirState $ \st ->
873+ case st of
874+ RemoteEndPointInvalid _ ->
875+ relyViolation (ourEndPoint, theirEndPoint)
876+ "handleIncomingMessages (invalid)"
877+ RemoteEndPointInit _ _ ->
878+ relyViolation (ourEndPoint, theirEndPoint)
879+ "handleIncomingMessages (init)"
880+ RemoteEndPointValid ep ->
881+ return . Just $ remoteSocket ep
882+ RemoteEndPointClosing _ ep ->
883+ return . Just $ remoteSocket ep
884+ RemoteEndPointClosed ->
885+ return Nothing
886+ RemoteEndPointFailed _ ->
887+ return Nothing
888+
889+ forM_ mSock $ \sock ->
890+ tryIO (go sock) >>= either (prematureExit sock) return
891+ where
892+ -- Dispatch
893+ --
894+ -- If a recv throws an exception this will be caught top-level and
895+ -- 'prematureExit' will be invoked. The same will happen if the remote
896+ -- endpoint is put into a Closed (or Closing) state by a concurrent thread
897+ -- (because a 'send' failed) -- the individual handlers below will throw a
898+ -- user exception which is then caught and handled the same way as an
899+ -- exception thrown by 'recv'.
900+ go :: N.Socket -> IO ()
901+ go sock = do
902+ connId <- recvInt32 sock
903+ if connId >= firstNonReservedConnectionId
904+ then do
905+ readMessage sock connId
906+ go sock
907+ else
908+ case tryToEnum (fromIntegral connId) of
909+ Just RequestConnectionId -> do
910+ recvInt32 sock >>= createNewConnection
911+ go sock
912+ Just ControlResponse -> do
913+ recvInt32 sock >>= readControlResponse sock
914+ go sock
915+ Just CloseConnection -> do
916+ recvInt32 sock >>= closeConnection
917+ go sock
918+ Just CloseSocket -> do
919+ didClose <- closeSocket sock
920+ unless didClose $ go sock
921+ Nothing ->
922+ throwIO $ userError "Invalid control request"
923+
924+ -- Create a new connection
925+ createNewConnection :: ControlRequestId -> IO ()
926+ createNewConnection reqId = do
927+ newId <- getNextConnectionId ourEndPoint
928+ modifyMVar_ theirState $ \st -> do
929+ vst <- case st of
930+ RemoteEndPointInvalid _ ->
931+ relyViolation (ourEndPoint, theirEndPoint)
932+ "handleIncomingMessages:createNewConnection (invalid)"
933+ RemoteEndPointInit _ _ ->
934+ relyViolation (ourEndPoint, theirEndPoint)
935+ "handleIncomingMessages:createNewConnection (init)"
936+ RemoteEndPointValid vst ->
937+ return (remoteIncoming ^: IntSet.insert newId $ vst)
938+ RemoteEndPointClosing resolved vst -> do
939+ -- If the endpoint is in closing state that means we send a
940+ -- CloseSocket request to the remote endpoint. If the remote
941+ -- endpoint replies with the request to create a new connection, it
942+ -- either ignored our request or it sent the request before it got
943+ -- ours. Either way, at this point we simply restore the endpoint
944+ -- to RemoteEndPointValid
945+ putMVar resolved ()
946+ return (remoteIncoming ^= IntSet.singleton newId $ vst)
947+ RemoteEndPointFailed err ->
948+ throwIO err
949+ RemoteEndPointClosed ->
950+ relyViolation (ourEndPoint, theirEndPoint)
951+ "createNewConnection (closed)"
952+ sendOn vst ( encodeInt32 ControlResponse
953+ : encodeInt32 reqId
954+ : prependLength [encodeInt32 newId]
955+ )
956+ return (RemoteEndPointValid vst)
957+ writeChan ourChannel (ConnectionOpened newId ReliableOrdered theirAddr)
958+
959+ -- Read a control response
960+ readControlResponse :: N.Socket -> ControlRequestId -> IO ()
961+ readControlResponse sock reqId = do
962+ response <- recvWithLength sock
963+ mmvar <- modifyMVar theirState $ \st -> case st of
964+ RemoteEndPointInvalid _ ->
965+ relyViolation (ourEndPoint, theirEndPoint)
966+ "readControlResponse (invalid)"
967+ RemoteEndPointInit _ _ ->
968+ relyViolation (ourEndPoint, theirEndPoint)
969+ "readControlResponse (init)"
970+ RemoteEndPointValid vst ->
971+ return ( RemoteEndPointValid
972+ . (pendingCtrlRequestsAt reqId ^= Nothing)
973+ $ vst
974+ , vst ^. pendingCtrlRequestsAt reqId
975+ )
976+ RemoteEndPointClosing _ _ ->
977+ throwIO $ userError "Invalid control response"
978+ RemoteEndPointFailed err ->
979+ throwIO err
980+ RemoteEndPointClosed ->
981+ relyViolation (ourEndPoint, theirEndPoint)
982+ "readControlResponse (closed)"
983+ case mmvar of
984+ Nothing ->
985+ throwIO $ userError "Invalid request ID"
986+ Just mvar ->
987+ putMVar mvar (Right response)
988+
989+ -- Close a connection
990+ -- It is important that we verify that the connection is in fact open,
991+ -- because otherwise we should not decrement the reference count
992+ closeConnection :: ConnectionId -> IO ()
993+ closeConnection cid = do
994+ modifyMVar_ theirState $ \st -> case st of
995+ RemoteEndPointInvalid _ ->
996+ relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"
997+ RemoteEndPointInit _ _ ->
998+ relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"
999+ RemoteEndPointValid vst -> do
1000+ unless (IntSet.member cid (vst ^. remoteIncoming)) $
1001+ throwIO $ userError "Invalid CloseConnection"
1002+ return ( RemoteEndPointValid
1003+ . (remoteIncoming ^: IntSet.delete cid)
1004+ $ vst
1005+ )
1006+ RemoteEndPointClosing _ _ ->
1007+ -- If the remote endpoint is in Closing state, that means that are as
1008+ -- far as we are concerned there are no incoming connections. This
1009+ -- means that a CloseConnection request at this point is invalid.
1010+ throwIO $ userError "Invalid CloseConnection request"
1011+ RemoteEndPointFailed err ->
1012+ throwIO err
1013+ RemoteEndPointClosed ->
1014+ relyViolation (ourEndPoint, theirEndPoint) "closeConnection (closed)"
1015+ writeChan ourChannel (ConnectionClosed cid)
1016+ closeIfUnused (ourEndPoint, theirEndPoint)
1017+
1018+ -- Close the socket (if we don't have any outgoing connections)
1019+ closeSocket :: N.Socket -> IO Bool
1020+ closeSocket sock =
1021+ modifyMVar theirState $ \st ->
1022+ case st of
1023+ RemoteEndPointInvalid _ ->
1024+ relyViolation (ourEndPoint, theirEndPoint)
1025+ "handleIncomingMessages:closeSocket (invalid)"
1026+ RemoteEndPointInit _ _ ->
1027+ relyViolation (ourEndPoint, theirEndPoint)
1028+ "handleIncomingMessages:closeSocket (init)"
1029+ RemoteEndPointValid vst -> do
1030+ -- We regard a CloseSocket message as an (optimized) way for the
1031+ -- remote endpoint to indicate that all its connections to us are
1032+ -- now properly closed
1033+ forM_ (IntSet.elems $ vst ^. remoteIncoming) $
1034+ writeChan ourChannel . ConnectionClosed
1035+ let vst' = remoteIncoming ^= IntSet.empty $ vst
1036+ -- Check if we agree that the connection should be closed
1037+ if vst' ^. remoteOutgoing == 0
1038+ then do
1039+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1040+ -- Attempt to reply (but don't insist)
1041+ tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1042+ tryCloseSocket sock
1043+ return (RemoteEndPointClosed, True)
1044+ else
1045+ return (RemoteEndPointValid vst', False)
1046+ RemoteEndPointClosing resolved _ -> do
1047+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1048+ tryCloseSocket sock
1049+ putMVar resolved ()
1050+ return (RemoteEndPointClosed, True)
1051+ RemoteEndPointFailed err ->
1052+ throwIO err
1053+ RemoteEndPointClosed ->
1054+ relyViolation (ourEndPoint, theirEndPoint)
1055+ "handleIncomingMessages:closeSocket (closed)"
1056+
1057+ -- Read a message and output it on the endPoint's channel. By rights we
1058+ -- should verify that the connection ID is valid, but this is unnecessary
1059+ -- overhead
1060+ readMessage :: N.Socket -> ConnectionId -> IO ()
1061+ readMessage sock connId =
1062+ recvWithLength sock >>= writeChan ourChannel . Received connId
1063+
1064+ -- Arguments
1065+ ourChannel = localChannel ourEndPoint
1066+ theirState = remoteState theirEndPoint
1067+ theirAddr = remoteAddress theirEndPoint
1068+
1069+ -- Deal with a premature exit
1070+ prematureExit :: N.Socket -> IOException -> IO ()
1071+ prematureExit sock err = do
1072+ tryCloseSocket sock
1073+ modifyMVar_ theirState $ \st ->
1074+ case st of
1075+ RemoteEndPointInvalid _ ->
1076+ relyViolation (ourEndPoint, theirEndPoint)
1077+ "handleIncomingMessages:prematureExit"
1078+ RemoteEndPointInit _ _ ->
1079+ relyViolation (ourEndPoint, theirEndPoint)
1080+ "handleIncomingMessages:prematureExit"
1081+ RemoteEndPointValid vst -> do
1082+ let code = EventConnectionLost
1083+ (Just $ remoteAddress theirEndPoint)
1084+ (IntSet.elems $ vst ^. remoteIncoming)
1085+ writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1086+ forM_ (vst ^. pendingCtrlRequests) $ flip putMVar (Left err)
1087+ return (RemoteEndPointFailed err)
1088+ RemoteEndPointClosing resolved _ -> do
1089+ putMVar resolved ()
1090+ return (RemoteEndPointFailed err)
1091+ RemoteEndPointClosed ->
1092+ relyViolation (ourEndPoint, theirEndPoint)
1093+ "handleIncomingMessages:prematureExit"
1094+ RemoteEndPointFailed err' ->
1095+ return (RemoteEndPointFailed err')
1096+
1097+--------------------------------------------------------------------------------
1098+-- Uninterruptable auxiliary functions --
1099+-- --
1100+-- All these functions assume they are running in a thread which will never --
1101+-- be killed.
1102+--------------------------------------------------------------------------------
1103+
1104+-- | Request a connection to a remote endpoint
1105+--
1106+-- This will block until we get a connection ID from the remote endpoint; if
1107+-- the remote endpoint was in 'RemoteEndPointClosing' state then we will
1108+-- additionally block until that is resolved.
1109+--
1110+-- May throw a TransportError ConnectErrorCode exception.
1111+requestConnectionTo :: TCPParameters
1112+ -> LocalEndPoint
1113+ -> EndPointAddress
1114+ -> ConnectHints
1115+ -> IO (RemoteEndPoint, ConnectionId)
1116+requestConnectionTo params ourEndPoint theirAddress hints = go
1117+ where
1118+ go = do
1119+ (theirEndPoint, isNew) <- mapIOException connectFailed $
1120+ findRemoteEndPoint ourEndPoint theirAddress RequestedByUs
1121+
1122+ if isNew
1123+ then do
1124+ forkIO . handle absorbAllExceptions $
1125+ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
1126+ go
1127+ else do
1128+ reply <- mapIOException connectFailed $
1129+ doRemoteRequest (ourEndPoint, theirEndPoint) RequestConnectionId
1130+ return (theirEndPoint, decodeInt32 . BS.concat $ reply)
1131+
1132+ connectFailed :: IOException -> TransportError ConnectErrorCode
1133+ connectFailed = TransportError ConnectFailed . show
1134+
1135+ absorbAllExceptions :: SomeException -> IO ()
1136+ absorbAllExceptions _ex =
1137+ return ()
1138+
1139+-- | Set up a remote endpoint
1140+setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
1141+setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
1142+ result <- socketToEndPoint ourAddress
1143+ theirAddress
1144+ (tcpReuseClientAddr params)
1145+ (connectTimeout hints)
1146+ didAccept <- case result of
1147+ Right (sock, ConnectionRequestAccepted) -> do
1148+ let vst = ValidRemoteEndPointState
1149+ { remoteSocket = sock
1150+ , _remoteOutgoing = 0
1151+ , _remoteIncoming = IntSet.empty
1152+ , sendOn = sendMany sock
1153+ , _pendingCtrlRequests = IntMap.empty
1154+ , _nextCtrlRequestId = 0
1155+ }
1156+ resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
1157+ return True
1158+ Right (sock, ConnectionRequestInvalid) -> do
1159+ let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"
1160+ resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1161+ tryCloseSocket sock
1162+ return False
1163+ Right (sock, ConnectionRequestCrossed) -> do
1164+ resolveInit (ourEndPoint, theirEndPoint) RemoteEndPointClosed
1165+ tryCloseSocket sock
1166+ return False
1167+ Left err -> do
1168+ resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
1169+ return False
1170+
1171+ when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
1172+ where
1173+ ourAddress = localAddress ourEndPoint
1174+ theirAddress = remoteAddress theirEndPoint
1175+ invalidAddress = TransportError ConnectNotFound
1176+
1177+-- | Do a (blocking) remote request
1178+--
1179+-- May throw IO (user) exception if the local or the remote endpoint is closed,
1180+-- if the send fails, or if the remote endpoint fails before it replies.
1181+doRemoteRequest :: EndPointPair -> ControlHeader -> IO [ByteString]
1182+doRemoteRequest (ourEndPoint, theirEndPoint) header = do
1183+ replyMVar <- newEmptyMVar
1184+ modifyRemoteState_ (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
1185+ { caseValid = \vst -> do
1186+ let reqId = vst ^. nextCtrlRequestId
1187+ sendOn vst [encodeInt32 header, encodeInt32 reqId]
1188+ return ( RemoteEndPointValid
1189+ . (nextCtrlRequestId ^: (+ 1))
1190+ . (pendingCtrlRequestsAt reqId ^= Just replyMVar)
1191+ $ vst
1192+ )
1193+ -- Error cases
1194+ , caseInvalid =
1195+ throwIO
1196+ , caseInit = \_ _ ->
1197+ relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (init)"
1198+ , caseClosing = \_ _ ->
1199+ relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closing)"
1200+ , caseClosed =
1201+ relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest (closed)"
1202+ , caseFailed =
1203+ throwIO
1204+ }
1205+ mReply <- takeMVar replyMVar
1206+ case mReply of
1207+ Left err -> throwIO err
1208+ Right reply -> return reply
1209+
1210+-- | Send a CloseSocket request if the remote endpoint is unused
1211+closeIfUnused :: EndPointPair -> IO ()
1212+closeIfUnused (ourEndPoint, theirEndPoint) =
1213+ modifyRemoteState_ (ourEndPoint, theirEndPoint) remoteStateIdentity
1214+ { caseValid = \vst ->
1215+ if vst ^. remoteOutgoing == 0 && IntSet.null (vst ^. remoteIncoming)
1216+ then do
1217+ sendOn vst [encodeInt32 CloseSocket]
1218+ resolved <- newEmptyMVar
1219+ return $ RemoteEndPointClosing resolved vst
1220+ else
1221+ return $ RemoteEndPointValid vst
1222+ }
1223+
1224+-- | Reset a remote endpoint if it is in Invalid mode
1225+--
1226+-- If the remote endpoint is currently in broken state, and
1227+--
1228+-- - a user calls the API function 'connect', or and the remote endpoint is
1229+-- - an inbound connection request comes in from this remote address
1230+--
1231+-- we remove the remote endpoint first.
1232+--
1233+-- Throws a TransportError ConnectFailed exception if the local endpoint is
1234+-- closed.
1235+resetIfBroken :: LocalEndPoint -> EndPointAddress -> IO ()
1236+resetIfBroken ourEndPoint theirAddress = do
1237+ mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1238+ LocalEndPointValid vst ->
1239+ return (vst ^. localConnectionTo theirAddress)
1240+ LocalEndPointClosed ->
1241+ throwIO $ TransportError ConnectFailed "Endpoint closed"
1242+ forM_ mTheirEndPoint $ \theirEndPoint ->
1243+ withMVar (remoteState theirEndPoint) $ \st -> case st of
1244+ RemoteEndPointInvalid _ ->
1245+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1246+ RemoteEndPointFailed _ ->
1247+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1248+ _ ->
1249+ return ()
1250+
1251+-- | Special case of 'apiConnect': connect an endpoint to itself
1252+--
1253+-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)
1254+connectToSelf :: LocalEndPoint
1255+ -> IO Connection
1256+connectToSelf ourEndPoint = do
1257+ connAlive <- newIORef True -- Protected by the local endpoint lock
1258+ connId <- mapIOException connectFailed $ getNextConnectionId ourEndPoint
1259+ writeChan ourChan $
1260+ ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)
1261+ return Connection
1262+ { send = selfSend connAlive connId
1263+ , close = selfClose connAlive connId
1264+ }
1265+ where
1266+ selfSend :: IORef Bool
1267+ -> ConnectionId
1268+ -> [ByteString]
1269+ -> IO (Either (TransportError SendErrorCode) ())
1270+ selfSend connAlive connId msg =
1271+ try . withMVar ourState $ \st -> case st of
1272+ LocalEndPointValid _ -> do
1273+ alive <- readIORef connAlive
1274+ if alive
1275+ then writeChan ourChan (Received connId msg)
1276+ else throwIO $ TransportError SendClosed "Connection closed"
1277+ LocalEndPointClosed ->
1278+ throwIO $ TransportError SendFailed "Endpoint closed"
1279+
1280+ selfClose :: IORef Bool -> ConnectionId -> IO ()
1281+ selfClose connAlive connId =
1282+ withMVar ourState $ \st -> case st of
1283+ LocalEndPointValid _ -> do
1284+ alive <- readIORef connAlive
1285+ when alive $ do
1286+ writeChan ourChan (ConnectionClosed connId)
1287+ writeIORef connAlive False
1288+ LocalEndPointClosed ->
1289+ return ()
1290+
1291+ ourChan = localChannel ourEndPoint
1292+ ourState = localState ourEndPoint
1293+ connectFailed = TransportError ConnectFailed . show
1294+
1295+-- | Resolve an endpoint currently in 'Init' state
1296+resolveInit :: EndPointPair -> RemoteState -> IO ()
1297+resolveInit (ourEndPoint, theirEndPoint) newState =
1298+ modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
1299+ RemoteEndPointInit resolved _ -> do
1300+ putMVar resolved ()
1301+ case newState of
1302+ RemoteEndPointClosed ->
1303+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1304+ _ ->
1305+ return ()
1306+ return newState
1307+ RemoteEndPointFailed ex ->
1308+ throwIO ex
1309+ _ ->
1310+ relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
1311+
1312+-- | Get the next connection ID
1313+--
1314+-- Throws an IO exception when the endpoint is closed.
1315+getNextConnectionId :: LocalEndPoint -> IO ConnectionId
1316+getNextConnectionId ourEndpoint =
1317+ modifyMVar (localState ourEndpoint) $ \st -> case st of
1318+ LocalEndPointValid vst -> do
1319+ let connId = vst ^. nextConnectionId
1320+ return ( LocalEndPointValid
1321+ . (nextConnectionId ^= connId + 1)
1322+ $ vst
1323+ , connId)
1324+ LocalEndPointClosed ->
1325+ throwIO $ userError "Local endpoint closed"
1326+
1327+-- | Create a new local endpoint
1328+--
1329+-- May throw a TransportError NewEndPointErrorCode exception if the transport
1330+-- is closed.
1331+createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
1332+createLocalEndPoint transport = do
1333+ chan <- newChan
1334+ state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
1335+ { _nextConnectionId = firstNonReservedConnectionId
1336+ , _localConnections = Map.empty
1337+ , _nextRemoteId = 0
1338+ }
1339+ modifyMVar (transportState transport) $ \st -> case st of
1340+ TransportValid vst -> do
1341+ let ix = vst ^. nextEndPointId
1342+ let addr = encodeEndPointAddress (transportHost transport)
1343+ (transportPort transport)
1344+ ix
1345+ let localEndPoint = LocalEndPoint { localAddress = addr
1346+ , localChannel = chan
1347+ , localState = state
1348+ }
1349+ return ( TransportValid
1350+ . (localEndPointAt addr ^= Just localEndPoint)
1351+ . (nextEndPointId ^= ix + 1)
1352+ $ vst
1353+ , localEndPoint
1354+ )
1355+ TransportClosed ->
1356+ throwIO (TransportError NewEndPointFailed "Transport closed")
1357+
1358+
1359+-- | Remove reference to a remote endpoint from a local endpoint
1360+--
1361+-- If the local endpoint is closed, do nothing
1362+removeRemoteEndPoint :: EndPointPair -> IO ()
1363+removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
1364+ modifyMVar_ ourState $ \st -> case st of
1365+ LocalEndPointValid vst ->
1366+ case vst ^. localConnectionTo theirAddress of
1367+ Nothing ->
1368+ return st
1369+ Just remoteEndPoint' ->
1370+ if remoteId remoteEndPoint' == remoteId theirEndPoint
1371+ then return
1372+ ( LocalEndPointValid
1373+ . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
1374+ $ vst
1375+ )
1376+ else return st
1377+ LocalEndPointClosed ->
1378+ return LocalEndPointClosed
1379+ where
1380+ ourState = localState ourEndPoint
1381+ theirAddress = remoteAddress theirEndPoint
1382+
1383+-- | Remove reference to a local endpoint from the transport state
1384+--
1385+-- Does nothing if the transport is closed
1386+removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
1387+removeLocalEndPoint transport ourEndPoint =
1388+ modifyMVar_ (transportState transport) $ \st -> case st of
1389+ TransportValid vst ->
1390+ return ( TransportValid
1391+ . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
1392+ $ vst
1393+ )
1394+ TransportClosed ->
1395+ return TransportClosed
1396+
1397+-- | Find a remote endpoint. If the remote endpoint does not yet exist we
1398+-- create it in Init state. Returns if the endpoint was new.
1399+findRemoteEndPoint
1400+ :: LocalEndPoint
1401+ -> EndPointAddress
1402+ -> RequestedBy
1403+ -> IO (RemoteEndPoint, Bool)
1404+findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
1405+ where
1406+ go = do
1407+ (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of
1408+ LocalEndPointValid vst -> case vst ^. localConnectionTo theirAddress of
1409+ Just theirEndPoint ->
1410+ return (st, (theirEndPoint, False))
1411+ Nothing -> do
1412+ resolved <- newEmptyMVar
1413+ theirState <- newMVar (RemoteEndPointInit resolved findOrigin)
1414+ let theirEndPoint = RemoteEndPoint
1415+ { remoteAddress = theirAddress
1416+ , remoteState = theirState
1417+ , remoteId = vst ^. nextRemoteId
1418+ }
1419+ return ( LocalEndPointValid
1420+ . (localConnectionTo theirAddress ^= Just theirEndPoint)
1421+ . (nextRemoteId ^: (+ 1))
1422+ $ vst
1423+ , (theirEndPoint, True)
1424+ )
1425+ LocalEndPointClosed ->
1426+ throwIO $ userError "Local endpoint closed"
1427+
1428+ if isNew
1429+ then
1430+ return (theirEndPoint, True)
1431+ else do
1432+ let theirState = remoteState theirEndPoint
1433+ snapshot <- modifyMVar theirState $ \st -> case st of
1434+ RemoteEndPointValid vst ->
1435+ case findOrigin of
1436+ RequestedByUs -> do
1437+ let st' = RemoteEndPointValid
1438+ . (remoteOutgoing ^: (+ 1))
1439+ $ vst
1440+ return (st', st')
1441+ RequestedByThem ->
1442+ return (st, st)
1443+ _ ->
1444+ return (st, st)
1445+ -- The snapshot may no longer be up to date at this point, but if we
1446+ -- increased the refcount then it can only either be Valid or Failed
1447+ -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
1448+ case snapshot of
1449+ RemoteEndPointInvalid err ->
1450+ throwIO err
1451+ RemoteEndPointInit resolved initOrigin ->
1452+ case (findOrigin, initOrigin) of
1453+ (RequestedByUs, RequestedByUs) ->
1454+ readMVar resolved >> go
1455+ (RequestedByUs, RequestedByThem) ->
1456+ readMVar resolved >> go
1457+ (RequestedByThem, RequestedByUs) ->
1458+ if ourAddress > theirAddress
1459+ then
1460+ -- Wait for the Crossed message
1461+ readMVar resolved >> go
1462+ else
1463+ return (theirEndPoint, False)
1464+ (RequestedByThem, RequestedByThem) ->
1465+ throwIO $ userError "Already connected"
1466+ RemoteEndPointValid _ ->
1467+ -- We assume that the request crossed if we find the endpoint in
1468+ -- Valid state. It is possible that this is really an invalid
1469+ -- request, but only in the case of a broken client (we don't
1470+ -- maintain enough history to be able to tell the difference).
1471+ return (theirEndPoint, False)
1472+ RemoteEndPointClosing resolved _ ->
1473+ readMVar resolved >> go
1474+ RemoteEndPointClosed ->
1475+ go
1476+ RemoteEndPointFailed err ->
1477+ throwIO err
1478+
1479+ ourState = localState ourEndPoint
1480+ ourAddress = localAddress ourEndPoint
1481+
1482+--------------------------------------------------------------------------------
1483+-- "Stateless" (MVar free) functions --
1484+--------------------------------------------------------------------------------
1485+
1486+-- | Establish a connection to a remote endpoint
1487+--
1488+-- Maybe throw a TransportError
1489+socketToEndPoint :: EndPointAddress -- ^ Our address
1490+ -> EndPointAddress -- ^ Their address
1491+ -> Bool -- ^ Use SO_REUSEADDR?
1492+ -> Maybe Int -- ^ Timeout for connect
1493+ -> IO (Either (TransportError ConnectErrorCode)
1494+ (N.Socket, ConnectionRequestResponse))
1495+socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1496+ try $ do
1497+ (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
1498+ Nothing -> throwIO (failed . userError $ "Could not parse")
1499+ Just dec -> return dec
1500+ addr:_ <- mapIOException invalidAddress $
1501+ N.getAddrInfo Nothing (Just host) (Just port)
1502+ bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
1503+ when reuseAddr $
1504+ mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
1505+ mapIOException invalidAddress $
1506+ timeoutMaybe timeout timeoutError $
1507+ N.connect sock (N.addrAddress addr)
1508+ response <- mapIOException failed $ do
1509+ sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
1510+ recvInt32 sock
1511+ case tryToEnum response of
1512+ Nothing -> throwIO (failed . userError $ "Unexpected response")
1513+ Just r -> return (sock, r)
1514+ where
1515+ createSocket :: N.AddrInfo -> IO N.Socket
1516+ createSocket addr = mapIOException insufficientResources $
1517+ N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
1518+
1519+ invalidAddress = TransportError ConnectNotFound . show
1520+ insufficientResources = TransportError ConnectInsufficientResources . show
1521+ failed = TransportError ConnectFailed . show
1522+ timeoutError = TransportError ConnectTimeout "Timed out"
1523+
1524+-- | Encode end point address
1525+encodeEndPointAddress :: N.HostName
1526+ -> N.ServiceName
1527+ -> EndPointId
1528+ -> EndPointAddress
1529+encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
1530+ host ++ ":" ++ port ++ ":" ++ show ix
1531+
1532+-- | Decode end point address
1533+decodeEndPointAddress :: EndPointAddress
1534+ -> Maybe (N.HostName, N.ServiceName, EndPointId)
1535+decodeEndPointAddress (EndPointAddress bs) =
1536+ case map BSC.unpack $ BSC.split ':' bs of
1537+ [host, port, endPointIdStr] ->
1538+ case reads endPointIdStr of
1539+ [(endPointId, "")] -> Just (host, port, endPointId)
1540+ _ -> Nothing
1541+ _ ->
1542+ Nothing
1543+
1544+--------------------------------------------------------------------------------
1545+-- Functions from TransportInternals --
1546+--------------------------------------------------------------------------------
1547+
1548+-- Find a socket between two endpoints
1549+--
1550+-- Throws an IO exception if the socket could not be found.
1551+internalSocketBetween :: TCPTransport -- ^ Transport
1552+ -> EndPointAddress -- ^ Local endpoint
1553+ -> EndPointAddress -- ^ Remote endpoint
1554+ -> IO N.Socket
1555+internalSocketBetween transport ourAddress theirAddress = do
1556+ ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
1557+ TransportClosed ->
1558+ throwIO $ userError "Transport closed"
1559+ TransportValid vst ->
1560+ case vst ^. localEndPointAt ourAddress of
1561+ Nothing -> throwIO $ userError "Local endpoint not found"
1562+ Just ep -> return ep
1563+ theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
1564+ LocalEndPointClosed ->
1565+ throwIO $ userError "Local endpoint closed"
1566+ LocalEndPointValid vst ->
1567+ case vst ^. localConnectionTo theirAddress of
1568+ Nothing -> throwIO $ userError "Remote endpoint not found"
1569+ Just ep -> return ep
1570+ withMVar (remoteState theirEndPoint) $ \st -> case st of
1571+ RemoteEndPointInit _ _ ->
1572+ throwIO $ userError "Remote endpoint not yet initialized"
1573+ RemoteEndPointValid vst ->
1574+ return $ remoteSocket vst
1575+ RemoteEndPointClosing _ vst ->
1576+ return $ remoteSocket vst
1577+ RemoteEndPointClosed ->
1578+ throwIO $ userError "Remote endpoint closed"
1579+ RemoteEndPointInvalid err ->
1580+ throwIO err
1581+ RemoteEndPointFailed err ->
1582+ throwIO err
1583+
1584+--------------------------------------------------------------------------------
1585+-- Constants --
1586+--------------------------------------------------------------------------------
1587+
1588+-- | We reserve a bunch of connection IDs for control messages
1589+firstNonReservedConnectionId :: ConnectionId
1590+firstNonReservedConnectionId = 1024
1591+
1592+--------------------------------------------------------------------------------
1593+-- Accessor definitions --
1594+--------------------------------------------------------------------------------
1595+
1596+localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
1597+localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es })
1598+
1599+nextEndPointId :: Accessor ValidTransportState EndPointId
1600+nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid })
1601+
1602+nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
1603+nextConnectionId = accessor _nextConnectionId (\cix st -> st { _nextConnectionId = cix })
1604+
1605+localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
1606+localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
1607+
1608+nextRemoteId :: Accessor ValidLocalEndPointState Int
1609+nextRemoteId = accessor _nextRemoteId (\rid st -> st { _nextRemoteId = rid })
1610+
1611+remoteOutgoing :: Accessor ValidRemoteEndPointState Int
1612+remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs })
1613+
1614+remoteIncoming :: Accessor ValidRemoteEndPointState IntSet
1615+remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs })
1616+
1617+pendingCtrlRequests :: Accessor ValidRemoteEndPointState (IntMap (MVar (Either IOException [ByteString])))
1618+pendingCtrlRequests = accessor _pendingCtrlRequests (\rep st -> st { _pendingCtrlRequests = rep })
1619+
1620+nextCtrlRequestId :: Accessor ValidRemoteEndPointState ControlRequestId
1621+nextCtrlRequestId = accessor _nextCtrlRequestId (\cid st -> st { _nextCtrlRequestId = cid })
1622+
1623+localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1624+localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1625+
1626+pendingCtrlRequestsAt :: ControlRequestId -> Accessor ValidRemoteEndPointState (Maybe (MVar (Either IOException [ByteString])))
1627+pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral ix)
1628+
1629+localConnectionTo :: EndPointAddress
1630+ -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1631+localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1632+
1633+-------------------------------------------------------------------------------
1634+-- Debugging --
1635+-------------------------------------------------------------------------------
1636+
1637+relyViolation :: EndPointPair -> String -> IO a
1638+relyViolation (ourEndPoint, theirEndPoint) str = do
1639+ elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1640+ fail (str ++ " RELY violation")
1641+
1642+elog :: EndPointPair -> String -> IO ()
1643+elog (ourEndPoint, theirEndPoint) msg = do
1644+ tid <- myThreadId
1645+ putStrLn $ show (localAddress ourEndPoint)
1646+ ++ "/" ++ show (remoteAddress theirEndPoint)
1647+ ++ "(" ++ show (remoteId theirEndPoint) ++ ")"
1648+ ++ "/" ++ show tid
1649+ ++ ": " ++ msg
network-transport-tcp/src/Network/Transport/TCP/Internal.hsnew file+116
@@ -0,0 +1,116 @@
1+-- | Utility functions for TCP sockets
2+module Network.Transport.TCP.Internal ( forkServer
3+ , recvWithLength
4+ , recvExact
5+ , recvInt32
6+ , tryCloseSocket
7+ ) where
8+
9+import Prelude hiding (catch)
10+import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)
11+import qualified Network.Socket as N ( HostName
12+ , ServiceName
13+ , Socket
14+ , SocketType(Stream)
15+ , SocketOption(ReuseAddr)
16+ , getAddrInfo
17+ , defaultHints
18+ , socket
19+ , bindSocket
20+ , listen
21+ , addrFamily
22+ , addrAddress
23+ , defaultProtocol
24+ , setSocketOption
25+ , accept
26+ , sClose
27+ )
28+import qualified Network.Socket.ByteString as NBS (recv)
29+import Control.Concurrent (ThreadId)
30+import Control.Monad (forever, when)
31+import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_)
32+import Control.Applicative ((<$>))
33+import Data.ByteString (ByteString)
34+import qualified Data.ByteString as BS (length, concat, null)
35+import Data.Int (Int32)
36+
37+-- | Start a server at the specified address.
38+--
39+-- This sets up a server socket for the specified host and port. Exceptions
40+-- thrown during setup are not caught.
41+--
42+-- Once the socket is created we spawn a new thread which repeatedly accepts
43+-- incoming connections and executes the given request handler. If any
44+-- exception occurs the thread terminates and calls the terminationHandler.
45+-- This exception may occur because of a call to 'N.accept', because the thread
46+-- was explicitly killed, or because of a synchronous exception thrown by the
47+-- request handler. Typically, you should avoid the last case by catching any
48+-- relevant exceptions in the request handler.
49+--
50+-- The request handler should spawn threads to handle each individual request
51+-- or the server will block. Once a thread has been spawned it will be the
52+-- responsibility of the new thread to close the socket when an exception
53+-- occurs.
54+forkServer :: N.HostName -- ^ Host
55+ -> N.ServiceName -- ^ Port
56+ -> Int -- ^ Backlog (maximum number of queued connections)
57+ -> Bool -- ^ Set ReuseAddr option?
58+ -> (SomeException -> IO ()) -- ^ Termination handler
59+ -> (N.Socket -> IO ()) -- ^ Request handler
60+ -> IO ThreadId
61+forkServer host port backlog reuseAddr terminationHandler requestHandler = do
62+ -- Resolve the specified address. By specification, getAddrInfo will never
63+ -- return an empty list (but will throw an exception instead) and will return
64+ -- the "best" address first, whatever that means
65+ addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
66+ bracketOnError (N.socket (N.addrFamily addr) N.Stream N.defaultProtocol)
67+ tryCloseSocket $ \sock -> do
68+ when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1
69+ N.bindSocket sock (N.addrAddress addr)
70+ N.listen sock backlog
71+ -- We start listening for incoming requests in a separate thread. When
72+ -- that thread is killed, we close the server socket and the termination
73+ -- handler. We have to make sure that the exception handler is installed
74+ -- /before/ any asynchronous exception occurs. So we mask_, then fork
75+ -- (the child thread inherits the masked state from the parent), then
76+ -- unmask only inside the catch.
77+ mask_ $ forkIOWithUnmask $ \unmask ->
78+ catch (unmask (forever $ acceptRequest sock)) $ \ex -> do
79+ tryCloseSocket sock
80+ terminationHandler ex
81+ where
82+ acceptRequest :: N.Socket -> IO ()
83+ acceptRequest sock = bracketOnError (N.accept sock)
84+ (tryCloseSocket . fst)
85+ (requestHandler . fst)
86+
87+-- | Read a length and then a payload of that length
88+recvWithLength :: N.Socket -> IO [ByteString]
89+recvWithLength sock = recvInt32 sock >>= recvExact sock
90+
91+-- | Receive a 32-bit integer
92+recvInt32 :: Num a => N.Socket -> IO a
93+recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
94+
95+-- | Close a socket, ignoring I/O exceptions
96+tryCloseSocket :: N.Socket -> IO ()
97+tryCloseSocket sock = void . tryIO $
98+ N.sClose sock
99+
100+-- | Read an exact number of bytes from a socket
101+--
102+-- Throws an I/O exception if the socket closes before the specified
103+-- number of bytes could be read
104+recvExact :: N.Socket -- ^ Socket to read from
105+ -> Int32 -- ^ Number of bytes to read
106+ -> IO [ByteString]
107+recvExact _ len | len <= 0 = throwIO (userError "recvExact: Negative length")
108+recvExact sock len = go [] len
109+ where
110+ go :: [ByteString] -> Int32 -> IO [ByteString]
111+ go acc 0 = return (reverse acc)
112+ go acc l = do
113+ bs <- NBS.recv sock (fromIntegral l `min` 4096)
114+ if BS.null bs
115+ then throwIO (userError "recvExact: Socket closed")
116+ else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport-tcp/tests/TestAuxiliary.hsnew file+108
@@ -0,0 +1,108 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TestAuxiliary ( -- Running tests
3+ runTest
4+ , runTests
5+ -- Writing tests
6+ , forkTry
7+ , trySome
8+ , randomThreadDelay
9+ ) where
10+
11+import Prelude hiding (catch)
12+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
13+import Control.Concurrent.Chan (Chan)
14+import Control.Monad (liftM2, unless)
15+import Control.Exception (SomeException, try, catch)
16+import System.Timeout (timeout)
17+import System.IO (stdout, hFlush)
18+import System.Console.ANSI ( SGR(SetColor, Reset)
19+ , Color(Red, Green)
20+ , ConsoleLayer(Foreground)
21+ , ColorIntensity(Vivid)
22+ , setSGR
23+ )
24+import System.Random (randomIO)
25+import Network.Transport
26+import Traced (Traceable(..), traceShow)
27+
28+-- | Like fork, but throw exceptions in the child thread to the parent
29+forkTry :: IO () -> IO ThreadId
30+forkTry p = do
31+ tid <- myThreadId
32+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
33+
34+-- | Like try, but specialized to SomeException
35+trySome :: IO a -> IO (Either SomeException a)
36+trySome = try
37+
38+-- | Run the given test, catching timeouts and exceptions
39+runTest :: String -> IO () -> IO Bool
40+runTest description test = do
41+ putStr $ "Running " ++ show description ++ ": "
42+ hFlush stdout
43+ done <- try . timeout 60000000 $ test -- 60 seconds
44+ case done of
45+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
46+ Right Nothing -> failed $ "(timeout)"
47+ Right (Just ()) -> ok
48+ where
49+ failed :: String -> IO Bool
50+ failed err = do
51+ setSGR [SetColor Foreground Vivid Red]
52+ putStr "failed "
53+ setSGR [Reset]
54+ putStrLn err
55+ return False
56+
57+ ok :: IO Bool
58+ ok = do
59+ setSGR [SetColor Foreground Vivid Green]
60+ putStrLn "ok"
61+ setSGR [Reset]
62+ return True
63+
64+-- | Run a bunch of tests and throw an exception if any fails
65+runTests :: [(String, IO ())] -> IO ()
66+runTests tests = do
67+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
68+ unless success $ fail "Some tests failed"
69+
70+-- | Random thread delay between 0 and the specified max
71+randomThreadDelay :: Int -> IO ()
72+randomThreadDelay maxDelay = do
73+ delay <- randomIO :: IO Int
74+ threadDelay (delay `mod` maxDelay)
75+
76+--------------------------------------------------------------------------------
77+-- traceShow instances --
78+--------------------------------------------------------------------------------
79+
80+instance Traceable EndPoint where
81+ trace = const Nothing
82+
83+instance Traceable Transport where
84+ trace = const Nothing
85+
86+instance Traceable Connection where
87+ trace = const Nothing
88+
89+instance Traceable Event where
90+ trace = traceShow
91+
92+instance Show err => Traceable (TransportError err) where
93+ trace = traceShow
94+
95+instance Traceable EndPointAddress where
96+ trace = traceShow . endPointAddressToByteString
97+
98+instance Traceable SomeException where
99+ trace = traceShow
100+
101+instance Traceable ThreadId where
102+ trace = const Nothing
103+
104+instance Traceable (Chan a) where
105+ trace = const Nothing
106+
107+instance Traceable Float where
108+ trace = traceShow
network-transport-tcp/tests/TestTCP.hsnew file+786
@@ -0,0 +1,786 @@
1+{-# LANGUAGE RebindableSyntax #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module Main where
4+
5+import Prelude hiding (catch, (>>=), (>>), return, fail)
6+import TestTransport (testTransport)
7+import TestAuxiliary (forkTry, runTests)
8+import Network.Transport
9+import Network.Transport.TCP ( createTransport
10+ , createTransportExposeInternals
11+ , TransportInternals(..)
12+ , encodeEndPointAddress
13+ , defaultTCPParameters
14+ )
15+import Data.Int (Int32)
16+import Control.Concurrent (threadDelay, killThread)
17+import Control.Concurrent.MVar ( MVar
18+ , newEmptyMVar
19+ , putMVar
20+ , takeMVar
21+ , readMVar
22+ , isEmptyMVar
23+ , newMVar
24+ , modifyMVar
25+ )
26+import Control.Monad (replicateM, guard, forM_, replicateM_, when)
27+import Control.Applicative ((<$>))
28+import Control.Exception (throwIO, try, SomeException)
29+import Network.Transport.TCP ( ControlHeader(..)
30+ , ConnectionRequestResponse(..)
31+ , socketToEndPoint
32+ )
33+import Network.Transport.Internal ( encodeInt32
34+ , prependLength
35+ , tlog
36+ , tryIO
37+ , void
38+ )
39+import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)
40+import qualified Network.Socket as N ( sClose
41+ , ServiceName
42+ , Socket
43+ , AddrInfo
44+ , shutdown
45+ , ShutdownCmd(ShutdownSend)
46+ )
47+import Network.Socket.ByteString (sendMany)
48+import Data.String (fromString)
49+import Traced
50+import GHC.IO.Exception (ioe_errno)
51+import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)
52+import System.Timeout (timeout)
53+
54+instance Traceable ControlHeader where
55+ trace = traceShow
56+
57+instance Traceable ConnectionRequestResponse where
58+ trace = traceShow
59+
60+instance Traceable N.Socket where
61+ trace = traceShow
62+
63+instance Traceable N.AddrInfo where
64+ trace = traceShow
65+
66+instance Traceable TransportInternals where
67+ trace = const Nothing
68+
69+-- Test that the server gets a ConnectionClosed message when the client closes
70+-- the socket without sending an explicit control message to the server first
71+testEarlyDisconnect :: IO N.ServiceName -> IO ()
72+testEarlyDisconnect nextPort = do
73+ clientAddr <- newEmptyMVar
74+ serverAddr <- newEmptyMVar
75+ serverDone <- newEmptyMVar
76+
77+ tlog "testEarlyDisconnect"
78+ forkTry $ server serverAddr clientAddr serverDone
79+ forkTry $ client serverAddr clientAddr
80+
81+ takeMVar serverDone
82+ where
83+ server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
84+ server serverAddr clientAddr serverDone = do
85+ tlog "Server"
86+ Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
87+ Right endpoint <- newEndPoint transport
88+ putMVar serverAddr (address endpoint)
89+ theirAddr <- readMVar clientAddr
90+
91+ -- TEST 1: they connect to us, then drop the connection
92+ do
93+ ConnectionOpened cid _ addr <- receive endpoint
94+ True <- return $ addr == theirAddr
95+
96+ ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid']) _) <- receive endpoint
97+ True <- return $ addr' == theirAddr && cid' == cid
98+
99+ return ()
100+
101+ -- TEST 2: after they dropped their connection to us, we now try to
102+ -- establish a connection to them. This should re-establish the broken
103+ -- TCP connection.
104+ tlog "Trying to connect to client"
105+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
106+
107+ -- TEST 3: To test the connection, we do a simple ping test; as before,
108+ -- however, the remote client won't close the connection nicely but just
109+ -- closes the socket
110+ do
111+ Right () <- send conn ["ping"]
112+
113+ ConnectionOpened cid _ addr <- receive endpoint
114+ True <- return $ addr == theirAddr
115+
116+ Received cid' ["pong"] <- receive endpoint
117+ True <- return $ cid == cid'
118+
119+ ErrorEvent (TransportError (EventConnectionLost (Just addr') [cid'']) _) <- receive endpoint
120+ True <- return $ addr' == theirAddr && cid'' == cid
121+
122+ return ()
123+
124+ -- TEST 4: A subsequent send on an already-open connection will now break
125+ Left (TransportError SendFailed _) <- send conn ["ping2"]
126+
127+ -- *Pfew*
128+ putMVar serverDone ()
129+
130+ client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
131+ client serverAddr clientAddr = do
132+ tlog "Client"
133+ clientPort <- nextPort
134+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
135+ putMVar clientAddr ourAddress
136+
137+ -- Listen for incoming messages
138+ forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
139+ -- Initial setup
140+ 0 <- recvInt32 sock :: IO Int
141+ _ <- recvWithLength sock
142+ sendMany sock [encodeInt32 ConnectionRequestAccepted]
143+
144+ -- Server requests a logical connection
145+ RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
146+ reqId <- recvInt32 sock :: IO Int
147+ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
148+
149+ -- Server sends a message
150+ 10001 <- recvInt32 sock :: IO Int
151+ ["ping"] <- recvWithLength sock
152+
153+ -- Reply
154+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
155+ ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
156+ 10002 <- recvInt32 sock :: IO Int
157+ [cid] <- recvWithLength sock
158+ sendMany sock (cid : prependLength ["pong"])
159+
160+ -- Close the socket
161+ N.sClose sock
162+
163+ -- Connect to the server
164+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
165+
166+ -- Request a new connection, but don't wait for the response
167+ let reqId = 0 :: Int32
168+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
169+
170+ -- Close the socket without closing the connection explicitly
171+ -- The server should receive an error event
172+ N.sClose sock
173+
174+-- | Test the behaviour of a premature CloseSocket request
175+testEarlyCloseSocket :: IO N.ServiceName -> IO ()
176+testEarlyCloseSocket nextPort = do
177+ clientAddr <- newEmptyMVar
178+ serverAddr <- newEmptyMVar
179+ serverDone <- newEmptyMVar
180+
181+ tlog "testEarlyDisconnect"
182+ forkTry $ server serverAddr clientAddr serverDone
183+ forkTry $ client serverAddr clientAddr
184+
185+ takeMVar serverDone
186+ where
187+ server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
188+ server serverAddr clientAddr serverDone = do
189+ tlog "Server"
190+ Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
191+ Right endpoint <- newEndPoint transport
192+ putMVar serverAddr (address endpoint)
193+ theirAddr <- readMVar clientAddr
194+
195+ -- TEST 1: they connect to us, then send a CloseSocket. Since we don't
196+ -- have any outgoing connections, this means we will agree to close the
197+ -- socket
198+ do
199+ ConnectionOpened cid _ addr <- receive endpoint
200+ True <- return $ addr == theirAddr
201+
202+ ConnectionClosed cid' <- receive endpoint
203+ True <- return $ cid' == cid
204+
205+ return ()
206+
207+ -- TEST 2: after they dropped their connection to us, we now try to
208+ -- establish a connection to them. This should re-establish the broken
209+ -- TCP connection.
210+ tlog "Trying to connect to client"
211+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
212+
213+ -- TEST 3: To test the connection, we do a simple ping test; as before,
214+ -- however, the remote client won't close the connection nicely but just
215+ -- sends a CloseSocket -- except that now we *do* have outgoing
216+ -- connections, so we won't agree and hence will receive an error when
217+ -- the socket gets closed
218+ do
219+ Right () <- send conn ["ping"]
220+
221+ ConnectionOpened cid _ addr <- receive endpoint
222+ True <- return $ addr == theirAddr
223+
224+ Received cid' ["pong"] <- receive endpoint
225+ True <- return $ cid' == cid
226+
227+ ConnectionClosed cid'' <- receive endpoint
228+ True <- return $ cid'' == cid
229+
230+ ErrorEvent (TransportError (EventConnectionLost (Just addr') []) _) <- receive endpoint
231+ True <- return $ addr' == theirAddr
232+
233+ return ()
234+
235+ -- TEST 4: A subsequent send on an already-open connection will now break
236+ Left (TransportError SendFailed _) <- send conn ["ping2"]
237+
238+ -- *Pfew*
239+ putMVar serverDone ()
240+
241+ client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
242+ client serverAddr clientAddr = do
243+ tlog "Client"
244+ clientPort <- nextPort
245+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
246+ putMVar clientAddr ourAddress
247+
248+ -- Listen for incoming messages
249+ forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
250+ -- Initial setup
251+ 0 <- recvInt32 sock :: IO Int
252+ _ <- recvWithLength sock
253+ sendMany sock [encodeInt32 ConnectionRequestAccepted]
254+
255+ -- Server requests a logical connection
256+ RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
257+ reqId <- recvInt32 sock :: IO Int
258+ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
259+
260+ -- Server sends a message
261+ 10001 <- recvInt32 sock :: IO Int
262+ ["ping"] <- recvWithLength sock
263+
264+ -- Reply
265+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 (10002 :: Int)]
266+ ControlResponse <- toEnum <$> (recvInt32 sock :: IO Int)
267+ 10002 <- recvInt32 sock :: IO Int
268+ [cid] <- recvWithLength sock
269+ sendMany sock (cid : prependLength ["pong"])
270+
271+ -- Send a CloseSocket even though there are still connections *in both
272+ -- directions*
273+ sendMany sock [encodeInt32 CloseSocket]
274+ N.sClose sock
275+
276+ -- Connect to the server
277+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
278+
279+ -- Request a new connection, but don't wait for the response
280+ let reqId = 0 :: Int32
281+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
282+
283+ -- Send a CloseSocket without sending a closeconnecton
284+ -- The server should still receive a ConnectionClosed message
285+ sendMany sock [encodeInt32 CloseSocket]
286+ N.sClose sock
287+
288+-- | Test the creation of a transport with an invalid address
289+testInvalidAddress :: IO N.ServiceName -> IO ()
290+testInvalidAddress nextPort = do
291+ Left _ <- nextPort >>= \port -> createTransport "invalidHostName" port defaultTCPParameters
292+ return ()
293+
294+-- | Test connecting to invalid or non-existing endpoints
295+testInvalidConnect :: IO N.ServiceName -> IO ()
296+testInvalidConnect nextPort = do
297+ port <- nextPort
298+ Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
299+ Right endpoint <- newEndPoint transport
300+
301+ -- Syntax error in the endpoint address
302+ Left (TransportError ConnectFailed _) <-
303+ connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints
304+
305+ -- Syntax connect, but invalid hostname (TCP address lookup failure)
306+ Left (TransportError ConnectNotFound _) <-
307+ connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints
308+
309+ -- TCP address correct, but nobody home at that address
310+ Left (TransportError ConnectNotFound _) <-
311+ connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints
312+
313+ -- Valid TCP address but invalid endpoint number
314+ Left (TransportError ConnectNotFound _) <-
315+ connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered defaultConnectHints
316+
317+ return ()
318+
319+-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
320+-- would happen when the endpoint sends a new connection request before
321+-- receiving an (already underway) CloseSocket request)
322+testIgnoreCloseSocket :: IO N.ServiceName -> IO ()
323+testIgnoreCloseSocket nextPort = do
324+ serverAddr <- newEmptyMVar
325+ clientDone <- newEmptyMVar
326+ Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
327+
328+ forkTry $ server transport serverAddr
329+ forkTry $ client transport serverAddr clientDone
330+
331+ takeMVar clientDone
332+
333+ where
334+ server :: Transport -> MVar EndPointAddress -> IO ()
335+ server transport serverAddr = do
336+ tlog "Server"
337+ Right endpoint <- newEndPoint transport
338+ putMVar serverAddr (address endpoint)
339+
340+ -- Wait for the client to connect and disconnect
341+ tlog "Waiting for ConnectionOpened"
342+ ConnectionOpened _ _ _ <- receive endpoint
343+ tlog "Waiting for ConnectionClosed"
344+ ConnectionClosed _ <- receive endpoint
345+
346+ -- At this point the server will have sent a CloseSocket request to the
347+ -- client, which however ignores it, instead it requests and closes
348+ -- another connection
349+ tlog "Waiting for ConnectionOpened"
350+ ConnectionOpened _ _ _ <- receive endpoint
351+ tlog "Waiting for ConnectionClosed"
352+ ConnectionClosed _ <- receive endpoint
353+
354+
355+ tlog "Server waiting.."
356+
357+ client :: Transport -> MVar EndPointAddress -> MVar () -> IO ()
358+ client transport serverAddr clientDone = do
359+ tlog "Client"
360+ Right endpoint <- newEndPoint transport
361+ let ourAddress = address endpoint
362+
363+ -- Connect to the server
364+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
365+
366+ -- Request a new connection
367+ tlog "Requesting connection"
368+ let reqId = 0 :: Int32
369+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
370+ response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
371+
372+ -- Close the connection again
373+ tlog "Closing connection"
374+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
375+
376+ -- Server will now send a CloseSocket request as its refcount reached 0
377+ tlog "Waiting for CloseSocket request"
378+ CloseSocket <- toEnum <$> recvInt32 sock
379+
380+ -- But we ignore it and request another connection
381+ tlog "Ignoring it, requesting another connection"
382+ let reqId' = 1 :: Int32
383+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
384+ response' <- replicateM 4 $ recvInt32 sock :: IO [Int32]
385+
386+ -- Close it again
387+ tlog "Closing connection"
388+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response' !! 3)]
389+
390+ -- We now get a CloseSocket again, and this time we heed it
391+ tlog "Waiting for second CloseSocket request"
392+ CloseSocket <- toEnum <$> recvInt32 sock
393+
394+ tlog "Closing socket"
395+ sendMany sock [encodeInt32 CloseSocket]
396+ N.sClose sock
397+
398+ putMVar clientDone ()
399+
400+-- | Like 'testIgnoreSocket', but now the server requests a connection after the
401+-- client closed their connection. In the meantime, the server will have sent a
402+-- CloseSocket request to the client, and must block until the client responds.
403+testBlockAfterCloseSocket :: IO N.ServiceName -> IO ()
404+testBlockAfterCloseSocket nextPort = do
405+ serverAddr <- newEmptyMVar
406+ clientAddr <- newEmptyMVar
407+ clientDone <- newEmptyMVar
408+ port <- nextPort
409+ Right transport <- createTransport "127.0.0.1" port defaultTCPParameters
410+
411+ forkTry $ server transport serverAddr clientAddr
412+ forkTry $ client transport serverAddr clientAddr clientDone
413+
414+ takeMVar clientDone
415+
416+ where
417+ server :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> IO ()
418+ server transport serverAddr clientAddr = do
419+ tlog "Server"
420+ Right endpoint <- newEndPoint transport
421+ putMVar serverAddr (address endpoint)
422+
423+ -- Wait for the client to connect and disconnect
424+ tlog "Waiting for ConnectionOpened"
425+ ConnectionOpened _ _ _ <- receive endpoint
426+ tlog "Waiting for ConnectionClosed"
427+ ConnectionClosed _ <- receive endpoint
428+
429+ -- At this point the server will have sent a CloseSocket request to the
430+ -- client, and must block until the client responds
431+ tlog "Server waiting to connect to the client.."
432+ Right _ <- readMVar clientAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
433+
434+ tlog "Server waiting.."
435+
436+ client :: Transport -> MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
437+ client transport serverAddr clientAddr clientDone = do
438+ tlog "Client"
439+ Right endpoint <- newEndPoint transport
440+ putMVar clientAddr (address endpoint)
441+ let ourAddress = address endpoint
442+
443+ -- Connect to the server
444+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
445+
446+ -- Request a new connection
447+ tlog "Requesting connection"
448+ let reqId = 0 :: Int32
449+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
450+ response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
451+
452+ -- Close the connection again
453+ tlog "Closing connection"
454+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
455+
456+ -- Server will now send a CloseSocket request as its refcount reached 0
457+ tlog "Waiting for CloseSocket request"
458+ CloseSocket <- toEnum <$> recvInt32 sock
459+
460+ unblocked <- newEmptyMVar
461+
462+ -- We should not hear from the server until we unblock him by
463+ -- responding to the CloseSocket request (in this case, we
464+ -- respond by sending a ConnectionRequest)
465+ forkTry $ do
466+ recvInt32 sock :: IO Int32
467+ isEmptyMVar unblocked >>= (guard . not)
468+ putMVar clientDone ()
469+
470+ threadDelay 1000000
471+
472+ tlog "Client ignores close socket and sends connection request"
473+ tlog "This should unblock the server"
474+ putMVar unblocked ()
475+ let reqId' = 1 :: Int32
476+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
477+
478+-- | Test what happens when a remote endpoint sends a connection request to our
479+-- transport for an endpoint it already has a connection to
480+testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()
481+testUnnecessaryConnect nextPort numThreads = do
482+ clientDone <- newEmptyMVar
483+ serverAddr <- newEmptyMVar
484+
485+ forkTry $ do
486+ Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
487+ Right endpoint <- newEndPoint transport
488+ putMVar serverAddr (address endpoint)
489+
490+ forkTry $ do
491+ -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check
492+ let ourAddress = EndPointAddress "126.0.0.1"
493+
494+ -- We should only get a single 'Accepted' reply
495+ gotAccepted <- newEmptyMVar
496+ dones <- replicateM numThreads $ do
497+ done <- newEmptyMVar
498+ forkTry $ do
499+ -- It is possible that the remote endpoint just rejects the request by closing the socket
500+ -- immediately (depending on far the remote endpoint got with the initialization)
501+ response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
502+ case response of
503+ Right (_, ConnectionRequestAccepted) ->
504+ -- We don't close this socket because we want to keep this connection open
505+ putMVar gotAccepted ()
506+ -- We might get either Invalid or Crossed (the transport does not
507+ -- maintain enough history to be able to tell)
508+ Right (sock, ConnectionRequestInvalid) ->
509+ N.sClose sock
510+ Right (sock, ConnectionRequestCrossed) ->
511+ N.sClose sock
512+ Left _ ->
513+ return ()
514+ putMVar done ()
515+ return done
516+
517+ mapM_ readMVar (gotAccepted : dones)
518+ putMVar clientDone ()
519+
520+ takeMVar clientDone
521+
522+-- | Test that we can create "many" transport instances
523+testMany :: IO N.ServiceName -> IO ()
524+testMany nextPort = do
525+ Right masterTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
526+ Right masterEndPoint <- newEndPoint masterTransport
527+
528+ replicateM_ 10 $ do
529+ mTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
530+ case mTransport of
531+ Left ex -> do
532+ putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)
533+ case (ioe_errno ex) of
534+ Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"
535+ _ -> return ()
536+ throwIO ex
537+ Right transport ->
538+ replicateM_ 2 $ do
539+ Right endpoint <- newEndPoint transport
540+ Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered defaultConnectHints
541+ return ()
542+
543+-- | Test what happens when the transport breaks completely
544+testBreakTransport :: IO N.ServiceName -> IO ()
545+testBreakTransport nextPort = do
546+ Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
547+ Right endpoint <- newEndPoint transport
548+
549+ killThread (transportThread internals) -- Uh oh
550+
551+ ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint
552+
553+ return ()
554+
555+-- | Test that a second call to 'connect' might succeed even if the first
556+-- failed. This is a TCP specific test rather than an endpoint specific test
557+-- because we must manually create the endpoint address to match an endpoint we
558+-- have yet to set up.
559+-- Then test that we get a connection lost message after the remote endpoint
560+-- suddenly closes the socket, and that a subsequent 'connect' allows us to
561+-- re-establish a connection to the same endpoint
562+testReconnect :: IO N.ServiceName -> IO ()
563+testReconnect nextPort = do
564+ serverPort <- nextPort
565+ serverDone <- newEmptyMVar
566+ firstAttempt <- newEmptyMVar
567+ endpointCreated <- newEmptyMVar
568+
569+ -- Server
570+ forkTry $ do
571+ -- Wait for the client to do its first attempt
572+ readMVar firstAttempt
573+
574+ counter <- newMVar (0 :: Int)
575+
576+ forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
577+ -- Accept the connection
578+ Right 0 <- tryIO $ (recvInt32 sock :: IO Int)
579+ Right _ <- tryIO $ recvWithLength sock
580+ Right () <- tryIO $ sendMany sock [encodeInt32 ConnectionRequestAccepted]
581+
582+ -- The first time we close the socket before accepting the logical connection
583+ count <- modifyMVar counter $ \i -> return (i + 1, i)
584+
585+ when (count > 0) $ do
586+ -- Client requests a logical connection
587+ Right RequestConnectionId <- tryIO $ toEnum <$> (recvInt32 sock :: IO Int)
588+ Right reqId <- tryIO $ (recvInt32 sock :: IO Int)
589+ Right () <- tryIO $ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
590+ return ()
591+
592+ when (count > 1) $ do
593+ -- Client sends a message
594+ Right 10001 <- tryIO $ (recvInt32 sock :: IO Int)
595+ Right ["ping"] <- tryIO $ recvWithLength sock
596+ putMVar serverDone ()
597+
598+ Right () <- tryIO $ N.sClose sock
599+ return ()
600+
601+ putMVar endpointCreated ()
602+
603+ -- Client
604+ forkTry $ do
605+ Right transport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
606+ Right endpoint <- newEndPoint transport
607+ let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
608+
609+ -- The first attempt will fail because no endpoint is yet set up
610+ -- Left (TransportError ConnectNotFound _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
611+ putMVar firstAttempt ()
612+
613+ -- The second attempt will fail because the server closes the socket before we can request a connection
614+ takeMVar endpointCreated
615+ -- This might time out or not, depending on whether the server closes the
616+ -- socket before or after we can send the RequestConnectionId request
617+ resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints
618+ case resultConnect of
619+ Nothing -> return ()
620+ Just (Left (TransportError ConnectFailed _)) -> return ()
621+ Just (Left err) -> throwIO err
622+ Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
623+
624+ -- The third attempt succeeds
625+ Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
626+
627+ -- But a send will fail because the server has closed the connection again
628+ Left (TransportError SendFailed _) <- send conn1 ["ping"]
629+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
630+
631+ -- But a subsequent call to connect should reestablish the connection
632+ Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
633+
634+ -- Send should now succeed
635+ Right () <- send conn2 ["ping"]
636+ return ()
637+
638+ takeMVar serverDone
639+
640+-- Test what happens if we close the socket one way only. This means that the
641+-- 'recv' in 'handleIncomingMessages' will not fail, but a 'send' or 'connect'
642+-- *will* fail. We are testing that error handling everywhere does the right
643+-- thing.
644+testUnidirectionalError :: IO N.ServiceName -> IO ()
645+testUnidirectionalError nextPort = do
646+ clientDone <- newEmptyMVar
647+ serverPort <- nextPort
648+ serverGotPing <- newEmptyMVar
649+
650+ -- Server
651+ forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
652+ -- We accept connections, but when an exception occurs we don't do
653+ -- anything (in particular, we don't close the socket). This is important
654+ -- because when we shutdown one direction of the socket a recv here will
655+ -- fail, but we don't want to close that socket at that point (which
656+ -- would shutdown the socket in the other direction)
657+ void . (try :: IO () -> IO (Either SomeException ())) $ do
658+ 0 <- recvInt32 sock :: IO Int
659+ _ <- recvWithLength sock
660+ () <- sendMany sock [encodeInt32 ConnectionRequestAccepted]
661+
662+ RequestConnectionId <- toEnum <$> (recvInt32 sock :: IO Int)
663+ reqId <- recvInt32 sock :: IO Int
664+ sendMany sock (encodeInt32 ControlResponse : encodeInt32 reqId : prependLength [encodeInt32 (10001 :: Int)])
665+
666+ 10001 <- recvInt32 sock :: IO Int
667+ ["ping"] <- recvWithLength sock
668+ putMVar serverGotPing ()
669+
670+ -- Client
671+ forkTry $ do
672+ Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
673+ Right endpoint <- newEndPoint transport
674+ let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
675+
676+ -- Establish a connection to the server
677+ Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
678+ send conn1 ["ping"]
679+ takeMVar serverGotPing
680+
681+ -- Close the *outgoing* part of the socket only
682+ sock <- socketBetween internals (address endpoint) theirAddr
683+ N.shutdown sock N.ShutdownSend
684+
685+ -- At this point we cannot notice the problem yet so we shouldn't receive an event yet
686+ Nothing <- timeout 500000 $ receive endpoint
687+
688+ -- But when we send we find the error
689+ Left (TransportError SendFailed _) <- send conn1 ["ping"]
690+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
691+
692+ -- A call to connect should now re-establish the connection
693+ Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
694+ send conn2 ["ping"]
695+ takeMVar serverGotPing
696+
697+ -- Again, close the outgoing part of the socket
698+ sock' <- socketBetween internals (address endpoint) theirAddr
699+ N.shutdown sock' N.ShutdownSend
700+
701+ -- We now find the error when we attempt to close the connection
702+ Nothing <- timeout 500000 $ receive endpoint
703+ close conn2
704+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
705+ Right conn3 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
706+ send conn3 ["ping"]
707+ takeMVar serverGotPing
708+
709+ -- We repeat once more.
710+ sock'' <- socketBetween internals (address endpoint) theirAddr
711+ N.shutdown sock'' N.ShutdownSend
712+
713+ -- Now we notice the problem when we try to connect
714+ Nothing <- timeout 500000 $ receive endpoint
715+ Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
716+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint
717+ Right conn4 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
718+ send conn4 ["ping"]
719+ takeMVar serverGotPing
720+
721+ putMVar clientDone ()
722+
723+ takeMVar clientDone
724+
725+testInvalidCloseConnection :: IO N.ServiceName -> IO ()
726+testInvalidCloseConnection nextPort = do
727+ Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
728+ serverAddr <- newEmptyMVar
729+ clientDone <- newEmptyMVar
730+ serverDone <- newEmptyMVar
731+
732+ -- Server
733+ forkTry $ do
734+ Right endpoint <- newEndPoint transport
735+ putMVar serverAddr (address endpoint)
736+
737+ ConnectionOpened _ _ _ <- receive endpoint
738+
739+ -- At this point the client sends an invalid request, so we terminate the
740+ -- connection
741+ ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint
742+
743+ putMVar serverDone ()
744+
745+ -- Client
746+ forkTry $ do
747+ Right endpoint <- newEndPoint transport
748+ let ourAddr = address endpoint
749+
750+ -- Connect so that we have a TCP connection
751+ theirAddr <- readMVar serverAddr
752+ Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
753+
754+ -- Get a handle on the TCP connection and manually send an invalid CloseConnection request
755+ sock <- socketBetween internals ourAddr theirAddr
756+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (12345 :: Int)]
757+
758+ putMVar clientDone ()
759+
760+ mapM_ takeMVar [clientDone, serverDone]
761+
762+main :: IO ()
763+main = do
764+ portMVar <- newEmptyMVar
765+ forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
766+ let nextPort = takeMVar portMVar
767+ tcpResult <- tryIO $ runTests
768+ [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
769+ , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
770+ , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
771+ , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)
772+ , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort 10)
773+ , ("InvalidAddress", testInvalidAddress nextPort)
774+ , ("InvalidConnect", testInvalidConnect nextPort)
775+ , ("Many", testMany nextPort)
776+ , ("BreakTransport", testBreakTransport nextPort)
777+ , ("Reconnect", testReconnect nextPort)
778+ , ("UnidirectionalError", testUnidirectionalError nextPort)
779+ , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)
780+ ]
781+ -- Run the generic tests even if the TCP specific tests failed..
782+ testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)
783+ -- ..but if the generic tests pass, still fail if the specific tests did not
784+ case tcpResult of
785+ Left err -> throwIO err
786+ Right () -> return ()
network-transport-tcp/tests/TestTransport.hsnew file+956

This diff is too big to show here.

network-transport-tcp/tests/Traced.hsnew file+191

This diff is too big to show here.

network-transport/ChangeLognew file+3

This diff is too big to show here.

network-transport/LICENSEnew file+31

This diff is too big to show here.

network-transport/Setup.hsnew file+2

This diff is too big to show here.

network-transport/network-transport.cabalnew file+80

This diff is too big to show here.

network-transport/src/Network/Transport.hsnew file+226

This diff is too big to show here.

network-transport/src/Network/Transport/Internal.hsnew file+150

This diff is too big to show here.

network-transport/src/Network/Transport/Util.hsnew file+24

This diff is too big to show here.

network-transport/tests/chat/ChatClient.hsnew file+107

This diff is too big to show here.

network-transport/tests/chat/ChatServer.hsnew file+28

This diff is too big to show here.

network-transport/tests/sumeuler/SumEulerMaster.hsnew file+44

This diff is too big to show here.

network-transport/tests/sumeuler/SumEulerWorker.hsnew file+52

This diff is too big to show here.

network-transport/tests/sumeuler/sumeuler.shnew file+20

This diff is too big to show here.

src/Control/Distributed/Process.hsdeleted−447

This diff is too big to show here.

src/Control/Distributed/Process/Closure.hsdeleted−244

This diff is too big to show here.

src/Control/Distributed/Process/Debug.hsdeleted−288

This diff is too big to show here.

src/Control/Distributed/Process/Internal/BiMultiMap.hsdeleted−135

This diff is too big to show here.

src/Control/Distributed/Process/Internal/CQueue.hsdeleted−300

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Closure/BuiltIn.hsdeleted−320

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Closure/Explicit.hsdeleted−147

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Closure/TH.hsdeleted−330

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Messaging.hsdeleted−207

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Primitives.hsdeleted−1363

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Spawn.hsdeleted−165

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictContainerAccessors.hsdeleted−21

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictList.hsdeleted−27

This diff is too big to show here.

src/Control/Distributed/Process/Internal/StrictMVar.hsdeleted−93

This diff is too big to show here.

src/Control/Distributed/Process/Internal/Types.hsdeleted−887

This diff is too big to show here.

src/Control/Distributed/Process/Internal/WeakTQueue.hsdeleted−107

This diff is too big to show here.

src/Control/Distributed/Process/Management.hsdeleted−509

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Agent.hsdeleted−157

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Bus.hsdeleted−21

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hsdeleted−179

This diff is too big to show here.

src/Control/Distributed/Process/Management/Internal/Trace/Remote.hsdeleted−61

This diff is too big to show here.

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/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.