@@ -1,107 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−module Main where
4−
5−import Control.Monad
6−
7−import Data.Int
8−import qualified Data.Serialize as Ser
9−import Data.Word (Word8)
10−import 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 )
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
22−import Debug.Trace
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)
28−
29−main :: IO ()
30−main = do
31− [pingsStr] <- getArgs
32− serverReady <- newEmptyMVar
33− clientDone <- newEmptyMVar
34−
35− -- Start the server
36− forkIO $ do
37− putStrLn "server: creating TCP connection"
38− serverAddrs <- getAddrInfo
39− (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
40− Nothing
41− (Just "8080")
42− let serverAddr = head serverAddrs
43− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
44− setSocketOption sock ReuseAddr 1
45− bindSocket sock (addrAddress serverAddr)
46−
47− putStrLn "server: awaiting client connection"
48− putMVar serverReady ()
49− listen sock 1
50− (clientSock, clientAddr) <- accept sock
51−
52− putStrLn "server: listening for pings"
53− pong clientSock
54−
55− -- Client
56− forkIO $ do
57− takeMVar serverReady
58− let pings = read pingsStr
59− serverAddrs <- getAddrInfo
60− Nothing
61− (Just "127.0.0.1")
62− (Just "8080")
63− let serverAddr = head serverAddrs
64− sock <- socket (addrFamily serverAddr) Stream defaultProtocol
65−
66− N.connect sock (addrAddress serverAddr)
67−
68− ping sock pings
69− putMVar clientDone ()
70−
71− -- Wait for the client to be complete
72− takeMVar clientDone
73−
74−pingMessage :: ByteString
75−pingMessage = pack "ping123"
76−
77−ping :: Socket -> Int -> IO ()
78−ping sock pings = go pings
79− where
80− go :: Int -> IO ()
81− go 0 = do
82− putStrLn $ "client did " ++ show pings ++ " pings"
83− go !i = do
84− before <- getCurrentTime
85− send sock pingMessage
86− bs <- recv sock 8
87− after <- getCurrentTime
88− -- putStrLn $ "client received " ++ unpack bs
89− let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
90− hPutStrLn stderr $ show i ++ " " ++ show latency
91− go (i - 1)
92−
93−pong :: Socket -> IO ()
94−pong sock = do
95− bs <- recv sock 8
96− -- putStrLn $ "server received " ++ unpack bs
97− when (BS.length bs > 0) $ do
98− send sock bs
99− pong sock
100−
101−-- | Wrapper around NBS.recv (for profiling)
102−recv :: Socket -> Int -> IO ByteString
103−recv = NBS.recv
104−
105−-- | Wrapper around NBS.send (for profiling)
106−send :: Socket -> ByteString -> IO Int
107−send = NBS.send