git.iko.soy/distributed-process
on master help sign in
Merge branch 'master' of github.com:haskell-distributed/distributed-process
commit00f0e540169024131ff921ac00a826082cd6e69c authorEdsko de Vries <edsko@edsko.net> dateWed 25 Jul 2012, 14:11 (14 years ago) parentb98867641112a5
47 files changed+745−3372
compare with master
unifiedsplit
README.md+18−103 benchmarks/.gitignore−3 benchmarks/Headers.gnuplot−16 benchmarks/Indirection.gnuplot−16 benchmarks/JustPingC.c−150 benchmarks/JustPingCacheHeader.hs−134 benchmarks/JustPingHaskell.hs−105 benchmarks/JustPingOneRecv.hs−131 benchmarks/JustPingThroughChan.hs−127 benchmarks/JustPingThroughMVar.hs−127 benchmarks/JustPingTransport.hs−95 benchmarks/JustPingTwoSocketPairs.hs−151 benchmarks/JustPingWithHeader.hs−131 benchmarks/Makefile−72 benchmarks/Makefile.JustPing−52 benchmarks/NewTransport.gnuplot−8 benchmarks/PingPipes.hs−112 benchmarks/PingTCP.hs−133 benchmarks/PingTCPTransport.hs−128 benchmarks/SendTCP.hs−109 benchmarks/SendTransport.hs−117 benchmarks/pingtest.c−183 benchmarks/results_notes.md−111 distributed-process/ChangeLog+12 distributed-process/distributed-process.cabal+2−2 distributed-process/src/Control/Distributed/Process.hs+28 distributed-process/src/Control/Distributed/Process/Closure.hs+125−58 distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+3−3 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+71−50 distributed-process/src/Control/Distributed/Process/Internal/MessageT.hs−130 distributed-process/src/Control/Distributed/Process/Internal/Node.hs+84−9 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+25−21 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+21−30 distributed-process/src/Control/Distributed/Process/Node.hs+64−47 distributed-process/tests/TestCH.hs+19 distributed-process/tests/TestClosure.hs+15 doc/reconnect/blacklist.tex+255 examples/.gitignore−1 examples/DemoProcess.hs−36 examples/DemoTCP.hs−113 examples/DemoTransport.hs−192 examples/Makefile−20 install_all.sh−18 network-transport-pipes/LICENSE−31 network-transport-pipes/network-transport-pipes.cabal−33 network-transport-pipes/src/Network/Transport/Pipes.hs−264 network-transport-tcp/network-transport-tcp.cabal+3
README.md+18−103
@@ -1,114 +1,29 @@
11Haskell Distributed Project
22===========================
33
4−This repository holds an implementation of [Cloud Haskell][1] based on the work
5−of Jeff Epstein, Andrew Black, and Simon Peyton-Jones.
4+This repository holds an implementation of [Cloud Haskell][1].
65
7−At present, this repository hosts two packages:
6+At present, this repository hosts
87
9−* distributed-process
108* network-transport
9+* network-transport-tcp
10+* network-transport-inmemory (incomplete)
11+* distributed-process
12+* distributed-process-simplelocalnet
13+* azure-service-api (skeleton only)
1114
1215For more detailed information about the interfaces provided by these packages,
13−please refer to the [distributed-process repository wiki][2].
14−
15−Examples
16−--------
17−
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
16+please refer to the [distributed-process repository wiki][2]. People who wish
17+to get started with Cloud Haskell should cabal install
18+distributed-process and possibly distributed-process-simplelocalnet and refer
19+to the corresponding Haddock documentation ([Control.Distributed.Process][3],
20+[Control.Distributed.Process.Closure][4],
21+[Control.Distributed.Process.Node][5], and
22+[Control.Distributed.Process.Backend.SimpleLocalnet][6]).
11223
11324[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
11425[2]: https://github.com/haskell-distributed/distributed-process/wiki
26+[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html
27+[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html
28+[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html
29+[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html
benchmarks/.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−*.swp
2−*.exe
3−*.data
benchmarks/Headers.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
4− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
5− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
6− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
7− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
8− "JustPingC.data" smooth bezier with lines title "JustPingC"
9−set terminal postscript color
10−set output "Headers.ps"
11−plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \
12− "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
13− "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
14− "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \
15− "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \
16− "JustPingC.data" smooth bezier with lines title "JustPingC"
benchmarks/Indirection.gnuplotdeleted−16
@@ -1,16 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
4− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
5− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
6− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
7− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
8− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
9−set terminal postscript color
10−set output "Indirection.ps"
11−plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \
12− "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \
13− "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \
14− "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \
15− "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \
16− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
benchmarks/JustPingC.cdeleted−150
@@ -1,150 +0,0 @@
1−#include <stdio.h>
2−#include <stdlib.h>
3−#include <sys/types.h>
4−#include <sys/socket.h>
5−#include <netdb.h>
6−#include <string.h>
7−#include <unistd.h>
8−#include <signal.h>
9−#include <errno.h>
10−#include <time.h>
11−#include <sys/time.h>
12−#include <math.h>
13−
14−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
15−double timestamp() {
16− struct timeval tp;
17− gettimeofday(&tp, NULL);
18− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
19−}
20−
21−int server() {
22− printf("starting server\n");
23−
24− struct addrinfo hints, *res;
25− int error, server_socket;
26−
27− memset(&hints, 0, sizeof(hints));
28− hints.ai_family = PF_INET;
29− hints.ai_socktype = SOCK_STREAM;
30− hints.ai_flags = AI_PASSIVE;
31−
32− error = getaddrinfo(NULL, "8080", &hints, &res);
33− if(error) {
34− printf("server error: %s\n", gai_strerror(error));
35− return -1;
36− }
37−
38− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
39− if(server_socket < 0) {
40− printf("server error: could not create socket\n");
41− return -1;
42− }
43−
44− int yes = 1;
45− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
46− printf("server error: could not set socket options\n");
47− return -1;
48− }
49−
50− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
51− printf("server error: could not bind to socket\n");
52− return -1;
53− }
54−
55− listen(server_socket, 5);
56−
57− int client_socket;
58− struct sockaddr_storage client_addr;
59− socklen_t addr_size;
60− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
61−
62− for(;;) {
63− char* buf = malloc(8);
64− ssize_t read = recv(client_socket, buf, 8, 0);
65− if(read == 0) {
66− free(buf);
67− break;
68− }
69− // printf("server received '%s'\n", buf);
70− send(client_socket, buf, 8, 0);
71− free(buf);
72− }
73−
74− freeaddrinfo(res);
75− return 0;
76−}
77−
78−int client(int pings) {
79− printf("starting client\n");
80−
81− struct addrinfo hints, *res;
82− int error, client_socket;
83−
84− memset(&hints, 0, sizeof(hints));
85− hints.ai_family = PF_INET;
86− hints.ai_socktype = SOCK_STREAM;
87−
88− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
89− if(error) {
90− printf("client error: %s\n", gai_strerror(error));
91− return -1;
92− }
93−
94− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
95− if(client_socket < 0) {
96− printf("client error: could not create socket\n");
97− return -1;
98− }
99−
100− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
101− printf("client error: could not connect: %s\n", strerror(errno));
102− return -1;
103− }
104−
105− for(int i = 0; i < pings; i++) {
106− double timestamp_before = timestamp();
107−
108− send(client_socket, "ping123", 8, 0);
109−
110− char *buf = malloc(8);
111− ssize_t read = recv(client_socket, buf, 8, 0);
112−
113− if(read == 0) {
114− printf("server exited prematurely\n");
115− free(buf);
116− break;
117− }
118−
119− // printf("client received '%s'\n", buf);
120− free(buf);
121−
122− double timestamp_after = timestamp();
123− fprintf(stderr, "%i %lf\n", i, timestamp_after - timestamp_before);
124− }
125−
126− printf("client did %d pings\n", pings);
127−
128− freeaddrinfo(res);
129− return 0;
130−}
131−
132−int usage(int argc, char** argv) {
133− printf("usage: %s <number of pings>\n", argv[0]);
134− return -1;
135−}
136−
137−int main(int argc, char** argv) {
138− if(argc != 2) {
139− return usage(argc, argv);
140− }
141−
142− if(fork() == 0) {
143− // TODO: we should wait until we know the server is ready
144− int pings = 0;
145− sscanf(argv[1], "%d", &pings);
146− return client(pings);
147− } else {
148− return server();
149− }
150−}
benchmarks/JustPingCacheHeader.hsdeleted−134
@@ -1,134 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− -- Ignore header
111− return payload
112−
113−-- | Cached header
114−header :: ByteString
115−header = pack "fake"
116−
117−-- | Wrapper around NBS.send (for profiling)
118−send :: Socket -> ByteString -> IO ()
119−send sock bs = do
120− NBS.sendMany sock [header, bs]
121−
122−-- | Encode length (manual for now)
123−encodeLength :: Int32 -> IO ByteString
124−encodeLength i32 =
125− BSI.create 4 $ \p ->
126− pokeByteOff p 0 (htonl (fromIntegral i32))
127−
128−-- | Decode length (manual for now)
129−decodeLength :: ByteString -> IO Int32
130−decodeLength bs =
131− let (fp, _, _) = BSI.toForeignPtr bs in
132− withForeignPtr fp $ \p -> do
133− w32 <- peekByteOff p 0
134− return (fromIntegral (ntohl w32))
benchmarks/JustPingHaskell.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−
27−main :: IO ()
28−main = do
29− [pingsStr] <- getArgs
30− serverReady <- newEmptyMVar
31− clientDone <- newEmptyMVar
32−
33− -- Start the server
34− forkIO $ do
35− putStrLn "server: creating TCP connection"
36− serverAddrs <- getAddrInfo
37− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
38− Nothing
39− (Just "8080")
40− let serverAddr = head serverAddrs
41− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
42− setSocketOption sock ReuseAddr 1
43− bindSocket sock (addrAddress serverAddr)
44−
45− putStrLn "server: awaiting client connection"
46− putMVar serverReady ()
47− listen sock 1
48− (clientSock, clientAddr) <- accept sock
49−
50− putStrLn "server: listening for pings"
51− pong clientSock
52−
53− -- Start the client
54− forkIO $ do
55− takeMVar serverReady
56− let pings = read pingsStr
57− serverAddrs <- getAddrInfo
58− Nothing
59− (Just "127.0.0.1")
60− (Just "8080")
61− let serverAddr = head serverAddrs
62− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
63−
64− N.connect sock (addrAddress serverAddr)
65−
66− ping sock pings
67− putMVar clientDone ()
68−
69− -- Wait for the client to finish
70− takeMVar clientDone
71−
72−pingMessage :: ByteString
73−pingMessage = pack "ping123"
74−
75−ping :: Socket -> Int -> IO ()
76−ping sock pings = go pings
77− where
78− go :: Int -> IO ()
79− go 0 = do
80− putStrLn $ "client did " ++ show pings ++ " pings"
81− go !i = do
82− before <- getCurrentTime
83− send sock pingMessage
84− bs <- recv sock 8
85− after <- getCurrentTime
86− -- putStrLn $ "client received " ++ unpack bs
87− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
88− hPutStrLn stderr $ show i ++ " " ++ show latency
89− go (i - 1)
90−
91−pong :: Socket -> IO ()
92−pong sock = do
93− bs <- recv sock 8
94− -- putStrLn $ "server received " ++ unpack bs
95− when (BS.length bs > 0) $ do
96− send sock bs
97− pong sock
98−
99−-- | Wrapper around NBS.recv (for profiling)
100−recv :: Socket -> Int -> IO ByteString
101−recv = NBS.recv
102−
103−-- | Wrapper around NBS.send (for profiling)
104−send :: Socket -> ByteString -> IO Int
105−send = NBS.send
benchmarks/JustPingOneRecv.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock i = do
109− (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
110− length <- decodeLength header -- Ignored
111− return payload
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
benchmarks/JustPingThroughChan.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexChannel <- newChan
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToChan clientSock multiplexChannel
59−
60− -- Reply to the client
61− forever $ readChan multiplexChannel >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToChan :: Socket -> Chan ByteString -> IO ()
76−socketToChan sock chan = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− writeChan chan bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
benchmarks/JustPingThroughMVar.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− [pingsStr] <- getArgs
40− serverReady <- newEmptyMVar
41− clientDone <- newEmptyMVar
42−
43− -- Start the server
44− forkIO $ do
45− -- Initialize the server
46− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
47− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
48− setSocketOption sock ReuseAddr 1
49− bindSocket sock (addrAddress serverAddr)
50− listen sock 1
51−
52− -- Set up multiplexing channel
53− multiplexMVar <- newEmptyMVar
54−
55− -- Wait for incoming connections (pings from the client)
56− putMVar serverReady ()
57− (clientSock, pingAddr) <- accept sock
58− forkIO $ socketToMVar clientSock multiplexMVar
59−
60− -- Reply to the client
61− forever $ takeMVar multiplexMVar >>= send clientSock
62−
63− -- Start the client
64− forkIO $ do
65− takeMVar serverReady
66− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
67− clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− N.connect clientSock (addrAddress serverAddr)
69− ping clientSock (read pingsStr)
70− putMVar clientDone ()
71−
72− -- Wait for the client to finish
73− takeMVar clientDone
74−
75−socketToMVar :: Socket -> MVar ByteString -> IO ()
76−socketToMVar sock mvar = go
77− where
78− go = do bs <- recv sock
79− when (BS.length bs > 0) $ do
80− putMVar mvar bs
81− go
82−
83−pingMessage :: ByteString
84−pingMessage = pack "ping123"
85−
86−ping :: Socket -> Int -> IO ()
87−ping sock pings = go pings
88− where
89− go :: Int -> IO ()
90− go 0 = do
91− putStrLn $ "client did " ++ show pings ++ " pings"
92− go !i = do
93− before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
96− after <- getCurrentTime
97− -- putStrLn $ "client received " ++ unpack bs
98− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
100− go (i - 1)
101−
102−-- | Receive a package
103−recv :: Socket -> IO ByteString
104−recv sock = do
105− header <- NBS.recv sock 4
106− length <- decodeLength header
107− NBS.recv sock (fromIntegral (length :: Int32))
108−
109−-- | Send a package
110−send :: Socket -> ByteString -> IO ()
111−send sock bs = do
112− length <- encodeLength (fromIntegral (BS.length bs))
113− NBS.sendMany sock [length, bs]
114−
115−-- | Encode length (manual for now)
116−encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
118− BSI.create 4 $ \p ->
119− pokeByteOff p 0 (htonl (fromIntegral i32))
120−
121−-- | Decode length (manual for now)
122−decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
125− withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
127− return (fromIntegral (ntohl w32))
benchmarks/JustPingTransport.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import System.Environment (getArgs, withArgs)
9−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
10−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
11−import Control.Concurrent (forkIO)
12−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
13−import qualified Network.Socket as N
14−import Debug.Trace
15−import Data.ByteString (ByteString)
16−import Data.ByteString.Char8 (pack, unpack)
17−import qualified Data.ByteString as BS
18−import qualified Network.Socket.ByteString as NBS
19−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
20−import Network.Transport
21−import Network.Transport.TCP
22−
23−main :: IO ()
24−main = do
25− [pingsStr] <- getArgs
26− serverAddr <- newEmptyMVar
27− clientAddr <- newEmptyMVar
28− clientDone <- newEmptyMVar
29−
30− -- Start the server
31− forkIO $ do
32− -- establish transport and endpoint
33− putStrLn "server: creating TCP connection"
34− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35− Right endpoint <- newEndPoint transport
36− putMVar serverAddr (address endpoint)
37−
38− -- Connect to the client so that we can reply
39− theirAddr <- takeMVar clientAddr
40− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
41−
42− -- reply to pings with pongs
43− putStrLn "server: awaiting client connection"
44− ConnectionOpened _ _ _ <- receive endpoint
45− pong endpoint conn
46−
47− -- Start the client
48− forkIO $ do
49− let pings = read pingsStr
50−
51− -- establish transport and endpoint
52− Right transport <- createTransport "127.0.0.1" "8081" defaultTCPParameters
53− Right endpoint <- newEndPoint transport
54− putMVar clientAddr (address endpoint)
55−
56− -- Connect to the server to send pings
57− theirAddr <- takeMVar serverAddr
58− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
59−
60− -- Send pings, waiting for a reply after every ping
61− ConnectionOpened _ _ _ <- receive endpoint
62− ping endpoint conn pings
63− putMVar clientDone ()
64−
65− -- Wait for the client to finish
66− takeMVar clientDone
67−
68−pingMessage :: [ByteString]
69−pingMessage = [pack "ping123"]
70−
71−ping :: EndPoint -> Connection -> Int -> IO ()
72−ping endpoint conn pings = go pings
73− where
74− go :: Int -> IO ()
75− go 0 = do
76− putStrLn $ "client did " ++ show pings ++ " pings"
77− go !i = do
78− before <- getCurrentTime
79− send conn pingMessage
80− Received _ _payload <- receive endpoint
81− after <- getCurrentTime
82− -- putStrLn $ "client received " ++ show _payload
83− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
84− hPutStrLn stderr $ show i ++ " " ++ show latency
85− go (i - 1)
86−
87−pong :: EndPoint -> Connection -> IO ()
88−pong endpoint conn = go
89− where
90− go = do
91− msg <- receive endpoint
92− case msg of
93− Received _ payload -> send conn payload >> go
94− ConnectionClosed _ -> return ()
95− _ -> fail "Unexpected message"
benchmarks/JustPingTwoSocketPairs.hsdeleted−151
@@ -1,151 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr, NoDelay)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
31−
32−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
33−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
34−
35−passive :: Maybe AddrInfo
36−passive = Just (defaultHints { addrFlags = [AI_PASSIVE] })
37−
38−main = do
39− pingsStr:args <- getArgs
40− serverReady <- newEmptyMVar
41− clientReady <- newEmptyMVar
42− clientDone <- newEmptyMVar
43−
44− -- Start the server
45− forkIO $ do
46− -- Initialize the server
47− serverAddr:_ <- getAddrInfo passive Nothing (Just "8080")
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51− listen sock 1
52−
53− -- Set up multiplexing channel
54− multiplexChannel <- newChan
55−
56− -- Connect to the client (to reply)
57− forkIO $ do
58− takeMVar clientReady
59− clientAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8081")
60− pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol
61− N.connect pongSock (addrAddress clientAddr)
62− when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1
63− forever $ readChan multiplexChannel >>= send pongSock
64−
65− -- Wait for incoming connections (pings from the client)
66− putMVar serverReady ()
67− (pingSock, pingAddr) <- accept sock
68− socketToChan pingSock multiplexChannel
69−
70− -- Start the client
71− forkIO $ do
72− clientAddr:_ <- getAddrInfo passive Nothing (Just "8081")
73− sock <- socket (addrFamily clientAddr) Stream defaultProtocol
74− setSocketOption sock ReuseAddr 1
75− bindSocket sock (addrAddress clientAddr)
76− listen sock 1
77−
78− -- Set up multiplexing channel
79− multiplexChannel <- newChan
80−
81− -- Connect to the server (to send pings)
82− forkIO $ do
83− takeMVar serverReady
84− serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080")
85− pingSock <- socket (addrFamily serverAddr) Stream defaultProtocol
86− N.connect pingSock (addrAddress serverAddr)
87− when ("--NoDelay" `elem` args) $ setSocketOption pingSock NoDelay 1
88− ping pingSock multiplexChannel (read pingsStr)
89− putMVar clientDone ()
90−
91− -- Wait for incoming connections (pongs from the server)
92− putMVar clientReady ()
93− (pongSock, pongAddr) <- accept sock
94− socketToChan pongSock multiplexChannel
95−
96− -- Wait for the client to finish
97− takeMVar clientDone
98−
99−socketToChan :: Socket -> Chan ByteString -> IO ()
100−socketToChan sock chan = go
101− where
102− go = do bs <- recv sock
103− when (BS.length bs > 0) $ do
104− writeChan chan bs
105− go
106−
107−pingMessage :: ByteString
108−pingMessage = pack "ping123"
109−
110−ping :: Socket -> Chan ByteString -> Int -> IO ()
111−ping sock chan pings = go pings
112− where
113− go :: Int -> IO ()
114− go 0 = do
115− putStrLn $ "client did " ++ show pings ++ " pings"
116− go !i = do
117− before <- getCurrentTime
118− send sock pingMessage
119− bs <- readChan chan
120− after <- getCurrentTime
121− -- putStrLn $ "client received " ++ unpack bs
122− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
123− hPutStrLn stderr $ show i ++ " " ++ show latency
124− go (i - 1)
125−
126−-- | Receive a package
127−recv :: Socket -> IO ByteString
128−recv sock = do
129− header <- NBS.recv sock 4
130− length <- decodeLength header
131− NBS.recv sock (fromIntegral (length :: Int32))
132−
133−-- | Send a package
134−send :: Socket -> ByteString -> IO ()
135−send sock bs = do
136− length <- encodeLength (fromIntegral (BS.length bs))
137− NBS.sendMany sock [length, bs]
138−
139−-- | Encode length (manual for now)
140−encodeLength :: Int32 -> IO ByteString
141−encodeLength i32 =
142− BSI.create 4 $ \p ->
143− pokeByteOff p 0 (htonl (fromIntegral i32))
144−
145−-- | Decode length (manual for now)
146−decodeLength :: ByteString -> IO Int32
147−decodeLength bs =
148− let (fp, _, _) = BSI.toForeignPtr bs in
149− withForeignPtr fp $ \p -> do
150− w32 <- peekByteOff p 0
151− return (fromIntegral (ntohl w32))
benchmarks/JustPingWithHeader.hsdeleted−131
@@ -1,131 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import Network.Socket
9− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
10− , SocketType (Stream), SocketOption (ReuseAddr)
11− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
12− , defaultHints
13− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−import qualified Network.Socket as N
20−import Debug.Trace
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Char8 (pack, unpack)
23−import qualified Data.ByteString as BS
24−import qualified Network.Socket.ByteString as NBS
25−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
26−import Data.ByteString.Internal as BSI
27−import Foreign.Storable (pokeByteOff, peekByteOff)
28−import Foreign.C (CInt(..))
29−import Foreign.ForeignPtr (withForeignPtr)
30−
31−foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
32−foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
33−
34−main :: IO ()
35−main = do
36− [pingsStr] <- getArgs
37− serverReady <- newEmptyMVar
38− clientDone <- newEmptyMVar
39−
40− -- Start the server
41− forkIO $ do
42− putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
44− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
45− Nothing
46− (Just "8080")
47− let serverAddr = head serverAddrs
48− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
49− setSocketOption sock ReuseAddr 1
50− bindSocket sock (addrAddress serverAddr)
51−
52− putStrLn "server: awaiting client connection"
53− putMVar serverReady ()
54− listen sock 1
55− (clientSock, clientAddr) <- accept sock
56−
57− putStrLn "server: listening for pings"
58− pong clientSock
59−
60− -- Start the client
61− forkIO $ do
62− takeMVar serverReady
63− let pings = read pingsStr
64− serverAddrs <- getAddrInfo
65− Nothing
66− (Just "127.0.0.1")
67− (Just "8080")
68− let serverAddr = head serverAddrs
69− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
71− N.connect sock (addrAddress serverAddr)
72−
73− ping sock pings
74− putMVar clientDone ()
75−
76− -- Wait for the client to finish
77− takeMVar clientDone
78−
79−pingMessage :: ByteString
80−pingMessage = pack "ping123"
81−
82−ping :: Socket -> Int -> IO ()
83−ping sock pings = go pings
84− where
85− go :: Int -> IO ()
86− go 0 = do
87− putStrLn $ "client did " ++ show pings ++ " pings"
88− go !i = do
89− before <- getCurrentTime
90− send sock pingMessage
91− bs <- recv sock 8
92− after <- getCurrentTime
93− -- putStrLn $ "client received " ++ unpack bs
94− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
96− go (i - 1)
97−
98−pong :: Socket -> IO ()
99−pong sock = do
100− bs <- recv sock 8
101− -- putStrLn $ "server received " ++ unpack bs
102− when (BS.length bs > 0) $ do
103− send sock bs
104− pong sock
105−
106−-- | Wrapper around NBS.recv (for profiling)
107−recv :: Socket -> Int -> IO ByteString
108−recv sock _ = do
109− header <- NBS.recv sock 4
110− length <- decodeLength header
111− NBS.recv sock (fromIntegral (length :: Int32))
112−
113−-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
115−send sock bs = do
116− length <- encodeLength (fromIntegral (BS.length bs))
117− NBS.sendMany sock [length, bs]
118−
119−-- | Encode length (manual for now)
120−encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
122− BSI.create 4 $ \p ->
123− pokeByteOff p 0 (htonl (fromIntegral i32))
124−
125−-- | Decode length (manual for now)
126−decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
129− withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
131− return (fromIntegral (ntohl w32))
benchmarks/Makefiledeleted−72
@@ -1,72 +0,0 @@
1−
2−# Run 100K ping-pongs, for one trial:
3−size = 100000
4−trials = 1
5−# You can run "make run1 size=1000 trials=100" for example.
6−
7−
8−# Disable this to test installed packages only:
9−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src
10−
11−# Enable for profiling
12−# PROFILING=-prof -fprof-auto
13−
14−ifeq ($(GHC),)
15− GHC=ghc
16−endif
17−
18−BENCHS= PingTCP.exe PingTCPTransport.exe PingPipes.exe SendTransport.exe
19−
20−all: $(BENCHS)
21−$(BENCHS): %.exe: %.hs
22− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $(PROFILING) $< -o $@
23−
24−#-------------------------------------------------------------------------------
25−# Shorthands for running benchmarks:
26−
27−run: run1 run2 run3 run4
28−
29−run1: runBaseline
30−runBaseline:
31− ./PingTCP.exe server 8080 &
32− sleep 1
33− time ./PingTCP.exe client 0.0.0.0 8080 $(size) $(trials)
34− # Kill the server:
35− killall PingTCP.exe
36−
37−run2: runTCP
38−runTCP:
39− ./PingTCPTransport.exe server 0.0.0.0 8080 sourceAddr &
40− sleep 1
41− # Run 100K ping-pongs, for one trial:
42− time ./PingTCPTransport.exe client 0.0.0.0 8081 sourceAddr $(size) $(trials)
43− # Kill the server:
44− killall PingTCPTransport.exe
45−
46−run3: runPipes
47−runPipes:
48− ./PingPipes.exe server sourceAddr &
49− sleep 1
50− time ./PingPipes.exe client sourceAddr $(size) $(trials)
51− # Kill the server:
52− killall PingPipes.exe
53−
54−# This benchmark measures throughput rather than latency
55−# Here 'size' means message size rather than number of pings:
56−run4: runTPT
57−runTPT:
58− ./SendTransport.exe server 0.0.0.0 8080 sourceAddr &
59− sleep 1
60− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr $(size)
61− killall SendTransport.exe
62−
63−# Run multiple sizes:
64−runTPTs:
65− $(MAKE) runTPT size=1000
66− $(MAKE) runTPT size=5000
67− $(MAKE) runTPT size=10000
68− $(MAKE) runTPT size=50000
69− $(MAKE) runTPT size=100000
70−
71−clean:
72− rm -f *.hi *.o *.exe
benchmarks/Makefile.JustPingdeleted−52
@@ -1,52 +0,0 @@
1−# The "Just Ping" tests measure ping latency with as little overhead as possible
2−
3−NUMPINGS=100000
4−INCLUDES=-i../network-transport/src -i../network-transport-pipes/src
5−
6−# Enable for profiling
7−# PROF_GHC=-prof -fprof-auto
8−# PROF_EXE=+RTS -pa -RTS
9−
10−GCC=gcc -std=c99
11−GHC=ghc -rtsopts -XRankNTypes -XScopedTypeVariables -XDeriveDataTypeable
12−
13−NewTransport.ps: JustPingHaskell.data \
14− JustPingTransport.data
15− gnuplot ./NewTransport.gnuplot
16−
17−Indirection.ps: JustPingWithHeader.data \
18− JustPingThroughChan.data \
19− JustPingThroughMVar.data \
20− JustPingTwoSocketPairs.data \
21− JustPingTwoSocketPairsND.data \
22− JustPingTransport.data
23− gnuplot ./Indirection.gnuplot
24−
25−Headers.ps: JustPingC.data \
26− JustPingHaskellNT.data \
27− JustPingHaskell.data \
28− JustPingWithHeader.data \
29− JustPingOneRecv.data \
30− JustPingCacheHeader.data
31− gnuplot ./Headers.gnuplot
32−
33−JustPingC.exe: JustPingC.c
34− $(GCC) -O2 -o JustPingC.exe JustPingC.c
35−
36−JustPingHaskellNT.exe: JustPingHaskell.hs
37− $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs
38−
39−JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe
40− time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@
41−
42−%.data : %.exe
43− time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@
44−
45−%.exe :: %.hs
46− $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES)
47−
48−.PHONY: clean
49−clean:
50− rm -f *.data *.ps *.pdf *.o *.hi *.exe
51−
52−# vi:set noexpandtab:
benchmarks/NewTransport.gnuplotdeleted−8
@@ -1,8 +0,0 @@
1−set title "Roundtrip (us)"
2−set yrange [0:150]
3−plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
4− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
5−set terminal postscript color
6−set output "NewTransport.ps"
7−plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \
8− "JustPingTransport.data" smooth bezier with lines title "JustPingTransport"
benchmarks/PingPipes.hsdeleted−112
@@ -1,112 +0,0 @@
1−module Main where
2−
3−-- TODO: Merge with PingTCPTransport and factor differences.
4−
5−import Network.Transport (newConnection, receive, connect, send,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.Pipes (mkTransport)
8−
9−import Control.Monad (forever, replicateM_)
10−import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
11−import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
12−-- import Data.Binary (encode,decode)
13−import Data.Serialize (encode,decode)
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−
18−-- import qualified Data.ByteString.Lazy.Char8 as LBS
19−import qualified Data.ByteString.Char8 as BS
20−
21−-- | This performs a ping benchmark on the TCP transport. This can be
22−-- compiled using:
23−--
24−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
25−--
26−-- To use the compiled binary, first set up a server:
27−--
28−-- ./benchmarks/PingPipes server sourceAddr
29−--
30−-- Once this is established, launch a client to perform the benchmark. The
31−-- following command sends 1000 pings per mark.
32−--
33−-- ./benchmarks/PingPipes client sourceAddr 1000
34−--
35−-- The server must be restarted between benchmarks.
36−main :: IO ()
37−main = do
38− args <- getArgs
39− case args of
40− "server" : sourceAddrFilePath : [] -> do
41− -- establish transport
42− transport <- mkTransport
43−
44− -- create ping end
45− putStrLn "server: creating ping end"
46− (sourceAddrPing, targetEndPing) <- newConnection transport
47− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
48−
49− -- create pong end
50− putStrLn "server: creating pong end"
51− [sourceAddrPongBS] <- receive targetEndPing
52− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
53−
54− -- always respond to a ping with a pong
55− putStrLn "server: awaiting pings"
56− forever $ pong targetEndPing sourceEndPong
57−
58−
59− "client" : sourceAddrFilePath : pingsStr : reps : args' -> do
60− let pings = read pingsStr
61− -- establish transport
62− transport <- mkTransport
63−
64− -- create ping end
65− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
66− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
67−
68− -- create pong end
69− (sourceAddrPong, targetEndPong) <- newConnection transport
70− send sourceEndPing [serialize sourceAddrPong]
71−
72− -- benchmark the pings
73− case (read reps) :: Int of
74− 0 -> error "What would zero reps mean?"
75− 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
76− replicateM_ pings (ping sourceEndPing targetEndPong)
77− n -> withArgs args' $ defaultMainWith
78− (defaultConfig{ cfgSamples = ljust n })
79− (return ()) -- Init action.
80− [ benchPing sourceEndPing targetEndPong (fromIntegral pings) ]
81− putStrLn "Done with all ping/pongs."
82−
83−
84−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
85−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
86−-- in reply down the `SourceEnd`, repeating whatever was sent.
87−pong :: TargetEnd -> SourceEnd -> IO ()
88−pong targetEndPing sourceEndPong = do
89− bs <- receive targetEndPing
90− send sourceEndPong bs
91−
92−-- | The effect of `ping sourceEndPing targetEndPong n` is to send the number
93−-- `n` using `sourceEndPing`, and to then receive the a number from
94−-- `targetEndPong`, which is then returned.
95−ping :: SourceEnd -> TargetEnd -> IO Int64
96−ping sourceEndPing targetEndPong = do
97− -- send sourceEndPing [BS.empty]
98− send sourceEndPing [encode (42 :: Int64)]
99−
100− [bs] <- receive targetEndPong
101−-- return $ decode bs
102− case decode bs of
103− Left err -> error$ "decode failure: " ++ err
104− Right x -> return x
105−
106−-- | The effect of `benchPing sourceEndPing targetEndPong n` is to send
107−-- `n` pings down `sourceEndPing` using the `ping` function. The time
108−-- taken is benchmarked.
109−benchPing :: SourceEnd -> TargetEnd -> Int64 -> Benchmark
110−benchPing sourceEndPing targetEndPong n = bench "PingTransport" $
111− nfIO (replicateM_ (fromIntegral n) (ping sourceEndPing targetEndPong))
112−
benchmarks/PingTCP.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
18−import System.IO (withFile, IOMode(..), hPutStrLn, Handle)
19−import Control.Concurrent (forkIO)
20−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
21−
22−import qualified Network.Socket as N
23−
24−import Debug.Trace
25−
26−#ifndef LAZY
27−import Data.ByteString (ByteString)
28−import Data.ByteString.Char8 (pack)
29−import qualified Data.ByteString as BS
30−import qualified Network.Socket.ByteString as NBS
31−encode = Ser.encode
32−decode = Ser.decode
33−#else
34−import Data.ByteString.Lazy (ByteString, pack)
35−import qualified Network.Socket.ByteString.Lazy as NBS
36−encode = Ser.encodeLazy
37−decode = Ser.decodeLazy
38−#endif
39−{-# INLINE encode #-}
40−{-# INLINE decode #-}
41−encode :: Ser.Serialize a => a -> ByteString
42−decode :: Ser.Serialize a => ByteString -> Either String a
43−
44−-- | This performs a ping benchmark on a TCP connection created by
45−-- Network.Socket. To compile this file, you might use:
46−--
47−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTCP.hs
48−--
49−-- To use the compiled binary, first set up the server on the current machine:
50−--
51−-- ./benchmarks/PingTCP server 8080
52−--
53−-- Next, perform the benchmark on a client using the server address, where
54−-- each mark is 1000 pings:
55−--
56−-- ./benchmarks/PingTCP client 0.0.0.0 8080 1000
57−--
58−-- The server must be restarted between benchmarks.
59−main :: IO ()
60−main = do
61− [pingsStr] <- getArgs
62− serverReady <- newEmptyMVar
63−
64− -- Start the server
65− forkIO $ do
66− putStrLn "server: creating TCP connection"
67− serverAddrs <- getAddrInfo
68− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
69− Nothing
70− (Just "8080")
71− let serverAddr = head serverAddrs
72− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
73− setSocketOption sock ReuseAddr 1
74− bindSocket sock (addrAddress serverAddr)
75−
76− putStrLn "server: awaiting client connection"
77− putMVar serverReady ()
78− listen sock 1
79− (clientSock, clientAddr) <- accept sock
80−
81− putStrLn "server: listening for pings"
82− pong clientSock
83−
84− -- Client
85− takeMVar serverReady
86− let pings = read pingsStr
87− serverAddrs <- getAddrInfo
88− Nothing
89− (Just "127.0.0.1")
90− (Just "8080")
91− let serverAddr = head serverAddrs
92− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
93−
94− N.connect sock (addrAddress serverAddr)
95−
96− ping sock pings
97−
98−pingMessage :: ByteString
99−pingMessage = pack "ping123"
100−
101−ping :: Socket -> Int -> IO ()
102−ping sock pings = go [] pings
103− where
104− go :: [Double] -> Int -> IO ()
105− go rtl 0 = do
106− withFile "round-trip-latency-tcp.data" WriteMode (writeData rtl)
107− putStrLn $ "client did " ++ show pings ++ " pings"
108− go rtl !i = do
109− before <- getCurrentTime
110− send sock pingMessage
111− bs <- recv sock 8
112− after <- getCurrentTime
113− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
114− latency `seq` go (latency : rtl) (i - 1)
115− writeData :: [Double] -> Handle -> IO ()
116− writeData rtl h = forM_ (zip [0..] rtl) (writeDataLine h)
117− writeDataLine :: Handle -> (Int, Double) -> IO ()
118− writeDataLine h (i, latency) = hPutStrLn h $ (show i) ++ " " ++ (show latency)
119−
120−pong :: Socket -> IO ()
121−pong sock = do
122− bs <- recv sock 8
123− when (BS.length bs > 0) $ do
124− send sock bs
125− pong sock
126−
127−-- | Wrapper around NBS.recv (for profiling)
128−recv :: Socket -> Int -> IO ByteString
129−recv = NBS.recv
130−
131−-- | Wrapper around NBS.send (for profiling)
132−send :: Socket -> ByteString -> IO Int
133−send = NBS.send
benchmarks/PingTCPTransport.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Network.Transport (newConnection, receive, connect, send, defaultHints,
6− serialize, deserialize, SourceEnd, TargetEnd)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Monad (forever, replicateM_, forM_)
10−
11−import qualified Data.Serialize as Ser
12−import Data.Maybe (fromJust)
13−import Data.Int
14−import System.Environment (getArgs, withArgs)
15−import Data.Time (getCurrentTime, diffUTCTime)
16−import System.IO (withFile, IOMode(..), hPutStrLn)
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
19−
20−#ifndef LAZY
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import qualified Data.ByteString.Lazy.Char8 as BS
27−import qualified Network.Socket.ByteString.Lazy as NBS
28−encode = Ser.encodeLazy
29−decode = Ser.decodeLazy
30−#endif
31−{-# INLINE encode #-}
32−{-# INLINE decode #-}
33−encode :: Ser.Serialize a => a -> BS.ByteString
34−decode :: Ser.Serialize a => BS.ByteString -> Either String a
35−
36−
37−
38−-- | This performs a ping benchmark on the TCP transport. This can be
39−-- compiled using:
40−--
41−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTransport.hs
42−--
43−-- To use the compiled binary, first set up a server:
44−--
45−-- ./benchmarks/PingTransport server 0.0.0.0 8080 sourceAddr
46−--
47−-- Once this is established, launch a client to perform the benchmark. The
48−-- following command sends 1000 pings per mark.
49−--
50−-- ./benchmarks/PingTransport client 0.0.0.0 8081 sourceAddr 1000
51−--
52−-- The server must be restarted between benchmarks.
53−main :: IO ()
54−main = do
55− [pingsStr] <- getArgs
56− serverAddr <- newEmptyMVar
57− clientAddr <- newEmptyMVar
58−
59− -- Start the server
60− forkIO $ do
61− -- establish transport
62− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
63−
64− -- create ping end
65− putStrLn "server: creating ping end"
66− (sourceAddrPing, targetEndPing) <- newConnection transport
67− putMVar serverAddr sourceAddrPing
68−
69− -- create pong end
70− putStrLn "server: creating pong end"
71− sourceAddrPong <- takeMVar clientAddr
72− sourceEndPong <- connect sourceAddrPong
73−
74− -- always respond to a ping with a pong
75− putStrLn "server: awaiting pings"
76− pong targetEndPing sourceEndPong
77−
78− -- Client
79− sourceAddr <- takeMVar serverAddr
80− let pings = read pingsStr
81− -- establish transport
82− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
83−
84− -- create ping end
85− sourceEndPing <- connect sourceAddr
86−
87− -- create pong end
88− (sourceAddrPong, targetEndPong) <- newConnection transport
89− putMVar clientAddr sourceAddrPong
90−
91− ping sourceEndPing targetEndPong pings
92− putStrLn "Done with all ping/pongs."
93−
94−-- | The message we use to ping (CAF so that we don't keep encoding it)
95−pingMessage :: BS.ByteString
96−pingMessage = BS.pack "ping123"
97−
98−-- | Keep replying to pings (send pongs)
99−pong :: TargetEnd -> SourceEnd -> IO ()
100−pong targetEndPing sourceEndPong = do
101− [bs] <- receive targetEndPing
102− -- putStrLn $ "server got " ++ BS.unpack bs
103− send sourceEndPong [bs]
104− pong targetEndPing sourceEndPong
105−
106−-- | Send a number of pings
107−ping :: SourceEnd -> TargetEnd -> Int -> IO ()
108−ping sourceEndPing targetEndPong pings = go [] pings
109− where
110− go :: [Double] -> Int -> IO ()
111− go rtl 0 = do
112− outputData rtl
113− putStrLn $ "client did " ++ show pings ++ " pings"
114− go rtl !i = do
115− before <- getCurrentTime
116− send sourceEndPing [pingMessage]
117− [bs] <- receive targetEndPong
118− -- putStrLn $ "client got " ++ BS.unpack bs
119− after <- getCurrentTime
120− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
121− latency `seq` go (latency : rtl) (i - 1)
122−
123−-- | Output latencies to a file to be plotted
124−outputData :: [Double] -> IO ()
125−outputData rtl = do
126− withFile "round-trip-latency-tcp-transport.data" WriteMode $ \h ->
127− forM_ (zip [0..] rtl) $ \(i, latency) ->
128− hPutStrLn h $ (show i) ++ " " ++ (show latency)
benchmarks/SendTCP.hsdeleted−109
@@ -1,109 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Main where
4−
5−import Control.Monad
6−import Criterion.Main (Benchmark, bench, defaultMain, nfIO, bgroup)
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import Network.Socket
11− ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12− , SocketType (Stream), SocketOption (ReuseAddr)
13− , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
14− , defaultHints
15− , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16−import System.Environment (getArgs, withArgs)
17−
18−import qualified Network.Socket as N
19−
20−#ifdef LAZY
21−import Data.ByteString (ByteString)
22−import qualified Data.ByteString as BS
23−import qualified Network.Socket.ByteString as NBS
24−encode = Ser.encode
25−decode = Ser.decode
26−#else
27−import Data.ByteString.Lazy (ByteString)
28−import qualified Data.ByteString.Lazy as BS
29−import qualified Network.Socket.ByteString.Lazy as NBS
30−encode = Ser.encodeLazy
31−decode = Ser.decodeLazy
32−#endif
33−{-# INLINE encode #-}
34−{-# INLINE decode #-}
35−encode :: Ser.Serialize a => a -> ByteString
36−decode :: Ser.Serialize a => ByteString -> Either String a
37−
38−-- | This performs a benchmark on a TCP connection to measure how long it takes
39−-- to transfer a number of bytes.
40−-- To compile this file, you might use:
41−--
42−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTCP.hs
43−--
44−-- To use the compiled binary, first set up the server on the current machine,
45−-- such that it expects 1000 bytes:
46−--
47−-- ./benchmarks/SendTCP server 8080 1000
48−--
49−-- Next, perform the benchmark on a client using the server address, where
50−-- each mark is 1000 bytes:
51−--
52−-- ./benchmarks/SendTCP client 0.0.0.0 8080 1000
53−--
54−-- The server must be restarted between benchmarks.
55−main :: IO ()
56−main = do
57− args <- getArgs
58− case args of
59− "server" : service : sizeStr : [] -> withSocketsDo $ do
60− let size = read sizeStr
61− putStrLn "server: creating TCP connection"
62− serverAddrs <- getAddrInfo
63− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
64− Nothing
65− (Just service)
66− let serverAddr = head serverAddrs
67− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
68− setSocketOption sock ReuseAddr 1
69− bindSocket sock (addrAddress serverAddr)
70−
71− putStrLn "server: awaiting client connection"
72− listen sock 1
73− (clientSock, clientAddr) <- accept sock
74−
75− putStrLn "server: listening for data"
76−
77− forever $ pong clientSock size
78−
79− "client": host : service : sizeStr : args' -> withSocketsDo $ do
80− let size = read sizeStr
81− serverAddrs <- getAddrInfo
82− Nothing
83− (Just host)
84− (Just service)
85− let serverAddr = head serverAddrs
86− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
87−
88− N.connect sock (addrAddress serverAddr)
89−
90− -- benchmark the data
91− let bs = BS.replicate size 0
92− withArgs args' $ defaultMain [ benchSend sock bs ]
93−
94−-- | Each `ping` sends a `ByteString` and expects a byte in return.
95−ping :: Socket -> ByteString -> IO Word8
96−ping sock bs = do
97− NBS.send sock bs
98− bs' <- NBS.recv sock 1
99− either error return $ decode bs
100−
101−-- pong :: Socket -> Int64 -> IO ()
102−pong sock size = do
103− bs <- NBS.recv sock size
104− NBS.sendAll sock (encode (0 :: Word8))
105− return ()
106−
107−benchSend :: Socket -> ByteString -> Benchmark
108−benchSend sock bs = bench "SendTCP" $
109− nfIO (ping sock bs)
benchmarks/SendTransport.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoMonomorphismRestriction #-}
3−
4−module Main where
5−
6−import Network.Transport (newConnection, receive, connect, send, defaultHints,
7− serialize, deserialize, SourceEnd, TargetEnd)
8−import Network.Transport.TCP (mkTransport, TCPConfig (..))
9−
10−import Control.Applicative
11−import Control.Monad (forever, replicateM, replicateM_)
12−import Criterion.Main (Benchmark, bench, defaultMain, nfIO)
13−import qualified Data.Serialize as Ser
14−import Data.Maybe (fromJust)
15−import Data.Int
16−import System.Environment (getArgs, withArgs)
17−import System.Random
18−
19−#ifndef LAZY
20−import Data.ByteString (ByteString)
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.Socket.ByteString as NBS
23−encode = Ser.encode
24−decode = Ser.decode
25−#else
26−import Data.ByteString.Lazy (ByteString)
27−import qualified Data.ByteString.Lazy.Char8 as BS
28−import qualified Network.Socket.ByteString.Lazy as NBS
29−encode = Ser.encodeLazy
30−decode = Ser.decodeLazy
31−#endif
32−{-# INLINE encode #-}
33−{-# INLINE decode #-}
34−encode :: Ser.Serialize a => a -> ByteString
35−decode :: Ser.Serialize a => ByteString -> Either String a
36−
37−-- | This performs a benchmark on the TCP transport to measure how long
38−-- it takes to transfer a number of bytes. This can be compiled using:
39−--
40−-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTransport.hs
41−--
42−-- To use the compiled binary, first set up a server:
43−--
44−-- ./benchmarks/SendTransport server 0.0.0.0 8080 sourceAddr
45−--
46−-- Once this is established, launch a client to perform the benchmark. The
47−-- following command sends 1000 bytes per mark.
48−--
49−-- ./benchmarks/SendTransport client 0.0.0.0 8081 sourceAddr 1000
50−--
51−-- The server must be restarted between benchmarks.
52−main :: IO ()
53−main = do
54− args <- getArgs
55− case args of
56− "server" : host : service : sourceAddrFilePath : [] -> do
57−
58− -- establish transport
59− transport <- mkTransport $ TCPConfig defaultHints host service
60−
61− -- create ping end
62− putStrLn "server: creating ping end"
63− (sourceAddrPing, targetEndPing) <- newConnection transport
64− BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
65−
66− -- create pong end
67− putStrLn "server: creating pong end"
68− [sourceAddrPongBS] <- receive targetEndPing
69− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
70−
71− -- always respond to a ping with a pong
72− putStrLn "server: awaiting pings"
73− forever $ pong targetEndPing sourceEndPong
74−
75−
76− "client" : host : service : sourceAddrFilePath : sizeStr : args' -> do
77− let size = read sizeStr
78−
79− -- establish transport
80− transport <- mkTransport $ TCPConfig defaultHints host service
81−
82− -- create ping end
83− sourceAddrPingBS <- BS.readFile sourceAddrFilePath
84− sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
85−
86− -- create pong end
87− (sourceAddrPong, targetEndPong) <- newConnection transport
88− send sourceEndPing [serialize sourceAddrPong]
89−
90− -- benchmark the data
91− bs <- BS.pack <$> replicateM size randomIO
92− withArgs args' $ defaultMain [ benchSend sourceEndPing targetEndPong bs ]
93−
94−-- | The effect of `ping sourceEndPing targetEndPong bs` is to send the
95−-- `ByteString` `bs` using `sourceEndPing`, and to then receive
96−-- that string back. Returns the length of the received message.
97−ping :: SourceEnd -> TargetEnd -> ByteString -> IO Int
98−ping sourceEndPing targetEndPong bs = do
99− send sourceEndPing [bs]
100− cs <- receive targetEndPong
101− return . fromIntegral $! sum (map BS.length cs)
102−
103−-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
104−-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
105−-- in reply down the `SourceEnd`, repeating whatever was sent.
106−pong :: TargetEnd -> SourceEnd -> IO ()
107−pong targetEndPing sourceEndPong = do
108− bs <- receive targetEndPing
109− send sourceEndPong bs
110−
111−-- | The effect of `benchSend sourceEndPing targetEndPong bs` is to send
112−-- `bs` pings down `sourceEndPing` using the `ping` function. The time
113−-- taken is benchmarked.
114−benchSend :: SourceEnd -> TargetEnd -> ByteString -> Benchmark
115−benchSend sourceEndPing targetEndPong bs = bench "SendTransport" $
116− nfIO (ping sourceEndPing targetEndPong bs)
117−
benchmarks/pingtest.cdeleted−183
@@ -1,183 +0,0 @@
1−/**
2− * Compute baseline average and standard deviancy ping latency
3− *
4− * Compile using
5− *
6− * gcc -o pingtest -O2 -std=c99 pingtest.c
7− *
8− * Then start server
9− *
10− * ./pingtest server &
11− *
12− * And finally start the client
13− *
14− * ./pingtest client <number of pings; for instance, 10000>
15− *
16− * The server will terminate when the client does.
17− *
18− * Edsko de Vries <edsko@well-typed.com>
19− */
20−
21−#include <stdio.h>
22−#include <stdlib.h>
23−#include <sys/types.h>
24−#include <sys/socket.h>
25−#include <netdb.h>
26−#include <string.h>
27−#include <unistd.h>
28−#include <signal.h>
29−#include <errno.h>
30−#include <time.h>
31−#include <sys/time.h>
32−#include <math.h>
33−
34−// Note: this is not consistent across CPUs (and hence across threads on multicore machines)
35−double timestamp() {
36− struct timeval tp;
37− gettimeofday(&tp, NULL);
38− return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec;
39−}
40−
41−int server() {
42− printf("starting server\n");
43−
44− struct addrinfo hints, *res;
45− int error, server_socket;
46−
47− memset(&hints, 0, sizeof(hints));
48− hints.ai_family = PF_INET;
49− hints.ai_socktype = SOCK_STREAM;
50− hints.ai_flags = AI_PASSIVE;
51−
52− error = getaddrinfo(NULL, "8080", &hints, &res);
53− if(error) {
54− printf("server error: %s\n", gai_strerror(error));
55− return -1;
56− }
57−
58− server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
59− if(server_socket < 0) {
60− printf("server error: could not create socket\n");
61− return -1;
62− }
63−
64− int yes = 1;
65− if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) {
66− printf("server error: could not set socket options\n");
67− return -1;
68− }
69−
70− if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) {
71− printf("server error: could not bind to socket\n");
72− return -1;
73− }
74−
75− listen(server_socket, 5);
76−
77− int client_socket;
78− struct sockaddr_storage client_addr;
79− socklen_t addr_size;
80− client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size);
81−
82− for(;;) {
83− char buf[8];
84− ssize_t read = recv(client_socket, &buf, 8, 0);
85− // printf("server received '%s'\n", buf);
86− send(client_socket, buf, 8, 0);
87− }
88−
89− freeaddrinfo(res);
90− return 0;
91−}
92−
93−int client(int pings) {
94− printf("starting client\n");
95−
96− struct addrinfo hints, *res;
97− int error, client_socket;
98−
99− memset(&hints, 0, sizeof(hints));
100− hints.ai_family = PF_INET;
101− hints.ai_socktype = SOCK_STREAM;
102−
103− error = getaddrinfo("127.0.0.1", "8080", &hints, &res);
104− if(error) {
105− printf("client error: %s\n", gai_strerror(error));
106− return -1;
107− }
108−
109− client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol);
110− if(client_socket < 0) {
111− printf("client error: could not create socket\n");
112− return -1;
113− }
114−
115− if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) {
116− printf("client error: could not connect: %s\n", strerror(errno));
117− return -1;
118− }
119−
120− double* round_trip_latency = (double*) calloc(pings, sizeof(double));
121−
122− for(int i = 0; i < pings; i++) {
123− double timestamp_before = timestamp();
124−
125− send(client_socket, "ping123", 8, 0);
126−
127− char buf[8];
128− ssize_t read = recv(client_socket, &buf, 8, 0);
129− // printf("client received '%s'\n", buf);
130−
131− double timestamp_after = timestamp();
132− round_trip_latency[i] = timestamp_after - timestamp_before;
133− }
134−
135− printf("client did %d pings\n", pings);
136−
137− // Write data to a file for plotting
138− FILE* data = fopen("round-trip-latency-c.data", "wt");
139− for(int i = 0; i < pings; i++) {
140− fprintf(data, "%i %lf\n", i, round_trip_latency[i]);
141− }
142− fclose(data);
143−
144− // compute average
145− double round_trip_latency_average = 0;
146− for(int i = 0; i < pings; i++) {
147− round_trip_latency_average += round_trip_latency[i];
148− };
149− round_trip_latency_average /= (double) pings;
150−
151−
152− // compute standard deviation
153− double round_trip_latency_stddev = 0;
154− for(int i = 0; i < pings; i++) {
155− round_trip_latency_stddev += pow(round_trip_latency[i] - round_trip_latency_average, 2);
156− }
157− round_trip_latency_stddev = sqrt(round_trip_latency_stddev / (double) (pings - 1));
158−
159− printf("average round-trip latency: %lf us (standard devitation %lf us)\n", round_trip_latency_average, round_trip_latency_stddev);
160−
161− freeaddrinfo(res);
162− return 0;
163−}
164−
165−int usage(int argc, char** argv) {
166− printf("usage: %s <number of pings>\n", argv[0]);
167− return -1;
168−}
169−
170−int main(int argc, char** argv) {
171− if(argc != 2) {
172− return usage(argc, argv);
173− }
174−
175− if(fork() == 0) {
176− // TODO: we should wait until we know the server is ready
177− int pings = 0;
178− sscanf(argv[1], "%d", &pings);
179− return client(pings);
180− } else {
181− return server();
182− }
183−}
benchmarks/results_notes.mddeleted−111
@@ -1,111 +0,0 @@
1−
2−
3−[2012.02.22] {File for notes on results}
4−============================================================
5−
6−Here's a run of the PingTCP benchmark on a 3.1 ghz Intel Westmere running RHEL 6.2:
7−
8− ./PingTCP.exe server 8080 &
9− sleep 1
10− server: creating TCP connection
11− server: awaiting client connection
12− ./PingTCP.exe client 0.0.0.0 8080 1000
13− server: listening for pings
14− warming up
15− estimating clock resolution...
16− mean is 1.963031 us (320001 iterations)
17− found 38180 outliers among 319999 samples (11.9%)
18− 32741 (10.2%) low severe
19− 5439 (1.7%) high severe
20− estimating cost of a clock call...
21− mean is 43.17696 ns (15 iterations)
22− found 2 outliers among 15 samples (13.3%)
23− 1 (6.7%) high mild
24− 1 (6.7%) high severe
25−
26− benchmarking PingTCP
27− collecting 100 samples, 1 iterations each, in estimated 8.073997 s
28− mean: 77.01177 ms, lb 76.92822 ms, ub 77.14009 ms, ci 0.950
29− std dev: 526.1251 us, lb 366.2692 us, ub 803.1751 us, ci 0.950
30−
31−(That was without -O2)
32−
33− -----
34−
35−Running a C benchmark on the same machine it takes 5.6 seconds to do
36−200K ping pongs.
37−
38− => 28 us avg latency for C
39−
40−I got 72 us avg latency using PingTCP. The named pipes backend took
41−19.8s and was using 100% CPU. That's a 99 us latency.
42−
43−Pipes with unix-bytestring take 11.0 seconds, but still use 100% CPU.
44−
45− => 55 us latency for Pipes with unix-bytestring
46−
47−
48−
49−[2012.02.24] {After Adam's strictness refactoring.}
50−============================================================
51−
52−100K ping/pongs, 1 trial:
53−
54− PingTCP: 7.34s >80%CPU
55− PingTCPTransport: 19s ~60%CPU
56− PingPipes: 6.36s >=100%CPU
57−
58−Timing instead using 100 trials of 1000 pingpongs via criterion gives
59−results consistent with the above. Here are the mean latencies:
60−
61− PingTCP: 72 us
62− PingTCPTransport: 191 us
63− PingPipes: 65 us
64−
65−And here is my first attempt at running the SendTransport benchmark (TCP backend):
66−
67− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 1000
68− mean: 38.10901 ms, lb 35.92353 ms, ub 39.30006 ms, ci 0.950
69− std dev: 8.305210 ms, lb 4.935312 ms, ub 11.97144 ms, ci 0.950
70− found 5 outliers among 100 samples (5.0%)
71− 5 (5.0%) low severe
72− variance introduced by outliers: 94.703%
73− variance is severely inflated by outliers
74−
75− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 5000
76− mean: 32.87646 ms, lb 29.69947 ms, ub 35.62485 ms, ci 0.950
77− std dev: 15.21419 ms, lb 12.39949 ms, ub 17.39441 ms, ci 0.950
78− found 18 outliers among 100 samples (18.0%)
79− 18 (18.0%) low severe
80− variance introduced by outliers: 98.928%
81− variance is severely inflated by outliers
82−
83− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 10000
84− mean: 32.87737 ms, lb 29.34305 ms, ub 35.62680 ms, ci 0.950
85− std dev: 15.22060 ms, lb 12.40398 ms, ub 17.57401 ms, ci 0.950
86− found 18 outliers among 100 samples (18.0%)
87− 18 (18.0%) low severe
88− variance introduced by outliers: 98.929%
89− variance is severely inflated by outliers
90−
91− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 50000
92− mean: 1.351308 ms, lb 1.249680 ms, ub 1.548209 ms, ci 0.950
93− std dev: 696.6768 us, lb 448.3538 us, ub 1.314057 ms, ci 0.950
94− found 24 outliers among 100 samples (24.0%)
95− 3 (3.0%) high mild
96− 21 (21.0%) high severe
97− variance introduced by outliers: 98.942%
98− variance is severely inflated by outliers
99−
100− ./SendTransport.exe client 0.0.0.0 8081 sourceAddr 100000
101− mean: 2.184967 ms, lb 2.030858 ms, ub 2.641543 ms, ci 0.950
102− std dev: 1.235358 ms, lb 518.3995 us, ub 2.666540 ms, ci 0.950
103− found 15 outliers among 100 samples (15.0%)
104− 4 (4.0%) low severe
105− 9 (9.0%) high severe
106− variance introduced by outliers: 98.952%
107− variance is severely inflated by outliers
108−
109−This is quite odd. so in addition to the high variance it would seem
110−that messages of size 50K or 100K are much FASTER to send than smaller
111−massages?
distributed-process/ChangeLog+12
@@ -1,3 +1,15 @@
1+2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
2+
3+* Bugfix in the node controller
4+(one way this bug materialized: when using the SimpleLocalnet backend,
5+slave nodes could not be reused)
6+* Improved documentation in Control.Distributed.Process.Closure
7+
8+2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3
9+
10+* Improve docs
11+* Local versions of spawn
12+
1132012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
214
315* Base 4.6 compatibility
distributed-process/distributed-process.cabal+2−2
@@ -1,5 +1,5 @@
11Name: distributed-process
2−Version: 0.2.1.2
2+Version: 0.2.1.4
33Cabal-Version: >=1.8
44Build-Type: Simple
55License: BSD3
@@ -52,7 +52,6 @@ Library
5252 Control.Distributed.Process.Internal.CQueue,
5353 Control.Distributed.Process.Internal.Dynamic,
5454 Control.Distributed.Process.Internal.TypeRep,
55− Control.Distributed.Process.Internal.MessageT,
5655 Control.Distributed.Process.Internal.Types,
5756 Control.Distributed.Process.Internal.Closure.Static,
5857 Control.Distributed.Process.Internal.Closure.MkClosure,
@@ -124,6 +123,7 @@ Test-Suite TestClosure
124123 random >= 1.0 && < 1.1,
125124 ghc-prim >= 0.2 && < 0.3,
126125 ansi-terminal >= 0.5 && < 0.6
126+ Other-modules: TestAuxiliary
127127 Extensions: RankNTypes,
128128 ScopedTypeVariables,
129129 FlexibleInstances,
distributed-process/src/Control/Distributed/Process.hs+28
@@ -89,6 +89,9 @@ module Control.Distributed.Process
8989 , spawnMonitor
9090 , spawnChannel
9191 , DidSpawn(..)
92+ -- * Local versions of 'spawn'
93+ , spawnLocal
94+ , spawnChannelLocal
9295 ) where
9396
9497
@@ -98,6 +101,8 @@ import Prelude hiding (catch)
98101
99102import Data.Typeable (Typeable)
100103import Control.Monad.IO.Class (liftIO)
104+import Control.Applicative ((<$>))
105+import Control.Monad.Reader (ask)
101106import Control.Distributed.Process.Internal.Types
102107 ( RemoteTable
103108 , NodeId(..)
@@ -121,6 +126,7 @@ import Control.Distributed.Process.Internal.Types
121126 , SerializableDict(..)
122127 , SendPortId(..)
123128 , WhereIsReply(..)
129+ , LocalProcess(processNode)
124130 )
125131import Control.Distributed.Process.Internal.Closure.CP
126132 ( cpSeq
@@ -190,6 +196,7 @@ import Control.Distributed.Process.Internal.Primitives
190196 , spawnAsync
191197 )
192198import Control.Distributed.Process.Serializable (Serializable)
199+import Control.Distributed.Process.Node (forkProcess)
193200
194201-- INTERNAL NOTES
195202--
@@ -355,3 +362,24 @@ spawnChannel dict nid proc = do
355362 (cpSend (sdictSendPort dict) pid `cpSplit` proc)
356363 `cpBind`
357364 cpCancelL
365+
366+--------------------------------------------------------------------------------
367+-- Local versions of spawn --
368+--------------------------------------------------------------------------------
369+
370+-- | Spawn a process on the local node
371+spawnLocal :: Process () -> Process ProcessId
372+spawnLocal proc = do
373+ node <- processNode <$> ask
374+ liftIO $ forkProcess node proc
375+
376+-- | Create a new typed channel, spawn a process on the local node, passing it
377+-- the receive port, and return the send port
378+spawnChannelLocal :: Serializable a
379+ => (ReceivePort a -> Process ())
380+ -> Process (SendPort a)
381+spawnChannelLocal proc = do
382+ node <- processNode <$> ask
383+ (sport, rport) <- newChan
384+ _ <- liftIO $ forkProcess node (proc rport)
385+ return sport
distributed-process/src/Control/Distributed/Process/Closure.hs+125−58
@@ -12,7 +12,7 @@
1212--
1313-- you can use a Template Haskell splice to create a static version of 'f':
1414--
15−-- > $(mkStatic 'f) :: forall a1 .. an. Static T
15+-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T
1616--
1717-- Every module that you write that contains calls to 'mkStatic' needs to
1818-- have a call to 'remotable':
@@ -35,29 +35,90 @@
3535-- > . Mn.__remoteTable
3636-- > $ initRemoteTable
3737--
38+-- [Dealing with type class qualifiers]
39+--
40+-- Although 'mkStatic' supports polymorphic types, it does not support
41+-- qualified types. For instance, you cannot call 'mkStatic' on
42+--
43+-- > decode :: Serializable a => ByteString -> a
44+--
45+-- Instead, you will need to reify the type class dictionary. Cloud Haskell
46+-- comes with a reified version of 'Serializable':
47+--
48+-- > data SerializableDict a where
49+-- > SerializableDict :: Serializable a => SerializableDict a
50+--
51+-- Using the reified dictionary you can define
52+--
53+-- > decodeDict :: SerializableDict a -> ByteString -> a
54+-- > decodeDict SerializableDict = decode
55+--
56+-- where 'decodeDict' is a normal (unqualified) polymorphic value and hence
57+-- can be passed as an argument to remotable:
58+--
59+-- > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)
60+--
3861-- [Composing static values]
3962--
40−-- We generalize the notion of 'static' as described in the paper, and also
41−-- provide
63+-- The version of 'static' provided by this implementation of Cloud Haskell is
64+-- strictly more expressive than the one proposed in the paper, and additionally
65+-- supports
4266--
4367-- > staticApply :: Static (a -> b) -> Static a -> Static b
4468--
45−-- This makes it possible to define a rich set of combinators on 'static'
46−-- values, a number of which are provided in this module.
69+-- This is extremely useful. For example, Cloud Haskell comes with
70+-- 'staticDecode' defined as
71+--
72+-- > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
73+-- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
74+--
75+-- 'staticDecode' is used when defining closures (see below), and makes
76+-- essential use of 'staticApply'.
77+--
78+-- Support for 'staticApply' also makes it possible to define a rich set of
79+-- combinators on 'static' values, a number of which are provided in this
80+-- module.
81+--
82+-- [Static serialization dictionaries]
83+--
84+-- Many Cloud Haskell primitives (like 'staticDecode', above) require static
85+-- serialization dictionaries. In principle these dictionaries require nothing
86+-- special; for instance, given some serializable type 'T' you can define
87+--
88+-- > sdictT :: SerializableDict T
89+-- > sdictT = SerializableDict
90+--
91+-- and then have
92+--
93+-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)
94+--
95+-- However, since these dictionaries are so frequently required Cloud Haskell
96+-- provides special support for them. When you call 'remotable' on a
97+-- /monomorphic/ function @f :: T1 -> T2@
98+--
99+-- > remotable ['f]
100+--
101+-- then a serialization dictionary is automatically created for you, which you
102+-- can access with
103+--
104+-- > $(functionSDict 'f) :: Static (SerializableDict T1)
105+--
106+-- In addition, if @f :: T1 -> Process T2@, then a second dictionary is created
107+--
108+-- > $(functionTDict 'f) :: Static (SerializableDict T2)
47109--
48110-- [Closures]
49111--
50112-- Suppose you have a process
51113--
52−-- > factorial :: Int -> Process Int
114+-- > isPrime :: Integer -> Process Bool
53115--
54−-- Then you can use the supplied Template Haskell function 'mkClosure' to define
116+-- Then
55117--
56−-- > factorialClosure :: Int -> Closure (Process Int)
57−-- > factorialClosure = $(mkClosure 'factorial)
118+-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)
58119--
59−-- You can then pass 'factorialClosure n' to 'spawn', for example, to have a
60−-- remote node compute a factorial number.
120+-- which you can then 'call', for example, to have a remote node check if
121+-- a number is prime.
61122--
62123-- In general, if you have a /monomorphic/ function
63124--
@@ -76,55 +137,17 @@
76137--
77138-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
78139--
79−-- The splice @$(mkClosure 'factorial)@ above expands to (prettified a bit):
140+-- The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit):
80141--
81−-- > factorialClosure :: Int -> Closure (Process Int)
82−-- > factorialClosure n = Closure decoder (encode n)
83−-- > where
84−-- > decoder :: Static (ByteString -> Process Int)
85−-- > decoder = $(mkStatic 'factorial)
142+-- > let decoder :: Static (ByteString -> Process Bool)
143+-- > decoder = $(mkStatic 'isPrime)
86144-- > `staticCompose`
87−-- > staticDecode $(functionSDict 'factorial)
88−--
89−-- 'mkStatic' we have already seen:
90−--
91−-- > $(mkStatic 'factorial) :: Static (Int -> Process Int)
92−--
93−-- 'staticCompose' is function composition on static functions. 'staticDecode'
94−-- has type (**)
95−--
96−-- > staticDecode :: Typeable a
97−-- > => Static (SerializableDict a) -> Static (ByteString -> a)
98−--
99−-- and gives you a static decoder, given a static Serializable dictionary.
100−-- 'SerializableDict' is a reified type class dictionary, and defined simply as
101−--
102−-- > data SerializableDict a where
103−-- > SerializableDict :: Serializable a => SerializableDict a
104−--
105−-- That means that for any serialziable type 'T', you can define
106−--
107−-- > sdictForMyType :: SerializableDict T
108−-- > sdictForMyType = SerializableDict
145+-- > staticDecode $(functionSDict 'isPrime)
146+-- > in Closure decoder (encode n)
109147--
110−-- and then use
111−--
112−-- > $(mkStatic 'sdictForMyType) :: Static (SerializableDict T)
113−--
114−-- to obtain a static serializable dictionary for 'T' (make sure to pass
115−-- 'sdictForMyType' to 'remotable').
116−--
117−-- However, since these serialization dictionaries are so frequently required,
118−-- when you call 'remotable' on a monomorphic function @f : T1 -> T2@
119−--
120−-- > remotable ['f]
121−--
122−-- then a serialization dictionary is automatically created for you, which you
123−-- can access with
124−--
125−-- > $(functionDict 'f) :: Static (SerializableDict T1)
126−--
127−-- This is the dictionary that 'mkClosure' uses.
148+-- where 'staticCompose' is composition of static functions. Note that
149+-- 'mkClosure' makes use of the static serialization dictionary
150+-- ('functionSDict') created by 'remotable'.
128151--
129152-- [Combinators on Closures]
130153--
@@ -133,6 +156,47 @@
133156-- the most important of which is 'cpBind'. Have a look at the implementation
134157-- of 'Control.Distributed.Process.call' for an example use.
135158--
159+-- [Example]
160+--
161+-- Here is a small self-contained example that uses closures and serialization
162+-- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet
163+-- Cloud Haskell backend.
164+--
165+-- > {-# LANGUAGE TemplateHaskell #-}
166+-- > import System.Environment (getArgs)
167+-- > import Control.Distributed.Process
168+-- > import Control.Distributed.Process.Closure
169+-- > import Control.Distributed.Process.Backend.SimpleLocalnet
170+-- > import Control.Distributed.Process.Node (initRemoteTable)
171+-- >
172+-- > isPrime :: Integer -> Process Bool
173+-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
174+-- > where
175+-- > sieve :: [Integer] -> [Integer]
176+-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
177+-- >
178+-- > remotable ['isPrime]
179+-- >
180+-- > master :: [NodeId] -> Process ()
181+-- > master [] = liftIO $ putStrLn "no slaves"
182+-- > master (slave:_) = do
183+-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))
184+-- > liftIO $ print isPrime79
185+-- >
186+-- > main :: IO ()
187+-- > main = do
188+-- > args <- getArgs
189+-- > case args of
190+-- > ["master", host, port] -> do
191+-- > backend <- initializeBackend host port rtable
192+-- > startMaster backend master
193+-- > ["slave", host, port] -> do
194+-- > backend <- initializeBackend host port rtable
195+-- > startSlave backend
196+-- > where
197+-- > rtable :: RemoteTable
198+-- > rtable = __remoteTable initRemoteTable
199+--
136200-- [Notes]
137201--
138202-- (*) If 'T1' is not serializable you will get a type error in the generated
@@ -147,11 +211,13 @@
147211-- instance into scope, but unless proper 'static' support is added to
148212-- ghc we need both the type class argument and the explicit dictionary.
149213module Control.Distributed.Process.Closure
150− ( -- * User-defined closures
214+ ( -- * Creating static values
151215 remotable
152216 , mkStatic
217+ -- * Template-Haskell support for creating closures
153218 , mkClosure
154219 , functionSDict
220+ , functionTDict
155221 -- * Primitive operations on static values
156222 , staticApply
157223 , staticDuplicate
@@ -207,6 +273,7 @@ import Control.Distributed.Process.Internal.Closure.TH
207273 ( remotable
208274 , mkStatic
209275 , functionSDict
276+ , functionTDict
210277 )
211278import Control.Distributed.Process.Internal.Closure.Static
212279 ( -- Static functionals
distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+3−3
@@ -31,6 +31,7 @@ import Data.ByteString.Lazy (ByteString)
3131import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
3232import Control.Applicative ((<$>))
3333import Control.Monad ((>=>))
34+import Control.Monad.Reader (ask)
3435import Control.Distributed.Process.Serializable (Serializable)
3536import Control.Distributed.Process.Internal.Types
3637 ( Closure(Closure)
@@ -43,7 +44,7 @@ import Control.Distributed.Process.Internal.Types
4344 , typeOfStaticLabel
4445 , ProcessId
4546 , LocalNode(remoteTable)
46− , procMsg
47+ , LocalProcess(processNode)
4748 , SendPort
4849 , ReceivePort
4950 )
@@ -55,7 +56,6 @@ import Control.Distributed.Process.Internal.Primitives
5556 , newChan
5657 )
5758import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
58−import Control.Distributed.Process.Internal.MessageT (getLocalNode)
5959import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
6060import Control.Distributed.Process.Internal.Closure.Static
6161 ( staticCompose
@@ -118,7 +118,7 @@ sdictComp = SerializableDict
118118-- | Resolve a closure
119119unClosure :: Static a -> ByteString -> Process Dynamic
120120unClosure (Static label) env = do
121− rtable <- remoteTable <$> procMsg getLocalNode
121+ rtable <- remoteTable . processNode <$> ask
122122 case resolveClosure rtable label env of
123123 Nothing -> fail "Derived.unClosure: resolveClosure failed"
124124 Just dyn -> return dyn
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+71−50
@@ -7,6 +7,7 @@ module Control.Distributed.Process.Internal.Closure.TH
77 remotable
88 , mkStatic
99 , functionSDict
10+ , functionTDict
1011 ) where
1112
1213import Prelude hiding (lookup)
@@ -47,6 +48,7 @@ import Control.Distributed.Process.Internal.Types
4748 , StaticLabel(StaticLabel)
4849 , remoteTableLabel
4950 , SerializableDict(SerializableDict)
51+ , Process
5052 )
5153import Control.Distributed.Process.Internal.Dynamic
5254 ( Dynamic(..)
@@ -74,18 +76,19 @@ remotable ns = do
7476mkStatic :: Name -> Q Exp
7577mkStatic = varE . staticName
7678
77−-- | Serialization dictionary for a function argument (see module header)
79+-- | If @f : T1 -> T2@ is a monomorphic function
80+-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
81+--
82+-- Be sure to pass 'f' to 'remotable'.
7883functionSDict :: Name -> Q Exp
7984functionSDict = varE . sdictName
8085
81−{-
82−-- | Create a closure
83−--
84−-- See module documentation header for "Control.Distributed.Process.Closure"
85−-- for a detailed explanation and examples.
86−mkClosure :: Name -> Q Exp
87−mkClosure = varE . closureName
88−-}
86+-- | If @f : T1 -> Process T2@ is a monomorphic function
87+-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
88+--
89+-- Be sure to pass 'f' to 'remotable'.
90+functionTDict :: Name -> Q Exp
91+functionTDict = varE . tdictName
8992
9093--------------------------------------------------------------------------------
9194-- Internal (Template Haskell) --
@@ -100,44 +103,59 @@ createMetaData is =
100103
101104generateDefs :: Name -> Q ([Dec], [Q Exp])
102105generateDefs n = do
103− mType <- getType n
104− case mType of
105− Just (origName, typ) -> do
106− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
107− _ -> ([], typ)
108− (static, register) <- do
109− static <- generateStatic origName typVars typ'
110− let dyn = case typVars of
111− [] -> [| toDyn $(varE origName) |]
112− _ -> [| Dynamic (error "Polymorphic value")
113− (unsafeCoerce# $(varE origName))
114− |]
115− return ( static
116− , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
106+ proc <- [t| Process |]
107+ mType <- getType n
108+ case mType of
109+ Just (origName, typ) -> do
110+ let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
111+ _ -> ([], typ)
112+
113+ -- The main "static" entry
114+ (static, register) <- makeStatic origName typVars typ'
115+
116+ -- If n :: T1 -> T2, static serializable dictionary for T1
117+ -- TODO: we should check if arg is an instance of Serializable, but we cannot
118+ -- http://hackage.haskell.org/trac/ghc/ticket/7066
119+ (sdict, registerSDict) <- case (typVars, typ') of
120+ ([], ArrowT `AppT` arg `AppT` _res) ->
121+ makeDict (sdictName origName) arg
122+ _ ->
123+ return ([], [])
124+
125+ -- If n :: T1 -> Process T2, static serializable dictionary for T2
126+ -- TODO: check if T2 is serializable (same as above)
127+ (tdict, registerTDict) <- case (typVars, typ') of
128+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
129+ makeDict (tdictName origName) res
130+ _ ->
131+ return ([], [])
132+
133+ return ( concat [static, sdict, tdict]
134+ , concat [register, registerSDict, registerTDict]
117135 )
136+ _ ->
137+ fail $ "remotable: " ++ show n ++ " not found"
138+ where
139+ makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
140+ makeStatic origName typVars typ = do
141+ static <- generateStatic origName typVars typ
142+ let dyn = case typVars of
143+ [] -> [| toDyn $(varE origName) |]
144+ _ -> [| Dynamic (error "Polymorphic value")
145+ (unsafeCoerce# $(varE origName))
146+ |]
147+ return ( static
148+ , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
149+ )
118150
119− (sdict, registerSDict) <- case (typVars, typ') of
120− ([], ArrowT `AppT` arg `AppT` _res) -> do
121− -- TODO: we should check if arg is an instance of Serializable, but we cannot
122− -- http://hackage.haskell.org/trac/ghc/ticket/7066
123− sdict <- generateSDict origName arg
124− let dyn' = [| toDyn (SerializableDict
125− :: SerializableDict $(return arg)
126− )
127− |]
128− return ( sdict
129− , [ [| registerStatic $(stringE (show (sdictName origName)))
130− $dyn'
131− |] ]
132− )
133− _ ->
134− return ([], [])
135−
136− return ( static ++ sdict
137− , register ++ registerSDict
151+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
152+ makeDict dictName typ = do
153+ sdict <- generateDict dictName typ
154+ let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]
155+ return ( sdict
156+ , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
138157 )
139− _ ->
140− fail $ "remotable: " ++ show n ++ " not found"
158+
141159
142160registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
143161registerStatic label dyn = remoteTableLabel label ^= Just dyn
@@ -163,14 +181,14 @@ generateStatic n xs typ = do
163181 typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
164182 typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
165183
166−-- | Generate a function serialization dictionary
167−generateSDict :: Name -> Type -> Q [Dec]
168−generateSDict n typ = do
184+-- | Generate a serialization dictionary with name 'n' for type 'typ'
185+generateDict :: Name -> Type -> Q [Dec]
186+generateDict n typ = do
169187 sequence
170− [ sigD (sdictName n) $ [t| Static (SerializableDict $(return typ)) |]
171− , sfnD (sdictName n)
188+ [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
189+ , sfnD n
172190 [| Static $ StaticLabel
173− $(stringE (show (sdictName n)))
191+ $(stringE (show n))
174192 (typeOf (undefined :: SerializableDict $(return typ)))
175193 |]
176194 ]
@@ -181,6 +199,9 @@ staticName n = mkName $ nameBase n ++ "__static"
181199sdictName :: Name -> Name
182200sdictName n = mkName $ nameBase n ++ "__sdict"
183201
202+tdictName :: Name -> Name
203+tdictName n = mkName $ nameBase n ++ "__tdict"
204+
184205--------------------------------------------------------------------------------
185206-- Generic Template Haskell auxiliary functions --
186207--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/MessageT.hsdeleted−130
@@ -1,130 +0,0 @@
1−-- | Add message sending capability to a monad
2−--
3−-- NOTE: Not thread-safe (you should not do concurrent sends within the same
4−-- monad).
5−module Control.Distributed.Process.Internal.MessageT
6− ( MessageT
7− , runMessageT
8− , getLocalNode
9− , sendPayload
10− , sendBinary
11− , sendMessage
12− , payloadToMessage
13− , createMessage
14− ) where
15−
16−import Data.Binary (Binary, encode)
17−import qualified Data.ByteString as BSS (ByteString)
18−import qualified Data.ByteString.Lazy as BSL (toChunks)
19−import Data.Map (Map)
20−import qualified Data.Map as Map (empty)
21−import Data.Accessor (Accessor, accessor, (^=), (^.))
22−import qualified Data.Accessor.Container as DAC (mapMaybe)
23−import Control.Category ((>>>))
24−import Control.Monad (unless, liftM)
25−import Control.Monad.State (gets, modify, evalStateT)
26−import Control.Monad.IO.Class (MonadIO, liftIO)
27−import Control.Concurrent.Chan (writeChan)
28−import Control.Distributed.Process.Internal.Types
29− ( Identifier(..)
30− , nodeOf
31− , NodeId(nodeAddress)
32− , LocalNode(localCtrlChan, localEndPoint)
33− , NCMsg(NCMsg, ctrlMsgSender, ctrlMsgSignal)
34− , DiedReason(DiedDisconnect)
35− , ProcessSignal(Died)
36− , MessageT(..)
37− , MessageState(..)
38− , createMessage
39− , messageToPayload
40− , payloadToMessage
41− )
42−import Control.Distributed.Process.Serializable (Serializable)
43−import qualified Network.Transport as NT
44− ( EndPoint
45− , Connection
46− , connect
47− , send
48− , Reliability(ReliableOrdered)
49− , defaultConnectHints
50− )
51−
52−--------------------------------------------------------------------------------
53−-- API --
54−--------------------------------------------------------------------------------
55−
56−runMessageT :: Monad m => LocalNode -> MessageT m a -> m a
57−runMessageT localNode m =
58− evalStateT (unMessageT m) $ initMessageState localNode
59−
60−getLocalNode :: Monad m => MessageT m LocalNode
61−getLocalNode = gets messageLocalNode
62−
63−sendPayload :: MonadIO m => Identifier -> [BSS.ByteString] -> MessageT m ()
64−sendPayload them payload = do
65− mConn <- connTo them
66− didSend <- case mConn of
67− Just conn -> do
68− didSend <- liftIO $ NT.send conn payload
69− case didSend of
70− Left _ -> return False
71− Right _ -> return True
72− Nothing -> return False
73− unless didSend $ do
74− node <- getLocalNode
75− liftIO . writeChan (localCtrlChan node) $ NCMsg
76− { ctrlMsgSender = them
77− , ctrlMsgSignal = Died them DiedDisconnect
78− }
79−
80−sendBinary :: (MonadIO m, Binary a) => Identifier -> a -> MessageT m ()
81−sendBinary them = sendPayload them . BSL.toChunks . encode
82−
83−sendMessage :: (MonadIO m, Serializable a) => Identifier -> a -> MessageT m ()
84−sendMessage them = sendPayload them . messageToPayload . createMessage
85−
86−--------------------------------------------------------------------------------
87−-- Internal --
88−--------------------------------------------------------------------------------
89−
90−initMessageState :: LocalNode -> MessageState
91−initMessageState localNode = MessageState {
92− messageLocalNode = localNode
93− , _messageConnections = Map.empty
94− }
95−
96−setupConnTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
97−setupConnTo them = do
98− endPoint <- localEndPoint `liftM` getLocalNode
99− mConn <- liftIO $ NT.connect endPoint
100− (nodeAddress . nodeOf $ them)
101− NT.ReliableOrdered
102− NT.defaultConnectHints
103− case mConn of
104− Right conn -> do
105− didSend <- liftIO $ NT.send conn (BSL.toChunks . encode $ them)
106− case didSend of
107− Left _ ->
108− return Nothing
109− Right () -> do
110− modify $ messageConnectionTo them ^= Just conn
111− return $ Just conn
112− Left _ ->
113− return Nothing
114−
115−connTo :: MonadIO m => Identifier -> MessageT m (Maybe NT.Connection)
116−connTo them = do
117− mConn <- gets (^. messageConnectionTo them)
118− case mConn of
119− Just conn -> return $ Just conn
120− Nothing -> setupConnTo them
121−
122−--------------------------------------------------------------------------------
123−-- Accessors --
124−--------------------------------------------------------------------------------
125−
126−messageConnections :: Accessor MessageState (Map Identifier NT.Connection)
127−messageConnections = accessor _messageConnections (\conns st -> st { _messageConnections = conns })
128−
129−messageConnectionTo :: Identifier -> Accessor MessageState (Maybe NT.Connection)
130−messageConnectionTo them = messageConnections >>> DAC.mapMaybe them
distributed-process/src/Control/Distributed/Process/Internal/Node.hs+84−9
@@ -1,16 +1,91 @@
11module Control.Distributed.Process.Internal.Node
2− ( runLocalProcess
2+ ( -- * Message sending
3+ sendPayload
4+ , sendBinary
5+ , sendMessage
36 ) where
47
5−import Control.Monad.Reader (runReaderT)
8+import Data.Accessor ((^.), (^=))
9+import Data.Binary (Binary, encode)
10+import qualified Data.ByteString.Lazy as BSL (toChunks)
11+import qualified Data.ByteString as BSS (ByteString)
12+import Control.Concurrent.MVar (withMVar, modifyMVar_)
13+import Control.Concurrent.Chan (writeChan)
14+import Control.Monad (unless)
15+import qualified Network.Transport as NT
16+ ( Connection
17+ , send
18+ , defaultConnectHints
19+ , connect
20+ , Reliability(ReliableOrdered)
21+ )
622import Control.Distributed.Process.Internal.Types
7− ( LocalNode
8− , LocalProcess
9− , Process(unProcess)
23+ ( LocalNode(localState, localEndPoint, localCtrlChan)
24+ , Identifier
25+ , localConnectionBetween
26+ , nodeAddress
27+ , nodeOf
28+ , messageToPayload
29+ , createMessage
30+ , NCMsg(..)
31+ , ProcessSignal(Died)
32+ , DiedReason(DiedDisconnect)
1033 )
11−import Control.Distributed.Process.Internal.MessageT (runMessageT)
34+import Control.Distributed.Process.Serializable (Serializable)
35+
36+--------------------------------------------------------------------------------
37+-- Message sending --
38+--------------------------------------------------------------------------------
39+
40+sendPayload :: LocalNode -> Identifier -> Identifier -> [BSS.ByteString] -> IO ()
41+sendPayload node from to payload = do
42+ mConn <- connBetween node from to
43+ didSend <- case mConn of
44+ Just conn -> do
45+ didSend <- NT.send conn payload
46+ case didSend of
47+ Left _ -> return False
48+ Right _ -> return True
49+ Nothing -> return False
50+ unless didSend $
51+ writeChan (localCtrlChan node) NCMsg
52+ { ctrlMsgSender = to
53+ , ctrlMsgSignal = Died to DiedDisconnect
54+ }
55+
56+sendBinary :: Binary a => LocalNode -> Identifier -> Identifier -> a -> IO ()
57+sendBinary node from to = sendPayload node from to . BSL.toChunks . encode
58+
59+sendMessage :: Serializable a => LocalNode -> Identifier -> Identifier -> a -> IO ()
60+sendMessage node from to = sendPayload node from to . messageToPayload . createMessage
1261
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)
62+setupConnBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
63+setupConnBetween node from to = do
64+ mConn <- NT.connect endPoint
65+ (nodeAddress . nodeOf $ to)
66+ NT.ReliableOrdered
67+ NT.defaultConnectHints
68+ case mConn of
69+ Right conn -> do
70+ didSend <- NT.send conn (BSL.toChunks . encode $ to)
71+ case didSend of
72+ Left _ ->
73+ return Nothing
74+ Right () -> do
75+ modifyMVar_ nodeState $ return .
76+ (localConnectionBetween from to ^= Just conn)
77+ return $ Just conn
78+ Left _ ->
79+ return Nothing
80+ where
81+ endPoint = localEndPoint node
82+ nodeState = localState node
1683
84+connBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
85+connBetween node from to = do
86+ mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)
87+ case mConn of
88+ Just conn -> return $ Just conn
89+ Nothing -> setupConnBetween node from to
90+ where
91+ nodeState = localState node
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+25−21
@@ -68,7 +68,7 @@ import Control.Monad.Reader (ask)
6868import Control.Monad.IO.Class (MonadIO, liftIO)
6969import Control.Applicative ((<$>))
7070import Control.Exception (Exception, throw)
71−import qualified Control.Exception as Exception (catch)
71+import qualified Control.Exception as Ex (catch)
7272import Control.Concurrent.MVar (modifyMVar)
7373import Control.Concurrent.Chan (writeChan)
7474import Control.Concurrent.STM
@@ -106,7 +106,6 @@ import Control.Distributed.Process.Internal.Types
106106 , TypedChannel(..)
107107 , SendPortId(..)
108108 , Identifier(..)
109− , procMsg
110109 , DidUnmonitor(..)
111110 , DidUnlinkProcess(..)
112111 , DidUnlinkNode(..)
@@ -114,13 +113,9 @@ import Control.Distributed.Process.Internal.Types
114113 , WhereIsReply(..)
115114 , createMessage
116115 , Static(..)
116+ , runLocalProcess
117117 )
118−import Control.Distributed.Process.Internal.MessageT
119− ( sendMessage
120− , sendBinary
121− , getLocalNode
122− )
123−import Control.Distributed.Process.Internal.Node (runLocalProcess)
118+import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)
124119import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
125120import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
126121
@@ -132,7 +127,12 @@ import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
132127send :: Serializable a => ProcessId -> a -> Process ()
133128-- This requires a lookup on every send. If we want to avoid that we need to
134129-- modify serializable to allow for stateful (IO) deserialization
135−send them msg = procMsg $ sendMessage (ProcessIdentifier them) msg
130+send them msg = do
131+ proc <- ask
132+ liftIO $ sendMessage (processNode proc)
133+ (ProcessIdentifier (processId proc))
134+ (ProcessIdentifier them)
135+ msg
136136
137137-- | Wait for a message of a specific type
138138expect :: forall a. Serializable a => Process a
@@ -163,7 +163,12 @@ newChan = do
163163
164164-- | Send a message on a typed channel
165165sendChan :: Serializable a => SendPort a -> a -> Process ()
166−sendChan (SendPort cid) msg = procMsg $ sendBinary (SendPortIdentifier cid) msg
166+sendChan (SendPort cid) msg = do
167+ proc <- ask
168+ liftIO $ sendBinary (processNode proc)
169+ (ProcessIdentifier (processId proc))
170+ (SendPortIdentifier cid)
171+ msg
167172
168173-- | Wait for a message on a typed channel
169174receiveChan :: Serializable a => ReceivePort a -> Process a
@@ -261,7 +266,7 @@ getSelfPid = processId <$> ask
261266
262267-- | Get the node ID of our local node
263268getSelfNode :: Process NodeId
264−getSelfNode = localNodeId <$> procMsg getLocalNode
269+getSelfNode = localNodeId . processNode <$> ask
265270
266271--------------------------------------------------------------------------------
267272-- Monitoring and linking --
@@ -318,11 +323,8 @@ unmonitor ref = do
318323-- | Catch exceptions within a process
319324catch :: Exception e => Process a -> (e -> Process a) -> Process a
320325catch p h = do
321− node <- procMsg getLocalNode
322326 lproc <- ask
323− let run :: Process a -> IO a
324− run proc = runLocalProcess node proc lproc
325− liftIO $ Exception.catch (run p) (run . h)
327+ liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
326328
327329-- | Like 'expect' but with a timeout
328330expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
@@ -460,7 +462,7 @@ nsendRemote nid label msg =
460462-- | Deserialize a closure
461463unClosure :: forall a. Typeable a => Closure a -> Process a
462464unClosure (Closure (Static label) env) = do
463− rtable <- remoteTable <$> procMsg getLocalNode
465+ rtable <- remoteTable . processNode <$> ask
464466 case resolveClosure rtable label env of
465467 Nothing -> throw . userError $ "Unregistered closure " ++ show label
466468 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
@@ -507,14 +509,16 @@ sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
507509 -> ProcessSignal -- ^ Message to send
508510 -> Process ()
509511sendCtrlMsg mNid signal = do
510− us <- getSelfPid
511− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier us
512+ proc <- ask
513+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
512514 , ctrlMsgSignal = signal
513515 }
514516 case mNid of
515517 Nothing -> do
516− ctrlChan <- localCtrlChan <$> procMsg getLocalNode
518+ ctrlChan <- localCtrlChan . processNode <$> ask
517519 liftIO $ writeChan ctrlChan msg
518520 Just nid ->
519− procMsg $ sendBinary (NodeIdentifier nid) msg
520−
521+ liftIO $ sendBinary (processNode proc)
522+ (ProcessIdentifier (processId proc))
523+ (NodeIdentifier nid)
524+ msg
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+21−30
@@ -17,7 +17,7 @@ module Control.Distributed.Process.Internal.Types
1717 , LocalProcess(..)
1818 , LocalProcessState(..)
1919 , Process(..)
20− , procMsg
20+ , runLocalProcess
2121 -- * Typed channels
2222 , LocalSendPortId
2323 , SendPortId(..)
@@ -58,14 +58,13 @@ module Control.Distributed.Process.Internal.Types
5858 -- * Node controller internal data types
5959 , NCMsg(..)
6060 , ProcessSignal(..)
61− -- * MessageT monad
62− , MessageT(..)
63− , MessageState(..)
6461 -- * Accessors
6562 , localProcesses
6663 , localPidCounter
6764 , localPidUnique
65+ , localConnections
6866 , localProcessWithId
67+ , localConnectionBetween
6968 , monitorCounter
7069 , spawnCounter
7170 , channelCounter
@@ -97,10 +96,8 @@ import Control.Concurrent.Chan (Chan)
9796import Control.Concurrent.STM (TChan, TVar)
9897import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
9998import Control.Applicative (Applicative, (<$>), (<*>))
100−import Control.Monad.Reader (MonadReader(..), ReaderT)
99+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
101100import Control.Monad.IO.Class (MonadIO)
102−import Control.Monad.State (MonadState, StateT)
103−import qualified Control.Monad.Trans.Class as Trans (lift)
104101import Control.Distributed.Process.Serializable
105102 ( Fingerprint
106103 , Serializable
@@ -131,10 +128,7 @@ data LocalProcessId = LocalProcessId
131128 { lpidUnique :: Int32
132129 , lpidCounter :: Int32
133130 }
134− deriving (Eq, Ord, Typeable)
135−
136−instance Show LocalProcessId where
137− show = show . lpidCounter
131+ deriving (Eq, Ord, Typeable, Show)
138132
139133-- | Process identifier
140134data ProcessId = ProcessId
@@ -187,9 +181,10 @@ data LocalNode = LocalNode
187181
188182-- | Local node state
189183data LocalNodeState = LocalNodeState
190− { _localProcesses :: Map LocalProcessId LocalProcess
191− , _localPidCounter :: Int32
192− , _localPidUnique :: Int32
184+ { _localProcesses :: Map LocalProcessId LocalProcess
185+ , _localPidCounter :: Int32
186+ , _localPidUnique :: Int32
187+ , _localConnections :: Map (Identifier, Identifier) NT.Connection
193188 }
194189
195190-- | Processes running on our local node
@@ -198,8 +193,13 @@ data LocalProcess = LocalProcess
198193 , processId :: ProcessId
199194 , processState :: MVar LocalProcessState
200195 , processThread :: ThreadId
196+ , processNode :: LocalNode
201197 }
202198
199+-- | Deconstructor for 'Process' (not exported to the public API)
200+runLocalProcess :: LocalProcess -> Process a -> IO a
201+runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
202+
203203-- | Local process state
204204data LocalProcessState = LocalProcessState
205205 { _monitorCounter :: Int32
@@ -210,13 +210,10 @@ data LocalProcessState = LocalProcessState
210210
211211-- | The Cloud Haskell 'Process' type
212212newtype Process a = Process {
213− unProcess :: ReaderT LocalProcess (MessageT IO) a
213+ unProcess :: ReaderT LocalProcess IO a
214214 }
215215 deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
216216
217−procMsg :: MessageT IO a -> Process a
218−procMsg = Process . Trans.lift
219−
220217--------------------------------------------------------------------------------
221218-- Typed channels --
222219--------------------------------------------------------------------------------
@@ -574,9 +571,15 @@ localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter =
574571localPidUnique :: Accessor LocalNodeState Int32
575572localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
576573
574+localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) NT.Connection)
575+localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })
576+
577577localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
578578localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
579579
580+localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe NT.Connection)
581+localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)
582+
580583monitorCounter :: Accessor LocalProcessState Int32
581584monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
582585
@@ -597,15 +600,3 @@ remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLa
597600
598601remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
599602remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label
600−
601−--------------------------------------------------------------------------------
602−-- MessageT monad --
603−--------------------------------------------------------------------------------
604−
605−newtype MessageT m a = MessageT { unMessageT :: StateT MessageState m a }
606− deriving (Functor, Monad, MonadIO, MonadState MessageState, Applicative)
607−
608−data MessageState = MessageState {
609− messageLocalNode :: LocalNode
610− , _messageConnections :: Map Identifier NT.Connection
611− }
distributed-process/src/Control/Distributed/Process/Node.hs+64−47
@@ -38,7 +38,7 @@ import Control.Applicative ((<$>))
3838import Control.Monad (void, when, forever)
3939import Control.Monad.IO.Class (MonadIO, liftIO)
4040import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
41−import qualified Control.Monad.Trans.Class as Trans (lift)
41+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
4242import Control.Exception (throwIO, SomeException, Exception, throwTo)
4343import qualified Control.Exception as Exception (catch)
4444import Control.Concurrent (forkIO)
@@ -101,7 +101,6 @@ import Control.Distributed.Process.Internal.Types
101101 , Closure(..)
102102 , Static(..)
103103 , Message
104− , MessageT
105104 , TypedChannel(..)
106105 , Identifier(..)
107106 , nodeOf
@@ -110,20 +109,18 @@ import Control.Distributed.Process.Internal.Types
110109 , WhereIsReply(..)
111110 , messageToPayload
112111 , RemoteTable(..)
112+ , payloadToMessage
113+ , createMessage
114+ , runLocalProcess
113115 )
114116import Control.Distributed.Process.Serializable (Serializable)
115−import Control.Distributed.Process.Internal.MessageT
117+import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
118+import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
119+import Control.Distributed.Process.Internal.Node
116120 ( sendBinary
117121 , sendMessage
118122 , sendPayload
119− , getLocalNode
120− , runMessageT
121− , payloadToMessage
122− , createMessage
123123 )
124−import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
125−import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
126−import Control.Distributed.Process.Internal.Node (runLocalProcess)
127124import Control.Distributed.Process.Internal.Primitives (expect, register)
128125import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
129126import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
@@ -156,9 +153,10 @@ createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
156153createBareLocalNode endPoint rtable = do
157154 unq <- randomIO
158155 state <- newMVar LocalNodeState
159− { _localProcesses = Map.empty
160− , _localPidCounter = 0
161− , _localPidUnique = unq
156+ { _localProcesses = Map.empty
157+ , _localPidCounter = 0
158+ , _localPidUnique = unq
159+ , _localConnections = Map.empty
162160 }
163161 ctrlChan <- newChan
164162 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
@@ -214,10 +212,11 @@ forkProcess node proc = modifyMVar (localState node) $ \st -> do
214212 , processId = pid
215213 , processState = pst
216214 , processThread = tid
215+ , processNode = node
217216 }
218217 tid' <- forkIO $ do
219218 reason <- Exception.catch
220− (runLocalProcess node proc lproc >> return DiedNormal)
219+ (runLocalProcess lproc proc >> return DiedNormal)
221220 (return . DiedException . (show :: SomeException -> String))
222221 -- [Unified: Table 4, rules termination and exiting]
223222 modifyMVar_ (localState node) $
@@ -287,7 +286,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
287286 (Map.insert cid proc procs)
288287 chans
289288 ctrls
290− Nothing ->
289+ Nothing ->
291290 -- Request for an unknown process.
292291 --
293292 -- TODO: We should treat this as a fatal error on the
@@ -367,8 +366,8 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
367366--------------------------------------------------------------------------------
368367
369368runNodeController :: LocalNode -> IO ()
370−runNodeController node =
371− runMessageT node (evalStateT (unNC nodeController) initNCState)
369+runNodeController =
370+ runReaderT (evalStateT (unNC nodeController) initNCState)
372371
373372--------------------------------------------------------------------------------
374373-- Internal data types --
@@ -383,11 +382,8 @@ data NCState = NCState
383382 , _registry :: Map String ProcessId
384383 }
385384
386−newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }
387− deriving (Functor, Monad, MonadIO, MonadState NCState)
388−
389−ncMsg :: MessageT IO a -> NC a
390−ncMsg = NC . Trans.lift
385+newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }
386+ deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)
391387
392388initNCState :: NCState
393389initNCState = NCState { _links = Map.empty
@@ -402,14 +398,17 @@ initNCState = NCState { _links = Map.empty
402398-- [Unified: Table 7]
403399nodeController :: NC ()
404400nodeController = do
405− node <- ncMsg getLocalNode
401+ node <- ask
406402 forever $ do
407403 msg <- liftIO $ readChan (localCtrlChan node)
408404
409405 -- [Unified: Table 7, rule nc_forward]
410406 case destNid (ctrlMsgSignal msg) of
411407 Just nid' | nid' /= localNodeId node ->
412− ncMsg $ sendBinary (NodeIdentifier nid') msg
408+ liftIO $ sendBinary node
409+ (ctrlMsgSender msg)
410+ (NodeIdentifier nid')
411+ msg
413412 _ ->
414413 return ()
415414
@@ -441,7 +440,7 @@ ncEffectMonitor :: ProcessId -- ^ Who's watching?
441440 -> Maybe MonitorRef -- ^ 'Nothing' to link
442441 -> NC ()
443442ncEffectMonitor from them mRef = do
444− node <- ncMsg getLocalNode
443+ node <- ask
445444 shouldLink <-
446445 if not (isLocal node them)
447446 then return True
@@ -454,15 +453,21 @@ ncEffectMonitor from them mRef = do
454453 (False, True) -> -- [Unified: second rule]
455454 notifyDied from them DiedUnknownId mRef
456455 (False, False) -> -- [Unified: third rule]
457− ncMsg $ sendBinary (NodeIdentifier $ processNodeId from) NCMsg
458− { ctrlMsgSender = NodeIdentifier (localNodeId node)
459− , ctrlMsgSignal = Died them DiedUnknownId
460− }
456+ -- TODO: this is the right sender according to the Unified semantics,
457+ -- but perhaps having 'them' as the sender would make more sense
458+ -- (see also: notifyDied)
459+ liftIO $ sendBinary node
460+ (NodeIdentifier $ localNodeId node)
461+ (NodeIdentifier $ processNodeId from)
462+ NCMsg
463+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
464+ , ctrlMsgSignal = Died them DiedUnknownId
465+ }
461466
462467-- [Unified: Table 11]
463468ncEffectUnlink :: ProcessId -> Identifier -> NC ()
464469ncEffectUnlink from them = do
465− node <- ncMsg getLocalNode
470+ node <- ask
466471 when (isLocal node (ProcessIdentifier from)) $
467472 case them of
468473 ProcessIdentifier pid ->
@@ -476,7 +481,7 @@ ncEffectUnlink from them = do
476481-- [Unified: Table 11]
477482ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
478483ncEffectUnmonitor from ref = do
479− node <- ncMsg getLocalNode
484+ node <- ask
480485 when (isLocal node (ProcessIdentifier from)) $
481486 postAsMessage from $ DidUnmonitor ref
482487 modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
@@ -484,7 +489,7 @@ ncEffectUnmonitor from ref = do
484489-- [Unified: Table 12]
485490ncEffectDied :: Identifier -> DiedReason -> NC ()
486491ncEffectDied ident reason = do
487− node <- ncMsg getLocalNode
492+ node <- ask
488493 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
489494 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
490495
@@ -509,9 +514,12 @@ ncEffectSpawn pid cProc ref = do
509514 -- If the closure does not exist, we spawn a process that throws an exception
510515 -- This allows the remote node to find out what's happening
511516 let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
512− node <- ncMsg getLocalNode
517+ node <- ask
513518 pid' <- liftIO $ forkProcess node proc
514− ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
519+ liftIO $ sendMessage node
520+ (NodeIdentifier (localNodeId node))
521+ (ProcessIdentifier pid)
522+ (DidSpawn ref pid')
515523
516524-- Unified semantics does not explicitly describe how to implement 'register',
517525-- but mentions it's "very similar to nsend" (Table 14)
@@ -525,18 +533,24 @@ ncEffectRegister label mPid =
525533-- Unified semantics does not explicitly describe 'whereis'
526534ncEffectWhereIs :: ProcessId -> String -> NC ()
527535ncEffectWhereIs from label = do
536+ node <- ask
528537 mPid <- gets (^. registryFor label)
529− ncMsg $ sendMessage (ProcessIdentifier from) (WhereIsReply label mPid)
538+ liftIO $ sendMessage node
539+ (NodeIdentifier (localNodeId node))
540+ (ProcessIdentifier from)
541+ (WhereIsReply label mPid)
530542
531543-- [Unified: Table 14]
532544ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
533−ncEffectNamedSend _from label msg = do
545+ncEffectNamedSend from label msg = do
534546 mPid <- gets (^. registryFor label)
535547 -- If mPid is Nothing, we just ignore the named send (as per Table 14)
536− -- TODO: messages don't carry a "from", but if they do, we should set it
537− -- to be the 'from' of the original named send, not this node controller
548+ node <- ask
538549 forM_ mPid $ \pid ->
539− ncMsg $ sendPayload (ProcessIdentifier pid) (messageToPayload msg)
550+ liftIO $ sendPayload node
551+ from
552+ (ProcessIdentifier pid)
553+ (messageToPayload msg)
540554
541555--------------------------------------------------------------------------------
542556-- Auxiliary --
@@ -548,7 +562,7 @@ notifyDied :: ProcessId -- ^ Who to notify?
548562 -> Maybe MonitorRef -- ^ 'Nothing' for linking
549563 -> NC ()
550564notifyDied dest src reason mRef = do
551− node <- ncMsg getLocalNode
565+ node <- ask
552566 case (isLocal node (ProcessIdentifier dest), mRef, src) of
553567 (True, Just ref, ProcessIdentifier pid) ->
554568 postAsMessage dest $ ProcessMonitorNotification ref pid reason
@@ -565,10 +579,13 @@ notifyDied dest src reason mRef = do
565579 (False, _, _) ->
566580 -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
567581 -- (see [Unified: Table 10]
568− ncMsg $ sendBinary (NodeIdentifier $ processNodeId dest) NCMsg
569− { ctrlMsgSender = NodeIdentifier (localNodeId node)
570− , ctrlMsgSignal = Died src reason
571− }
582+ liftIO $ sendBinary node
583+ (NodeIdentifier $ localNodeId node)
584+ (NodeIdentifier $ processNodeId dest)
585+ NCMsg
586+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
587+ , ctrlMsgSignal = Died src reason
588+ }
572589
573590-- | [Unified: Table 8]
574591destNid :: ProcessSignal -> Maybe NodeId
@@ -592,13 +609,13 @@ isLocal nid ident = nodeOf ident == localNodeId nid
592609-- | Lookup a local closure
593610unClosure :: Typeable a => Closure a -> NC (Maybe a)
594611unClosure (Closure (Static label) env) = do
595− rtable <- remoteTable <$> ncMsg getLocalNode
612+ rtable <- remoteTable <$> ask
596613 return (resolveClosure rtable label env >>= fromDynamic)
597614
598615-- | Check if an identifier refers to a valid local object
599616isValidLocalIdentifier :: Identifier -> NC Bool
600617isValidLocalIdentifier ident = do
601− node <- ncMsg getLocalNode
618+ node <- ask
602619 liftIO . withMVar (localState node) $ \nSt ->
603620 case ident of
604621 NodeIdentifier nid ->
@@ -631,7 +648,7 @@ throwException pid e = withLocalProc pid $ \p ->
631648
632649withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
633650withLocalProc pid p = do
634− node <- ncMsg getLocalNode
651+ node <- ask
635652 liftIO $ do
636653 -- By [Unified: table 6, rule missing_process] messages to dead processes
637654 -- can silently be dropped
distributed-process/tests/TestCH.hs+19
@@ -560,6 +560,24 @@ testRemoteRegistry transport = do
560560 True <- return $ pingServer == pid'
561561 return ()
562562
563+testSpawnLocal :: NT.Transport -> IO ()
564+testSpawnLocal transport = do
565+ node <- newLocalNode transport initRemoteTable
566+
567+ runProcess node $ do
568+ us <- getSelfPid
569+
570+ pid <- spawnLocal $ do
571+ sport <- expect
572+ sendChan sport (1234 :: Int)
573+
574+ sport <- spawnChannelLocal $ \rport -> do
575+ (1234 :: Int) <- receiveChan rport
576+ send us ()
577+
578+ send pid sport
579+ expect
580+
563581main :: IO ()
564582main = do
565583 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -574,6 +592,7 @@ main = do
574592 , ("Terminate", testTerminate transport)
575593 , ("Registry", testRegistry transport)
576594 , ("RemoteRegistry", testRemoteRegistry transport)
595+ , ("SpawnLocal", testSpawnLocal transport)
577596 -- Monitoring processes
578597 --
579598 -- The "missing" combinations in the list below don't make much sense, as
distributed-process/tests/TestClosure.hs+15
@@ -36,6 +36,12 @@ sendPid toPid = do
3636wait :: Int -> Process ()
3737wait = liftIO . threadDelay
3838
39+isPrime :: Integer -> Process Bool
40+isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
41+ where
42+ sieve :: [Integer] -> [Integer]
43+ sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
44+
3945-- | First argument indicates empty closure environment
4046typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
4147typedPingServer () rport = forever $ do
@@ -49,6 +55,7 @@ remotable [ 'factorial
4955 , 'sdictInt
5056 , 'wait
5157 , 'typedPingServer
58+ , 'isPrime
5259 ]
5360
5461factorialClosure :: Int -> Closure (Process Int)
@@ -296,6 +303,13 @@ testSpawnChannel transport rtable = do
296303 sendChan pingServer sendReply
297304 receiveChan receiveReply
298305
306+testTDict :: Transport -> RemoteTable -> IO ()
307+testTDict transport rtable = do
308+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
309+ runProcess node1 $ do
310+ True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
311+ return ()
312+
299313main :: IO ()
300314main = do
301315 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -314,4 +328,5 @@ main = do
314328 , ("SpawnInvalid", testSpawnInvalid transport rtable)
315329 , ("ClosureExpect", testClosureExpect transport rtable)
316330 , ("SpawnChannel", testSpawnChannel transport rtable)
331+ , ("TDict", testTDict transport rtable)
317332 ]
doc/reconnect/blacklist.texnew file+255
@@ -0,0 +1,255 @@
1+\documentclass{article}
2+\usepackage[margin=2.5cm]{geometry}
3+\usepackage{amsmath, amssymb}
4+\usepackage{mathpazo, times}
5+
6+\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}}
7+\newcommand{\sApp}[2]{{#1} {#2}}
8+\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}}
9+\newcommand{\sReturn}{\mathtt{return}}
10+
11+\newcommand{\sExpect}{\mathtt{expect}}
12+\newcommand{\sSend}{\mathtt{send}}
13+\newcommand{\sSpawn}{\mathtt{spawn}}
14+\newcommand{\sLink}{\mathtt{link}}
15+\newcommand{\sThrow}{\mathtt{throw}}
16+\newcommand{\sReconnect}{\mathtt{reconnect}}
17+
18+\newcommand{\sParP}{\mathrel{{\parallel}_P}}
19+\newcommand{\sParN}{\mathrel{{\parallel}_N}}
20+\newcommand{\sProc}[2]{{#1}_{#2}}
21+\newcommand{\sPid}{\ensuremath{\mathit{pid}}}
22+\newcommand{\sNid}{\ensuremath{\mathit{nid}}}
23+\newcommand{\sLinks}{\ensuremath{\mathit{links}}}
24+\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}}
25+\newcommand{\sSystem}[3]{\left\langle #1 ; #2 ; #3 \right\rangle}
26+\newcommand{\sNodes}{\mathcal{N}}
27+\newcommand{\sQueue}{\mathcal{Q}}
28+\newcommand{\sProcesses}{\mathcal{P}}
29+\newcommand{\sBlacklist}{\mathcal{B}}
30+
31+\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}}
32+\newcommand{\sNothing}{\mathtt{Nothing}}
33+
34+\newcommand{\sCtxt}[1]{\mathbb{#1}}
35+
36+\newcommand{\sSenders}{\mathit{senders}}
37+
38+\newcommand{\OR}{\mathrel{|}}
39+
40+
41+\begin{document}
42+
43+\title{Cloud Haskell Semantics}
44+\author{Edsko de Vries, Well-Typed LLP}
45+\date{\today}
46+
47+\maketitle
48+
49+\section{Syntax}
50+
51+\subsection{Terms}
52+
53+\begin{equation*}
54+\begin{array}{ll@{\;::=\;}l}
55+\text{value} & V & \sLam{x}{M} \OR
56+ \sExpect \OR
57+ \sSend \; \sPid \; V \OR
58+ \sSpawn \; \sNid \; V \OR
59+ \sReturn \; M
60+\\
61+\text{term} & M, N & \sApp{M}{N} \OR
62+ \sBind{M}{N}
63+\end{array}
64+\end{equation*}
65+
66+\subsection{Processes, Nodes, Systems}
67+
68+A \emph{process} $\sProc{M}{\sPid}$ is a pair of a term $M$ and a process ID $\sPid$.
69+A \emph{node}
70+ $$\sNode{\sProcesses}
71+ {\sLinks}
72+ {\sNid}$$
73+is a tuple consisting of a set of
74+processes $\sProcesses$, sometimes written as
75+ $$\sProc{M}{\sPid} \sParP \cdots \sParP \sProc{N}{\sPid'}$$
76+together with a set \sLinks{} of pairs of process IDs and a node ID \sNid.
77+A \emph{system}
78+ $\sSystem{\sNodes}{\sQueue}{\sBlacklist}$
79+finally is a tuple containing a set $\sNodes$ of nodes, sometimes written
80+ $$\sNode{\sProcesses}{\sLinks}{\sNid}
81+ \sParN
82+ \cdots
83+ \sParN
84+ \sNode{\sProcesses'}{\sLinks'}{\sNid'}
85+ $$
86+a \emph{system queue} $\sQueue$, and a \emph{blacklist} $\sBlacklist$. The
87+system queue is a set of triples $(\mathit{to}, \mathit{from},
88+\mathit{message})$ of messages that have been sent but not yet processed. The
89+blacklist is a set of pairs $(\mathit{to}, \mathit{from})$. Once a pair
90+$(\mathit{to}, \mathit{from})$ has been blacklisted messages from
91+$\mathit{from}$ to $\mathit{to}$ will never be delivered ($\mathit{to}$ and
92+$\mathit{from}$ are node or process identifiers).
93+
94+\section{Semantics}
95+
96+\subsection{Contexts}
97+
98+We define an evaluation context as usual (TODO: catch?)
99+
100+\begin{equation*}
101+\sCtxt{E} ::= [] \OR \sBind{\sCtxt{E}}{M}
102+\end{equation*}
103+
104+A process context, parametrized by a \sPid, identifies a process within a set
105+of nodes.
106+
107+\begin{equation*}
108+\sCtxt{P}_\sPid ::= \sNode{\sProc{\sCtxt{E}}{pid} \sParP \sProcesses}{\sLinks}{\sNid} \sParN \sNodes
109+\end{equation*}
110+
111+We also find it useful to have a process context with two holes, one for a
112+process identified by \sPid{} and one for the set of processes on node \sNid.
113+This set of processes may or may not live on the same node as \sPid.
114+
115+\begin{equation*}
116+\begin{array}{rl}
117+\sCtxt{P}_{\sPid,\sNid} ::= &
118+ \sNode{\sProc{\sCtxt{E}}{pid} \sParP []}{\sLinks}{\sNid} \sParN \sNodes \\[1em]
119+\OR &
120+ \sNode{\sProc{\sCtxt{E}}{pid} \sParP \sProcesses}{\sLinks}{\sNid'} \sParN \sNode{[]}{\sLinks}{\sNid} \sParN \sNodes
121+ \qquad
122+ (\sNid \neq \sNid')
123+\end{array}
124+\end{equation*}
125+
126+\subsection{System Rules}
127+
128+\begin{equation*}
129+\frac{
130+}{
131+ \sSystem{\sNodes}{\sQueue}{\sBlacklist}
132+\rightarrow
133+ \sSystem{\sNodes}{\sQueue}{\sBlacklist, (\mathit{to}, \mathit{from})}
134+} \textsc{Disconnect}
135+\end{equation*}
136+
137+\subsection{Process rules}
138+
139+\subsubsection{Sending}
140+
141+If the communication is blacklisted the send is a no-op.
142+
143+\begin{equation*}
144+\frac{
145+(\mathit{to}, \mathit{from}) \notin \sBlacklist
146+}{
147+ \sSystem{\sCtxt{P}[ \sSend \; \mathit{to} \; V ]_\mathit{from}}
148+ {\sQueue}
149+ {\sBlacklist}
150+\rightarrow
151+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\mathit{from}}
152+ {\sQueue, (\mathit{to}, \mathit{from}, V)}
153+ {\sBlacklist}
154+} \textsc{Send-Ok}
155+\end{equation*}
156+
157+\begin{equation*}
158+\frac{
159+(\mathit{to}, \mathit{from}) \in \sBlacklist
160+}{
161+ \sSystem{\sCtxt{P}[ \sSend \; \mathit{to} \; V ]_\mathit{from}}
162+ {\sQueue}
163+ {\sBlacklist}
164+\rightarrow
165+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\mathit{from}}
166+ {\sQueue}
167+ {\sBlacklist}
168+} \textsc{Send-No}
169+\end{equation*}
170+
171+TODO: this allows to send functions
172+
173+\subsubsection{Receiving}
174+
175+We return the \emph{first} message of a randomly chosen sender.
176+
177+\begin{equation*}
178+\frac{
179+ \mathit{from} \notin \sSenders(\sQueue)
180+}{
181+ \sSystem{\sCtxt{P}[ \sExpect ]_\mathit{from}}
182+ {\sQueue, (\mathit{to}, \mathit{from}, V), \sQueue'}
183+ {\sBlacklist}
184+\rightarrow
185+ \sSystem{\sCtxt{P}[ \sReturn \; V ]_\mathit{from}}
186+ {\sQueue, \sQueue'}
187+ {\sBlacklist}
188+} \textsc{Expect}
189+\end{equation*}
190+
191+\subsubsection{Spawning}
192+
193+\begin{equation*}
194+\frac{
195+ \sPid' \text{ fresh} \qquad
196+ (\sNid, \sPid) \notin \sBlacklist
197+}{
198+ \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid[\sProcesses]_\sNid}
199+ {\sQueue}
200+ {\sBlacklist}
201+\rightarrow
202+ \sSystem{\sCtxt{P}[ \sReturn \; (\sJust{\sPid'}) ]_\sPid[\sProcesses \sParP M_{\sPid'}]_\sNid}
203+ {\sQueue}
204+ {\sBlacklist}
205+} \textsc{Spawn-Ok}
206+\end{equation*}
207+
208+\begin{equation*}
209+\frac{
210+ (\sNid, \sPid) \in \sBlacklist
211+}{
212+ \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid}
213+ {\sQueue}
214+ {\sBlacklist}
215+\rightarrow
216+ \sSystem{\sCtxt{P}[ \sReturn \; \sNothing ]_\sPid}
217+ {\sQueue}
218+ {\sBlacklist}
219+} \textsc{Spawn-No}
220+\end{equation*}
221+
222+\subsubsection{Reconnect}
223+
224+\begin{equation*}
225+\frac{
226+}{
227+ \sSystem{\sCtxt{P}[ \sReconnect \; \mathit{id} ]_\sPid}
228+ {\sQueue}
229+ {\sBlacklist, (\mathit{id}, \sPid), \sBlacklist'}
230+\rightarrow
231+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
232+ {\sQueue}
233+ {\sBlacklist, \sBlacklist'}
234+} \textsc{Reconnect-Ok}
235+\end{equation*}
236+
237+\begin{equation*}
238+\frac{
239+ (\mathit{id}, \sPid) \notin \sBlacklist
240+}{
241+ \sSystem{\sCtxt{P}[ \sReconnect \; \mathit{id} ]_\sPid}
242+ {\sQueue}
243+ {\sBlacklist}
244+\rightarrow
245+ \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid}
246+ {\sQueue}
247+ {\sBlacklist}
248+} \textsc{Reconnect-No}
249+\end{equation*}
250+
251+\subsubsection{Administration}
252+
253+TODO: bind, pure evaluation, maybe exception handling
254+
255+\end{document}
examples/.gitignoredeleted−1
@@ -1 +0,0 @@
1−*.exe
examples/DemoProcess.hsdeleted−36
@@ -1,36 +0,0 @@
1−module Main where
2−
3−import Control.Distributed.Process
4−import Control.Concurrent (threadDelay)
5−
6−import Network.Transport (closeTransport)
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Debug.Trace
10−
11−demo1 = do
12− trans <- mkTransport $ TCPConfig undefined "127.0.0.1" "8080"
13− node <- newLocalNode trans
14− print "Starting node"
15− runProcess node $ do
16− liftIO $ print "Starting process"
17− lpid1 <- spawnLocal (logger 1)
18− spawnLocal (chatty "jim1" lpid1)
19− spawnLocal (chatty "bob1" lpid1)
20− return ()
21− threadDelay 600000
22− closeTransport trans
23−
24−chatty :: String -> ProcessId -> Process ()
25−chatty name target = do
26− send target (name ++ " says: hi there")
27− liftIO $ threadDelay 500000
28− send target (name ++ " says: bye")
29−
30−logger :: Int -> Process ()
31−logger n = do
32− str <- expect
33− liftIO . putStrLn $ show n ++ ": " ++ str
34− logger (n+1)
35−
36−main = demo1
examples/DemoTCP.hsdeleted−113
@@ -1,113 +0,0 @@
1−module Main where
2−
3−import Network.Transport
4−import Network.Transport.TCP
5−
6−import Control.Monad
7−import Data.Char
8−import Data.String
9−import Network.Socket (HostName, ServiceName)
10−import System.Environment
11−
12−import qualified Data.ByteString.Char8 as BS
13−
14−import Debug.Trace
15−
16−type ChanId = Int
17−
18−-- | This example demonstrates how a master can be connected to slaves using
19−-- the transport layer. After compiling, the following will initialize a new
20−-- master that waits for two clients to connect on the local machine:
21−--
22−-- ./DemoTCP 127.0.0.1 8080 sourceAddrFile 2
23−--
24−-- Following this, two slaves should be created that will connect to the master:
25−--
26−-- ./DemoTCP 127.0.0.1 8081 sourceAddrFile
27−-- ./DemoTCP 127.0.0.1 8082 sourceAddrFile
28−--
29−-- Once the connection is established, the slaves will provide the master
30−-- with their SourceAddr. The master then decodes this, and sends a message
31−-- back. After processing this message, the slaves respond to the master,
32−-- which then outputs some data.
33−main :: IO ()
34−main = do
35− args <- getArgs
36− case args of
37− -- Master:
38− -- The master only provides the host, service, and slaves to expect.
39− [host, service, sourceAddrFilePath, number] -> do
40− let numSlaves = read number
41− transport <- mkTransport $ TCPConfig defaultHints host service
42− (clientSourceEnds, masterTargetEnd) <- demoMaster transport sourceAddrFilePath numSlaves
43− zipWithM_
44− (\clientSourceEnd clientId ->
45− send clientSourceEnd [BS.pack . show $ clientId])
46− clientSourceEnds [0 .. numSlaves-1]
47− replicateM_ numSlaves $ do
48− [clientMessage] <- receive masterTargetEnd
49− print clientMessage
50−
51− closeTargetEnd masterTargetEnd
52− putStrLn "master: close connections"
53−
54− -- Slave:
55− -- Each slave provides its own host and service, as well as details of
56− -- the master it wishes to connect to.
57− [host, service, sourceAddrFilePath] -> do
58− transport <- mkTransport $ TCPConfig defaultHints host service
59− (masterSourceEnd, slaveTargetEnd) <- demoSlave transport sourceAddrFilePath
60− [clientId] <- receive slaveTargetEnd
61− putStrLn $ "slave: received clientId: " ++ show clientId
62− let message = "Connected to slave: " ++ (BS.unpack clientId)
63−
64− send masterSourceEnd [BS.pack message]
65− putStrLn "slave: sent message to master"
66−
67− closeSourceEnd masterSourceEnd
68− putStrLn "slave: close connection"
69−
70− _ -> error "Unexpected arguments"
71−
72−demoMaster :: Transport -- ^ Transport
73− -> FilePath -- ^ File to write SourceAddr
74− -> Int -- ^ Number of slaves to expect
75− -> IO ([SourceEnd], TargetEnd)
76−demoMaster transport sourceAddrFilePath numSlaves = do
77− -- Establish an initial transport
78− (sourceAddr, targetEnd) <- newConnection transport
79−
80− -- Write a file containing the sourceAddr
81− putStrLn $ "master: writing sourceAddr file:" ++ (show . serialize $ sourceAddr)
82− BS.writeFile sourceAddrFilePath $ serialize sourceAddr
83−
84− -- Deserialize each of the sourceEnds received by the slaves
85− sourceEnds <- replicateM numSlaves $ do
86− [bytes] <- receive targetEnd
87− putStrLn "master: received connection."
88− case deserialize transport bytes of
89− Nothing -> fail "Garbage message from slave!"
90− Just sourceAddr -> connect sourceAddr
91− return (sourceEnds, targetEnd)
92−
93−demoSlave :: Transport -- ^ Transport
94− -> FilePath -- ^ File to read SourceAddr
95− -> IO (SourceEnd, TargetEnd)
96−demoSlave transport masterSourceAddrFilePath = do
97− -- Create a new connection on the transport
98− (sourceAddr, targetEnd) <- newConnection transport
99−
100− -- Establish connection with the master
101− bytes <- BS.readFile masterSourceAddrFilePath
102− case deserialize transport bytes of
103− Just masterSourceAddr -> do
104− putStrLn $ "slave: connecting to sourceAddr: " ++ (show . serialize $ masterSourceAddr)
105− masterSourceEnd <- connect masterSourceAddr
106−
107− -- Source the serialized address of this slave
108− send masterSourceEnd [serialize sourceAddr]
109− putStrLn "slave: sent sourceAddr"
110− return (masterSourceEnd, targetEnd)
111−
112− Nothing -> error "slave: Unable to deserialize master SourceAddr!"
113−
examples/DemoTransport.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE CPP, NamedFieldPuns #-}
2−module Main where
3−
4−import Network.Transport
5−import qualified Network.Transport.MVar
6−import qualified Network.Transport.Pipes
7−import Network.Transport.TCP (mkTransport, TCPConfig (..))
8−
9−import Control.Concurrent
10−import Control.Monad
11−
12−#ifndef LAZY
13−import qualified Data.ByteString.Char8 as BS
14−#else
15−import qualified Data.ByteString.Lazy.Char8 as BS
16−#endif
17−
18−import Data.IORef
19−import Debug.Trace
20−
21−-------------------------------------------
22−
23−{- Run a demo above with one of these tranpsort shorthands like this:
24− tcp >>= demo0
25− -}
26−tcp = mkTCPOff 8080
27−mvar = return Network.Transport.MVar.mkTransport
28−pipes = return Network.Transport.Pipes.mkTransport
29−
30−tcp :: IO (IO Transport)
31−mvar :: IO (IO Transport)
32−pipes :: IO (IO Transport)
33−
34−-------------------------------------------
35−-- Example programs using backend directly
36−
37−
38−-- | Check if multiple messages can be sent on the same connection.
39−demo0 :: IO Transport -> IO ()
40−demo0 mktrans = do
41− trans <- mktrans
42−
43− (sourceAddr, targetEnd) <- newConnection trans
44−
45− forkIO $ logServer "logServer" targetEnd
46− threadDelay 100000
47−
48− sourceEnd <- connect sourceAddr
49−
50− mapM_ (\n -> send sourceEnd [BS.pack ("hello " ++ show n)]) [1 .. 10]
51− threadDelay 100000
52−
53− closeTransport trans
54−
55−
56−-- | Check endpoint serialization and deserialization.
57−demo1 :: IO Transport -> IO ()
58−demo1 mktrans = do
59− trans <- mktrans
60−
61− (sourceAddr, targetEnd) <- newConnection trans
62−
63− forkIO $ logServer "logServer" targetEnd
64− threadDelay 100000
65−
66− sourceEnd <- connect sourceAddr
67−
68− -- This use of Just is slightly naughty
69− let Just sourceAddr' = deserialize trans (serialize sourceAddr)
70− sourceEnd' <- connect sourceAddr'
71−
72− send sourceEnd [BS.pack "hello 1"]
73− send sourceEnd' [BS.pack "hello 2"]
74− threadDelay 100000
75− closeTransport trans
76−
77−
78−-- | Check that messages can be sent before receive is set up.
79−demo2 :: IO Transport -> IO ()
80−demo2 mktrans = do
81− trans <- mktrans
82−
83− (sourceAddr, targetEnd) <- newConnection trans
84− sourceEnd <- connect sourceAddr
85−
86− forkIO $ send sourceEnd [BS.pack "hello 1"]
87− threadDelay 100000
88−
89− forkIO $ logServer "logServer" targetEnd
90− threadDelay 100000
91− closeTransport trans
92−
93−
94−-- | Check that two different transports can be created.
95−demo3 :: IO Transport -> IO ()
96−demo3 mktrans = do
97− trans1 <- mktrans
98− trans2 <- mktrans
99−
100− (sourceAddr1, targetEnd1) <- newConnection trans1
101− (sourceAddr2, targetEnd2) <- newConnection trans2
102−
103− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
104− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
105−
106− sourceEnd1 <- connect sourceAddr1
107− sourceEnd2 <- connect sourceAddr2
108−
109− send sourceEnd1 [BS.pack "hello1"]
110− send sourceEnd2 [BS.pack "hello2"]
111−
112− threadDelay 100000
113− putStrLn "demo3: Time, up, killing threads & closing transports.."
114− killThread threadId1
115− killThread threadId2
116− putStrLn "demo3: Threads killed."
117− closeTransport trans1
118− closeTransport trans2
119− putStrLn "demo3: Done."
120−
121−
122−-- | Check that two different connections on the same transport can be created.
123−demo4 :: IO Transport -> IO ()
124−demo4 mktrans = do
125− trans <- mktrans
126−
127− (sourceAddr1, targetEnd1) <- newConnection trans
128− (sourceAddr2, targetEnd2) <- newConnection trans
129−
130− threadId1 <- forkIO $ logServer "logServer1" targetEnd1
131− threadId2 <- forkIO $ logServer "logServer2" targetEnd2
132−
133− sourceEnd1 <- connect sourceAddr1
134− sourceEnd2 <- connect sourceAddr2
135−
136− threadId3 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd1 [BS.pack ("A" ++ show i)]
137− threadId4 <- forkIO $ forM_ [1..10] $ \i -> send sourceEnd2 [BS.pack ("B" ++ show i)]
138−
139− threadDelay 1000000
140−
141− putStrLn "demo4: Time, up, killing threads & closing transports.."
142− killThread threadId1
143− killThread threadId2
144− killThread threadId3
145− killThread threadId4
146− putStrLn "demo4: Threads killed."
147− closeTransport trans
148− putStrLn "demo4: Done."
149−
150−
151−
152−--------------------------------------------------------------------------------
153−
154−logServer :: String -> TargetEnd -> IO ()
155−logServer name targetEnd = forever $ do
156− x <- receive targetEnd
157− trace (name ++ " rcvd: " ++ show x) $ return ()
158−
159−mkTCPOff off = do
160− cntr <- newIORef 0
161− return$ do cnt <- readIORef cntr
162− writeIORef cntr (cnt+1)
163− mkTransport (TCPConfig undefined "127.0.0.1" (show (off + cnt)))
164−
165−--------------------------------------------------------------------------------
166−
167−runWAllTranports :: (IO Transport -> IO ()) -> Int -> IO ()
168−runWAllTranports demo offset = do
169− putStrLn "------------------------------------------------------------"
170− putStrLn " MVAR transport:"
171− mvar >>= demo
172− putStrLn "\n TCP transport:"
173− tcp >>= demo
174− putStrLn "\n PIPES transport:"
175− pipes >>= demo
176− putStrLn "\n"
177−
178−
179−main = do
180− putStrLn "Demo0:"
181− runWAllTranports demo0 0
182− putStrLn "Demo1:"
183− runWAllTranports demo1 10
184− putStrLn "Demo2:"
185− runWAllTranports demo2 20
186− putStrLn "Demo3:"
187− runWAllTranports demo3 30
188− putStrLn "Demo4:"
189− runWAllTranports demo4 40
190−
191− threadDelay (300 * 1000)
192− putStrLn "Done with all demos!"
examples/Makefiledeleted−20
@@ -1,20 +0,0 @@
1−
2−
3−ifeq ($(GHC),)
4− GHC=ghc
5−endif
6−
7−INCLUDES= -i../network-transport/src -i../network-transport-pipes/src -i../distributed-process/src
8−
9−EXMPLS= DemoTransport.exe DemoProcess.exe
10−
11−all: $(EXMPLS)
12−
13−$(EXMPLS): %.exe: %.hs
14− $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $< -o $@
15−
16−# transport:
17−# $(GHC) -threaded --make -i../network-transport/src DemoTransport.hs -o DemoTransport.exe -fforce-recomp
18−
19−clean:
20− rm -f *.hi *.o $(EXMPLS)
install_all.shdeleted−18
@@ -1,18 +0,0 @@
1−#!/bin/bash
2−
3−set -e
4−
5−if [ "$GHC" == "" ]; then
6− GHC=ghc
7−fi
8−
9−cd network-transport/
10−cabal.par install --with-ghc=$GHC $*
11−
12−echo;echo
13−cd ../network-transport-pipes/
14−cabal.par install --with-ghc=$GHC $*
15−
16−echo;echo
17−cd ../distributed-process/
18−cabal.par install --with-ghc=$GHC $*
network-transport-pipes/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright Ryan Newton, 2011
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of the owner nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31−
network-transport-pipes/network-transport-pipes.cabaldeleted−33
@@ -1,33 +0,0 @@
1−Name: network-transport-pipes
2−Version: 0.0.1.2
3−-- Version History:
4−-- 0.0.1.1 - Initial
5−
6−Description: Named Pipes backend for network-transport interface.
7−License: BSD3
8−License-file: LICENSE
9−Author: Ryan Newton
10−Maintainer: rrnewton@gmail.com
11−Homepage: http://github.com/haskell-distributed/
12−Build-Type: Simple
13−Cabal-Version: >=1.2
14−
15−Library
16− Build-Depends: base >= 3 && < 5,
17−-- binary >= 0.5,
18− cereal,
19− bytestring >= 0.9,
20− network-transport >= 0.0.1.1,
21−-- containers >= 0.4,
22− containers >= 0.3,
23−-- network >= 2.3,
24−-- safe >= 0.3,
25− unix >= 2.4,
26− random,
27− directory,
28− unix-bytestring >= 0.3.5.3,
29− time
30− Exposed-modules: Network.Transport.Pipes
31−-- Extensions: BangPatterns
32− ghc-options: -Wall
33− HS-Source-Dirs: src
network-transport-pipes/src/Network/Transport/Pipes.hsdeleted−264
@@ -1,264 +0,0 @@
1−{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, PackageImports #-}
2−
3−----------------------------------------------------------------------------------------------------
4−
5−-- WARNING -- This transport is not yet completed. TODO:
6−
7−-- * Add support for messages greater than 4096 bytes.
8−-- * debug ODD problem with CEREAL below
9−
10−----------------------------------------------------------------------------------------------------
11−
12−module Network.Transport.Pipes
13− ( mkTransport
14− ) where
15−
16−import Control.Monad (when, unless)
17−import Control.Exception (evaluate, throw, handle, fromException,
18− SomeException, IOException)
19−import Control.Concurrent.MVar
20−import Control.Concurrent (threadDelay, forkOS)
21−import Data.IntMap (IntMap)
22−-- import Data.ByteString.Char8 (ByteString)
23−import Data.Word
24−import Data.Int
25−import Data.IORef
26−import qualified Data.IntMap as IntMap
27−import qualified Data.ByteString.Char8 as BS
28−import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) -- Not in 6.10
29−
30−-- For some STRANGE reason this is not working with Data.Binary [2012.02.20]:
31−#define CEREAL
32−#ifdef CEREAL
33−import Data.Serialize (encode,decode) -- Uses strict BS
34−#else
35−import Data.Binary (encode,decode) -- Uses lazy BS
36−#endif
37−
38−import Data.List (foldl')
39−import Network.Transport
40−import System.Random (randomIO)
41−import System.IO (IOMode(ReadMode,AppendMode,WriteMode,ReadWriteMode),
42− openFile, hClose, hPutStrLn, hPutStr, stderr, stdout, hFlush)
43−import System.IO.Error (ioeGetHandle)
44−import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
45−import System.Posix.Types (Fd, ByteCount)
46−import System.Directory (doesFileExist, removeFile)
47−import System.Mem (performGC)
48−
49−#define USE_UNIX_BYTESTRING
50−#ifdef USE_UNIX_BYTESTRING
51−import qualified "unix-bytestring" System.Posix.IO.ByteString as PIO
52−-- import qualified "unix-bytestring" System.Posix.IO.ByteString.Lazy as PIO
53−import System.Posix.IO as PIO (openFd, closeFd, -- append, exclusive, noctty, nonBlock, trunc,
54− OpenFileFlags(..), OpenMode(ReadOnly, WriteOnly))
55−-- (fromS,toS) = (BS.pack, BS.unpack)
56−(fromS,toS) = (BS.pack, BS.unpack)
57−fromBS = id
58−readit fd n = PIO.fdRead fd n
59−#else
60−import qualified System.Posix.IO as PIO
61−(toS,fromS) = (id,id)
62−fromBS = BS.unpack
63−readit fd n = do (s,_) <- PIO.fdRead fd n
64− return (BS.pack s)
65−#endif
66−-- readit :: Fd -> Int -> IO BS.ByteString
67−readit :: Fd -> ByteCount -> IO BS.ByteString
68−
69−----------------------------------------------------------------------------------------------------
70−
71−-- The msg header consists of just a length field represented as a Word32
72−sizeof_header = 4
73−
74−fileFlags =
75− PIO.OpenFileFlags {
76− PIO.append = False,
77− PIO.exclusive = False,
78− PIO.noctty = False,
79− PIO.nonBlock = True,
80− -- In nonblocking mode opening for read will always succeed and
81− -- opening for write must happen second.
82− PIO.trunc = False
83− }
84−-- NOTE:
85−-- "The only open file status flags that can be meaningfully applied
86−-- to a pipe or FIFO are O_NONBLOCK and O_ASYNC. "
87−
88−
89−mkTransport :: IO Transport
90−mkTransport = do
91−-- uid <- randomIO :: IO Word64
92− -- For backwards compatibility we shouldn't assume a Random instance for Word64:
93− uid <- randomIO :: IO Int
94−
95− lock <- newMVar ()
96− let filename = "/tmp/pipe_"++show (abs uid)
97− createNamedPipe filename $ unionFileModes ownerReadMode ownerWriteMode
98−
99− return Transport
100− { newConnectionWith = \ _ -> do
101− -- Here we protect from blocking other threads by running on a separate (OS) thread:
102− -- Opening the file on the reader side should always succeed:
103− mv <- onOSThread$ tryUntilNoIOErr "open pipe for read" $
104−-- spinTillThere filename
105− PIO.openFd filename PIO.ReadOnly Nothing fileFlags
106−
107− return (mkSourceAddr filename,
108− mkTargetEnd mv lock)
109− , newMulticastWith = error "Pipes.hs: newMulticastWith not implemented yet"
110− , deserialize = \bs -> return$ mkSourceAddr (BS.unpack bs)
111− , closeTransport = removeFile filename
112− }
113− where
114− mkSourceAddr :: String -> SourceAddr
115− mkSourceAddr filename = SourceAddr
116− { connectWith = \_ -> mkSourceEnd filename
117− , serialize = BS.pack filename
118− }
119−
120− mkSourceEnd :: String -> IO SourceEnd
121− mkSourceEnd filename = do
122− -- Initiate but do not block on file opening:
123− mv <- onOSThread$ tryUntilNoIOErr "open pipe for write" $
124− -- The reader must connect first, the writer here spins with backoff.
125− PIO.openFd filename PIO.WriteOnly Nothing fileFlags
126−
127− return $
128− -- Write to the named pipe. If the message is less than
129− -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
130− -- we have to do something more sophisticated.
131− SourceEnd
132− { send = \bsls -> do
133− -- ThreadSafe: This may happen on multiple processes/threads:
134− -- We don't need to lock because the write is atomic (for <4096):
135− let msgsize :: Word32 = fromIntegral$ foldl' (\n s -> n + BS.length s) 0 bsls
136− when (msgsize > 4096)$ -- TODO, look up PIPE_BUF in foreign code
137− error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
138− -- Otherwise it's just a simple write:
139− -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
140−
141− let hdrbss :: BS.ByteString
142−#ifdef CEREAL
143− hdrbss = encode msgsize
144−#else
145−-- hdrbss = BS.fromChunks[encode msgsize]
146− [hdrbss] = BS.toChunks (encode msgsize)
147−#endif
148−
149−-- let finalmsg = BS.concat (encode msgsize : bss)
150− let finalmsg = BS.concat (hdrbss : bsls)
151−
152− fd <- readMVar mv -- Synchronize with file opening.
153− ----------------------------------------
154− cnt <- PIO.fdWrite fd (fromBS finalmsg) -- inefficient to use String here!
155− unless (fromIntegral cnt == BS.length finalmsg) $
156− error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
157− ----------------------------------------
158− return ()
159− , closeSourceEnd = do
160− fd <- readMVar mv
161− PIO.closeFd fd
162− }
163−
164− mkTargetEnd :: MVar Fd -> MVar () -> TargetEnd
165− mkTargetEnd mv lock = TargetEnd
166− { receive = do
167− fd <- readMVar mv -- Make sure Fd is there before
168−
169− -- This should only happen on a *single* process. But it may
170− -- happen on multiple threads so we grab a lock.
171−
172− -- If we don't lock, we cannot atomically read the length
173− -- and THEN read the payload. (A single read could be
174− -- atomic, but not two reads.)
175− takeMVar lock
176−
177− let spinread :: Int -> IO BS.ByteString
178− spinread desired = do
179−
180− bs <- tryUntilNoIOErr "read pipe file descriptor"$
181− readit fd (fromIntegral desired)
182−
183− case BS.length bs of
184− n | n == desired -> return bs
185− -- Because we're in non-blocking mode we deal with failed reads thusly:
186−-- 0 -> do threadDelay (10*1000)
187−-- spinread desired
188− 0 -> error$ "receive: read zero bytes from pipe. Even in non-blocking mode should have had an EAGAIN error instead."
189− l -> error$ "Inclomplete read expected either 0 bytes or complete msg ("++
190− show desired ++" bytes) got "++ show l ++ " bytes"
191−
192− hdr <- spinread sizeof_header
193− let
194−#ifdef CEREAL
195− decoded = decode hdr
196−#else
197− decoded = decode (BS.fromChunks [hdr])
198−#endif
199− payload <- case decoded of
200− Left err -> error$ "ERROR: "++ err
201− Right size -> spinread (fromIntegral (size::Word32))
202−
203− putMVar lock ()
204− return [payload] -- How terribly listy.
205− , closeTargetEnd = do
206− fd <- readMVar mv
207− PIO.closeFd fd
208− }
209−
210−-- | Wait untila file is present, with backoff.
211−spinTillThere :: String -> IO ()
212−spinTillThere filename = mkBackoff >>= loop
213− where
214− loop bkoff = do b <- doesFileExist filename
215− unless b $ do bkoff; loop bkoff
216−
217−-- | Create a backoff action that waits successively longer between attempts.
218−mkBackoff :: IO (IO ())
219−mkBackoff =
220− do tref <- newIORef 1
221− return$ do t <- readIORef tref
222− writeIORef tref (min maxwait (2 * t))
223− threadDelay t
224− where
225− maxwait = 50 * 1000
226−
227−-- | Try an IO action repeatedly (with backoff) until it succeeds without exception.
228−tryUntilNoIOErr :: String -> IO a -> IO a
229−tryUntilNoIOErr msg action =
230− do startTime <- getCurrentTime
231− bkoff <- mkBackoff
232− loop startTime startTime bkoff
233− where
234− loop start lastWarned bkoff =
235− handle (\ (e :: IOException) ->
236− do lw <- maybeWarn start lastWarned
237− bkoff
238−-- BSS.hPutStr stderr$ BSS.pack$ " got IO err: " ++ show e
239− -- case ioeGetHandle e of
240− -- Nothing -> BSS.hPutStrLn stderr$ BSS.pack$ " no hndl io err."
241− -- Just x -> BSS.hPutStrLn stderr$ BSS.pack$ " HNDL on io err!" ++ show x
242− loop start lw bkoff) $
243− action
244− -- After how many milleseconds should we start warning?
245− warn_lvl = 3000
246− maybeWarn :: UTCTime -> UTCTime -> IO UTCTime
247− maybeWarn start lastWarned = do
248− now <- getCurrentTime
249− let seconds :: Double = fromRational $ toRational $ diffUTCTime now start
250− sinceWarned :: Double = fromRational $ toRational $ diffUTCTime now lastWarned
251− if (seconds * 1000 >= warn_lvl &&
252− sinceWarned >= 1.0 ) then do
253− BS.hPutStrLn stderr$ BS.pack$ "WARNING: have been trying an IO action ("++msg++
254− ") for "++show seconds++ " seconds without success"
255− return now
256− else
257− return lastWarned
258−
259−-- Execute an action on its own OS thread. Return an MVar to synchronize on.
260−onOSThread :: IO a -> IO (MVar a)
261−onOSThread action = do
262− mv <- newEmptyMVar
263− forkOS (action >>= putMVar mv )
264− return mv
network-transport-tcp/network-transport-tcp.cabal+3
@@ -45,6 +45,9 @@ Test-Suite TestTCP
4545 random >= 1.0 && < 1.1,
4646 ansi-terminal >= 0.5 && < 0.6,
4747 mtl >= 2.0 && < 2.2
48+ Other-modules: TestAuxiliary,
49+ TestTransport,
50+ Traced
4851 ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
4952 Extensions: ExistentialQuantification,
5053 FlexibleInstances,