@@ -0,0 +1,106 @@
1+{-# LANGUAGE CPP, BangPatterns #-}
8+import qualified Data.Serialize as Ser
9+import Data.Word (Word8)
11+ ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
12+ , SocketType (Stream), SocketOption (ReuseAddr)
13+ , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
15+ , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
16+import System.Environment (getArgs, withArgs)
17+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
18+import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr)
19+import Control.Concurrent (forkIO)
20+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
21+import qualified Network.Socket as N
23+import Data.ByteString (ByteString)
24+import Data.ByteString.Char8 (pack, unpack)
25+import qualified Data.ByteString as BS
26+import qualified Network.Socket.ByteString as NBS
27+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
31+ [pingsStr] <- getArgs
32+ serverReady <- newEmptyMVar
36+ putStrLn "server: creating TCP connection"
37+ serverAddrs <- getAddrInfo
38+ (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
41+ let serverAddr = head serverAddrs
42+ sock <- socket (addrFamily serverAddr) Stream defaultProtocol
43+ setSocketOption sock ReuseAddr 1
44+ bindSocket sock (addrAddress serverAddr)
46+ putStrLn "server: awaiting client connection"
47+ putMVar serverReady ()
49+ (clientSock, clientAddr) <- accept sock
51+ putStrLn "server: listening for pings"
56+ let pings = read pingsStr
57+ serverAddrs <- getAddrInfo
61+ let serverAddr = head serverAddrs
62+ sock <- socket (addrFamily serverAddr) Stream defaultProtocol
64+ N.connect sock (addrAddress serverAddr)
68+pingMessage :: ByteString
69+pingMessage = pack "ping123"
71+ping :: Socket -> Int -> IO ()
72+ping sock pings = go pings
76+ putStrLn $ "client did " ++ show pings ++ " pings"
78+ before <- getCurrentTime
79+ send sock pingMessage
81+ after <- getCurrentTime
82+ -- putStrLn $ "client received " ++ unpack bs
83+ let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
84+ hPutStrLn stderr $ show i ++ " " ++ show latency
87+pong :: Socket -> IO ()
90+ -- putStrLn $ "server received " ++ unpack bs
91+ when (BS.length bs > 0) $ do
95+-- | Wrapper around NBS.recv (for profiling)
96+recv :: Socket -> Int -> IO ByteString
98+ headerAndPayload <- NBS.recv sock (4 + i)
99+ return (BS.drop 4 headerAndPayload)
101+-- | Wrapper around NBS.send (for profiling)
102+send :: Socket -> ByteString -> IO ()
105+ length = fromIntegral $ BS.length bs
106+ NBS.sendMany sock [Ser.encode length, bs]