git.iko.soy/distributed-process
on ff8d9c6 help sign in
distributed-process/benchmarks/PingTCP.hs
120 lines 3.8 kB history raw
1{-# LANGUAGE CPP #-}
3module Main where
5import Control.Monad
6import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
7import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
9import Data.Int
10import qualified Data.Serialize as Ser
11import Data.Word (Word8)
12import Network.Socket
13 ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
14 , SocketType (Stream), SocketOption (ReuseAddr)
15 , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
16 , defaultHints
17 , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
18import System.Environment (getArgs, withArgs)
20import qualified Network.Socket as N
22import Debug.Trace
24#ifndef LAZY
25import Data.ByteString (ByteString)
26import qualified Network.Socket.ByteString as NBS
27encode = Ser.encode
28decode = Ser.decode
29#else
30import Data.ByteString.Lazy (ByteString)
31import qualified Network.Socket.ByteString.Lazy as NBS
32encode = Ser.encodeLazy
33decode = Ser.decodeLazy
34#endif
35{-# INLINE encode #-}
36{-# INLINE decode #-}
37encode :: Ser.Serialize a => a -> ByteString
38decode :: Ser.Serialize a => ByteString -> Either String a
40-- | This performs a ping benchmark on a TCP connection created by
41-- Network.Socket. To compile this file, you might use:
42--
43-- ghc --make -idistributed-process/src -inetwork-transport/src -O2 benchmarks/PingTCP.hs
44--
45-- To use the compiled binary, first set up the server on the current machine:
46--
47-- ./benchmarks/PingTCP server 8080
48--
49-- Next, perform the benchmark on a client using the server address, where
50-- each mark is 1000 pings:
51--
52-- ./benchmarks/PingTCP 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 : [] -> withSocketsDo $ do
60 putStrLn "server: creating TCP connection"
61 serverAddrs <- getAddrInfo
62 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
63 Nothing
64 (Just service)
65 let serverAddr = head serverAddrs
66 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
67 setSocketOption sock ReuseAddr 1
68 bindSocket sock (addrAddress serverAddr)
70 putStrLn "server: awaiting client connection"
71 listen sock 1
72 (clientSock, clientAddr) <- accept sock
74 putStrLn "server: listening for pings"
75 forever (pong clientSock)
77 "client": host : service : pingsStr : reps : args' -> withSocketsDo $ do
78 let pings = read pingsStr
79 serverAddrs <- getAddrInfo
80 Nothing
81 (Just host)
82 (Just service)
83 let serverAddr = head serverAddrs
84 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
86 N.connect sock (addrAddress serverAddr)
88 -- benchmark the pings
89 case (read reps) :: Int of
90 0 -> error "What would zero reps mean?"
91 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
92 replicateM_ pings (ping sock)
93 n -> withArgs args' $ defaultMainWith
94 (defaultConfig{ cfgSamples = ljust n })
95 (return ()) -- Init action.
96 [ benchPing sock (fromIntegral pings) ]
97 putStrLn "Done with all ping/pongs."
99-- withArgs args' $ defaultMain [ benchPing sock pings ]
100-- replicateM_ pings (ping sock)
102-- | Each `ping` sends a single byte, and expects to receive one
103-- back in return.
104ping :: Socket -> IO Int64
105ping sock = do
106 NBS.send sock $ encode (42 :: Int64)
107 bs <- NBS.recv sock 8
108 either error return $ decode bs
110pong :: Socket -> IO ()
111pong sock = do
112 bs <- NBS.recv sock 8
113 NBS.sendAll sock bs
114 return ()
116benchPing :: Socket -> Int64 -> Benchmark
117benchPing sock n =
118 bench "PingTCP" $
119 nfIO (replicateM_ (fromIntegral n) (ping sock))