git.iko.soy/distributed-process
on c7f72ce help sign in
distributed-process/benchmarks/SendTCP.hs
109 lines 3.4 kB history raw
1{-# LANGUAGE CPP #-}
3module Main where
5import Control.Monad
6import Criterion.Main (Benchmark, bench, defaultMain, nfIO, bgroup)
7import Data.Int
8import qualified Data.Serialize as Ser
9import Data.Word (Word8)
10import 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 )
16import System.Environment (getArgs, withArgs)
18import qualified Network.Socket as N
20#ifdef LAZY
21import Data.ByteString (ByteString)
22import qualified Data.ByteString as BS
23import qualified Network.Socket.ByteString as NBS
24encode = Ser.encode
25decode = Ser.decode
26#else
27import Data.ByteString.Lazy (ByteString)
28import qualified Data.ByteString.Lazy as BS
29import qualified Network.Socket.ByteString.Lazy as NBS
30encode = Ser.encodeLazy
31decode = Ser.decodeLazy
32#endif
33{-# INLINE encode #-}
34{-# INLINE decode #-}
35encode :: Ser.Serialize a => a -> ByteString
36decode :: Ser.Serialize a => ByteString -> Either String a
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.
55main :: IO ()
56main = 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)
71 putStrLn "server: awaiting client connection"
72 listen sock 1
73 (clientSock, clientAddr) <- accept sock
75 putStrLn "server: listening for data"
77 forever $ pong clientSock size
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
88 N.connect sock (addrAddress serverAddr)
90 -- benchmark the data
91 let bs = BS.replicate size 0
92 withArgs args' $ defaultMain [ benchSend sock bs ]
94-- | Each `ping` sends a `ByteString` and expects a byte in return.
95ping :: Socket -> ByteString -> IO Word8
96ping sock bs = do
97 NBS.send sock bs
98 bs' <- NBS.recv sock 1
99 either error return $ decode bs
101-- pong :: Socket -> Int64 -> IO ()
102pong sock size = do
103 bs <- NBS.recv sock size
104 NBS.sendAll sock (encode (0 :: Word8))
105 return ()
107benchSend :: Socket -> ByteString -> Benchmark
108benchSend sock bs = bench "SendTCP" $
109 nfIO (ping sock bs)