git.iko.soy/distributed-process
on master help sign in
Test blocking behaviour
b0cad33Edsko de Vries
network-transport-2/network-transport.cabal+6−3
compare with master
unifiedsplit
@@ -34,7 +34,8 @@ Test-Suite TestTCP
34 network,
34 network,
35 regex-applicative,
35 regex-applicative,
36 mtl,
36 mtl,
37− transformers
37+ transformers,
38+ ansi-terminal
38 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
39 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
39 ghc-options: -Wall -fno-warn-unused-do-bind
40 ghc-options: -Wall -fno-warn-unused-do-bind
40 HS-Source-Dirs: tests src
41 HS-Source-Dirs: tests src
@@ -47,7 +48,8 @@ Test-Suite TestMulticastInMemory
47 bytestring,
48 bytestring,
48 data-lens,
49 data-lens,
49 mtl,
50 mtl,
50− transformers
51+ transformers,
52+ ansi-terminal
51 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
53 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
52 ghc-options: -Wall -fno-warn-unused-do-bind
54 ghc-options: -Wall -fno-warn-unused-do-bind
53 HS-Source-Dirs: tests src
55 HS-Source-Dirs: tests src
@@ -60,7 +62,8 @@ Test-Suite TestInMemory
60 bytestring,
62 bytestring,
61 data-lens,
63 data-lens,
62 mtl,
64 mtl,
63− transformers
65+ transformers,
66+ ansi-terminal
64 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
67 extensions: EmptyDataDecls, OverloadedStrings, ForeignFunctionInterface, FlexibleContexts, BangPatterns
65 ghc-options: -Wall -fno-warn-unused-do-bind
68 ghc-options: -Wall -fno-warn-unused-do-bind
66 HS-Source-Dirs: tests src
69 HS-Source-Dirs: tests src
network-transport-2/src/Network/Transport/TCP.hs+1
@@ -13,6 +13,7 @@ module Network.Transport.TCP ( -- * Main API
13 , decodeEndPointAddress
13 , decodeEndPointAddress
14 , ControlHeader(..)
14 , ControlHeader(..)
15 , ConnectionRequestResponse(..)
15 , ConnectionRequestResponse(..)
16+ , firstNonReservedConnectionId
16 -- * Design notes
17 -- * Design notes
17 -- $design
18 -- $design
18 ) where
19 ) where
network-transport-2/tests/TestAuxiliary.hsnew file+43
@@ -0,0 +1,43 @@
1+module TestAuxiliary (runTest, forkTry) where
2+
3+import Prelude hiding (catch)
4+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo)
5+import Control.Exception (SomeException, try, catch)
6+import System.Timeout (timeout)
7+import System.IO (stdout, hFlush)
8+import System.Console.ANSI ( SGR(SetColor, Reset)
9+ , Color(Red, Green)
10+ , ConsoleLayer(Foreground)
11+ , ColorIntensity(Vivid)
12+ , setSGR
13+ )
14+
15+-- | Like fork, but throw exceptions in the child thread to the parent
16+forkTry :: IO () -> IO ThreadId
17+forkTry p = do
18+ tid <- myThreadId
19+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
20+
21+-- | Run the given test, catching timeouts and exceptions
22+runTest :: String -> IO () -> IO ()
23+runTest description test = do
24+ putStr $ "Running " ++ show description ++ ": "
25+ hFlush stdout
26+ done <- try . timeout 10000000 $ test
27+ case done of
28+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
29+ Right Nothing -> failed $ "(timeout)"
30+ Right (Just ()) -> ok
31+ where
32+ failed :: String -> IO ()
33+ failed err = do
34+ setSGR [SetColor Foreground Vivid Red]
35+ putStr "failed "
36+ setSGR [Reset]
37+ putStrLn err
38+
39+ ok :: IO ()
40+ ok = do
41+ setSGR [SetColor Foreground Vivid Green]
42+ putStrLn "ok"
43+ setSGR [Reset]
network-transport-2/tests/TestTCP.hs+132−37
@@ -1,14 +1,20 @@
1module Main where
1module Main where
2
2
3+import Prelude hiding (catch)
3import TestTransport
4import TestTransport
5+import TestAuxiliary (forkTry, runTest)
4import Network.Transport
6import Network.Transport
5import Network.Transport.TCP (createTransport)
7import Network.Transport.TCP (createTransport)
6import Data.Int (Int32)
8import Data.Int (Int32)
7import Data.Maybe (fromJust)
9import Data.Maybe (fromJust)
8−import Control.Concurrent (forkIO)
10+import Control.Concurrent (threadDelay)
9−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
11+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar, isEmptyMVar)
10−import Control.Monad (replicateM)
12+import Control.Monad (replicateM, guard)
11−import Network.Transport.TCP (decodeEndPointAddress, EndPointId, ControlHeader(..), ConnectionRequestResponse(..))
13+import Network.Transport.TCP ( decodeEndPointAddress
14+ , EndPointId
15+ , ControlHeader(..)
16+ , ConnectionRequestResponse(..)
17+ )
12import Network.Transport.Internal (encodeInt32, prependLength, tlog)
18import Network.Transport.Internal (encodeInt32, prependLength, tlog)
13import Network.Transport.Internal.TCP (recvInt32)
19import Network.Transport.Internal.TCP (recvInt32)
14import qualified Network.Socket as N ( getAddrInfo
20import qualified Network.Socket as N ( getAddrInfo
@@ -34,8 +40,8 @@ testEarlyDisconnect = do
34 serverDone <- newEmptyMVar
40 serverDone <- newEmptyMVar
35 Right transport <- createTransport "127.0.0.1" "8081"
41 Right transport <- createTransport "127.0.0.1" "8081"
36
42
37− forkIO $ server transport serverAddr serverDone
43+ forkTry $ server transport serverAddr serverDone
38− forkIO $ client transport serverAddr
44+ forkTry $ client transport serverAddr
39
45
40 takeMVar serverDone
46 takeMVar serverDone
41 where
47 where
@@ -72,6 +78,36 @@ testEarlyDisconnect = do
72 -- The server should still receive a ConnectionClosed message
78 -- The server should still receive a ConnectionClosed message
73 N.sClose sock
79 N.sClose sock
74
80
81+-- | Test the creation of a transport with an invalid address
82+testInvalidAddress :: IO ()
83+testInvalidAddress = do
84+ Left _ <- createTransport "invalidHostName" "8082"
85+ return ()
86+
87+-- | Test connecting to invalid or non-existing endpoints
88+testInvalidConnect :: IO ()
89+testInvalidConnect = do
90+ Right transport <- createTransport "127.0.0.1" "8083"
91+ Right endpoint <- newEndPoint transport
92+
93+ -- Syntax error in the endpoint address
94+ Left (FailedWith ConnectInvalidAddress _) <-
95+ connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered
96+
97+ -- Syntax connect, but invalid hostname (TCP address lookup failure)
98+ Left (FailedWith ConnectInvalidAddress _) <-
99+ connect endpoint (EndPointAddress "invalidHost:port:0") ReliableOrdered
100+
101+ -- TCP address correct, but nobody home at that address
102+ Left (FailedWith ConnectFailed _) <-
103+ connect endpoint (EndPointAddress "127.0.0.1:9000:0") ReliableOrdered
104+
105+ -- Valid TCP address but invalid endpoint number
106+ Left (FailedWith ConnectInvalidAddress _) <-
107+ connect endpoint (EndPointAddress "127.0.0.1:8083:1") ReliableOrdered
108+
109+ return ()
110+
75-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
111-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
76-- would happen when the endpoint sends a new connection request before
112-- would happen when the endpoint sends a new connection request before
77-- receiving an (already underway) CloseSocket request)
113-- receiving an (already underway) CloseSocket request)
@@ -81,8 +117,8 @@ testIgnoreCloseSocket = do
81 clientDone <- newEmptyMVar
117 clientDone <- newEmptyMVar
82 Right transport <- createTransport "127.0.0.1" "8084"
118 Right transport <- createTransport "127.0.0.1" "8084"
83
119
84− forkIO $ server transport serverAddr
120+ forkTry $ server transport serverAddr
85− forkIO $ client transport serverAddr clientDone
121+ forkTry $ client transport serverAddr clientDone
86
122
87 takeMVar clientDone
123 takeMVar clientDone
88
124
@@ -163,41 +199,100 @@ testIgnoreCloseSocket = do
163
199
164 putMVar clientDone ()
200 putMVar clientDone ()
165
201
166−-- | Test the creation of a transport with an invalid address
202+-- | Like 'testIgnoreSocket', but now the server requests a connection after the
167−testInvalidAddress :: IO ()
203+-- client closed their connection. In the meantime, the server will have sent a
168−testInvalidAddress = do
204+-- CloseSocket request to the client, and must block until the client responds.
169− Left _ <- createTransport "invalidHostName" "8082"
205+testBlockAfterCloseSocket :: IO ()
170− return ()
206+testBlockAfterCloseSocket = do
207+ serverAddr <- newEmptyMVar
208+ clientAddr <- newEmptyMVar
209+ clientDone <- newEmptyMVar
210+ Right transport <- createTransport "127.0.0.1" "8085"
211+
212+ forkTry $ server transport serverAddr clientAddr
213+ forkTry $ client transport serverAddr clientAddr clientDone
214+
215+ takeMVar clientDone
171
216
172−-- | Test connecting to invalid or non-existing endpoints
217+ where
173−testInvalidConnect :: IO ()
218+ server :: Transport -> MVar (N.HostName, N.ServiceName, EndPointId) -> MVar EndPointAddress -> IO ()
174−testInvalidConnect = do
219+ server transport serverAddr clientAddr = do
175− Right transport <- createTransport "127.0.0.1" "8083"
220+ tlog "Server"
176− Right endpoint <- newEndPoint transport
221+ Right endpoint <- newEndPoint transport
222+ putMVar serverAddr (fromJust . decodeEndPointAddress . address $ endpoint)
177
223
178− -- Syntax error in the endpoint address
224+ -- Wait for the client to connect and disconnect
179− Left (FailedWith ConnectInvalidAddress _) <-
225+ tlog "Waiting for ConnectionOpened"
180− connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered
226+ ConnectionOpened _ _ _ <- receive endpoint
181−
227+ tlog "Waiting for ConnectionClosed"
182− -- Syntax connect, but invalid hostname (TCP address lookup failure)
228+ ConnectionClosed _ <- receive endpoint
183− Left (FailedWith ConnectInvalidAddress _) <-
184− connect endpoint (EndPointAddress "invalidHost:port:0") ReliableOrdered
185−
186− -- TCP address correct, but nobody home at that address
187− Left (FailedWith ConnectFailed _) <-
188− connect endpoint (EndPointAddress "127.0.0.1:9000:0") ReliableOrdered
189
229
190− -- Valid TCP address but invalid endpoint number
230+ -- At this point the server will have sent a CloseSocket request to the
191− Left (FailedWith ConnectInvalidAddress _) <-
231+ -- client, and must block until the client responds
232+ tlog "Server waiting to connect to the client.."
192− connect endpoint (EndPointAddress "127.0.0.1:8083:1") ReliableOrdered
233+ Right conn <- readMVar clientAddr >>= \addr -> connect endpoint addr ReliableOrdered
234+
235+
236+ tlog "Server waiting.."
193
237
194− return ()
238+ client :: Transport -> MVar (N.HostName, N.ServiceName, EndPointId) -> MVar EndPointAddress -> MVar () -> IO ()
239+ client transport serverAddr clientAddr clientDone = do
240+ tlog "Client"
241+ Right endpoint <- newEndPoint transport
242+ putMVar clientAddr (address endpoint)
243+ let EndPointAddress myAddress = address endpoint
244+
245+ -- Connect to the server
246+ addr:_ <- N.getAddrInfo Nothing (Just "127.0.0.1") (Just "8084")
247+ sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
248+ N.setSocketOption sock N.ReuseAddr 1
249+ N.connect sock (N.addrAddress addr)
250+
251+ tlog "Connecting to endpoint"
252+ (_, _, endPointIx) <- readMVar serverAddr
253+ sendMany sock (encodeInt32 endPointIx : prependLength [myAddress])
254+
255+ -- Wait for acknowledgement
256+ ConnectionRequestAccepted <- recvInt32 sock
257+
258+ -- Request a new connection
259+ tlog "Requesting connection"
260+ let reqId = 0 :: Int32
261+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
262+ response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
263+
264+ -- Close the connection again
265+ tlog "Closing connection"
266+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
267+
268+ -- Server will now send a CloseSocket request as its refcount reached 0
269+ tlog "Waiting for CloseSocket request"
270+ CloseSocket <- recvInt32 sock
271+
272+ unblocked <- newEmptyMVar
273+
274+ -- We should not hear from the server until we unblock him by
275+ -- responding to the CloseSocket request (in this case, we
276+ -- respond by sending a ConnectionRequest)
277+ forkTry $ do
278+ recvInt32 sock :: IO Int32
279+ isEmptyMVar unblocked >>= guard . not
280+ putMVar clientDone ()
281+
282+ threadDelay 1000000
283+
284+ tlog "Client ignores close socket and sends connection request"
285+ tlog "This should unblock the server"
286+ putMVar unblocked ()
287+ let reqId' = 1 :: Int32
288+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
195
289
196main :: IO ()
290main :: IO ()
197main = do
291main = do
198− runTestIO "EarlyDisconnect" testEarlyDisconnect
292+ runTest "EarlyDisconnect" testEarlyDisconnect
199− runTestIO "InvalidAddress" testInvalidAddress
293+ runTest "InvalidAddress" testInvalidAddress
200− runTestIO "InvalidConnect" testInvalidConnect
294+ runTest "InvalidConnect" testInvalidConnect
201− runTestIO "IgnoreCloseSocket" testIgnoreCloseSocket
295+ runTest "IgnoreCloseSocket" testIgnoreCloseSocket
296+ runTest "BlockAfterCloseSocket" testBlockAfterCloseSocket
202 Right transport <- createTransport "127.0.0.1" "8080"
297 Right transport <- createTransport "127.0.0.1" "8080"
203 testTransport transport
298 testTransport transport
network-transport-2/tests/TestTransport.hs+29−43
@@ -1,7 +1,7 @@
1module TestTransport where
1module TestTransport where
2
2
3import Prelude hiding (catch)
3import Prelude hiding (catch)
4−import Control.Concurrent (forkIO)
4+import TestAuxiliary (forkTry, runTest)
5import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
5import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
6import Control.Monad (replicateM, replicateM_, when, guard, forM_)
6import Control.Monad (replicateM, replicateM_, when, guard, forM_)
7import Control.Monad.Reader (ReaderT, runReaderT, ask)
7import Control.Monad.Reader (ReaderT, runReaderT, ask)
@@ -15,8 +15,6 @@ import Data.ByteString (ByteString)
15import Data.ByteString.Char8 (pack)
15import Data.ByteString.Char8 (pack)
16import Data.Map (Map)
16import Data.Map (Map)
17import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
17import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
18−import System.IO (hFlush, stdout)
19−import System.Timeout (timeout)
20
18
21-- Server that echoes messages straight back to the origin endpoint.
19-- Server that echoes messages straight back to the origin endpoint.
22echoServer :: EndPoint -> IO ()
20echoServer :: EndPoint -> IO ()
@@ -90,7 +88,7 @@ testPingPong transport numPings = do
90 result <- newEmptyMVar
88 result <- newEmptyMVar
91
89
92 -- Client
90 -- Client
93− forkIO $ do
91+ forkTry $ do
94 tlog "Ping client"
92 tlog "Ping client"
95 Right endpoint <- newEndPoint transport
93 Right endpoint <- newEndPoint transport
96 ping endpoint server numPings "ping"
94 ping endpoint server numPings "ping"
@@ -104,7 +102,7 @@ testEndPoints transport numPings = do
104 server <- spawn transport echoServer
102 server <- spawn transport echoServer
105 dones <- replicateM 2 newEmptyMVar
103 dones <- replicateM 2 newEmptyMVar
106
104
107− forM_ (zip dones ['A'..]) $ \(done, name) -> forkIO $ do
105+ forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
108 let name' :: ByteString
106 let name' :: ByteString
109 name' = pack [name]
107 name' = pack [name]
110 Right endpoint <- newEndPoint transport
108 Right endpoint <- newEndPoint transport
@@ -121,7 +119,7 @@ testConnections transport numPings = do
121 result <- newEmptyMVar
119 result <- newEmptyMVar
122
120
123 -- Client
121 -- Client
124− forkIO $ do
122+ forkTry $ do
125 Right endpoint <- newEndPoint transport
123 Right endpoint <- newEndPoint transport
126
124
127 -- Open two connections to the server
125 -- Open two connections to the server
@@ -132,10 +130,10 @@ testConnections transport numPings = do
132 ConnectionOpened serv2 _ _ <- receive endpoint
130 ConnectionOpened serv2 _ _ <- receive endpoint
133
131
134 -- One thread to send "pingA" on the first connection
132 -- One thread to send "pingA" on the first connection
135− forkIO $ replicateM_ numPings $ send conn1 ["pingA"]
133+ forkTry $ replicateM_ numPings $ send conn1 ["pingA"]
136
134
137 -- One thread to send "pingB" on the second connection
135 -- One thread to send "pingB" on the second connection
138− forkIO $ replicateM_ numPings $ send conn2 ["pingB"]
136+ forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
139
137
140 -- Verify server responses
138 -- Verify server responses
141 let verifyResponse 0 = putMVar result ()
139 let verifyResponse 0 = putMVar result ()
@@ -159,7 +157,7 @@ testCloseOneConnection transport numPings = do
159 result <- newEmptyMVar
157 result <- newEmptyMVar
160
158
161 -- Client
159 -- Client
162− forkIO $ do
160+ forkTry $ do
163 Right endpoint <- newEndPoint transport
161 Right endpoint <- newEndPoint transport
164
162
165 -- Open two connections to the server
163 -- Open two connections to the server
@@ -170,12 +168,12 @@ testCloseOneConnection transport numPings = do
170 ConnectionOpened serv2 _ _ <- receive endpoint
168 ConnectionOpened serv2 _ _ <- receive endpoint
171
169
172 -- One thread to send "pingA" on the first connection
170 -- One thread to send "pingA" on the first connection
173− forkIO $ do
171+ forkTry $ do
174 replicateM_ numPings $ send conn1 ["pingA"]
172 replicateM_ numPings $ send conn1 ["pingA"]
175 close conn1
173 close conn1
176
174
177 -- One thread to send "pingB" on the second connection
175 -- One thread to send "pingB" on the second connection
178− forkIO $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
176+ forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
179
177
180 -- Verify server responses
178 -- Verify server responses
181 let verifyResponse 0 = putMVar result ()
179 let verifyResponse 0 = putMVar result ()
@@ -203,7 +201,7 @@ testCloseOneDirection transport numPings = do
203 doneB <- newEmptyMVar
201 doneB <- newEmptyMVar
204
202
205 -- A
203 -- A
206− forkIO $ do
204+ forkTry $ do
207 tlog "A"
205 tlog "A"
208 Right endpoint <- newEndPoint transport
206 Right endpoint <- newEndPoint transport
209 tlog (show (address endpoint))
207 tlog (show (address endpoint))
@@ -239,7 +237,7 @@ testCloseOneDirection transport numPings = do
239 putMVar doneA ()
237 putMVar doneA ()
240
238
241 -- B
239 -- B
242− forkIO $ do
240+ forkTry $ do
243 tlog "B"
241 tlog "B"
244 Right endpoint <- newEndPoint transport
242 Right endpoint <- newEndPoint transport
245 tlog (show (address endpoint))
243 tlog (show (address endpoint))
@@ -318,7 +316,7 @@ testCloseReopen transport numPings = do
318 let numRepeats = 2 :: Int
316 let numRepeats = 2 :: Int
319
317
320 -- A
318 -- A
321− forkIO $ do
319+ forkTry $ do
322 Right endpoint <- newEndPoint transport
320 Right endpoint <- newEndPoint transport
323
321
324 forM_ [1 .. numRepeats] $ \i -> do
322 forM_ [1 .. numRepeats] $ \i -> do
@@ -337,7 +335,7 @@ testCloseReopen transport numPings = do
337 tlog "A finishing"
335 tlog "A finishing"
338
336
339 -- B
337 -- B
340− forkIO $ do
338+ forkTry $ do
341 Right endpoint <- newEndPoint transport
339 Right endpoint <- newEndPoint transport
342 putMVar addrB (address endpoint)
340 putMVar addrB (address endpoint)
343
341
@@ -360,13 +358,13 @@ testParallelConnects transport numPings = do
360 Right endpoint <- newEndPoint transport
358 Right endpoint <- newEndPoint transport
361
359
362 -- Spawn lots of clients
360 -- Spawn lots of clients
363− forM_ [1 .. numPings] $ \i -> forkIO $ do
361+ forM_ [1 .. numPings] $ \i -> forkTry $ do
364 Right conn <- connect endpoint server ReliableOrdered
362 Right conn <- connect endpoint server ReliableOrdered
365 send conn [pack $ "ping" ++ show i]
363 send conn [pack $ "ping" ++ show i]
366 send conn [pack $ "ping" ++ show i]
364 send conn [pack $ "ping" ++ show i]
367 close conn
365 close conn
368
366
369− forkIO $ do
367+ forkTry $ do
370 eventss <- collect endpoint (numPings * 4)
368 eventss <- collect endpoint (numPings * 4)
371 -- Check that no pings got sent to the wrong connection
369 -- Check that no pings got sent to the wrong connection
372 forM_ eventss $ \(_, [[ping1], [ping2]]) ->
370 forM_ eventss $ \(_, [[ping1], [ping2]]) ->
@@ -381,7 +379,7 @@ testSendAfterClose transport _ = do
381 server <- spawn transport echoServer
379 server <- spawn transport echoServer
382 clientDone <- newEmptyMVar
380 clientDone <- newEmptyMVar
383
381
384− forkIO $ do
382+ forkTry $ do
385 Right endpoint <- newEndPoint transport
383 Right endpoint <- newEndPoint transport
386
384
387 -- We request two lightweight connections
385 -- We request two lightweight connections
@@ -403,15 +401,13 @@ testSendAfterClose transport _ = do
403
401
404 takeMVar clientDone
402 takeMVar clientDone
405
403
406−
407−
408-- Test that closing the same connection twice has no effect
404-- Test that closing the same connection twice has no effect
409testCloseTwice :: Transport -> Int -> IO ()
405testCloseTwice :: Transport -> Int -> IO ()
410testCloseTwice transport _ = do
406testCloseTwice transport _ = do
411 server <- spawn transport echoServer
407 server <- spawn transport echoServer
412 clientDone <- newEmptyMVar
408 clientDone <- newEmptyMVar
413
409
414− forkIO $ do
410+ forkTry $ do
415 Right endpoint <- newEndPoint transport
411 Right endpoint <- newEndPoint transport
416
412
417 -- We request two lightweight connections
413 -- We request two lightweight connections
@@ -437,30 +433,20 @@ testCloseTwice transport _ = do
437
433
438 takeMVar clientDone
434 takeMVar clientDone
439
435
440−runTestIO :: String -> IO () -> IO ()
441−runTestIO description test = do
442− putStr $ "Running " ++ show description ++ ": "
443− hFlush stdout
444− test
445− putStrLn "ok"
446−
447−runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT (Transport, Int) IO ()
436+runTransportTest :: String -> (Transport -> Int -> IO ()) -> ReaderT (Transport, Int) IO ()
448−runTest description test = do
437+runTransportTest description test = do
449 (transport, numPings) <- ask
438 (transport, numPings) <- ask
450− done <- liftIO $ timeout 10000000 $ runTestIO description (test transport numPings)
439+ liftIO $ runTest description (test transport numPings)
451− case done of
452− Just () -> return ()
453− Nothing -> error "timeout"
454
440
455-- Transport tests
441-- Transport tests
456testTransport :: Transport -> IO ()
442testTransport :: Transport -> IO ()
457testTransport transport = flip runReaderT (transport, 10000) $ do
443testTransport transport = flip runReaderT (transport, 10000) $ do
458− runTest "PingPong" testPingPong
444+ runTransportTest "PingPong" testPingPong
459− runTest "EndPoints" testEndPoints
445+ runTransportTest "EndPoints" testEndPoints
460− runTest "Connections" testConnections
446+ runTransportTest "Connections" testConnections
461− runTest "CloseOneConnection" testCloseOneConnection
447+ runTransportTest "CloseOneConnection" testCloseOneConnection
462− runTest "CloseOneDirection" testCloseOneDirection
448+ runTransportTest "CloseOneDirection" testCloseOneDirection
463− runTest "CloseReopen" testCloseReopen
449+ runTransportTest "CloseReopen" testCloseReopen
464− runTest "ParallelConnects" testParallelConnects
450+ runTransportTest "ParallelConnects" testParallelConnects
465− runTest "SendAfterClose" testSendAfterClose
451+ runTransportTest "SendAfterClose" testSendAfterClose
466− runTest "CloseTwice" testCloseTwice
452+ runTransportTest "CloseTwice" testCloseTwice