git.iko.soy/distributed-process
on master help sign in
Merge branch 'master' of github.com:haskell-distributed/distributed-process
00f0e54Edsko de Vries
README.md+18−103
compare with master
unifiedsplit
@@ -1,114 +1,29 @@
1Haskell Distributed Project
1Haskell Distributed Project
2===========================
2===========================
3
3
4−This repository holds an implementation of [Cloud Haskell][1] based on the work
4+This repository holds an implementation of [Cloud Haskell][1].
5−of Jeff Epstein, Andrew Black, and Simon Peyton-Jones.
6
5
7−At present, this repository hosts two packages:
6+At present, this repository hosts
8
7
9−* distributed-process
10* network-transport
8* network-transport
9+* network-transport-tcp
10+* network-transport-inmemory (incomplete)
11+* distributed-process
12+* distributed-process-simplelocalnet
13+* azure-service-api (skeleton only)
11
14
12For more detailed information about the interfaces provided by these packages,
15For more detailed information about the interfaces provided by these packages,
13−please refer to the [distributed-process repository wiki][2].
16+please refer to the [distributed-process repository wiki][2]. People who wish
14−
17+to get started with Cloud Haskell should cabal install
15−Examples
18+distributed-process and possibly distributed-process-simplelocalnet and refer
16−--------
19+to the corresponding Haddock documentation ([Control.Distributed.Process][3],
17−
20+[Control.Distributed.Process.Closure][4],
18−Examples of the transport layer at work can be found in the `/examples` folder.
21+[Control.Distributed.Process.Node][5], and
19−
22+[Control.Distributed.Process.Backend.SimpleLocalnet][6]).
20−### DemoTransport.hs
21−
22−The `DemoTransport.hs` file contains a number of different functions named
23−`demo#`. These functions demonstrate the use of the `Network.Transport` module.
24−
25−To try them out, launch `ghci`, including the appropriate sources:
26−
27− ghci -idistributed-process/src -inetwork-transport/src examples/DemoTransport.hs
28−
29−The first demo, `demo0` yields the following output when run with the TCP transport:
30−
31− *DemoTransport> tcp >>= demo0
32− logServer: [Chunk "hello 1" Empty]
33− logServer: [Chunk "hello 2" Empty]
34− logServer: [Chunk "hello 3" Empty]
35− logServer: [Chunk "hello 4" Empty]
36− logServer: [Chunk "hello 5" Empty]
37− logServer: [Chunk "hello 6" Empty]
38− logServer: [Chunk "hello 7" Empty]
39− logServer: [Chunk "hello 8" Empty]
40− logServer: [Chunk "hello 9" Empty]
41− logServer: [Chunk "hello 10" Empty]
42−
43−See the source code for more details.
44−
45−### DemoProcess.hs
46−
47−The `DemoProcess.hs` file shows a very basic example of how to use the
48−`Control.Distributed.Process` module in conjunction with `Network.Transport.TCP`.
49−This is demonstrated using the `demo1` function:
50−
51− ghci -idistributed-process/src -inetwork-transport/src examples/DemoProcess.hs
52−
53−The output of the example is as follows:
54−
55− *DemoProcess> demo1
56− "Starting node"
57− "Starting process"
58− 1: jim1 says: hi there
59− 2: bob1 says: hi there
60− 3: jim1 says: bye
61− 4: bob1 says: bye
62−
63−### DemoTCP.hs
64−
65−The `DemoTCP.hs` file demonstrates how a master can be connected to slaves
66−using the transport layer over TCP.
67−This example should be compiled in the usual fashion:
68−
69− ghc --make -idistributed-process/src -inetwork-transport/src examples/DemoTCP.hs
70−
71−After compiling, the following will initialize a new master that waits
72−for two clients to connect on the local machine:
73−
74− ./examples/DemoTCP 127.0.0.1 8080 sourceAddrFile 2
75−
76−Following this, two slaves should be created that will connect to the master:
77−
78− ./examples/DemoTCP 127.0.0.1 8081 sourceAddrFile
79− ./examples/DemoTCP 127.0.0.1 8082 sourceAddrFile
80−
81−Once the connection is established, the slaves will provide the master
82−with their `SourceAddr`. The master then decodes this, and sends a message
83−back. After processing this message, the slaves respond to the master,
84−which then outputs some data.
85−
86−Benchmarks
87−----------
88−
89−The `Transport.TCP` backend uses `Network.ByteString.Lazy` as its underlying
90−protocol, so we produce a benchmark that compares it directly with this.
91−Furthermore, the `Data.Binary` package is used for converting values
92−to `ByteStrings` for transmission.
93−
94−The benchmarking is performed on the client side using criterion:
95−the server must be set up before benching is performed.
96−
97−### Ping
98−
99−This benchmark measures how quickly a sequence of ping/pong messages
100−are sent between a server and client. Full details can be found in:
101−
102− ./benchmarks/PingTCP.hs
103− ./benchmarks/PingTransport.hs
104−
105−### Send
106−
107−This benchmark measures how quickly a number of bytes can be sent from
108−a client to a server. Full details can be found in the following files:
109−
110− ./benchmarks/SendTCP.hs
111− ./benchmarks/SendTransport.hs
112
23
113[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
24[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
114[2]: https://github.com/haskell-distributed/distributed-process/wiki
25[2]: https://github.com/haskell-distributed/distributed-process/wiki
26+[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html
27+[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html
28+[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html
29+[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html
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+
12012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
132012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2
2
14
3* Base 4.6 compatibility
15* Base 4.6 compatibility
distributed-process/distributed-process.cabal+2−2
@@ -1,5 +1,5 @@
1Name: distributed-process
1Name: distributed-process
2−Version: 0.2.1.2
2+Version: 0.2.1.4
3Cabal-Version: >=1.8
3Cabal-Version: >=1.8
4Build-Type: Simple
4Build-Type: Simple
5License: BSD3
5License: BSD3
@@ -52,7 +52,6 @@ Library
52 Control.Distributed.Process.Internal.CQueue,
52 Control.Distributed.Process.Internal.CQueue,
53 Control.Distributed.Process.Internal.Dynamic,
53 Control.Distributed.Process.Internal.Dynamic,
54 Control.Distributed.Process.Internal.TypeRep,
54 Control.Distributed.Process.Internal.TypeRep,
55− Control.Distributed.Process.Internal.MessageT,
56 Control.Distributed.Process.Internal.Types,
55 Control.Distributed.Process.Internal.Types,
57 Control.Distributed.Process.Internal.Closure.Static,
56 Control.Distributed.Process.Internal.Closure.Static,
58 Control.Distributed.Process.Internal.Closure.MkClosure,
57 Control.Distributed.Process.Internal.Closure.MkClosure,
@@ -124,6 +123,7 @@ Test-Suite TestClosure
124 random >= 1.0 && < 1.1,
123 random >= 1.0 && < 1.1,
125 ghc-prim >= 0.2 && < 0.3,
124 ghc-prim >= 0.2 && < 0.3,
126 ansi-terminal >= 0.5 && < 0.6
125 ansi-terminal >= 0.5 && < 0.6
126+ Other-modules: TestAuxiliary
127 Extensions: RankNTypes,
127 Extensions: RankNTypes,
128 ScopedTypeVariables,
128 ScopedTypeVariables,
129 FlexibleInstances,
129 FlexibleInstances,
distributed-process/src/Control/Distributed/Process.hs+28
@@ -89,6 +89,9 @@ module Control.Distributed.Process
89 , spawnMonitor
89 , spawnMonitor
90 , spawnChannel
90 , spawnChannel
91 , DidSpawn(..)
91 , DidSpawn(..)
92+ -- * Local versions of 'spawn'
93+ , spawnLocal
94+ , spawnChannelLocal
92 ) where
95 ) where
93
96
94
97
@@ -98,6 +101,8 @@ import Prelude hiding (catch)
98
101
99import Data.Typeable (Typeable)
102import Data.Typeable (Typeable)
100import Control.Monad.IO.Class (liftIO)
103import Control.Monad.IO.Class (liftIO)
104+import Control.Applicative ((<$>))
105+import Control.Monad.Reader (ask)
101import Control.Distributed.Process.Internal.Types
106import Control.Distributed.Process.Internal.Types
102 ( RemoteTable
107 ( RemoteTable
103 , NodeId(..)
108 , NodeId(..)
@@ -121,6 +126,7 @@ import Control.Distributed.Process.Internal.Types
121 , SerializableDict(..)
126 , SerializableDict(..)
122 , SendPortId(..)
127 , SendPortId(..)
123 , WhereIsReply(..)
128 , WhereIsReply(..)
129+ , LocalProcess(processNode)
124 )
130 )
125import Control.Distributed.Process.Internal.Closure.CP
131import Control.Distributed.Process.Internal.Closure.CP
126 ( cpSeq
132 ( cpSeq
@@ -190,6 +196,7 @@ import Control.Distributed.Process.Internal.Primitives
190 , spawnAsync
196 , spawnAsync
191 )
197 )
192import Control.Distributed.Process.Serializable (Serializable)
198import Control.Distributed.Process.Serializable (Serializable)
199+import Control.Distributed.Process.Node (forkProcess)
193
200
194-- INTERNAL NOTES
201-- INTERNAL NOTES
195--
202--
@@ -355,3 +362,24 @@ spawnChannel dict nid proc = do
355 (cpSend (sdictSendPort dict) pid `cpSplit` proc)
362 (cpSend (sdictSendPort dict) pid `cpSplit` proc)
356 `cpBind`
363 `cpBind`
357 cpCancelL
364 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 @@
12--
12--
13-- you can use a Template Haskell splice to create a static version of 'f':
13-- you can use a Template Haskell splice to create a static version of 'f':
14--
14--
15−-- > $(mkStatic 'f) :: forall a1 .. an. Static T
15+-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T
16--
16--
17-- Every module that you write that contains calls to 'mkStatic' needs to
17-- Every module that you write that contains calls to 'mkStatic' needs to
18-- have a call to 'remotable':
18-- have a call to 'remotable':
@@ -35,29 +35,90 @@
35-- > . Mn.__remoteTable
35-- > . Mn.__remoteTable
36-- > $ initRemoteTable
36-- > $ initRemoteTable
37--
37--
38+-- [Dealing with type class qualifiers]
39+--
40+-- Although 'mkStatic' supports polymorphic types, it does not support
41+-- qualified types. For instance, you cannot call 'mkStatic' on
42+--
43+-- > decode :: Serializable a => ByteString -> a
44+--
45+-- Instead, you will need to reify the type class dictionary. Cloud Haskell
46+-- comes with a reified version of 'Serializable':
47+--
48+-- > data SerializableDict a where
49+-- > SerializableDict :: Serializable a => SerializableDict a
50+--
51+-- Using the reified dictionary you can define
52+--
53+-- > decodeDict :: SerializableDict a -> ByteString -> a
54+-- > decodeDict SerializableDict = decode
55+--
56+-- where 'decodeDict' is a normal (unqualified) polymorphic value and hence
57+-- can be passed as an argument to remotable:
58+--
59+-- > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)
60+--
38-- [Composing static values]
61-- [Composing static values]
39--
62--
40−-- We generalize the notion of 'static' as described in the paper, and also
63+-- The version of 'static' provided by this implementation of Cloud Haskell is
41−-- provide
64+-- strictly more expressive than the one proposed in the paper, and additionally
65+-- supports
42--
66--
43-- > staticApply :: Static (a -> b) -> Static a -> Static b
67-- > staticApply :: Static (a -> b) -> Static a -> Static b
44--
68--
69+-- This is extremely useful. For example, Cloud Haskell comes with
70+-- 'staticDecode' defined as
71+--
72+-- > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
73+-- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
74+--
75+-- 'staticDecode' is used when defining closures (see below), and makes
76+-- essential use of 'staticApply'.
77+--
45−-- This makes it possible to define a rich set of combinators on 'static'
78+-- Support for 'staticApply' also makes it possible to define a rich set of
46−-- values, a number of which are provided in this module.
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)
47--
109--
48-- [Closures]
110-- [Closures]
49--
111--
50-- Suppose you have a process
112-- Suppose you have a process
51--
113--
52−-- > factorial :: Int -> Process Int
114+-- > isPrime :: Integer -> Process Bool
53--
115--
54−-- Then you can use the supplied Template Haskell function 'mkClosure' to define
116+-- Then
55--
117--
56−-- > factorialClosure :: Int -> Closure (Process Int)
118+-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)
57−-- > factorialClosure = $(mkClosure 'factorial)
58--
119--
59−-- You can then pass 'factorialClosure n' to 'spawn', for example, to have a
120+-- which you can then 'call', for example, to have a remote node check if
60−-- remote node compute a factorial number.
121+-- a number is prime.
61--
122--
62-- In general, if you have a /monomorphic/ function
123-- In general, if you have a /monomorphic/ function
63--
124--
@@ -76,55 +137,17 @@
76--
137--
77-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
138-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
78--
139--
79−-- The splice @$(mkClosure 'factorial)@ above expands to (prettified a bit):
140+-- The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit):
80--
141--
81−-- > factorialClosure :: Int -> Closure (Process Int)
82−-- > factorialClosure n = Closure decoder (encode n)
83−-- > where
84−-- > decoder :: Static (ByteString -> Process Int)
142+-- > let decoder :: Static (ByteString -> Process Bool)
85−-- > decoder = $(mkStatic 'factorial)
143+-- > decoder = $(mkStatic 'isPrime)
86-- > `staticCompose`
144-- > `staticCompose`
87−-- > staticDecode $(functionSDict 'factorial)
145+-- > staticDecode $(functionSDict 'isPrime)
88−--
146+-- > in Closure decoder (encode n)
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
109--
147--
110−-- and then use
148+-- where 'staticCompose' is composition of static functions. Note that
111−--
149+-- 'mkClosure' makes use of the static serialization dictionary
112−-- > $(mkStatic 'sdictForMyType) :: Static (SerializableDict T)
150+-- ('functionSDict') created by 'remotable'.
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.
128--
151--
129-- [Combinators on Closures]
152-- [Combinators on Closures]
130--
153--
@@ -133,6 +156,47 @@
133-- the most important of which is 'cpBind'. Have a look at the implementation
156-- the most important of which is 'cpBind'. Have a look at the implementation
134-- of 'Control.Distributed.Process.call' for an example use.
157-- of 'Control.Distributed.Process.call' for an example use.
135--
158--
159+-- [Example]
160+--
161+-- Here is a small self-contained example that uses closures and serialization
162+-- dictionaries. It makes use of the Control.Distributed.Process.SimpleLocalnet
163+-- Cloud Haskell backend.
164+--
165+-- > {-# LANGUAGE TemplateHaskell #-}
166+-- > import System.Environment (getArgs)
167+-- > import Control.Distributed.Process
168+-- > import Control.Distributed.Process.Closure
169+-- > import Control.Distributed.Process.Backend.SimpleLocalnet
170+-- > import Control.Distributed.Process.Node (initRemoteTable)
171+-- >
172+-- > isPrime :: Integer -> Process Bool
173+-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
174+-- > where
175+-- > sieve :: [Integer] -> [Integer]
176+-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
177+-- >
178+-- > remotable ['isPrime]
179+-- >
180+-- > master :: [NodeId] -> Process ()
181+-- > master [] = liftIO $ putStrLn "no slaves"
182+-- > master (slave:_) = do
183+-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))
184+-- > liftIO $ print isPrime79
185+-- >
186+-- > main :: IO ()
187+-- > main = do
188+-- > args <- getArgs
189+-- > case args of
190+-- > ["master", host, port] -> do
191+-- > backend <- initializeBackend host port rtable
192+-- > startMaster backend master
193+-- > ["slave", host, port] -> do
194+-- > backend <- initializeBackend host port rtable
195+-- > startSlave backend
196+-- > where
197+-- > rtable :: RemoteTable
198+-- > rtable = __remoteTable initRemoteTable
199+--
136-- [Notes]
200-- [Notes]
137--
201--
138-- (*) If 'T1' is not serializable you will get a type error in the generated
202-- (*) If 'T1' is not serializable you will get a type error in the generated
@@ -147,11 +211,13 @@
147-- instance into scope, but unless proper 'static' support is added to
211-- instance into scope, but unless proper 'static' support is added to
148-- ghc we need both the type class argument and the explicit dictionary.
212-- ghc we need both the type class argument and the explicit dictionary.
149module Control.Distributed.Process.Closure
213module Control.Distributed.Process.Closure
150− ( -- * User-defined closures
214+ ( -- * Creating static values
151 remotable
215 remotable
152 , mkStatic
216 , mkStatic
217+ -- * Template-Haskell support for creating closures
153 , mkClosure
218 , mkClosure
154 , functionSDict
219 , functionSDict
220+ , functionTDict
155 -- * Primitive operations on static values
221 -- * Primitive operations on static values
156 , staticApply
222 , staticApply
157 , staticDuplicate
223 , staticDuplicate
@@ -207,6 +273,7 @@ import Control.Distributed.Process.Internal.Closure.TH
207 ( remotable
273 ( remotable
208 , mkStatic
274 , mkStatic
209 , functionSDict
275 , functionSDict
276+ , functionTDict
210 )
277 )
211import Control.Distributed.Process.Internal.Closure.Static
278import Control.Distributed.Process.Internal.Closure.Static
212 ( -- Static functionals
279 ( -- Static functionals
distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+3−3
@@ -31,6 +31,7 @@ import Data.ByteString.Lazy (ByteString)
31import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
31import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
32import Control.Applicative ((<$>))
32import Control.Applicative ((<$>))
33import Control.Monad ((>=>))
33import Control.Monad ((>=>))
34+import Control.Monad.Reader (ask)
34import Control.Distributed.Process.Serializable (Serializable)
35import Control.Distributed.Process.Serializable (Serializable)
35import Control.Distributed.Process.Internal.Types
36import Control.Distributed.Process.Internal.Types
36 ( Closure(Closure)
37 ( Closure(Closure)
@@ -43,7 +44,7 @@ import Control.Distributed.Process.Internal.Types
43 , typeOfStaticLabel
44 , typeOfStaticLabel
44 , ProcessId
45 , ProcessId
45 , LocalNode(remoteTable)
46 , LocalNode(remoteTable)
46− , procMsg
47+ , LocalProcess(processNode)
47 , SendPort
48 , SendPort
48 , ReceivePort
49 , ReceivePort
49 )
50 )
@@ -55,7 +56,6 @@ import Control.Distributed.Process.Internal.Primitives
55 , newChan
56 , newChan
56 )
57 )
57import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
58import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
58−import Control.Distributed.Process.Internal.MessageT (getLocalNode)
59import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
59import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
60import Control.Distributed.Process.Internal.Closure.Static
60import Control.Distributed.Process.Internal.Closure.Static
61 ( staticCompose
61 ( staticCompose
@@ -118,7 +118,7 @@ sdictComp = SerializableDict
118-- | Resolve a closure
118-- | Resolve a closure
119unClosure :: Static a -> ByteString -> Process Dynamic
119unClosure :: Static a -> ByteString -> Process Dynamic
120unClosure (Static label) env = do
120unClosure (Static label) env = do
121− rtable <- remoteTable <$> procMsg getLocalNode
121+ rtable <- remoteTable . processNode <$> ask
122 case resolveClosure rtable label env of
122 case resolveClosure rtable label env of
123 Nothing -> fail "Derived.unClosure: resolveClosure failed"
123 Nothing -> fail "Derived.unClosure: resolveClosure failed"
124 Just dyn -> return dyn
124 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
7 remotable
7 remotable
8 , mkStatic
8 , mkStatic
9 , functionSDict
9 , functionSDict
10+ , functionTDict
10 ) where
11 ) where
11
12
12import Prelude hiding (lookup)
13import Prelude hiding (lookup)
@@ -47,6 +48,7 @@ import Control.Distributed.Process.Internal.Types
47 , StaticLabel(StaticLabel)
48 , StaticLabel(StaticLabel)
48 , remoteTableLabel
49 , remoteTableLabel
49 , SerializableDict(SerializableDict)
50 , SerializableDict(SerializableDict)
51+ , Process
50 )
52 )
51import Control.Distributed.Process.Internal.Dynamic
53import Control.Distributed.Process.Internal.Dynamic
52 ( Dynamic(..)
54 ( Dynamic(..)
@@ -74,18 +76,19 @@ remotable ns = do
74mkStatic :: Name -> Q Exp
76mkStatic :: Name -> Q Exp
75mkStatic = varE . staticName
77mkStatic = varE . staticName
76
78
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'.
78functionSDict :: Name -> Q Exp
83functionSDict :: Name -> Q Exp
79functionSDict = varE . sdictName
84functionSDict = varE . sdictName
80
85
81−{-
86+-- | If @f : T1 -> Process T2@ is a monomorphic function
82−-- | Create a closure
87+-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
83−--
88+--
84−-- See module documentation header for "Control.Distributed.Process.Closure"
89+-- Be sure to pass 'f' to 'remotable'.
85−-- for a detailed explanation and examples.
86−mkClosure :: Name -> Q Exp
90+functionTDict :: Name -> Q Exp
87−mkClosure = varE . closureName
91+functionTDict = varE . tdictName
88−-}
89
92
90--------------------------------------------------------------------------------
93--------------------------------------------------------------------------------
91-- Internal (Template Haskell) --
94-- Internal (Template Haskell) --
@@ -100,44 +103,59 @@ createMetaData is =
100
103
101generateDefs :: Name -> Q ([Dec], [Q Exp])
104generateDefs :: Name -> Q ([Dec], [Q Exp])
102generateDefs n = do
105generateDefs n = do
106+ proc <- [t| Process |]
103− mType <- getType n
107+ mType <- getType n
104− case mType of
108+ case mType of
105− Just (origName, typ) -> do
109+ Just (origName, typ) -> do
106− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
110+ let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
107− _ -> ([], typ)
111+ _ -> ([], typ)
112+
113+ -- The main "static" entry
108− (static, register) <- do
114+ (static, register) <- makeStatic origName typVars typ'
109− static <- generateStatic 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
110− let dyn = case typVars of
119+ (sdict, registerSDict) <- case (typVars, typ') of
111− [] -> [| toDyn $(varE origName) |]
120+ ([], ArrowT `AppT` arg `AppT` _res) ->
112− _ -> [| Dynamic (error "Polymorphic value")
121+ makeDict (sdictName origName) arg
113− (unsafeCoerce# $(varE origName))
122+ _ ->
114− |]
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+
115− return ( static
133+ return ( concat [static, sdict, tdict]
116− , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
134+ , concat [register, registerSDict, registerTDict]
117 )
135 )
136+ _ ->
137+ fail $ "remotable: " ++ show n ++ " not found"
138+ where
139+ makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
140+ makeStatic origName typVars typ = do
141+ static <- generateStatic origName typVars typ
142+ let dyn = case typVars of
143+ [] -> [| toDyn $(varE origName) |]
144+ _ -> [| Dynamic (error "Polymorphic value")
145+ (unsafeCoerce# $(varE origName))
146+ |]
147+ return ( static
148+ , [ [| registerStatic $(stringE (show origName)) $dyn |] ]
149+ )
118
150
119− (sdict, registerSDict) <- case (typVars, typ') of
151+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
120− ([], ArrowT `AppT` arg `AppT` _res) -> do
152+ makeDict dictName typ = do
121− -- TODO: we should check if arg is an instance of Serializable, but we cannot
153+ sdict <- generateDict dictName typ
122− -- http://hackage.haskell.org/trac/ghc/ticket/7066
123− sdict <- generateSDict origName arg
124− let dyn' = [| toDyn (SerializableDict
154+ let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]
125− :: SerializableDict $(return arg)
126− )
127− |]
128− return ( sdict
155+ return ( sdict
129− , [ [| registerStatic $(stringE (show (sdictName origName)))
156+ , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
130− $dyn'
131− |] ]
132− )
133− _ ->
134− return ([], [])
135−
136− return ( static ++ sdict
137− , register ++ registerSDict
138 )
157 )
139− _ ->
158+
140− fail $ "remotable: " ++ show n ++ " not found"
141
159
142registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
160registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
143registerStatic label dyn = remoteTableLabel label ^= Just dyn
161registerStatic label dyn = remoteTableLabel label ^= Just dyn
@@ -163,14 +181,14 @@ generateStatic n xs typ = do
163 typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
181 typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
164 typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
182 typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
165
183
166−-- | Generate a function serialization dictionary
184+-- | Generate a serialization dictionary with name 'n' for type 'typ'
167−generateSDict :: Name -> Type -> Q [Dec]
185+generateDict :: Name -> Type -> Q [Dec]
168−generateSDict n typ = do
186+generateDict n typ = do
169 sequence
187 sequence
170− [ sigD (sdictName n) $ [t| Static (SerializableDict $(return typ)) |]
188+ [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
171− , sfnD (sdictName n)
189+ , sfnD n
172 [| Static $ StaticLabel
190 [| Static $ StaticLabel
173− $(stringE (show (sdictName n)))
191+ $(stringE (show n))
174 (typeOf (undefined :: SerializableDict $(return typ)))
192 (typeOf (undefined :: SerializableDict $(return typ)))
175 |]
193 |]
176 ]
194 ]
@@ -181,6 +199,9 @@ staticName n = mkName $ nameBase n ++ "__static"
181sdictName :: Name -> Name
199sdictName :: Name -> Name
182sdictName n = mkName $ nameBase n ++ "__sdict"
200sdictName n = mkName $ nameBase n ++ "__sdict"
183
201
202+tdictName :: Name -> Name
203+tdictName n = mkName $ nameBase n ++ "__tdict"
204+
184--------------------------------------------------------------------------------
205--------------------------------------------------------------------------------
185-- Generic Template Haskell auxiliary functions --
206-- Generic Template Haskell auxiliary functions --
186--------------------------------------------------------------------------------
207--------------------------------------------------------------------------------
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 @@
1module Control.Distributed.Process.Internal.Node
1module Control.Distributed.Process.Internal.Node
2− ( runLocalProcess
2+ ( -- * Message sending
3+ sendPayload
4+ , sendBinary
5+ , sendMessage
3 ) where
6 ) where
4
7
8+import Data.Accessor ((^.), (^=))
9+import Data.Binary (Binary, encode)
10+import qualified Data.ByteString.Lazy as BSL (toChunks)
11+import qualified Data.ByteString as BSS (ByteString)
12+import Control.Concurrent.MVar (withMVar, modifyMVar_)
13+import Control.Concurrent.Chan (writeChan)
5−import Control.Monad.Reader (runReaderT)
14+import Control.Monad (unless)
15+import qualified Network.Transport as NT
16+ ( Connection
17+ , send
18+ , defaultConnectHints
19+ , connect
20+ , Reliability(ReliableOrdered)
21+ )
6import Control.Distributed.Process.Internal.Types
22import Control.Distributed.Process.Internal.Types
7− ( LocalNode
23+ ( LocalNode(localState, localEndPoint, localCtrlChan)
8− , LocalProcess
24+ , Identifier
9− , Process(unProcess)
25+ , localConnectionBetween
26+ , nodeAddress
27+ , nodeOf
28+ , messageToPayload
29+ , createMessage
30+ , NCMsg(..)
31+ , ProcessSignal(Died)
32+ , DiedReason(DiedDisconnect)
10 )
33 )
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
12
61
13−-- | Deconstructor for 'Process' (not exported to the public API)
62+setupConnBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
14−runLocalProcess :: LocalNode -> Process a -> LocalProcess -> IO a
63+setupConnBetween node from to = do
15−runLocalProcess node proc = runMessageT node . runReaderT (unProcess proc)
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
16
83
84+connBetween :: LocalNode -> Identifier -> Identifier -> IO (Maybe NT.Connection)
85+connBetween node from to = do
86+ mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)
87+ case mConn of
88+ Just conn -> return $ Just conn
89+ Nothing -> setupConnBetween node from to
90+ where
91+ nodeState = localState node
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+25−21
@@ -68,7 +68,7 @@ import Control.Monad.Reader (ask)
68import Control.Monad.IO.Class (MonadIO, liftIO)
68import Control.Monad.IO.Class (MonadIO, liftIO)
69import Control.Applicative ((<$>))
69import Control.Applicative ((<$>))
70import Control.Exception (Exception, throw)
70import Control.Exception (Exception, throw)
71−import qualified Control.Exception as Exception (catch)
71+import qualified Control.Exception as Ex (catch)
72import Control.Concurrent.MVar (modifyMVar)
72import Control.Concurrent.MVar (modifyMVar)
73import Control.Concurrent.Chan (writeChan)
73import Control.Concurrent.Chan (writeChan)
74import Control.Concurrent.STM
74import Control.Concurrent.STM
@@ -106,7 +106,6 @@ import Control.Distributed.Process.Internal.Types
106 , TypedChannel(..)
106 , TypedChannel(..)
107 , SendPortId(..)
107 , SendPortId(..)
108 , Identifier(..)
108 , Identifier(..)
109− , procMsg
110 , DidUnmonitor(..)
109 , DidUnmonitor(..)
111 , DidUnlinkProcess(..)
110 , DidUnlinkProcess(..)
112 , DidUnlinkNode(..)
111 , DidUnlinkNode(..)
@@ -114,13 +113,9 @@ import Control.Distributed.Process.Internal.Types
114 , WhereIsReply(..)
113 , WhereIsReply(..)
115 , createMessage
114 , createMessage
116 , Static(..)
115 , Static(..)
116+ , runLocalProcess
117 )
117 )
118−import Control.Distributed.Process.Internal.MessageT
118+import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)
119− ( sendMessage
120− , sendBinary
121− , getLocalNode
122− )
123−import Control.Distributed.Process.Internal.Node (runLocalProcess)
124import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
119import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
125import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
120import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
126
121
@@ -132,7 +127,12 @@ import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
132send :: Serializable a => ProcessId -> a -> Process ()
127send :: Serializable a => ProcessId -> a -> Process ()
133-- This requires a lookup on every send. If we want to avoid that we need to
128-- This requires a lookup on every send. If we want to avoid that we need to
134-- modify serializable to allow for stateful (IO) deserialization
129-- modify serializable to allow for stateful (IO) deserialization
130+send them msg = do
131+ proc <- ask
132+ liftIO $ sendMessage (processNode proc)
133+ (ProcessIdentifier (processId proc))
135−send them msg = procMsg $ sendMessage (ProcessIdentifier them) msg
134+ (ProcessIdentifier them)
135+ msg
136
136
137-- | Wait for a message of a specific type
137-- | Wait for a message of a specific type
138expect :: forall a. Serializable a => Process a
138expect :: forall a. Serializable a => Process a
@@ -163,7 +163,12 @@ newChan = do
163
163
164-- | Send a message on a typed channel
164-- | Send a message on a typed channel
165sendChan :: Serializable a => SendPort a -> a -> Process ()
165sendChan :: 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
167
172
168-- | Wait for a message on a typed channel
173-- | Wait for a message on a typed channel
169receiveChan :: Serializable a => ReceivePort a -> Process a
174receiveChan :: Serializable a => ReceivePort a -> Process a
@@ -261,7 +266,7 @@ getSelfPid = processId <$> ask
261
266
262-- | Get the node ID of our local node
267-- | Get the node ID of our local node
263getSelfNode :: Process NodeId
268getSelfNode :: Process NodeId
264−getSelfNode = localNodeId <$> procMsg getLocalNode
269+getSelfNode = localNodeId . processNode <$> ask
265
270
266--------------------------------------------------------------------------------
271--------------------------------------------------------------------------------
267-- Monitoring and linking --
272-- Monitoring and linking --
@@ -318,11 +323,8 @@ unmonitor ref = do
318-- | Catch exceptions within a process
323-- | Catch exceptions within a process
319catch :: Exception e => Process a -> (e -> Process a) -> Process a
324catch :: Exception e => Process a -> (e -> Process a) -> Process a
320catch p h = do
325catch p h = do
321− node <- procMsg getLocalNode
322 lproc <- ask
326 lproc <- ask
323− let run :: Process a -> IO a
327+ liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
324− run proc = runLocalProcess node proc lproc
325− liftIO $ Exception.catch (run p) (run . h)
326
328
327-- | Like 'expect' but with a timeout
329-- | Like 'expect' but with a timeout
328expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
330expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
@@ -460,7 +462,7 @@ nsendRemote nid label msg =
460-- | Deserialize a closure
462-- | Deserialize a closure
461unClosure :: forall a. Typeable a => Closure a -> Process a
463unClosure :: forall a. Typeable a => Closure a -> Process a
462unClosure (Closure (Static label) env) = do
464unClosure (Closure (Static label) env) = do
463− rtable <- remoteTable <$> procMsg getLocalNode
465+ rtable <- remoteTable . processNode <$> ask
464 case resolveClosure rtable label env of
466 case resolveClosure rtable label env of
465 Nothing -> throw . userError $ "Unregistered closure " ++ show label
467 Nothing -> throw . userError $ "Unregistered closure " ++ show label
466 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
468 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
@@ -507,14 +509,16 @@ sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
507 -> ProcessSignal -- ^ Message to send
509 -> ProcessSignal -- ^ Message to send
508 -> Process ()
510 -> Process ()
509sendCtrlMsg mNid signal = do
511sendCtrlMsg mNid signal = do
510− us <- getSelfPid
512+ proc <- ask
511− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier us
513+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
512 , ctrlMsgSignal = signal
514 , ctrlMsgSignal = signal
513 }
515 }
514 case mNid of
516 case mNid of
515 Nothing -> do
517 Nothing -> do
516− ctrlChan <- localCtrlChan <$> procMsg getLocalNode
518+ ctrlChan <- localCtrlChan . processNode <$> ask
517 liftIO $ writeChan ctrlChan msg
519 liftIO $ writeChan ctrlChan msg
518 Just nid ->
520 Just nid ->
521+ liftIO $ sendBinary (processNode proc)
522+ (ProcessIdentifier (processId proc))
519− procMsg $ sendBinary (NodeIdentifier nid) msg
523+ (NodeIdentifier nid)
520−
524+ msg
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+21−30
@@ -17,7 +17,7 @@ module Control.Distributed.Process.Internal.Types
17 , LocalProcess(..)
17 , LocalProcess(..)
18 , LocalProcessState(..)
18 , LocalProcessState(..)
19 , Process(..)
19 , Process(..)
20− , procMsg
20+ , runLocalProcess
21 -- * Typed channels
21 -- * Typed channels
22 , LocalSendPortId
22 , LocalSendPortId
23 , SendPortId(..)
23 , SendPortId(..)
@@ -58,14 +58,13 @@ module Control.Distributed.Process.Internal.Types
58 -- * Node controller internal data types
58 -- * Node controller internal data types
59 , NCMsg(..)
59 , NCMsg(..)
60 , ProcessSignal(..)
60 , ProcessSignal(..)
61− -- * MessageT monad
62− , MessageT(..)
63− , MessageState(..)
64 -- * Accessors
61 -- * Accessors
65 , localProcesses
62 , localProcesses
66 , localPidCounter
63 , localPidCounter
67 , localPidUnique
64 , localPidUnique
65+ , localConnections
68 , localProcessWithId
66 , localProcessWithId
67+ , localConnectionBetween
69 , monitorCounter
68 , monitorCounter
70 , spawnCounter
69 , spawnCounter
71 , channelCounter
70 , channelCounter
@@ -97,10 +96,8 @@ import Control.Concurrent.Chan (Chan)
97import Control.Concurrent.STM (TChan, TVar)
96import Control.Concurrent.STM (TChan, TVar)
98import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
97import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
99import Control.Applicative (Applicative, (<$>), (<*>))
98import Control.Applicative (Applicative, (<$>), (<*>))
100−import Control.Monad.Reader (MonadReader(..), ReaderT)
99+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
101import Control.Monad.IO.Class (MonadIO)
100import Control.Monad.IO.Class (MonadIO)
102−import Control.Monad.State (MonadState, StateT)
103−import qualified Control.Monad.Trans.Class as Trans (lift)
104import Control.Distributed.Process.Serializable
101import Control.Distributed.Process.Serializable
105 ( Fingerprint
102 ( Fingerprint
106 , Serializable
103 , Serializable
@@ -131,10 +128,7 @@ data LocalProcessId = LocalProcessId
131 { lpidUnique :: Int32
128 { lpidUnique :: Int32
132 , lpidCounter :: Int32
129 , lpidCounter :: Int32
133 }
130 }
134− deriving (Eq, Ord, Typeable)
131+ deriving (Eq, Ord, Typeable, Show)
135−
136−instance Show LocalProcessId where
137− show = show . lpidCounter
138
132
139-- | Process identifier
133-- | Process identifier
140data ProcessId = ProcessId
134data ProcessId = ProcessId
@@ -187,9 +181,10 @@ data LocalNode = LocalNode
187
181
188-- | Local node state
182-- | Local node state
189data LocalNodeState = LocalNodeState
183data LocalNodeState = LocalNodeState
190− { _localProcesses :: Map LocalProcessId LocalProcess
184+ { _localProcesses :: Map LocalProcessId LocalProcess
191− , _localPidCounter :: Int32
185+ , _localPidCounter :: Int32
192− , _localPidUnique :: Int32
186+ , _localPidUnique :: Int32
187+ , _localConnections :: Map (Identifier, Identifier) NT.Connection
193 }
188 }
194
189
195-- | Processes running on our local node
190-- | Processes running on our local node
@@ -198,8 +193,13 @@ data LocalProcess = LocalProcess
198 , processId :: ProcessId
193 , processId :: ProcessId
199 , processState :: MVar LocalProcessState
194 , processState :: MVar LocalProcessState
200 , processThread :: ThreadId
195 , processThread :: ThreadId
196+ , processNode :: LocalNode
201 }
197 }
202
198
199+-- | Deconstructor for 'Process' (not exported to the public API)
200+runLocalProcess :: LocalProcess -> Process a -> IO a
201+runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
202+
203-- | Local process state
203-- | Local process state
204data LocalProcessState = LocalProcessState
204data LocalProcessState = LocalProcessState
205 { _monitorCounter :: Int32
205 { _monitorCounter :: Int32
@@ -210,13 +210,10 @@ data LocalProcessState = LocalProcessState
210
210
211-- | The Cloud Haskell 'Process' type
211-- | The Cloud Haskell 'Process' type
212newtype Process a = Process {
212newtype Process a = Process {
213− unProcess :: ReaderT LocalProcess (MessageT IO) a
213+ unProcess :: ReaderT LocalProcess IO a
214 }
214 }
215 deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
215 deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
216
216
217−procMsg :: MessageT IO a -> Process a
218−procMsg = Process . Trans.lift
219−
220--------------------------------------------------------------------------------
217--------------------------------------------------------------------------------
221-- Typed channels --
218-- Typed channels --
222--------------------------------------------------------------------------------
219--------------------------------------------------------------------------------
@@ -574,9 +571,15 @@ localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter =
574localPidUnique :: Accessor LocalNodeState Int32
571localPidUnique :: Accessor LocalNodeState Int32
575localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
572localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq })
576
573
574+localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) NT.Connection)
575+localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns })
576+
577localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
577localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)
578localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
578localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid
579
579
580+localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe NT.Connection)
581+localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)
582+
580monitorCounter :: Accessor LocalProcessState Int32
583monitorCounter :: Accessor LocalProcessState Int32
581monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
584monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })
582
585
@@ -597,15 +600,3 @@ remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLa
597
600
598remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
601remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)
599remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label
602remoteTableLabel 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 ((<$>))
38import Control.Monad (void, when, forever)
38import Control.Monad (void, when, forever)
39import Control.Monad.IO.Class (MonadIO, liftIO)
39import Control.Monad.IO.Class (MonadIO, liftIO)
40import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
40import 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)
42import Control.Exception (throwIO, SomeException, Exception, throwTo)
42import Control.Exception (throwIO, SomeException, Exception, throwTo)
43import qualified Control.Exception as Exception (catch)
43import qualified Control.Exception as Exception (catch)
44import Control.Concurrent (forkIO)
44import Control.Concurrent (forkIO)
@@ -101,7 +101,6 @@ import Control.Distributed.Process.Internal.Types
101 , Closure(..)
101 , Closure(..)
102 , Static(..)
102 , Static(..)
103 , Message
103 , Message
104− , MessageT
105 , TypedChannel(..)
104 , TypedChannel(..)
106 , Identifier(..)
105 , Identifier(..)
107 , nodeOf
106 , nodeOf
@@ -110,20 +109,18 @@ import Control.Distributed.Process.Internal.Types
110 , WhereIsReply(..)
109 , WhereIsReply(..)
111 , messageToPayload
110 , messageToPayload
112 , RemoteTable(..)
111 , RemoteTable(..)
112+ , payloadToMessage
113+ , createMessage
114+ , runLocalProcess
113 )
115 )
114import Control.Distributed.Process.Serializable (Serializable)
116import 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
116 ( sendBinary
120 ( sendBinary
117 , sendMessage
121 , sendMessage
118 , sendPayload
122 , sendPayload
119− , getLocalNode
120− , runMessageT
121− , payloadToMessage
122− , createMessage
123 )
123 )
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)
127import Control.Distributed.Process.Internal.Primitives (expect, register)
124import Control.Distributed.Process.Internal.Primitives (expect, register)
128import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
125import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
129import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
126import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
@@ -156,9 +153,10 @@ createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
156createBareLocalNode endPoint rtable = do
153createBareLocalNode endPoint rtable = do
157 unq <- randomIO
154 unq <- randomIO
158 state <- newMVar LocalNodeState
155 state <- newMVar LocalNodeState
159− { _localProcesses = Map.empty
156+ { _localProcesses = Map.empty
160− , _localPidCounter = 0
157+ , _localPidCounter = 0
161− , _localPidUnique = unq
158+ , _localPidUnique = unq
159+ , _localConnections = Map.empty
162 }
160 }
163 ctrlChan <- newChan
161 ctrlChan <- newChan
164 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
162 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
@@ -214,10 +212,11 @@ forkProcess node proc = modifyMVar (localState node) $ \st -> do
214 , processId = pid
212 , processId = pid
215 , processState = pst
213 , processState = pst
216 , processThread = tid
214 , processThread = tid
215+ , processNode = node
217 }
216 }
218 tid' <- forkIO $ do
217 tid' <- forkIO $ do
219 reason <- Exception.catch
218 reason <- Exception.catch
220− (runLocalProcess node proc lproc >> return DiedNormal)
219+ (runLocalProcess lproc proc >> return DiedNormal)
221 (return . DiedException . (show :: SomeException -> String))
220 (return . DiedException . (show :: SomeException -> String))
222 -- [Unified: Table 4, rules termination and exiting]
221 -- [Unified: Table 4, rules termination and exiting]
223 modifyMVar_ (localState node) $
222 modifyMVar_ (localState node) $
@@ -287,7 +286,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
287 (Map.insert cid proc procs)
286 (Map.insert cid proc procs)
288 chans
287 chans
289 ctrls
288 ctrls
290− Nothing ->
289+ Nothing ->
291 -- Request for an unknown process.
290 -- Request for an unknown process.
292 --
291 --
293 -- TODO: We should treat this as a fatal error on the
292 -- TODO: We should treat this as a fatal error on the
@@ -367,8 +366,8 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
367--------------------------------------------------------------------------------
366--------------------------------------------------------------------------------
368
367
369runNodeController :: LocalNode -> IO ()
368runNodeController :: LocalNode -> IO ()
370−runNodeController node =
369+runNodeController =
371− runMessageT node (evalStateT (unNC nodeController) initNCState)
370+ runReaderT (evalStateT (unNC nodeController) initNCState)
372
371
373--------------------------------------------------------------------------------
372--------------------------------------------------------------------------------
374-- Internal data types --
373-- Internal data types --
@@ -383,11 +382,8 @@ data NCState = NCState
383 , _registry :: Map String ProcessId
382 , _registry :: Map String ProcessId
384 }
383 }
385
384
386−newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }
385+newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }
387− deriving (Functor, Monad, MonadIO, MonadState NCState)
386+ deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)
388−
389−ncMsg :: MessageT IO a -> NC a
390−ncMsg = NC . Trans.lift
391
387
392initNCState :: NCState
388initNCState :: NCState
393initNCState = NCState { _links = Map.empty
389initNCState = NCState { _links = Map.empty
@@ -402,14 +398,17 @@ initNCState = NCState { _links = Map.empty
402-- [Unified: Table 7]
398-- [Unified: Table 7]
403nodeController :: NC ()
399nodeController :: NC ()
404nodeController = do
400nodeController = do
405− node <- ncMsg getLocalNode
401+ node <- ask
406 forever $ do
402 forever $ do
407 msg <- liftIO $ readChan (localCtrlChan node)
403 msg <- liftIO $ readChan (localCtrlChan node)
408
404
409 -- [Unified: Table 7, rule nc_forward]
405 -- [Unified: Table 7, rule nc_forward]
410 case destNid (ctrlMsgSignal msg) of
406 case destNid (ctrlMsgSignal msg) of
411 Just nid' | nid' /= localNodeId node ->
407 Just nid' | nid' /= localNodeId node ->
408+ liftIO $ sendBinary node
409+ (ctrlMsgSender msg)
412− ncMsg $ sendBinary (NodeIdentifier nid') msg
410+ (NodeIdentifier nid')
411+ msg
413 _ ->
412 _ ->
414 return ()
413 return ()
415
414
@@ -441,7 +440,7 @@ ncEffectMonitor :: ProcessId -- ^ Who's watching?
441 -> Maybe MonitorRef -- ^ 'Nothing' to link
440 -> Maybe MonitorRef -- ^ 'Nothing' to link
442 -> NC ()
441 -> NC ()
443ncEffectMonitor from them mRef = do
442ncEffectMonitor from them mRef = do
444− node <- ncMsg getLocalNode
443+ node <- ask
445 shouldLink <-
444 shouldLink <-
446 if not (isLocal node them)
445 if not (isLocal node them)
447 then return True
446 then return True
@@ -454,15 +453,21 @@ ncEffectMonitor from them mRef = do
454 (False, True) -> -- [Unified: second rule]
453 (False, True) -> -- [Unified: second rule]
455 notifyDied from them DiedUnknownId mRef
454 notifyDied from them DiedUnknownId mRef
456 (False, False) -> -- [Unified: third rule]
455 (False, False) -> -- [Unified: third rule]
456+ -- TODO: this is the right sender according to the Unified semantics,
457+ -- but perhaps having 'them' as the sender would make more sense
458+ -- (see also: notifyDied)
459+ liftIO $ sendBinary node
460+ (NodeIdentifier $ localNodeId node)
457− ncMsg $ sendBinary (NodeIdentifier $ processNodeId from) NCMsg
461+ (NodeIdentifier $ processNodeId from)
462+ NCMsg
458− { ctrlMsgSender = NodeIdentifier (localNodeId node)
463+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
459− , ctrlMsgSignal = Died them DiedUnknownId
464+ , ctrlMsgSignal = Died them DiedUnknownId
460− }
465+ }
461
466
462-- [Unified: Table 11]
467-- [Unified: Table 11]
463ncEffectUnlink :: ProcessId -> Identifier -> NC ()
468ncEffectUnlink :: ProcessId -> Identifier -> NC ()
464ncEffectUnlink from them = do
469ncEffectUnlink from them = do
465− node <- ncMsg getLocalNode
470+ node <- ask
466 when (isLocal node (ProcessIdentifier from)) $
471 when (isLocal node (ProcessIdentifier from)) $
467 case them of
472 case them of
468 ProcessIdentifier pid ->
473 ProcessIdentifier pid ->
@@ -476,7 +481,7 @@ ncEffectUnlink from them = do
476-- [Unified: Table 11]
481-- [Unified: Table 11]
477ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
482ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
478ncEffectUnmonitor from ref = do
483ncEffectUnmonitor from ref = do
479− node <- ncMsg getLocalNode
484+ node <- ask
480 when (isLocal node (ProcessIdentifier from)) $
485 when (isLocal node (ProcessIdentifier from)) $
481 postAsMessage from $ DidUnmonitor ref
486 postAsMessage from $ DidUnmonitor ref
482 modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
487 modify $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
@@ -484,7 +489,7 @@ ncEffectUnmonitor from ref = do
484-- [Unified: Table 12]
489-- [Unified: Table 12]
485ncEffectDied :: Identifier -> DiedReason -> NC ()
490ncEffectDied :: Identifier -> DiedReason -> NC ()
486ncEffectDied ident reason = do
491ncEffectDied ident reason = do
487− node <- ncMsg getLocalNode
492+ node <- ask
488 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
493 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
489 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
494 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
490
495
@@ -509,9 +514,12 @@ ncEffectSpawn pid cProc ref = do
509 -- If the closure does not exist, we spawn a process that throws an exception
514 -- If the closure does not exist, we spawn a process that throws an exception
510 -- This allows the remote node to find out what's happening
515 -- This allows the remote node to find out what's happening
511 let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
516 let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
512− node <- ncMsg getLocalNode
517+ node <- ask
513 pid' <- liftIO $ forkProcess node proc
518 pid' <- liftIO $ forkProcess node proc
519+ liftIO $ sendMessage node
520+ (NodeIdentifier (localNodeId node))
514− ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
521+ (ProcessIdentifier pid)
522+ (DidSpawn ref pid')
515
523
516-- Unified semantics does not explicitly describe how to implement 'register',
524-- Unified semantics does not explicitly describe how to implement 'register',
517-- but mentions it's "very similar to nsend" (Table 14)
525-- but mentions it's "very similar to nsend" (Table 14)
@@ -525,18 +533,24 @@ ncEffectRegister label mPid =
525-- Unified semantics does not explicitly describe 'whereis'
533-- Unified semantics does not explicitly describe 'whereis'
526ncEffectWhereIs :: ProcessId -> String -> NC ()
534ncEffectWhereIs :: ProcessId -> String -> NC ()
527ncEffectWhereIs from label = do
535ncEffectWhereIs from label = do
536+ node <- ask
528 mPid <- gets (^. registryFor label)
537 mPid <- gets (^. registryFor label)
538+ liftIO $ sendMessage node
539+ (NodeIdentifier (localNodeId node))
529− ncMsg $ sendMessage (ProcessIdentifier from) (WhereIsReply label mPid)
540+ (ProcessIdentifier from)
541+ (WhereIsReply label mPid)
530
542
531-- [Unified: Table 14]
543-- [Unified: Table 14]
532ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
544ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
533−ncEffectNamedSend _from label msg = do
545+ncEffectNamedSend from label msg = do
534 mPid <- gets (^. registryFor label)
546 mPid <- gets (^. registryFor label)
535 -- If mPid is Nothing, we just ignore the named send (as per Table 14)
547 -- 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
548+ node <- ask
537− -- to be the 'from' of the original named send, not this node controller
538 forM_ mPid $ \pid ->
549 forM_ mPid $ \pid ->
550+ liftIO $ sendPayload node
551+ from
539− ncMsg $ sendPayload (ProcessIdentifier pid) (messageToPayload msg)
552+ (ProcessIdentifier pid)
553+ (messageToPayload msg)
540
554
541--------------------------------------------------------------------------------
555--------------------------------------------------------------------------------
542-- Auxiliary --
556-- Auxiliary --
@@ -548,7 +562,7 @@ notifyDied :: ProcessId -- ^ Who to notify?
548 -> Maybe MonitorRef -- ^ 'Nothing' for linking
562 -> Maybe MonitorRef -- ^ 'Nothing' for linking
549 -> NC ()
563 -> NC ()
550notifyDied dest src reason mRef = do
564notifyDied dest src reason mRef = do
551− node <- ncMsg getLocalNode
565+ node <- ask
552 case (isLocal node (ProcessIdentifier dest), mRef, src) of
566 case (isLocal node (ProcessIdentifier dest), mRef, src) of
553 (True, Just ref, ProcessIdentifier pid) ->
567 (True, Just ref, ProcessIdentifier pid) ->
554 postAsMessage dest $ ProcessMonitorNotification ref pid reason
568 postAsMessage dest $ ProcessMonitorNotification ref pid reason
@@ -565,10 +579,13 @@ notifyDied dest src reason mRef = do
565 (False, _, _) ->
579 (False, _, _) ->
566 -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
580 -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
567 -- (see [Unified: Table 10]
581 -- (see [Unified: Table 10]
582+ liftIO $ sendBinary node
583+ (NodeIdentifier $ localNodeId node)
568− ncMsg $ sendBinary (NodeIdentifier $ processNodeId dest) NCMsg
584+ (NodeIdentifier $ processNodeId dest)
585+ NCMsg
569− { ctrlMsgSender = NodeIdentifier (localNodeId node)
586+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
570− , ctrlMsgSignal = Died src reason
587+ , ctrlMsgSignal = Died src reason
571− }
588+ }
572
589
573-- | [Unified: Table 8]
590-- | [Unified: Table 8]
574destNid :: ProcessSignal -> Maybe NodeId
591destNid :: ProcessSignal -> Maybe NodeId
@@ -592,13 +609,13 @@ isLocal nid ident = nodeOf ident == localNodeId nid
592-- | Lookup a local closure
609-- | Lookup a local closure
593unClosure :: Typeable a => Closure a -> NC (Maybe a)
610unClosure :: Typeable a => Closure a -> NC (Maybe a)
594unClosure (Closure (Static label) env) = do
611unClosure (Closure (Static label) env) = do
595− rtable <- remoteTable <$> ncMsg getLocalNode
612+ rtable <- remoteTable <$> ask
596 return (resolveClosure rtable label env >>= fromDynamic)
613 return (resolveClosure rtable label env >>= fromDynamic)
597
614
598-- | Check if an identifier refers to a valid local object
615-- | Check if an identifier refers to a valid local object
599isValidLocalIdentifier :: Identifier -> NC Bool
616isValidLocalIdentifier :: Identifier -> NC Bool
600isValidLocalIdentifier ident = do
617isValidLocalIdentifier ident = do
601− node <- ncMsg getLocalNode
618+ node <- ask
602 liftIO . withMVar (localState node) $ \nSt ->
619 liftIO . withMVar (localState node) $ \nSt ->
603 case ident of
620 case ident of
604 NodeIdentifier nid ->
621 NodeIdentifier nid ->
@@ -631,7 +648,7 @@ throwException pid e = withLocalProc pid $ \p ->
631
648
632withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
649withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
633withLocalProc pid p = do
650withLocalProc pid p = do
634− node <- ncMsg getLocalNode
651+ node <- ask
635 liftIO $ do
652 liftIO $ do
636 -- By [Unified: table 6, rule missing_process] messages to dead processes
653 -- By [Unified: table 6, rule missing_process] messages to dead processes
637 -- can silently be dropped
654 -- can silently be dropped
distributed-process/tests/TestCH.hs+19
@@ -560,6 +560,24 @@ testRemoteRegistry transport = do
560 True <- return $ pingServer == pid'
560 True <- return $ pingServer == pid'
561 return ()
561 return ()
562
562
563+testSpawnLocal :: NT.Transport -> IO ()
564+testSpawnLocal transport = do
565+ node <- newLocalNode transport initRemoteTable
566+
567+ runProcess node $ do
568+ us <- getSelfPid
569+
570+ pid <- spawnLocal $ do
571+ sport <- expect
572+ sendChan sport (1234 :: Int)
573+
574+ sport <- spawnChannelLocal $ \rport -> do
575+ (1234 :: Int) <- receiveChan rport
576+ send us ()
577+
578+ send pid sport
579+ expect
580+
563main :: IO ()
581main :: IO ()
564main = do
582main = do
565 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
583 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -574,6 +592,7 @@ main = do
574 , ("Terminate", testTerminate transport)
592 , ("Terminate", testTerminate transport)
575 , ("Registry", testRegistry transport)
593 , ("Registry", testRegistry transport)
576 , ("RemoteRegistry", testRemoteRegistry transport)
594 , ("RemoteRegistry", testRemoteRegistry transport)
595+ , ("SpawnLocal", testSpawnLocal transport)
577 -- Monitoring processes
596 -- Monitoring processes
578 --
597 --
579 -- The "missing" combinations in the list below don't make much sense, as
598 -- 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
36wait :: Int -> Process ()
36wait :: Int -> Process ()
37wait = liftIO . threadDelay
37wait = liftIO . threadDelay
38
38
39+isPrime :: Integer -> Process Bool
40+isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
41+ where
42+ sieve :: [Integer] -> [Integer]
43+ sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
44+
39-- | First argument indicates empty closure environment
45-- | First argument indicates empty closure environment
40typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
46typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
41typedPingServer () rport = forever $ do
47typedPingServer () rport = forever $ do
@@ -49,6 +55,7 @@ remotable [ 'factorial
49 , 'sdictInt
55 , 'sdictInt
50 , 'wait
56 , 'wait
51 , 'typedPingServer
57 , 'typedPingServer
58+ , 'isPrime
52 ]
59 ]
53
60
54factorialClosure :: Int -> Closure (Process Int)
61factorialClosure :: Int -> Closure (Process Int)
@@ -296,6 +303,13 @@ testSpawnChannel transport rtable = do
296 sendChan pingServer sendReply
303 sendChan pingServer sendReply
297 receiveChan receiveReply
304 receiveChan receiveReply
298
305
306+testTDict :: Transport -> RemoteTable -> IO ()
307+testTDict transport rtable = do
308+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
309+ runProcess node1 $ do
310+ True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
311+ return ()
312+
299main :: IO ()
313main :: IO ()
300main = do
314main = do
301 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
315 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -314,4 +328,5 @@ main = do
314 , ("SpawnInvalid", testSpawnInvalid transport rtable)
328 , ("SpawnInvalid", testSpawnInvalid transport rtable)
315 , ("ClosureExpect", testClosureExpect transport rtable)
329 , ("ClosureExpect", testClosureExpect transport rtable)
316 , ("SpawnChannel", testSpawnChannel transport rtable)
330 , ("SpawnChannel", testSpawnChannel transport rtable)
331+ , ("TDict", testTDict transport rtable)
317 ]
332 ]
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
45 random >= 1.0 && < 1.1,
45 random >= 1.0 && < 1.1,
46 ansi-terminal >= 0.5 && < 0.6,
46 ansi-terminal >= 0.5 && < 0.6,
47 mtl >= 2.0 && < 2.2
47 mtl >= 2.0 && < 2.2
48+ Other-modules: TestAuxiliary,
49+ TestTransport,
50+ Traced
48 ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
51 ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
49 Extensions: ExistentialQuantification,
52 Extensions: ExistentialQuantification,
50 FlexibleInstances,
53 FlexibleInstances,