git.iko.soy/distributed-process
on master help sign in
Fix testReconnect
commitc83ee69818c0a6d6051e2896f3fdcbcd53c8b15c authorEdsko de Vries <edsko@edsko.net> dateWed 30 May 2012, 17:02 (14 years ago) parent54ed63c
6 files changed+140−92
compare with master
unifiedsplit
network-transport/network-transport.cabal+4−4 network-transport/src/Network/Transport.hs+10−3 network-transport/src/Network/Transport/Internal.hs+13 network-transport/src/Network/Transport/TCP.hs+39−30 network-transport/tests/TestTCP.hs+12−8 network-transport/tests/TestTransport.hs+62−47
network-transport/network-transport.cabal+4−4
@@ -23,7 +23,7 @@ Library
2323 Network.Transport.Chan,
2424 Network.Transport.TCP,
2525 Network.Transport.Util
26− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes
26+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes
2727 ghc-options: -Wall -fno-warn-unused-do-bind
2828 HS-Source-Dirs: src
2929
@@ -39,7 +39,7 @@ Test-Suite TestTCP
3939 transformers,
4040 ansi-terminal,
4141 random
42− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
42+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
4343 ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
4444 HS-Source-Dirs: tests src
4545
@@ -54,7 +54,7 @@ Test-Suite TestMulticastInMemory
5454 transformers,
5555 ansi-terminal,
5656 random
57− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
57+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
5858 ghc-options: -Wall -fno-warn-unused-do-bind
5959 HS-Source-Dirs: tests src
6060
@@ -69,6 +69,6 @@ Test-Suite TestInMemory
6969 transformers,
7070 ansi-terminal,
7171 random
72− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
72+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances
7373 ghc-options: -Wall -fno-warn-unused-do-bind
7474 HS-Source-Dirs: tests src
network-transport/src/Network/Transport.hs+10−3
@@ -10,7 +10,7 @@ module Network.Transport ( -- * Types
1010 , EndPointAddress(..)
1111 , MulticastAddress(..)
1212 -- * Hints
13− , ConnectHints
13+ , ConnectHints(..)
1414 , defaultConnectHints
1515 -- * Error codes
1616 , TransportError(..)
@@ -129,11 +129,16 @@ instance Show MulticastAddress where
129129--------------------------------------------------------------------------------
130130
131131-- Hints used by 'connect'
132−data ConnectHints
132+data ConnectHints = ConnectHints {
133+ -- Timeout
134+ connectTimeout :: Maybe Int
135+ }
133136
134137-- Default hints for connecting
135138defaultConnectHints :: ConnectHints
136−defaultConnectHints = undefined
139+defaultConnectHints = ConnectHints {
140+ connectTimeout = Nothing
141+ }
137142
138143--------------------------------------------------------------------------------
139144-- Error codes --
@@ -172,6 +177,8 @@ data ConnectErrorCode =
172177 ConnectNotFound
173178 -- | Insufficient resources (for instance, no more sockets available)
174179 | ConnectInsufficientResources
180+ -- | Timeout
181+ | ConnectTimeout
175182 -- | Failed for other reasons (including syntax error)
176183 | ConnectFailed
177184 deriving (Show, Typeable, Eq)
network-transport/src/Network/Transport/Internal.hs+13
@@ -9,6 +9,7 @@ module Network.Transport.Internal ( -- * Encoders/decoders
99 , mapIOException
1010 , tryIO
1111 , tryToEnum
12+ , timeoutMaybe
1213 -- * Replicated functionality from "base"
1314 , void
1415 , forkIOWithUnmask
@@ -35,6 +36,7 @@ import Control.Exception ( IOException
3536 )
3637import Control.Concurrent (ThreadId, forkIO)
3738import GHC.IO (unsafeUnmask)
39+import System.Timeout (timeout)
3840--import Control.Concurrent (myThreadId)
3941
4042foreign import ccall unsafe "htonl" htonl :: CInt -> CInt
@@ -111,3 +113,14 @@ tryToEnum = go minBound maxBound
111113 where
112114 go :: Enum b => b -> b -> Int -> Maybe b
113115 go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing
116+
117+-- | If the timeout value is not Nothing, wrap the given computation with a
118+-- timeout and it if times out throw the specified exception. Identity
119+-- otherwise.
120+timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a
121+timeoutMaybe Nothing _ f = f
122+timeoutMaybe (Just n) e f = do
123+ ma <- timeout n f
124+ case ma of
125+ Nothing -> throwIO e
126+ Just a -> return a
network-transport/src/Network/Transport/TCP.hs+39−30
@@ -40,6 +40,7 @@ import Network.Transport.Internal ( encodeInt32
4040 , tryIO
4141 , tryToEnum
4242 , void
43+ , timeoutMaybe
4344 )
4445import qualified Network.Socket as N ( HostName
4546 , ServiceName
@@ -84,7 +85,6 @@ import Control.Exception ( IOException
8485 , mask_
8586 , onException
8687 , fromException
87− , catch
8888 )
8989import Data.IORef (IORef, newIORef, writeIORef, readIORef)
9090import Data.ByteString (ByteString)
@@ -473,12 +473,13 @@ apiConnect :: LocalEndPoint -- ^ Local end point
473473 -> Reliability -- ^ Reliability (ignored)
474474 -> ConnectHints -- ^ Hints (ignored for now)
475475 -> IO (Either (TransportError ConnectErrorCode) Connection)
476−apiConnect ourEndPoint theirAddress _reliability _hints =
476+apiConnect ourEndPoint theirAddress _reliability hints = do
477477 if localAddress ourEndPoint == theirAddress
478478 then connectToSelf ourEndPoint
479479 else try $ do
480− resetIfInvalid ourEndPoint theirAddress
481− (theirEndPoint, connId) <- requestConnectionTo ourEndPoint theirAddress
480+ resetRemoteEndPoint ourEndPoint theirAddress
481+ (theirEndPoint, connId) <-
482+ requestConnectionTo ourEndPoint theirAddress hints
482483 -- connAlive can be an IORef rather than an MVar because it is protected
483484 -- by the remoteState MVar. We don't need the overhead of locking twice.
484485 connAlive <- newIORef True
@@ -669,13 +670,13 @@ internalSocketBetween transport ourAddress theirAddress = do
669670-- | Reset a remote endpoint if it is in Invalid mode
670671--
671672-- If a user calls the API function 'connect' and the remote endpoint is
672−-- currently in Invalid state, we remove the remote endpoint first because a
673+-- currently in broken state, we remove the remote endpoint first because a
673674-- new attempt to connect might succeed even if the previous one failed.
674675--
675676-- Throws a TransportError ConnectFailed exception if the local endpoint is
676677-- closed.
677−resetIfInvalid :: LocalEndPoint -> EndPointAddress -> IO ()
678−resetIfInvalid ourEndPoint theirAddress = do
678+resetRemoteEndPoint :: LocalEndPoint -> EndPointAddress -> IO ()
679+resetRemoteEndPoint ourEndPoint theirAddress = do
679680 mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
680681 LocalEndPointValid vst ->
681682 return (vst ^. localConnectionTo theirAddress)
@@ -685,6 +686,8 @@ resetIfInvalid ourEndPoint theirAddress = do
685686 withMVar (remoteState theirEndPoint) $ \st -> case st of
686687 RemoteEndPointInvalid _ ->
687688 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
689+ RemoteEndPointClosed (Just _) ->
690+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
688691 _ ->
689692 return ()
690693
@@ -729,8 +732,9 @@ createLocalEndPoint transport = do
729732-- May throw a TransportError ConnectErrorCode exception.
730733requestConnectionTo :: LocalEndPoint
731734 -> EndPointAddress
735+ -> ConnectHints
732736 -> IO (RemoteEndPoint, ConnectionId)
733−requestConnectionTo ourEndPoint theirAddress = go
737+requestConnectionTo ourEndPoint theirAddress hints = go
734738 where
735739 go = do
736740 (theirEndPoint, isNew) <- mapIOException connectFailed $
@@ -738,9 +742,8 @@ requestConnectionTo ourEndPoint theirAddress = go
738742
739743 if isNew
740744 then do
741− void . forkEndPointThread ourEndPoint $
742− catch (setupRemoteEndPoint (ourEndPoint, theirEndPoint))
743− (\err -> let _ = err :: SomeException in return ())
745+ void . forkEndPointThread ourEndPoint . handle absorbAllExceptions $
746+ setupRemoteEndPoint (ourEndPoint, theirEndPoint) hints
744747 go
745748 else do
746749 reply <- mapIOException connectFailed $
@@ -749,10 +752,14 @@ requestConnectionTo ourEndPoint theirAddress = go
749752
750753 connectFailed = TransportError ConnectFailed . show
751754
755+ absorbAllExceptions :: SomeException -> IO ()
756+ absorbAllExceptions _ex =
757+ return ()
758+
752759-- | Set up a remote endpoint
753−setupRemoteEndPoint :: EndPointPair -> IO ()
754−setupRemoteEndPoint (ourEndPoint, theirEndPoint) = do
755− didAccept <- bracketOnError (socketToEndPoint ourAddress theirAddress)
760+setupRemoteEndPoint :: EndPointPair -> ConnectHints -> IO ()
761+setupRemoteEndPoint (ourEndPoint, theirEndPoint) hints = do
762+ didAccept <- bracketOnError (socketToEndPoint ourAddress theirAddress hints)
756763 onError $ \result ->
757764 case result of
758765 Right (sock, ConnectionRequestAccepted) -> do
@@ -767,7 +774,7 @@ setupRemoteEndPoint (ourEndPoint, theirEndPoint) = do
767774 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
768775 return True
769776 Right (sock, ConnectionRequestInvalid) -> do
770− let err = invalidAddress "Invalid endpoint"
777+ let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"
771778 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
772779 tryCloseSocket sock
773780 return False
@@ -820,22 +827,25 @@ resolveInit (ourEndPoint, theirEndPoint) newState =
820827 RemoteEndPointInit resolved _ -> do
821828 putMVar resolved ()
822829 case newState of
823− RemoteEndPointClosed _ ->
830+ RemoteEndPointClosed Nothing ->
824831 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
825832 _ ->
826833 return ()
827834 return newState
828− RemoteEndPointClosed (Just ex) ->
835+ RemoteEndPointClosed (Just ex) ->
829836 throwIO ex
830837 _ ->
831838 relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
832839
833840-- | Establish a connection to a remote endpoint
841+--
842+-- Maybe throw a TransportError
834843socketToEndPoint :: EndPointAddress -- ^ Our address
835844 -> EndPointAddress -- ^ Their address
845+ -> ConnectHints -- ^ Connection hints
836846 -> IO (Either (TransportError ConnectErrorCode)
837847 (N.Socket, ConnectionRequestResponse))
838−socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do
848+socketToEndPoint (EndPointAddress ourAddress) theirAddress hints = try $ do
839849 (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
840850 Nothing -> throwIO (failed . userError $ "Could not parse")
841851 Just dec -> return dec
@@ -843,7 +853,9 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do
843853 N.getAddrInfo Nothing (Just host) (Just port)
844854 bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
845855 mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
846− mapIOException invalidAddress $ N.connect sock (N.addrAddress addr)
856+ mapIOException invalidAddress $
857+ timeoutMaybe (connectTimeout hints) timeoutError $
858+ N.connect sock (N.addrAddress addr)
847859 response <- mapIOException failed $ do
848860 sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
849861 recvInt32 sock
@@ -858,6 +870,7 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do
858870 invalidAddress = TransportError ConnectNotFound . show
859871 insufficientResources = TransportError ConnectInsufficientResources . show
860872 failed = TransportError ConnectFailed . show
873+ timeoutError = TransportError ConnectTimeout "Timed out"
861874
862875-- | Remove reference to a remote endpoint from a local endpoint
863876--
@@ -1073,7 +1086,6 @@ modifyRemoteState (ourEndPoint, theirEndPoint) match =
10731086 handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()
10741087 handleIOException ex vst = do
10751088 tryCloseSocket (remoteSocket vst)
1076− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
10771089 putMVar theirState (RemoteEndPointClosed $ Just ex)
10781090 let incoming = IntSet.elems $ vst ^. remoteIncoming
10791091 code = EventConnectionLost (remoteAddress theirEndPoint) incoming
@@ -1148,7 +1160,7 @@ handleConnectionRequest transport sock = handle handleException $ do
11481160 case vst ^. localEndPointAt ourAddress of
11491161 Nothing -> do
11501162 sendMany sock [encodeInt32 ConnectionRequestInvalid]
1151− throwIO $ userError "Invalid endpoint"
1163+ throwIO $ userError "handleConnectionRequest: Invalid endpoint"
11521164 Just ourEndPoint ->
11531165 return ourEndPoint
11541166 TransportClosed ->
@@ -1157,7 +1169,8 @@ handleConnectionRequest transport sock = handle handleException $ do
11571169 where
11581170 go :: LocalEndPoint -> EndPointAddress -> IO ()
11591171 go ourEndPoint theirAddress = do
1160− mEndPoint <- handle ((>> return Nothing) . invalidEndPoint) $ do
1172+ mEndPoint <- handle ((>> return Nothing) . handleException) $ do
1173+ resetRemoteEndPoint ourEndPoint theirAddress
11611174 (theirEndPoint, isNew) <-
11621175 findRemoteEndPoint ourEndPoint theirAddress Remote
11631176
@@ -1185,12 +1198,9 @@ handleConnectionRequest transport sock = handle handleException $ do
11851198 -- exception from this point forward.
11861199 forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
11871200
1188− handleException :: IOException -> IO ()
1189− handleException _ = tryCloseSocket sock
1190−
1191− invalidEndPoint :: IOException -> IO ()
1192− invalidEndPoint _ = do
1193− tryIO $ sendMany sock [encodeInt32 ConnectionRequestInvalid]
1201+ handleException :: SomeException -> IO ()
1202+ handleException _ex =
1203+ -- putStrLn $ "handleConnectionRequest " ++ show _ex
11941204 tryCloseSocket sock
11951205
11961206-- | Find a remote endpoint. If the remote endpoint does not yet exist we
@@ -1268,7 +1278,7 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
12681278 readMVar resolved >> go
12691279 RemoteEndPointClosed Nothing ->
12701280 go
1271− RemoteEndPointClosed (Just err) ->
1281+ RemoteEndPointClosed (Just err) ->
12721282 throwIO err
12731283
12741284 ourState = localState ourEndPoint
@@ -1491,7 +1501,6 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
14911501 -- Deal with a premature exit
14921502 prematureExit :: N.Socket -> IOException -> IO ()
14931503 prematureExit sock err = do
1494− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
14951504 tryCloseSocket sock
14961505 modifyMVar_ theirState $ \st ->
14971506 case st of
network-transport/tests/TestTCP.hs+12−8
@@ -160,7 +160,7 @@ testEarlyDisconnect nextPort = do
160160 N.sClose sock
161161
162162 -- Connect to the server
163− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
163+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints
164164
165165 -- Request a new connection, but don't wait for the response
166166 let reqId = 0 :: Int32
@@ -273,7 +273,7 @@ testEarlyCloseSocket nextPort = do
273273 N.sClose sock
274274
275275 -- Connect to the server
276− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
276+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints
277277
278278 -- Request a new connection, but don't wait for the response
279279 let reqId = 0 :: Int32
@@ -360,7 +360,7 @@ testIgnoreCloseSocket nextPort = do
360360 let ourAddress = address endpoint
361361
362362 -- Connect to the server
363− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
363+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints
364364
365365 -- Request a new connection
366366 tlog "Requesting connection"
@@ -440,7 +440,7 @@ testBlockAfterCloseSocket nextPort = do
440440 let ourAddress = address endpoint
441441
442442 -- Connect to the server
443− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress
443+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints
444444
445445 -- Request a new connection
446446 tlog "Requesting connection"
@@ -495,7 +495,7 @@ testUnnecessaryConnect nextPort numThreads = do
495495 dones <- replicateM numThreads $ do
496496 done <- newEmptyMVar
497497 forkTry $ do
498− Right (_, reply) <- readMVar serverAddr >>= socketToEndPoint ourAddress
498+ Right (_, reply) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints
499499 case reply of
500500 ConnectionRequestAccepted ->
501501 putMVar gotAccepted ()
@@ -601,7 +601,7 @@ testReconnect nextPort = do
601601 let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0
602602
603603 -- The first attempt will fail because no endpoint is yet set up
604− Left (TransportError ConnectNotFound _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
604+ -- Left (TransportError ConnectNotFound _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
605605 putMVar firstAttempt ()
606606
607607 -- The second attempt will fail because the server closes the socket before we can request a connection
@@ -612,7 +612,8 @@ testReconnect nextPort = do
612612 case resultConnect of
613613 Nothing -> return ()
614614 Just (Left (TransportError ConnectFailed _)) -> return ()
615− _ -> fail "testReconnect"
615+ Just (Left err) -> throwIO err
616+ Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
616617
617618 -- The third attempt succeeds
618619 Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
@@ -757,7 +758,7 @@ main = do
757758 portMVar <- newEmptyMVar
758759 forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
759760 let nextPort = takeMVar portMVar
760− tryIO $ runTests
761+ tcpResult <- tryIO $ runTests
761762 [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
762763 , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
763764 , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
@@ -772,3 +773,6 @@ main = do
772773 , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)
773774 ]
774775 testTransport (either (Left . show) (Right) <$> nextPort >>= createTransport "127.0.0.1")
776+ case tcpResult of
777+ Left err -> throwIO err
778+ Right () -> return ()
network-transport/tests/TestTransport.hs+62−47
@@ -4,12 +4,11 @@ module TestTransport where
44import Prelude hiding (catch, (>>=), (>>), return, fail)
55import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)
66import Control.Concurrent (forkIO, killThread, yield)
7−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
8−import Control.Exception (evaluate, throw)
7+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar)
8+import Control.Exception (evaluate, throw, throwIO)
99import Control.Monad (replicateM, replicateM_, when, guard, forM, forM_)
1010import Control.Monad.Error ()
11−import Network.Transport hiding (connect)
12−import qualified Network.Transport as NT
11+import Network.Transport
1312import Network.Transport.Internal (tlog)
1413import Network.Transport.Util (spawn)
1514import System.Random (randomIO)
@@ -22,10 +21,6 @@ import Data.Maybe (catMaybes)
2221import Data.List (permutations)
2322import Traced
2423
25−-- | We overload connect to always pass the default hints
26−connect :: EndPoint -> EndPointAddress -> Reliability -> IO (Either (TransportError ConnectErrorCode) Connection)
27−connect ep addr rel = NT.connect ep addr rel defaultConnectHints
28−
2924-- | Server that echoes messages straight back to the origin endpoint.
3025echoServer :: EndPoint -> IO ()
3126echoServer endpoint = do
@@ -37,7 +32,7 @@ echoServer endpoint = do
3732 case event of
3833 ConnectionOpened cid rel addr -> do
3934 tlog $ "Opened new connection " ++ show cid
40− Right conn <- connect endpoint addr rel
35+ Right conn <- connect endpoint addr rel defaultConnectHints
4136 go (Map.insert cid conn cs)
4237 Received cid payload -> do
4338 send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
@@ -59,7 +54,7 @@ ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()
5954ping endpoint server numPings msg = do
6055 -- Open connection to the server
6156 tlog "Connect to echo server"
62− Right conn <- connect endpoint server ReliableOrdered
57+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
6358
6459 -- Wait for the server to open reply connection
6560 tlog "Wait for ConnectionOpened message"
@@ -126,10 +121,10 @@ testConnections transport numPings = do
126121 Right endpoint <- newEndPoint transport
127122
128123 -- Open two connections to the server
129− Right conn1 <- connect endpoint server ReliableOrdered
124+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
130125 ConnectionOpened serv1 _ _ <- receive endpoint
131126
132− Right conn2 <- connect endpoint server ReliableOrdered
127+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
133128 ConnectionOpened serv2 _ _ <- receive endpoint
134129
135130 -- One thread to send "pingA" on the first connection
@@ -164,10 +159,10 @@ testCloseOneConnection transport numPings = do
164159 Right endpoint <- newEndPoint transport
165160
166161 -- Open two connections to the server
167− Right conn1 <- connect endpoint server ReliableOrdered
162+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
168163 ConnectionOpened serv1 _ _ <- receive endpoint
169164
170− Right conn2 <- connect endpoint server ReliableOrdered
165+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
171166 ConnectionOpened serv2 _ _ <- receive endpoint
172167
173168 -- One thread to send "pingA" on the first connection
@@ -212,7 +207,7 @@ testCloseOneDirection transport numPings = do
212207
213208 -- Connect to B
214209 tlog "Connect to B"
215− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered
210+ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
216211
217212 -- Wait for B to connect to us
218213 tlog "Wait for B"
@@ -252,7 +247,7 @@ testCloseOneDirection transport numPings = do
252247
253248 -- Connect to A
254249 tlog "Connect to A"
255− Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered
250+ Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
256251
257252 -- Wait for A's pings
258253 tlog "Wait for pings from A"
@@ -331,7 +326,7 @@ testCloseReopen transport numPings = do
331326 forM_ [1 .. numRepeats] $ \i -> do
332327 tlog "A connecting"
333328 -- Connect to B
334− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered
329+ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
335330
336331 tlog "A pinging"
337332 -- Say hi
@@ -368,7 +363,7 @@ testParallelConnects transport numPings = do
368363
369364 -- Spawn lots of clients
370365 forM_ [1 .. numPings] $ \i -> forkTry $ do
371− Right conn <- connect endpoint server ReliableOrdered
366+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
372367 send conn [pack $ "ping" ++ show i]
373368 send conn [pack $ "ping" ++ show i]
374369 close conn
@@ -393,8 +388,8 @@ testSendAfterClose transport numRepeats = do
393388
394389 -- We request two lightweight connections
395390 replicateM numRepeats $ do
396− Right conn1 <- connect endpoint server ReliableOrdered
397− Right conn2 <- connect endpoint server ReliableOrdered
391+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
392+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
398393
399394 -- Close the second, but leave the first open; then output on the second
400395 -- connection (i.e., on a closed connection while there is still another
@@ -424,8 +419,8 @@ testCloseTwice transport numRepeats = do
424419
425420 replicateM numRepeats $ do
426421 -- We request two lightweight connections
427− Right conn1 <- connect endpoint server ReliableOrdered
428− Right conn2 <- connect endpoint server ReliableOrdered
422+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
423+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
429424
430425 -- Close the second one twice
431426 close conn2
@@ -455,7 +450,7 @@ testConnectToSelf transport numPings = do
455450 Right endpoint <- newEndPoint transport
456451
457452 tlog "Creating self-connection"
458− Right conn <- connect endpoint (address endpoint) ReliableOrdered
453+ Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
459454
460455 tlog "Talk to myself"
461456
@@ -496,8 +491,8 @@ testConnectToSelfTwice transport numPings = do
496491 Right endpoint <- newEndPoint transport
497492
498493 tlog "Creating self-connection"
499− Right conn1 <- connect endpoint (address endpoint) ReliableOrdered
500− Right conn2 <- connect endpoint (address endpoint) ReliableOrdered
494+ Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
495+ Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints
501496
502497 tlog "Talk to myself"
503498
@@ -541,9 +536,9 @@ testCloseSelf newTransport = do
541536 Right transport <- newTransport
542537 Right endpoint1 <- newEndPoint transport
543538 Right endpoint2 <- newEndPoint transport
544− Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered
545− Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered
546− Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered
539+ Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
540+ Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
541+ Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
547542
548543 -- Close the conneciton and try to send
549544 close conn1
@@ -554,13 +549,13 @@ testCloseSelf newTransport = do
554549 -- to the second endpoint should still be fine
555550 closeEndPoint endpoint1
556551 Left (TransportError SendFailed _) <- send conn2 ["ping"]
557− Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered
552+ Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
558553 Right () <- send conn3 ["ping"]
559554
560555 -- Close the transport; now the second should no longer work
561556 closeTransport transport
562557 Left (TransportError SendFailed _) <- send conn3 ["ping"]
563− Left (TransportError ConnectFailed _) <- connect endpoint2 (address endpoint2) ReliableOrdered
558+ Left (TransportError ConnectFailed _) <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
564559
565560 return ()
566561
@@ -592,7 +587,7 @@ testCloseEndPoint transport _ = do
592587 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
593588 Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
594589
595− Right conn <- connect endpoint theirAddr ReliableOrdered
590+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
596591 send conn ["pong"]
597592
598593 ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''
@@ -614,7 +609,7 @@ testCloseEndPoint transport _ = do
614609 putMVar clientAddr1 (address endpoint)
615610
616611 -- Connect to the server, then close the endpoint without disconnecting explicitly
617− Right _ <- connect endpoint theirAddr ReliableOrdered
612+ Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
618613 closeEndPoint endpoint
619614 EndPointClosed <- receive endpoint
620615 return ()
@@ -624,7 +619,7 @@ testCloseEndPoint transport _ = do
624619 Right endpoint <- newEndPoint transport
625620 putMVar clientAddr2 (address endpoint)
626621
627− Right conn <- connect endpoint theirAddr ReliableOrdered
622+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
628623 send conn ["ping"]
629624
630625 -- Reply from the server
@@ -642,7 +637,7 @@ testCloseEndPoint transport _ = do
642637 () <- close conn
643638
644639 -- And so should an attempt to connect
645− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered
640+ Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
646641
647642 return ()
648643
@@ -677,7 +672,7 @@ testCloseTransport newTransport = do
677672 ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
678673 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
679674
680− Right conn <- connect endpoint theirAddr2 ReliableOrdered
675+ Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints
681676 send conn ["pong"]
682677
683678 -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however)
@@ -703,13 +698,13 @@ testCloseTransport newTransport = do
703698 putMVar clientAddr1 (address endpoint1)
704699
705700 -- Connect to the server, then close the endpoint without disconnecting explicitly
706− Right _ <- connect endpoint1 theirAddr ReliableOrdered
701+ Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
707702
708703 -- Set up an endpoint with one outgoing and out incoming connection
709704 Right endpoint2 <- newEndPoint transport
710705 putMVar clientAddr2 (address endpoint2)
711706
712− Right conn <- connect endpoint2 theirAddr ReliableOrdered
707+ Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
713708 send conn ["ping"]
714709
715710 -- Reply from the server
@@ -730,8 +725,8 @@ testCloseTransport newTransport = do
730725 () <- close conn
731726
732727 -- And so should an attempt to connect on either endpoint
733− Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered
734− Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered
728+ Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
729+ Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
735730
736731 -- And finally, so should an attempt to create a new endpoint
737732 Left (TransportError NewEndPointFailed _) <- newEndPoint transport
@@ -760,7 +755,7 @@ testConnectClosedEndPoint transport = do
760755 Right endpoint <- newEndPoint transport
761756 readMVar serverClosed
762757
763− Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered
758+ Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
764759
765760 putMVar clientDone ()
766761
@@ -794,7 +789,7 @@ testSendException newTransport = do
794789 Right endpoint2 <- newEndPoint transport
795790
796791 -- Connect endpoint1 to endpoint2
797− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered
792+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
798793 ConnectionOpened _ _ _ <- receive endpoint2
799794
800795 -- Send an exceptional value
@@ -807,7 +802,7 @@ testSendException newTransport = do
807802 ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2
808803
809804 -- A new connection will re-establish the connection
810− Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered
805+ Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
811806 send conn2 ["ping"]
812807 close conn2
813808
@@ -836,7 +831,7 @@ testKill newTransport numThreads = do
836831 done <- newEmptyMVar
837832 tid <- forkIO $ do
838833 randomThreadDelay 10
839− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered
834+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
840835 randomThreadDelay 10
841836 Right () <- send conn ["ping"]
842837 randomThreadDelay 10
@@ -869,8 +864,13 @@ testCrossing :: Transport -> Int -> IO ()
869864testCrossing transport numRepeats = do
870865 [aAddr, bAddr] <- replicateM 2 newEmptyMVar
871866 [aDone, bDone] <- replicateM 2 newEmptyMVar
867+ [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar
872868 go <- newEmptyMVar
873869
870+ let hints = defaultConnectHints {
871+ connectTimeout = Just 5000000
872+ }
873+
874874 -- A
875875 forkTry $ do
876876 Right endpoint <- newEndPoint transport
@@ -879,8 +879,16 @@ testCrossing transport numRepeats = do
879879
880880 replicateM_ numRepeats $ do
881881 takeMVar go >> yield
882− Right conn <- connect endpoint theirAddress ReliableOrdered
883− close conn
882+ -- Because we are creating lots of connections, it's possible that
883+ -- connect times out (for instance, in the TCP transport,
884+ -- Network.Socket.connect may time out). We shouldn't regard this as an
885+ -- error in the Transport, though.
886+ connectResult <- connect endpoint theirAddress ReliableOrdered hints
887+ case connectResult of
888+ Right conn -> close conn
889+ Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()
890+ Left (TransportError ConnectFailed _) -> readMVar bTimeout
891+ Left err -> throwIO . userError $ "testCrossed: " ++ show err
884892 putMVar aDone ()
885893
886894 -- B
@@ -891,12 +899,19 @@ testCrossing transport numRepeats = do
891899
892900 replicateM_ numRepeats $ do
893901 takeMVar go >> yield
894− Right conn <- connect endpoint theirAddress ReliableOrdered
895− close conn
902+ connectResult <- connect endpoint theirAddress ReliableOrdered hints
903+ case connectResult of
904+ Right conn -> close conn
905+ Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
906+ Left (TransportError ConnectFailed _) -> readMVar aTimeout
907+ Left err -> throwIO . userError $ "testCrossed: " ++ show err
896908 putMVar bDone ()
897909
898910 -- Driver
899911 forM_ [1 .. numRepeats] $ \_i -> do
912+ -- putStrLn $ "Round " ++ show _i
913+ tryTakeMVar aTimeout
914+ tryTakeMVar bTimeout
900915 putMVar go ()
901916 putMVar go ()
902917 takeMVar aDone