git.iko.soy/distributed-process
on c7f72ce help sign in
distributed-process/benchmarks/PingTCPTransport.hs
128 lines 4.0 kB history raw
1{-# LANGUAGE CPP, BangPatterns #-}
3module Main where
5import Network.Transport (newConnection, receive, connect, send, defaultHints,
6 serialize, deserialize, SourceEnd, TargetEnd)
7import Network.Transport.TCP (mkTransport, TCPConfig (..))
9import Control.Monad (forever, replicateM_, forM_)
11import qualified Data.Serialize as Ser
12import Data.Maybe (fromJust)
13import Data.Int
14import System.Environment (getArgs, withArgs)
15import Data.Time (getCurrentTime, diffUTCTime)
16import System.IO (withFile, IOMode(..), hPutStrLn)
17import Control.Concurrent (forkIO)
18import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
20#ifndef LAZY
21import qualified Data.ByteString.Char8 as BS
22import qualified Network.Socket.ByteString as NBS
23encode = Ser.encode
24decode = Ser.decode
25#else
26import qualified Data.ByteString.Lazy.Char8 as BS
27import qualified Network.Socket.ByteString.Lazy as NBS
28encode = Ser.encodeLazy
29decode = Ser.decodeLazy
30#endif
31{-# INLINE encode #-}
32{-# INLINE decode #-}
33encode :: Ser.Serialize a => a -> BS.ByteString
34decode :: Ser.Serialize a => BS.ByteString -> Either String a
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.
53main :: IO ()
54main = do
55 [pingsStr] <- getArgs
56 serverAddr <- newEmptyMVar
57 clientAddr <- newEmptyMVar
59 -- Start the server
60 forkIO $ do
61 -- establish transport
62 transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
64 -- create ping end
65 putStrLn "server: creating ping end"
66 (sourceAddrPing, targetEndPing) <- newConnection transport
67 putMVar serverAddr sourceAddrPing
69 -- create pong end
70 putStrLn "server: creating pong end"
71 sourceAddrPong <- takeMVar clientAddr
72 sourceEndPong <- connect sourceAddrPong
74 -- always respond to a ping with a pong
75 putStrLn "server: awaiting pings"
76 pong targetEndPing sourceEndPong
78 -- Client
79 sourceAddr <- takeMVar serverAddr
80 let pings = read pingsStr
81 -- establish transport
82 transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
84 -- create ping end
85 sourceEndPing <- connect sourceAddr
87 -- create pong end
88 (sourceAddrPong, targetEndPong) <- newConnection transport
89 putMVar clientAddr sourceAddrPong
91 ping sourceEndPing targetEndPong pings
92 putStrLn "Done with all ping/pongs."
94-- | The message we use to ping (CAF so that we don't keep encoding it)
95pingMessage :: BS.ByteString
96pingMessage = BS.pack "ping123"
98-- | Keep replying to pings (send pongs)
99pong :: TargetEnd -> SourceEnd -> IO ()
100pong targetEndPing sourceEndPong = do
101 [bs] <- receive targetEndPing
102 -- putStrLn $ "server got " ++ BS.unpack bs
103 send sourceEndPong [bs]
104 pong targetEndPing sourceEndPong
106-- | Send a number of pings
107ping :: SourceEnd -> TargetEnd -> Int -> IO ()
108ping 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)
123-- | Output latencies to a file to be plotted
124outputData :: [Double] -> IO ()
125outputData 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)