@@ -9,6 +9,10 @@ import Data.ByteString (ByteString)
99import Data.ByteString.Char8 ()
1010import Data.Map (Map)
1111import 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)
1216
1317-- Logging (for debugging)
1418tlog :: String -> IO ()
@@ -80,7 +84,6 @@ testPingPong transport numPings = do
8084 tlog "Ping client"
8185 Right endpoint <- newEndPoint transport
8286 ping endpoint server numPings "ping"
83− putStrLn $ "client did " ++ show numPings ++ " pings"
8487 putMVar result ()
8588
8689 takeMVar result
@@ -95,14 +98,12 @@ testEndPoints transport numPings = do
9598 forkIO $ do
9699 Right endpoint <- newEndPoint transport
97100 ping endpoint server numPings "pingA"
98− putStrLn $ "client A did " ++ show numPings ++ " pings"
99101 putMVar resultA ()
100102
101103 -- Client B
102104 forkIO $ do
103105 Right endpoint <- newEndPoint transport
104106 ping endpoint server numPings "pingB"
105− putStrLn $ "client B did " ++ show numPings ++ " pings"
106107 putMVar resultB ()
107108
108109 mapM_ takeMVar [resultA, resultB]
@@ -125,14 +126,10 @@ testConnections transport numPings = do
125126 ConnectionOpened serv2 _ _ <- receive endpoint
126127
127128 -- One thread to send "pingA" on the first connection
128− forkIO $ do
129− replicateM_ numPings $ send conn1 ["pingA"]
130− putStrLn $ "client A did " ++ show numPings ++ " pings"
129+ forkIO $ replicateM_ numPings $ send conn1 ["pingA"]
131130
132131 -- One thread to send "pingB" on the second connection
133− forkIO $ do
134− replicateM_ numPings $ send conn2 ["pingB"]
135− putStrLn $ "client B did " ++ show numPings ++ " pings"
132+ forkIO $ replicateM_ numPings $ send conn2 ["pingB"]
136133
137134 -- Verify server responses
138135 let verifyResponse 0 = putMVar result ()
@@ -149,9 +146,64 @@ testConnections transport numPings = do
149146
150147 takeMVar result
151148
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+
152203-- Transport tests
153204testTransport :: Transport -> IO ()
154−testTransport transport = do
155− testPingPong transport 10000
156− testEndPoints transport 10000
157− testConnections transport 10000
205+testTransport = runReaderT $ do
206+ runTest "PingPong" testPingPong
207+ runTest "EndPoints" testEndPoints
208+ runTest "Connections" testConnections
209+ runTest "CloseOneConnection" testCloseOneConnection