@@ -0,0 +1,146 @@
1+{-# LANGUAGE CPP #-}
2+
3+
4+
5+-- | This performs a ping benchmark on the TCP transport. If
6+-- network-transport-tcp has been "cabal install"ed, then this
7+-- benchmark can be compiled with:
8+--
9+-- ghc --make -O2 benchmarks/PingTransport.hs
10+--
11+-- To use the compiled binary, first set up a server:
12+--
13+-- ./benchmarks/PingTCPTransport server 0.0.0.0 8080 sourceAddr.dat
14+--
15+-- Once this is established, launch a client to perform the benchmark. The
16+-- following command sends 1000 pings for 1 trial:
17+--
18+-- ./benchmarks/PingTCPTransport client 0.0.0.0 8081 sourceAddr.dat 1000 1
19+--
20+-- The server must be restarted between benchmarks.
21+
22+--------------------------------------------------------------------------------
23+module Main where
24+
25+import Network.Transport (receive, connect, send, defaultConnectHints, Event(..),
26+ Connection, EndPoint, EndPointAddress(EndPointAddress), Reliability(ReliableOrdered),
27+ newEndPoint, address, endPointAddressToByteString)
28+import Network.Transport.TCP (createTransport, defaultTCPParameters, decodeEndPointAddress)
29+
30+import Control.Monad (forever, replicateM_)
31+import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
32+import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
33+
34+import qualified Data.Serialize as Ser
35+import Data.Maybe (fromJust)
36+import Data.Int
37+import System.Environment (getArgs, withArgs)
38+
39+import System.Exit (exitSuccess)
40+
41+#ifndef LAZY
42+import qualified Data.ByteString.Char8 as BS
43+encode = Ser.encode
44+decode = Ser.decode
45+#else
46+import qualified Data.ByteString.Lazy.Char8 as BS
47+encode = Ser.encodeLazy
48+decode = Ser.decodeLazy
49+#endif
50+{-# INLINE encode #-}
51+{-# INLINE decode #-}
52+encode :: Ser.Serialize a => a -> BS.ByteString
53+decode :: Ser.Serialize a => BS.ByteString -> Either String a
54+
55+--------------------------------------------------------------------------------
56+
57+main :: IO ()
58+main = do
59+ args <- getArgs
60+ case args of
61+ "server" : host : port : sourceAddrFilePath : [] -> do
62+ -- establish transport
63+ Right transport <- createTransport host port defaultTCPParameters
64+
65+ -- create ping end
66+ putStrLn "server: creating ping end"
67+-- (sourceAddrPing, targetEndPing)
68+ Right endpoint <- newEndPoint transport
69+ BS.writeFile sourceAddrFilePath $ endPointAddressToByteString $ address endpoint
70+
71+ -- create pong end
72+ putStrLn "server: creating pong end"
73+ -- Establish the connection:
74+ event <- receive endpoint
75+ Right conn <- case event of
76+ ConnectionOpened cid rel addr ->
77+ -- Connect right back, and since this is a single-client
78+ -- benchmark, block this thread to do it:
79+ connect endpoint addr rel defaultConnectHints
80+ oth -> do putStrLn$" server waiting for connection, unexpected event: "++show oth
81+ exitSuccess
82+
83+ putStrLn "server: going into pong loop..."
84+ forever $ pong endpoint conn
85+ return ()
86+
87+ "client" : host : port : sourceAddrFilePath : numPings : reps : args' -> do
88+ let pings = read numPings :: Int
89+ -- establish transport
90+ Right transport <- createTransport host port defaultTCPParameters
91+ Right endpoint <- newEndPoint transport
92+
93+ -- create ping end
94+ bs <- BS.readFile sourceAddrFilePath
95+ Right conn <- connect endpoint (EndPointAddress bs) ReliableOrdered defaultConnectHints
96+-- let Just (host,port,endptID) = decodeEndPointAddress (EndPointAddress bs)
97+ -- create pong end
98+-- send sourceEndPing [serialize sourceAddrPong]
99+
100+ -- benchmark the pings
101+ case (read reps) :: Int of
102+ 0 -> error "Error: What would zero trials mean?"
103+ 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
104+ replicateM_ pings (ping conn endpoint 42)
105+ n -> withArgs args' $ defaultMainWith
106+ (defaultConfig{ cfgSamples = ljust n })
107+ (return ()) -- Init action.
108+ [ benchPing conn endpoint (fromIntegral pings)]
109+
110+ putStrLn$"client: Done with all "++show pings++" ping/pongs."
111+ return ()
112+
113+-- | This function takes an EndPoint to receieve pings, and a
114+-- Connection to send back pongs. It doesn't bother decoding the
115+-- message, rather it sends it right on back.
116+pong :: EndPoint -> Connection -> IO ()
117+pong endpoint conn = do
118+ event <- receive endpoint
119+ case event of
120+ Received cid payloads -> do
121+ Right _ <- send conn payloads
122+ return ()
123+ oth -> error$"while awaiting pings, server received unexpected event: \n"++show oth
124+
125+-- | The effect of `ping conn endpt n` is to send the number `n` on
126+-- the connection and then receive another number from the endpoint,
127+-- which is then returned.
128+ping :: Connection -> EndPoint -> Int64 -> IO Int64
129+ping conn endpt n = do
130+ send conn [encode n]
131+ loop
132+ where
133+ loop = do
134+ event <- receive endpt
135+ case event of
136+ Received _cid [payload] -> do
137+ let (Right n2) = decode payload
138+ return $! n2
139+ ConnectionOpened _ _ _ -> loop -- ignore this
140+ other -> error$"Unexpected event on endpoint during ping process: "++show other
141+
142+-- | The effect of `benchPing conn endpt n` is to send
143+-- `n` pings down `conn` using the `ping` function.
144+benchPing :: Connection -> EndPoint -> Int64 -> Benchmark
145+benchPing conn endpoint n = bench "PingTransport" $
146+ nfIO (replicateM_ (fromIntegral n) (ping conn endpoint 42))