git.iko.soy/distributed-process
on master help sign in
Expose a TODO in the TCP transport
7b1d69bEdsko de Vries
network-transport-2/network-transport.cabal+4−2
compare with master
unifiedsplit
@@ -44,7 +44,8 @@ Test-Suite TestMulticastInMemory
44 containers,
44 containers,
45 bytestring,
45 bytestring,
46 data-lens,
46 data-lens,
47− mtl
47+ mtl,
48+ transformers
48 extensions: EmptyDataDecls, OverloadedStrings
49 extensions: EmptyDataDecls, OverloadedStrings
49 ghc-options: -Wall -fno-warn-unused-do-bind
50 ghc-options: -Wall -fno-warn-unused-do-bind
50 HS-Source-Dirs: tests src
51 HS-Source-Dirs: tests src
@@ -56,7 +57,8 @@ Test-Suite TestInMemory
56 containers,
57 containers,
57 bytestring,
58 bytestring,
58 data-lens,
59 data-lens,
59− mtl
60+ mtl,
61+ transformers
60 extensions: EmptyDataDecls, OverloadedStrings
62 extensions: EmptyDataDecls, OverloadedStrings
61 ghc-options: -Wall -fno-warn-unused-do-bind
63 ghc-options: -Wall -fno-warn-unused-do-bind
62 HS-Source-Dirs: tests src
64 HS-Source-Dirs: tests src
network-transport-2/src/Network/Transport/TCP.hs−4
@@ -1,8 +1,4 @@
1-- | TCP transport
1-- | TCP transport
2−--
3−-- TODOs:
4−-- * Various errors are still left as "undefined"
5−-- * Many possible errors are not yet dealt with
6
2
7module Network.Transport.TCP ( -- * Main API
3module Network.Transport.TCP ( -- * Main API
8 createTransport
4 createTransport
network-transport-2/tests/TestTCP.hs+12−14
@@ -1,10 +1,10 @@
1module Main where
1module Main where
2
2
3+import TestTransport
3import Network.Transport
4import Network.Transport
4import Network.Transport.Internal (encodeInt32, prependLength)
5import Network.Transport.Internal (encodeInt32, prependLength)
5import Network.Transport.Internal.TCP (recvInt32, sendMany)
6import Network.Transport.Internal.TCP (recvInt32, sendMany)
6import Network.Transport.TCP (createTransport, decodeEndPointAddress, EndPointId, ControlHeader(..))
7import Network.Transport.TCP (createTransport, decodeEndPointAddress, EndPointId, ControlHeader(..))
7−import TestTransport (testTransport)
8import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
8import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
9import Control.Concurrent (forkIO)
9import Control.Concurrent (forkIO)
10import Control.Monad.Trans.Maybe (runMaybeT)
10import Control.Monad.Trans.Maybe (runMaybeT)
@@ -70,8 +70,8 @@ testEarlyDisconnect = do
70
70
71testInvalidAddress :: IO ()
71testInvalidAddress :: IO ()
72testInvalidAddress = do
72testInvalidAddress = do
73− Left err <- createTransport "invalidHostName" "8082"
73+ Left _ <- createTransport "invalidHostName" "8082"
74− putStrLn $ "Got expected error: " ++ show err
74+ return ()
75
75
76testInvalidConnect :: IO ()
76testInvalidConnect :: IO ()
77testInvalidConnect = do
77testInvalidConnect = do
@@ -79,29 +79,27 @@ testInvalidConnect = do
79 Right endpoint <- newEndPoint transport
79 Right endpoint <- newEndPoint transport
80
80
81 -- Syntax error in the endpoint address
81 -- Syntax error in the endpoint address
82− Left (FailedWith ConnectInvalidAddress err1) <-
82+ Left (FailedWith ConnectInvalidAddress _) <-
83 connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered
83 connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered
84− putStrLn $ "Got expected error: " ++ show err1
85
84
86 -- Syntax connect, but invalid hostname (TCP address lookup failure)
85 -- Syntax connect, but invalid hostname (TCP address lookup failure)
87− Left (FailedWith ConnectInvalidAddress err2) <-
86+ Left (FailedWith ConnectInvalidAddress _) <-
88 connect endpoint (EndPointAddress "invalidHost:port:0") ReliableOrdered
87 connect endpoint (EndPointAddress "invalidHost:port:0") ReliableOrdered
89− putStrLn $ "Got expected error: " ++ show err2
90
88
91 -- TCP address correct, but nobody home at that address
89 -- TCP address correct, but nobody home at that address
92− Left (FailedWith ConnectFailed err3) <-
90+ Left (FailedWith ConnectFailed _) <-
93 connect endpoint (EndPointAddress "127.0.0.1:9000:0") ReliableOrdered
91 connect endpoint (EndPointAddress "127.0.0.1:9000:0") ReliableOrdered
94− putStrLn $ "Got expected error: " ++ show err3
95
92
96 -- Valid TCP address but invalid endpoint number
93 -- Valid TCP address but invalid endpoint number
97− Left (FailedWith ConnectInvalidAddress err4) <-
94+ Left (FailedWith ConnectInvalidAddress _) <-
98 connect endpoint (EndPointAddress "127.0.0.1:8083:1") ReliableOrdered
95 connect endpoint (EndPointAddress "127.0.0.1:8083:1") ReliableOrdered
99− putStrLn $ "Got expected error: " ++ show err4
96+
97+ return ()
100
98
101main :: IO ()
99main :: IO ()
102main = do
100main = do
103− testEarlyDisconnect
101+ runTestIO "EarlyDisconnect" testEarlyDisconnect
104− testInvalidAddress
102+ runTestIO "InvalidAddress" testInvalidAddress
105− testInvalidConnect
103+ runTestIO "InvalidConnect" testInvalidConnect
106 Right transport <- createTransport "127.0.0.1" "8080"
104 Right transport <- createTransport "127.0.0.1" "8080"
107 testTransport transport
105 testTransport transport
network-transport-2/tests/TestTransport.hs+65−13
@@ -9,6 +9,10 @@ import Data.ByteString (ByteString)
9import Data.ByteString.Char8 ()
9import Data.ByteString.Char8 ()
10import Data.Map (Map)
10import Data.Map (Map)
11import qualified Data.Map as Map (empty, insert, (!), delete)
11import qualified Data.Map as Map (empty, insert, (!), delete)
12+import Control.Monad.Reader (ReaderT, runReaderT, ask)
13+import Control.Monad.IO.Class (liftIO)
14+import System.IO (hFlush, stdout)
15+import System.Timeout (timeout)
12
16
13-- Logging (for debugging)
17-- Logging (for debugging)
14tlog :: String -> IO ()
18tlog :: String -> IO ()
@@ -80,7 +84,6 @@ testPingPong transport numPings = do
80 tlog "Ping client"
84 tlog "Ping client"
81 Right endpoint <- newEndPoint transport
85 Right endpoint <- newEndPoint transport
82 ping endpoint server numPings "ping"
86 ping endpoint server numPings "ping"
83− putStrLn $ "client did " ++ show numPings ++ " pings"
84 putMVar result ()
87 putMVar result ()
85
88
86 takeMVar result
89 takeMVar result
@@ -95,14 +98,12 @@ testEndPoints transport numPings = do
95 forkIO $ do
98 forkIO $ do
96 Right endpoint <- newEndPoint transport
99 Right endpoint <- newEndPoint transport
97 ping endpoint server numPings "pingA"
100 ping endpoint server numPings "pingA"
98− putStrLn $ "client A did " ++ show numPings ++ " pings"
99 putMVar resultA ()
101 putMVar resultA ()
100
102
101 -- Client B
103 -- Client B
102 forkIO $ do
104 forkIO $ do
103 Right endpoint <- newEndPoint transport
105 Right endpoint <- newEndPoint transport
104 ping endpoint server numPings "pingB"
106 ping endpoint server numPings "pingB"
105− putStrLn $ "client B did " ++ show numPings ++ " pings"
106 putMVar resultB ()
107 putMVar resultB ()
107
108
108 mapM_ takeMVar [resultA, resultB]
109 mapM_ takeMVar [resultA, resultB]
@@ -125,14 +126,10 @@ testConnections transport numPings = do
125 ConnectionOpened serv2 _ _ <- receive endpoint
126 ConnectionOpened serv2 _ _ <- receive endpoint
126
127
127 -- One thread to send "pingA" on the first connection
128 -- One thread to send "pingA" on the first connection
128− forkIO $ do
129− replicateM_ numPings $ send conn1 ["pingA"]
129+ forkIO $ replicateM_ numPings $ send conn1 ["pingA"]
130− putStrLn $ "client A did " ++ show numPings ++ " pings"
131
130
132 -- One thread to send "pingB" on the second connection
131 -- One thread to send "pingB" on the second connection
133− forkIO $ do
134− replicateM_ numPings $ send conn2 ["pingB"]
132+ forkIO $ replicateM_ numPings $ send conn2 ["pingB"]
135− putStrLn $ "client B did " ++ show numPings ++ " pings"
136
133
137 -- Verify server responses
134 -- Verify server responses
138 let verifyResponse 0 = putMVar result ()
135 let verifyResponse 0 = putMVar result ()
@@ -149,9 +146,64 @@ testConnections transport numPings = do
149
146
150 takeMVar result
147 takeMVar result
151
148
149+-- Test that closing one connection does not close the other
150+testCloseOneConnection :: Transport -> Int -> IO ()
151+testCloseOneConnection transport numPings = do
152+ server <- spawn transport echoServer
153+ result <- newEmptyMVar
154+
155+ -- Client
156+ forkIO $ do
157+ Right endpoint <- newEndPoint transport
158+
159+ -- Open two connections to the server
160+ Right conn1 <- connect endpoint server ReliableOrdered
161+ ConnectionOpened serv1 _ _ <- receive endpoint
162+
163+ Right conn2 <- connect endpoint server ReliableOrdered
164+ ConnectionOpened serv2 _ _ <- receive endpoint
165+
166+ -- One thread to send "pingA" on the first connection
167+ forkIO $ replicateM_ numPings $ send conn1 ["pingA"] >> close conn1
168+
169+ -- One thread to send "pingB" on the second connection
170+ forkIO $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
171+
172+ -- Verify server responses
173+ let verifyResponse 0 = putMVar result ()
174+ verifyResponse n = do
175+ event <- receive endpoint
176+ case event of
177+ Received cid [payload] -> do
178+ when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
179+ when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
180+ verifyResponse (n - 1)
181+ _ ->
182+ verifyResponse n
183+ verifyResponse (3 * numPings)
184+
185+ takeMVar result
186+
187+runTestIO :: String -> IO () -> IO ()
188+runTestIO description test = do
189+ putStr $ "Running " ++ show description ++ ": "
190+ hFlush stdout
191+ test
192+ putStrLn "ok"
193+
194+runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT Transport IO ()
195+runTest description test = do
196+ transport <- ask
197+ done <- liftIO $ timeout 1000000 $ runTestIO description (test transport 1000)
198+ case done of
199+ Just () -> return ()
200+ Nothing -> error "timeout"
201+
202+
152-- Transport tests
203-- Transport tests
153testTransport :: Transport -> IO ()
204testTransport :: Transport -> IO ()
154−testTransport transport = do
205+testTransport = runReaderT $ do
155− testPingPong transport 10000
206+ runTest "PingPong" testPingPong
156− testEndPoints transport 10000
207+ runTest "EndPoints" testEndPoints
157− testConnections transport 10000
208+ runTest "Connections" testConnections
209+ runTest "CloseOneConnection" testCloseOneConnection