@@ -0,0 +1,96 @@
1+module Main where
2+
3+import Network.Transport
4+import Network.Transport.TCP (mkTransport, TCPConfig (..))
5+
6+import Control.Monad (forever, replicateM_)
7+import Criterion.Main (Benchmark, bench, defaultMain, nfIO)
8+import Data.Binary
9+import Data.ByteString.Lazy (ByteString)
10+import Data.Maybe (fromJust)
11+import Data.Int
12+import System.Environment (getArgs, withArgs)
13+
14+import qualified Data.ByteString.Lazy as BS
15+
16+-- | This performs a benchmark on the TCP transport to measure how long
17+-- it takes to transfer a number of bytes. This can be compiled using:
18+--
19+-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/SendTransport.hs
20+--
21+-- To use the compiled binary, first set up a server:
22+--
23+-- ./benchmarks/SendTransport server 0.0.0.0 8080 sourceAddr
24+--
25+-- Once this is established, launch a client to perform the benchmark. The
26+-- following command sends 1000 bytes per mark.
27+--
28+-- ./benchmarks/SendTransport client 0.0.0.0 8081 sourceAddr 1000
29+--
30+-- The server must be restarted between benchmarks.
31+main :: IO ()
32+main = do
33+ args <- getArgs
34+ case args of
35+ "server" : host : service : sourceAddrFilePath : [] -> do
36+
37+ -- establish transport
38+ transport <- mkTransport $ TCPConfig defaultHints host service
39+
40+ -- create ping end
41+ putStrLn "server: creating ping end"
42+ (sourceAddrPing, targetEndPing) <- newConnection transport
43+ BS.writeFile sourceAddrFilePath $ serialize sourceAddrPing
44+
45+ -- create pong end
46+ putStrLn "server: creating pong end"
47+ [sourceAddrPongBS] <- receive targetEndPing
48+ sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
49+
50+ -- always respond to a ping with a pong
51+ putStrLn "server: awaiting pings"
52+ forever $ pong targetEndPing sourceEndPong
53+
54+
55+ "client" : host : service : sourceAddrFilePath : sizeStr : args' -> do
56+ let size = read sizeStr
57+ let bs = BS.replicate size 0
58+
59+ -- establish transport
60+ transport <- mkTransport $ TCPConfig defaultHints host service
61+
62+ -- create ping end
63+ sourceAddrPingBS <- BS.readFile sourceAddrFilePath
64+ sourceEndPing <- connect . fromJust $ deserialize transport sourceAddrPingBS
65+
66+ -- create pong end
67+ (sourceAddrPong, targetEndPong) <- newConnection transport
68+ send sourceEndPing [serialize sourceAddrPong]
69+
70+ -- benchmark the pings
71+ withArgs args' $ defaultMain [ benchSend sourceEndPing targetEndPong bs ]
72+
73+-- | The effect of `ping sourceEndPing targetEndPong bs` is to send the
74+-- `ByteString` `bs` using `sourceEndPing`, and to then receive
75+-- a single byte back from `targetEndPong`.
76+ping :: SourceEnd -> TargetEnd -> ByteString -> IO Word8
77+ping sourceEndPing targetEndPong bs = do
78+ send sourceEndPing [bs]
79+ [cs] <- receive targetEndPong
80+ return $ decode cs
81+
82+-- | This function takes a `TargetEnd` for the pings, and a `SourceEnd` for
83+-- pongs. Whenever a ping is received from the `TargetEnd`, a pong is sent
84+-- in reply down the `SourceEnd`, repeating whatever was sent.
85+pong :: TargetEnd -> SourceEnd -> IO ()
86+pong targetEndPing sourceEndPong = do
87+ bs <- receive targetEndPing
88+ send sourceEndPong [encode (0 :: Word8)]
89+
90+-- | The effect of `benchSend sourceEndPing targetEndPong bs` is to send
91+-- `bs` pings down `sourceEndPing` using the `ping` function. The time
92+-- taken is benchmarked.
93+benchSend :: SourceEnd -> TargetEnd -> ByteString -> Benchmark
94+benchSend sourceEndPing targetEndPong bs = bench "Transport Ping" $
95+ nfIO (ping sourceEndPing targetEndPong bs)
96+