@@ -17,9 +17,8 @@ import Data.ByteString.Char8 (pack, unpack)
17import qualified Data.ByteString as BS
17import qualified Data.ByteString as BS
18import qualified Network.Socket.ByteString as NBS
18import qualified Network.Socket.ByteString as NBS
19import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
19import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
20−import Network.Transport (newConnection, receive, connect, send, defaultHints,
20+import Network.Transport
21− serialize, deserialize, SourceEnd, TargetEnd)
22−import Network.Transport.TCP (mkTransport, TCPConfig (..))
21+import Network.Transport.TCP
24main :: IO ()
23main :: IO ()
@@ -30,66 +29,67 @@ main = do
31 -- Start the server
30 -- Start the server
32 forkIO $ do
31 forkIO $ do
33− -- establish transport
32+ -- establish transport and endpoint
34 putStrLn "server: creating TCP connection"
33 putStrLn "server: creating TCP connection"
35− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8080"
34+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35+ Right endpoint <- newEndPoint transport
36+ putMVar serverAddr (address endpoint)
37− -- create ping end
38+ -- Connect to the client so that we can reply
38− (sourceAddrPing, targetEndPing) <- newConnection transport
39− putMVar serverAddr sourceAddrPing
42− sourceAddrPong <- takeMVar clientAddr
39+ theirAddr <- takeMVar clientAddr
43− sourceEndPong <- connect sourceAddrPong
40+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
45 -- reply to pings with pongs
42 -- reply to pings with pongs
46 putStrLn "server: awaiting client connection"
43 putStrLn "server: awaiting client connection"
47− pong targetEndPing sourceEndPong
44+ ConnectionOpened _ _ _ <- receive endpoint
49 -- Start the client
47 -- Start the client
50 forkIO $ do
48 forkIO $ do
51− sourceAddr <- takeMVar serverAddr
52 let pings = read pingsStr
49 let pings = read pingsStr
54− -- establish transport
51+ -- establish transport and endpoint
55− transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
52+ Right transport <- createTransport "127.0.0.1" "8081" defaultTCPParameters
53+ Right endpoint <- newEndPoint transport
54+ putMVar clientAddr (address endpoint)
57− -- Create ping end
56+ -- Connect to the server to send pings
58− sourceEndPing <- connect sourceAddr
57+ theirAddr <- takeMVar serverAddr
58+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
60− -- Create pong end
60+ -- Send pings, waiting for a reply after every ping
61− (sourceAddrPong, targetEndPong) <- newConnection transport
61+ ConnectionOpened _ _ _ <- receive endpoint
62− putMVar clientAddr sourceAddrPong
62+ ping endpoint conn pings
64− ping sourceEndPing targetEndPong pings
65 putMVar clientDone ()
63 putMVar clientDone ()
67 -- Wait for the client to finish
65 -- Wait for the client to finish
68 takeMVar clientDone
66 takeMVar clientDone
70−pingMessage :: ByteString
68+pingMessage :: [ByteString]
71−pingMessage = pack "ping123"
69+pingMessage = [pack "ping123"]
73−ping :: SourceEnd -> TargetEnd -> Int -> IO ()
71+ping :: EndPoint -> Connection -> Int -> IO ()
74−ping sourceEndPing targetEndPong pings = go pings
72+ping endpoint conn pings = go pings
76 go :: Int -> IO ()
74 go :: Int -> IO ()
77 go 0 = do
75 go 0 = do
78 putStrLn $ "client did " ++ show pings ++ " pings"
76 putStrLn $ "client did " ++ show pings ++ " pings"
79 go !i = do
77 go !i = do
80 before <- getCurrentTime
78 before <- getCurrentTime
81− send sourceEndPing [pingMessage]
79+ send conn pingMessage
82− [bs] <- receive targetEndPong
80+ Received _ _payload <- receive endpoint
83 after <- getCurrentTime
81 after <- getCurrentTime
84− -- putStrLn $ "client received " ++ unpack bs
82+ -- putStrLn $ "client received " ++ show _payload
85 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
83 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
86 hPutStrLn stderr $ show i ++ " " ++ show latency
84 hPutStrLn stderr $ show i ++ " " ++ show latency
87 go (i - 1)
85 go (i - 1)
89−pong :: TargetEnd -> SourceEnd -> IO ()
87+pong :: EndPoint -> Connection -> IO ()
90−pong targetEndPing sourceEndPong = do
88+pong endpoint conn = go
91− [bs] <- receive targetEndPing
89+ where
92− -- putStrLn $ "server received " ++ unpack bs
90+ go = do
93− when (BS.length bs > 0) $ do
91+ msg <- receive endpoint
94− send sourceEndPong [bs]
92+ case msg of
95− pong targetEndPing sourceEndPong
93+ Received _ payload -> send conn payload >> go
94+ ConnectionClosed _ -> return ()
95+ _ -> fail "Unexpected message"