c83ee69 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix testReconnect

c83ee69Edsko de Vries14 years ago

network-transport/network-transport.cabal+4−4

compare with master

unifiedsplit

@@ -23,7 +23,7 @@ Library

23 Network.Transport.Chan,

24 Network.Transport.TCP,

25 Network.Transport.Util

26− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes

26+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes

27 ghc-options: -Wall -fno-warn-unused-do-bind

28 HS-Source-Dirs: src

@@ -39,7 +39,7 @@ Test-Suite TestTCP

39 transformers,

40 ansi-terminal,

41 random

42− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

42+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

43 ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N

44 HS-Source-Dirs: tests src

@@ -54,7 +54,7 @@ Test-Suite TestMulticastInMemory

54 transformers,

55 ansi-terminal,

56 random

57− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

57+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

58 ghc-options: -Wall -fno-warn-unused-do-bind

59 HS-Source-Dirs: tests src

@@ -69,6 +69,6 @@ Test-Suite TestInMemory

69 transformers,

70 ansi-terminal,

71 random

72− extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

72+ extensions: OverloadedStrings, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, ExistentialQuantification, FlexibleInstances, OverlappingInstances

73 ghc-options: -Wall -fno-warn-unused-do-bind

74 HS-Source-Dirs: tests src

network-transport/src/Network/Transport.hs+10−3

@@ -10,7 +10,7 @@ module Network.Transport ( -- * Types

10 , EndPointAddress(..)

11 , MulticastAddress(..)

12 -- * Hints

13− , ConnectHints

13+ , ConnectHints(..)

14 , defaultConnectHints

15 -- * Error codes

16 , TransportError(..)

@@ -129,11 +129,16 @@ instance Show MulticastAddress where

129--------------------------------------------------------------------------------

130

131-- Hints used by 'connect'

132−data ConnectHints

132+data ConnectHints = ConnectHints {

133+ -- Timeout

134+ connectTimeout :: Maybe Int

135+ }

133

136

134-- Default hints for connecting

137-- Default hints for connecting

135defaultConnectHints :: ConnectHints

138defaultConnectHints :: ConnectHints

136−defaultConnectHints = undefined

139+defaultConnectHints = ConnectHints {

140+ connectTimeout = Nothing

141+ }

137

142

138--------------------------------------------------------------------------------

143--------------------------------------------------------------------------------

139-- Error codes --

144-- Error codes --

@@ -172,6 +177,8 @@ data ConnectErrorCode =

172 ConnectNotFound

177 ConnectNotFound

173 -- | Insufficient resources (for instance, no more sockets available)

178 -- | Insufficient resources (for instance, no more sockets available)

174 | ConnectInsufficientResources

179 | ConnectInsufficientResources

180+ -- | Timeout

181+ | ConnectTimeout

175 -- | Failed for other reasons (including syntax error)

182 -- | Failed for other reasons (including syntax error)

176 | ConnectFailed

183 | ConnectFailed

177 deriving (Show, Typeable, Eq)

184 deriving (Show, Typeable, Eq)

network-transport/src/Network/Transport/Internal.hs+13

@@ -9,6 +9,7 @@ module Network.Transport.Internal ( -- * Encoders/decoders

9 , mapIOException

10 , tryIO

11 , tryToEnum

12+ , timeoutMaybe

12 -- * Replicated functionality from "base"

13 -- * Replicated functionality from "base"

13 , void

14 , void

14 , forkIOWithUnmask

15 , forkIOWithUnmask

@@ -35,6 +36,7 @@ import Control.Exception ( IOException

35 )

36 )

36import Control.Concurrent (ThreadId, forkIO)

37import Control.Concurrent (ThreadId, forkIO)

37import GHC.IO (unsafeUnmask)

38import GHC.IO (unsafeUnmask)

39+import System.Timeout (timeout)

38--import Control.Concurrent (myThreadId)

40--import Control.Concurrent (myThreadId)

40foreign import ccall unsafe "htonl" htonl :: CInt -> CInt

42foreign import ccall unsafe "htonl" htonl :: CInt -> CInt

@@ -111,3 +113,14 @@ tryToEnum = go minBound maxBound

111 where

113 where

112 go :: Enum b => b -> b -> Int -> Maybe b

114 go :: Enum b => b -> b -> Int -> Maybe b

113 go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing

115 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

40 , tryIO

41 , tryToEnum

42 , void

43+ , timeoutMaybe

43 )

44 )

44import qualified Network.Socket as N ( HostName

45import qualified Network.Socket as N ( HostName

45 , ServiceName

46 , ServiceName

@@ -84,7 +85,6 @@ import Control.Exception ( IOException

84 , mask_

85 , mask_

85 , onException

86 , onException

86 , fromException

87 , fromException

87− , catch

88 )

89import Data.IORef (IORef, newIORef, writeIORef, readIORef)

90import Data.ByteString (ByteString)

@@ -473,12 +473,13 @@ apiConnect :: LocalEndPoint -- ^ Local end point

473 -> Reliability -- ^ Reliability (ignored)

474 -> ConnectHints -- ^ Hints (ignored for now)

475 -> IO (Either (TransportError ConnectErrorCode) Connection)

476−apiConnect ourEndPoint theirAddress _reliability _hints =

476+apiConnect ourEndPoint theirAddress _reliability hints = do

477 if localAddress ourEndPoint == theirAddress

478 then connectToSelf ourEndPoint

479 else try $ do

480− resetIfInvalid ourEndPoint theirAddress

480+ resetRemoteEndPoint ourEndPoint theirAddress

481+ (theirEndPoint, connId) <-

481− (theirEndPoint, connId) <- requestConnectionTo ourEndPoint theirAddress

482+ requestConnectionTo ourEndPoint theirAddress hints

482 -- connAlive can be an IORef rather than an MVar because it is protected

483 -- connAlive can be an IORef rather than an MVar because it is protected

483 -- by the remoteState MVar. We don't need the overhead of locking twice.

484 -- by the remoteState MVar. We don't need the overhead of locking twice.

484 connAlive <- newIORef True

485 connAlive <- newIORef True

@@ -669,13 +670,13 @@ internalSocketBetween transport ourAddress theirAddress = do

669-- | Reset a remote endpoint if it is in Invalid mode

670-- | Reset a remote endpoint if it is in Invalid mode

670--

671--

671-- If a user calls the API function 'connect' and the remote endpoint is

672-- 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

673-- new attempt to connect might succeed even if the previous one failed.

674-- new attempt to connect might succeed even if the previous one failed.

674--

675--

675-- Throws a TransportError ConnectFailed exception if the local endpoint is

676-- Throws a TransportError ConnectFailed exception if the local endpoint is

676-- closed.

677-- closed.

677−resetIfInvalid :: LocalEndPoint -> EndPointAddress -> IO ()

678+resetRemoteEndPoint :: LocalEndPoint -> EndPointAddress -> IO ()

678−resetIfInvalid ourEndPoint theirAddress = do

679+resetRemoteEndPoint ourEndPoint theirAddress = do

679 mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of

680 mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of

680 LocalEndPointValid vst ->

681 LocalEndPointValid vst ->

681 return (vst ^. localConnectionTo theirAddress)

682 return (vst ^. localConnectionTo theirAddress)

@@ -685,6 +686,8 @@ resetIfInvalid ourEndPoint theirAddress = do

685 withMVar (remoteState theirEndPoint) $ \st -> case st of

686 withMVar (remoteState theirEndPoint) $ \st -> case st of

686 RemoteEndPointInvalid _ ->

687 RemoteEndPointInvalid _ ->

687 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

688 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

689+ RemoteEndPointClosed (Just _) ->

690+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)

688 _ ->

691 _ ->

689 return ()

692 return ()

690

693

@@ -729,8 +732,9 @@ createLocalEndPoint transport = do

729-- May throw a TransportError ConnectErrorCode exception.

732-- May throw a TransportError ConnectErrorCode exception.

730requestConnectionTo :: LocalEndPoint

733requestConnectionTo :: LocalEndPoint

731 -> EndPointAddress

734 -> EndPointAddress

735+ -> ConnectHints

732 -> IO (RemoteEndPoint, ConnectionId)

736 -> IO (RemoteEndPoint, ConnectionId)

733−requestConnectionTo ourEndPoint theirAddress = go

737+requestConnectionTo ourEndPoint theirAddress hints = go

734 where

738 where

735 go = do

739 go = do

736 (theirEndPoint, isNew) <- mapIOException connectFailed $

740 (theirEndPoint, isNew) <- mapIOException connectFailed $

@@ -738,9 +742,8 @@ requestConnectionTo ourEndPoint theirAddress = go

738

742

739 if isNew

743 if isNew

740 then do

744 then do

741− void . forkEndPointThread ourEndPoint $

745+ void . forkEndPointThread ourEndPoint . handle absorbAllExceptions $

742− catch (setupRemoteEndPoint (ourEndPoint, theirEndPoint))

746+ setupRemoteEndPoint (ourEndPoint, theirEndPoint) hints

743− (\err -> let _ = err :: SomeException in return ())

744 go

747 go

745 else do

748 else do

746 reply <- mapIOException connectFailed $

749 reply <- mapIOException connectFailed $

@@ -749,10 +752,14 @@ requestConnectionTo ourEndPoint theirAddress = go

749

752

750 connectFailed = TransportError ConnectFailed . show

753 connectFailed = TransportError ConnectFailed . show

751

754

755+ absorbAllExceptions :: SomeException -> IO ()

756+ absorbAllExceptions _ex =

757+ return ()

758+

752-- | Set up a remote endpoint

759-- | Set up a remote endpoint

753−setupRemoteEndPoint :: EndPointPair -> IO ()

760+setupRemoteEndPoint :: EndPointPair -> ConnectHints -> IO ()

754−setupRemoteEndPoint (ourEndPoint, theirEndPoint) = do

761+setupRemoteEndPoint (ourEndPoint, theirEndPoint) hints = do

755− didAccept <- bracketOnError (socketToEndPoint ourAddress theirAddress)

762+ didAccept <- bracketOnError (socketToEndPoint ourAddress theirAddress hints)

756 onError $ \result ->

763 onError $ \result ->

757 case result of

764 case result of

758 Right (sock, ConnectionRequestAccepted) -> do

765 Right (sock, ConnectionRequestAccepted) -> do

@@ -767,7 +774,7 @@ setupRemoteEndPoint (ourEndPoint, theirEndPoint) = do

767 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)

774 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)

768 return True

775 return True

769 Right (sock, ConnectionRequestInvalid) -> do

776 Right (sock, ConnectionRequestInvalid) -> do

770− let err = invalidAddress "Invalid endpoint"

777+ let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint"

771 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)

778 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)

772 tryCloseSocket sock

779 tryCloseSocket sock

773 return False

780 return False

@@ -820,22 +827,25 @@ resolveInit (ourEndPoint, theirEndPoint) newState =

820 RemoteEndPointInit resolved _ -> do

827 RemoteEndPointInit resolved _ -> do

821 putMVar resolved ()

828 putMVar resolved ()

822 case newState of

829 case newState of

823− RemoteEndPointClosed _ ->

830+ RemoteEndPointClosed Nothing ->

824 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

831 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

825 _ ->

832 _ ->

826 return ()

833 return ()

827 return newState

834 return newState

828− RemoteEndPointClosed (Just ex) ->

835+ RemoteEndPointClosed (Just ex) ->

829 throwIO ex

836 throwIO ex

830 _ ->

837 _ ->

831 relyViolation (ourEndPoint, theirEndPoint) "resolveInit"

838 relyViolation (ourEndPoint, theirEndPoint) "resolveInit"

832

839

833-- | Establish a connection to a remote endpoint

840-- | Establish a connection to a remote endpoint

841+--

842+-- Maybe throw a TransportError

834socketToEndPoint :: EndPointAddress -- ^ Our address

843socketToEndPoint :: EndPointAddress -- ^ Our address

835 -> EndPointAddress -- ^ Their address

844 -> EndPointAddress -- ^ Their address

845+ -> ConnectHints -- ^ Connection hints

836 -> IO (Either (TransportError ConnectErrorCode)

846 -> IO (Either (TransportError ConnectErrorCode)

837 (N.Socket, ConnectionRequestResponse))

847 (N.Socket, ConnectionRequestResponse))

838−socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do

848+socketToEndPoint (EndPointAddress ourAddress) theirAddress hints = try $ do

839 (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of

849 (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of

840 Nothing -> throwIO (failed . userError $ "Could not parse")

850 Nothing -> throwIO (failed . userError $ "Could not parse")

841 Just dec -> return dec

851 Just dec -> return dec

@@ -843,7 +853,9 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do

843 N.getAddrInfo Nothing (Just host) (Just port)

853 N.getAddrInfo Nothing (Just host) (Just port)

844 bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do

854 bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do

845 mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1

855 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)

847 response <- mapIOException failed $ do

859 response <- mapIOException failed $ do

848 sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])

860 sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])

849 recvInt32 sock

861 recvInt32 sock

@@ -858,6 +870,7 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do

858 invalidAddress = TransportError ConnectNotFound . show

870 invalidAddress = TransportError ConnectNotFound . show

859 insufficientResources = TransportError ConnectInsufficientResources . show

871 insufficientResources = TransportError ConnectInsufficientResources . show

860 failed = TransportError ConnectFailed . show

872 failed = TransportError ConnectFailed . show

873+ timeoutError = TransportError ConnectTimeout "Timed out"

861

874

862-- | Remove reference to a remote endpoint from a local endpoint

875-- | Remove reference to a remote endpoint from a local endpoint

863--

876--

@@ -1073,7 +1086,6 @@ modifyRemoteState (ourEndPoint, theirEndPoint) match =

1073 handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()

1086 handleIOException :: IOException -> ValidRemoteEndPointState -> IO ()

1074 handleIOException ex vst = do

1087 handleIOException ex vst = do

1075 tryCloseSocket (remoteSocket vst)

1088 tryCloseSocket (remoteSocket vst)

1076− removeRemoteEndPoint (ourEndPoint, theirEndPoint)

1077 putMVar theirState (RemoteEndPointClosed $ Just ex)

1089 putMVar theirState (RemoteEndPointClosed $ Just ex)

1078 let incoming = IntSet.elems $ vst ^. remoteIncoming

1090 let incoming = IntSet.elems $ vst ^. remoteIncoming

1079 code = EventConnectionLost (remoteAddress theirEndPoint) incoming

1091 code = EventConnectionLost (remoteAddress theirEndPoint) incoming

@@ -1148,7 +1160,7 @@ handleConnectionRequest transport sock = handle handleException $ do

1148 case vst ^. localEndPointAt ourAddress of

1160 case vst ^. localEndPointAt ourAddress of

1149 Nothing -> do

1161 Nothing -> do

1150 sendMany sock [encodeInt32 ConnectionRequestInvalid]

1162 sendMany sock [encodeInt32 ConnectionRequestInvalid]

1151− throwIO $ userError "Invalid endpoint"

1163+ throwIO $ userError "handleConnectionRequest: Invalid endpoint"

1152 Just ourEndPoint ->

1164 Just ourEndPoint ->

1153 return ourEndPoint

1165 return ourEndPoint

1154 TransportClosed ->

1166 TransportClosed ->

@@ -1157,7 +1169,8 @@ handleConnectionRequest transport sock = handle handleException $ do

1157 where

1169 where

1158 go :: LocalEndPoint -> EndPointAddress -> IO ()

1170 go :: LocalEndPoint -> EndPointAddress -> IO ()

1159 go ourEndPoint theirAddress = do

1171 go ourEndPoint theirAddress = do

1160− mEndPoint <- handle ((>> return Nothing) . invalidEndPoint) $ do

1172+ mEndPoint <- handle ((>> return Nothing) . handleException) $ do

1173+ resetRemoteEndPoint ourEndPoint theirAddress

1161 (theirEndPoint, isNew) <-

1174 (theirEndPoint, isNew) <-

1162 findRemoteEndPoint ourEndPoint theirAddress Remote

1175 findRemoteEndPoint ourEndPoint theirAddress Remote

1163

1176

@@ -1185,12 +1198,9 @@ handleConnectionRequest transport sock = handle handleException $ do

1185 -- exception from this point forward.

1198 -- exception from this point forward.

1186 forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint

1199 forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint

1187

1200

1188− handleException :: IOException -> IO ()

1201+ handleException :: SomeException -> IO ()

1189− handleException _ = tryCloseSocket sock

1202+ handleException _ex =

1190−

1203+ -- putStrLn $ "handleConnectionRequest " ++ show _ex

1191− invalidEndPoint :: IOException -> IO ()

1192− invalidEndPoint _ = do

1193− tryIO $ sendMany sock [encodeInt32 ConnectionRequestInvalid]

1194 tryCloseSocket sock

1204 tryCloseSocket sock

1195

1205

1196-- | Find a remote endpoint. If the remote endpoint does not yet exist we

1206-- | Find a remote endpoint. If the remote endpoint does not yet exist we

@@ -1268,7 +1278,7 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go

1268 readMVar resolved >> go

1278 readMVar resolved >> go

1269 RemoteEndPointClosed Nothing ->

1279 RemoteEndPointClosed Nothing ->

1270 go

1280 go

1271− RemoteEndPointClosed (Just err) ->

1281+ RemoteEndPointClosed (Just err) ->

1272 throwIO err

1282 throwIO err

1273

1283

1274 ourState = localState ourEndPoint

1284 ourState = localState ourEndPoint

@@ -1491,7 +1501,6 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

1491 -- Deal with a premature exit

1501 -- Deal with a premature exit

1492 prematureExit :: N.Socket -> IOException -> IO ()

1502 prematureExit :: N.Socket -> IOException -> IO ()

1493 prematureExit sock err = do

1503 prematureExit sock err = do

1494− removeRemoteEndPoint (ourEndPoint, theirEndPoint)

1495 tryCloseSocket sock

1504 tryCloseSocket sock

1496 modifyMVar_ theirState $ \st ->

1505 modifyMVar_ theirState $ \st ->

1497 case st of

1506 case st of

network-transport/tests/TestTCP.hs+12−8

@@ -160,7 +160,7 @@ testEarlyDisconnect nextPort = do

160 N.sClose sock

161

162 -- Connect to the server

163− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

163+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints

164

165 -- Request a new connection, but don't wait for the response

166 let reqId = 0 :: Int32

@@ -273,7 +273,7 @@ testEarlyCloseSocket nextPort = do

273 N.sClose sock

274

275 -- Connect to the server

276− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

276+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints

277

278 -- Request a new connection, but don't wait for the response

279 let reqId = 0 :: Int32

@@ -360,7 +360,7 @@ testIgnoreCloseSocket nextPort = do

360 let ourAddress = address endpoint

361

362 -- Connect to the server

363− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

363+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints

364

365 -- Request a new connection

366 tlog "Requesting connection"

@@ -440,7 +440,7 @@ testBlockAfterCloseSocket nextPort = do

440 let ourAddress = address endpoint

441

442 -- Connect to the server

443− Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

443+ Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints

444

445 -- Request a new connection

446 tlog "Requesting connection"

@@ -495,7 +495,7 @@ testUnnecessaryConnect nextPort numThreads = do

495 dones <- replicateM numThreads $ do

496 done <- newEmptyMVar

497 forkTry $ do

498− Right (_, reply) <- readMVar serverAddr >>= socketToEndPoint ourAddress

498+ Right (_, reply) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr defaultConnectHints

499 case reply of

500 ConnectionRequestAccepted ->

501 putMVar gotAccepted ()

@@ -601,7 +601,7 @@ testReconnect nextPort = do

601 let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0

602

603 -- 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

605 putMVar firstAttempt ()

606

607 -- The second attempt will fail because the server closes the socket before we can request a connection

@@ -612,7 +612,8 @@ testReconnect nextPort = do

612 case resultConnect of

613 Nothing -> return ()

614 Just (Left (TransportError ConnectFailed _)) -> return ()

615− _ -> fail "testReconnect"

615+ Just (Left err) -> throwIO err

616+ Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"

616

617

617 -- The third attempt succeeds

618 -- The third attempt succeeds

618 Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

619 Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

@@ -757,7 +758,7 @@ main = do

757 portMVar <- newEmptyMVar

758 portMVar <- newEmptyMVar

758 forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show

759 forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show

759 let nextPort = takeMVar portMVar

760 let nextPort = takeMVar portMVar

760− tryIO $ runTests

761+ tcpResult <- tryIO $ runTests

761 [ ("EarlyDisconnect", testEarlyDisconnect nextPort)

762 [ ("EarlyDisconnect", testEarlyDisconnect nextPort)

762 , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)

763 , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)

763 , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)

764 , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)

@@ -772,3 +773,6 @@ main = do

772 , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)

773 , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)

773 ]

774 ]

774 testTransport (either (Left . show) (Right) <$> nextPort >>= createTransport "127.0.0.1")

775 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

4import Prelude hiding (catch, (>>=), (>>), return, fail)

5import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)

6import Control.Concurrent (forkIO, killThread, yield)

7−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)

7+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar)

8−import Control.Exception (evaluate, throw)

8+import Control.Exception (evaluate, throw, throwIO)

9import Control.Monad (replicateM, replicateM_, when, guard, forM, forM_)

10import Control.Monad.Error ()

11−import Network.Transport hiding (connect)

11+import Network.Transport

12−import qualified Network.Transport as NT

13import Network.Transport.Internal (tlog)

12import Network.Transport.Internal (tlog)

14import Network.Transport.Util (spawn)

13import Network.Transport.Util (spawn)

15import System.Random (randomIO)

14import System.Random (randomIO)

@@ -22,10 +21,6 @@ import Data.Maybe (catMaybes)

22import Data.List (permutations)

21import Data.List (permutations)

23import Traced

22import Traced

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−

29-- | Server that echoes messages straight back to the origin endpoint.

24-- | Server that echoes messages straight back to the origin endpoint.

30echoServer :: EndPoint -> IO ()

25echoServer :: EndPoint -> IO ()

31echoServer endpoint = do

26echoServer endpoint = do

@@ -37,7 +32,7 @@ echoServer endpoint = do

37 case event of

32 case event of

38 ConnectionOpened cid rel addr -> do

33 ConnectionOpened cid rel addr -> do

39 tlog $ "Opened new connection " ++ show cid

34 tlog $ "Opened new connection " ++ show cid

40− Right conn <- connect endpoint addr rel

35+ Right conn <- connect endpoint addr rel defaultConnectHints

41 go (Map.insert cid conn cs)

36 go (Map.insert cid conn cs)

42 Received cid payload -> do

37 Received cid payload -> do

43 send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload

38 send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload

@@ -59,7 +54,7 @@ ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO ()

59ping endpoint server numPings msg = do

54ping endpoint server numPings msg = do

60 -- Open connection to the server

55 -- Open connection to the server

61 tlog "Connect to echo server"

56 tlog "Connect to echo server"

62− Right conn <- connect endpoint server ReliableOrdered

57+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints

64 -- Wait for the server to open reply connection

59 -- Wait for the server to open reply connection

65 tlog "Wait for ConnectionOpened message"

60 tlog "Wait for ConnectionOpened message"

@@ -126,10 +121,10 @@ testConnections transport numPings = do

126 Right endpoint <- newEndPoint transport

121 Right endpoint <- newEndPoint transport

127

122

128 -- Open two connections to the server

123 -- Open two connections to the server

129− Right conn1 <- connect endpoint server ReliableOrdered

124+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

130 ConnectionOpened serv1 _ _ <- receive endpoint

125 ConnectionOpened serv1 _ _ <- receive endpoint

131

126

132− Right conn2 <- connect endpoint server ReliableOrdered

127+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

133 ConnectionOpened serv2 _ _ <- receive endpoint

128 ConnectionOpened serv2 _ _ <- receive endpoint

134

129

135 -- One thread to send "pingA" on the first connection

130 -- One thread to send "pingA" on the first connection

@@ -164,10 +159,10 @@ testCloseOneConnection transport numPings = do

164 Right endpoint <- newEndPoint transport

159 Right endpoint <- newEndPoint transport

165

160

166 -- Open two connections to the server

161 -- Open two connections to the server

167− Right conn1 <- connect endpoint server ReliableOrdered

162+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

168 ConnectionOpened serv1 _ _ <- receive endpoint

163 ConnectionOpened serv1 _ _ <- receive endpoint

169

164

170− Right conn2 <- connect endpoint server ReliableOrdered

165+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

171 ConnectionOpened serv2 _ _ <- receive endpoint

166 ConnectionOpened serv2 _ _ <- receive endpoint

172

167

173 -- One thread to send "pingA" on the first connection

168 -- One thread to send "pingA" on the first connection

@@ -212,7 +207,7 @@ testCloseOneDirection transport numPings = do

212

207

213 -- Connect to B

208 -- Connect to B

214 tlog "Connect to B"

209 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

216

211

217 -- Wait for B to connect to us

212 -- Wait for B to connect to us

218 tlog "Wait for B"

213 tlog "Wait for B"

@@ -252,7 +247,7 @@ testCloseOneDirection transport numPings = do

252

247

253 -- Connect to A

248 -- Connect to A

254 tlog "Connect to A"

249 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

256

251

257 -- Wait for A's pings

252 -- Wait for A's pings

258 tlog "Wait for pings from A"

253 tlog "Wait for pings from A"

@@ -331,7 +326,7 @@ testCloseReopen transport numPings = do

331 forM_ [1 .. numRepeats] $ \i -> do

326 forM_ [1 .. numRepeats] $ \i -> do

332 tlog "A connecting"

327 tlog "A connecting"

333 -- Connect to B

328 -- Connect to B

334− Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered

329+ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints

335

330

336 tlog "A pinging"

331 tlog "A pinging"

337 -- Say hi

332 -- Say hi

@@ -368,7 +363,7 @@ testParallelConnects transport numPings = do

368

363

369 -- Spawn lots of clients

364 -- Spawn lots of clients

370 forM_ [1 .. numPings] $ \i -> forkTry $ do

365 forM_ [1 .. numPings] $ \i -> forkTry $ do

371− Right conn <- connect endpoint server ReliableOrdered

366+ Right conn <- connect endpoint server ReliableOrdered defaultConnectHints

372 send conn [pack $ "ping" ++ show i]

367 send conn [pack $ "ping" ++ show i]

373 send conn [pack $ "ping" ++ show i]

368 send conn [pack $ "ping" ++ show i]

374 close conn

369 close conn

@@ -393,8 +388,8 @@ testSendAfterClose transport numRepeats = do

393

388

394 -- We request two lightweight connections

389 -- We request two lightweight connections

395 replicateM numRepeats $ do

390 replicateM numRepeats $ do

396− Right conn1 <- connect endpoint server ReliableOrdered

391+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

397− Right conn2 <- connect endpoint server ReliableOrdered

392+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

398

393

399 -- Close the second, but leave the first open; then output on the second

394 -- Close the second, but leave the first open; then output on the second

400 -- connection (i.e., on a closed connection while there is still another

395 -- connection (i.e., on a closed connection while there is still another

@@ -424,8 +419,8 @@ testCloseTwice transport numRepeats = do

424

419

425 replicateM numRepeats $ do

420 replicateM numRepeats $ do

426 -- We request two lightweight connections

421 -- We request two lightweight connections

427− Right conn1 <- connect endpoint server ReliableOrdered

422+ Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

428− Right conn2 <- connect endpoint server ReliableOrdered

423+ Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

429

424

430 -- Close the second one twice

425 -- Close the second one twice

431 close conn2

426 close conn2

@@ -455,7 +450,7 @@ testConnectToSelf transport numPings = do

455 Right endpoint <- newEndPoint transport

450 Right endpoint <- newEndPoint transport

456

451

457 tlog "Creating self-connection"

452 tlog "Creating self-connection"

458− Right conn <- connect endpoint (address endpoint) ReliableOrdered

453+ Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints

459

454

460 tlog "Talk to myself"

455 tlog "Talk to myself"

461

456

@@ -496,8 +491,8 @@ testConnectToSelfTwice transport numPings = do

496 Right endpoint <- newEndPoint transport

491 Right endpoint <- newEndPoint transport

497

492

498 tlog "Creating self-connection"

493 tlog "Creating self-connection"

499− Right conn1 <- connect endpoint (address endpoint) ReliableOrdered

494+ Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints

500− Right conn2 <- connect endpoint (address endpoint) ReliableOrdered

495+ Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints

501

496

502 tlog "Talk to myself"

497 tlog "Talk to myself"

503

498

@@ -541,9 +536,9 @@ testCloseSelf newTransport = do

541 Right transport <- newTransport

536 Right transport <- newTransport

542 Right endpoint1 <- newEndPoint transport

537 Right endpoint1 <- newEndPoint transport

543 Right endpoint2 <- newEndPoint transport

538 Right endpoint2 <- newEndPoint transport

544− Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered

539+ Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints

545− Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered

540+ Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints

546− Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered

541+ Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints

547

542

548 -- Close the conneciton and try to send

543 -- Close the conneciton and try to send

549 close conn1

544 close conn1

@@ -554,13 +549,13 @@ testCloseSelf newTransport = do

554 -- to the second endpoint should still be fine

549 -- to the second endpoint should still be fine

555 closeEndPoint endpoint1

550 closeEndPoint endpoint1

556 Left (TransportError SendFailed _) <- send conn2 ["ping"]

551 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

558 Right () <- send conn3 ["ping"]

553 Right () <- send conn3 ["ping"]

559

554

560 -- Close the transport; now the second should no longer work

555 -- Close the transport; now the second should no longer work

561 closeTransport transport

556 closeTransport transport

562 Left (TransportError SendFailed _) <- send conn3 ["ping"]

557 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

564

559

565 return ()

560 return ()

566

561

@@ -592,7 +587,7 @@ testCloseEndPoint transport _ = do

592 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr

587 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr

593 Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'

588 Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'

594

589

595− Right conn <- connect endpoint theirAddr ReliableOrdered

590+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

596 send conn ["pong"]

591 send conn ["pong"]

597

592

598 ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''

593 ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid''

@@ -614,7 +609,7 @@ testCloseEndPoint transport _ = do

614 putMVar clientAddr1 (address endpoint)

609 putMVar clientAddr1 (address endpoint)

615

610

616 -- Connect to the server, then close the endpoint without disconnecting explicitly

611 -- Connect to the server, then close the endpoint without disconnecting explicitly

617− Right _ <- connect endpoint theirAddr ReliableOrdered

612+ Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

618 closeEndPoint endpoint

613 closeEndPoint endpoint

619 EndPointClosed <- receive endpoint

614 EndPointClosed <- receive endpoint

620 return ()

615 return ()

@@ -624,7 +619,7 @@ testCloseEndPoint transport _ = do

624 Right endpoint <- newEndPoint transport

619 Right endpoint <- newEndPoint transport

625 putMVar clientAddr2 (address endpoint)

620 putMVar clientAddr2 (address endpoint)

626

621

627− Right conn <- connect endpoint theirAddr ReliableOrdered

622+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

628 send conn ["ping"]

623 send conn ["ping"]

629

624

630 -- Reply from the server

625 -- Reply from the server

@@ -642,7 +637,7 @@ testCloseEndPoint transport _ = do

642 () <- close conn

637 () <- close conn

643

638

644 -- And so should an attempt to connect

639 -- And so should an attempt to connect

645− Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered

640+ Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

646

641

647 return ()

642 return ()

648

643

@@ -677,7 +672,7 @@ testCloseTransport newTransport = do

677 ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2

672 ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2

678 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2

673 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2

679

674

680− Right conn <- connect endpoint theirAddr2 ReliableOrdered

675+ Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints

681 send conn ["pong"]

676 send conn ["pong"]

682

677

683 -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however)

678 -- 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

703 putMVar clientAddr1 (address endpoint1)

698 putMVar clientAddr1 (address endpoint1)

704

699

705 -- Connect to the server, then close the endpoint without disconnecting explicitly

700 -- Connect to the server, then close the endpoint without disconnecting explicitly

706− Right _ <- connect endpoint1 theirAddr ReliableOrdered

701+ Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints

707

702

708 -- Set up an endpoint with one outgoing and out incoming connection

703 -- Set up an endpoint with one outgoing and out incoming connection

709 Right endpoint2 <- newEndPoint transport

704 Right endpoint2 <- newEndPoint transport

710 putMVar clientAddr2 (address endpoint2)

705 putMVar clientAddr2 (address endpoint2)

711

706

712− Right conn <- connect endpoint2 theirAddr ReliableOrdered

707+ Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints

713 send conn ["ping"]

708 send conn ["ping"]

714

709

715 -- Reply from the server

710 -- Reply from the server

@@ -730,8 +725,8 @@ testCloseTransport newTransport = do

730 () <- close conn

725 () <- close conn

731

726

732 -- And so should an attempt to connect on either endpoint

727 -- And so should an attempt to connect on either endpoint

733− Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered

728+ Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints

734− Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered

729+ Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints

735

730

736 -- And finally, so should an attempt to create a new endpoint

731 -- And finally, so should an attempt to create a new endpoint

737 Left (TransportError NewEndPointFailed _) <- newEndPoint transport

732 Left (TransportError NewEndPointFailed _) <- newEndPoint transport

@@ -760,7 +755,7 @@ testConnectClosedEndPoint transport = do

760 Right endpoint <- newEndPoint transport

755 Right endpoint <- newEndPoint transport

761 readMVar serverClosed

756 readMVar serverClosed

762

757

763− Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered

758+ Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints

764

759

765 putMVar clientDone ()

760 putMVar clientDone ()

766

761

@@ -794,7 +789,7 @@ testSendException newTransport = do

794 Right endpoint2 <- newEndPoint transport

789 Right endpoint2 <- newEndPoint transport

795

790

796 -- Connect endpoint1 to endpoint2

791 -- Connect endpoint1 to endpoint2

797− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered

792+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints

798 ConnectionOpened _ _ _ <- receive endpoint2

793 ConnectionOpened _ _ _ <- receive endpoint2

799

794

800 -- Send an exceptional value

795 -- Send an exceptional value

@@ -807,7 +802,7 @@ testSendException newTransport = do

807 ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2

802 ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2

808

803

809 -- A new connection will re-establish the connection

804 -- 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

811 send conn2 ["ping"]

806 send conn2 ["ping"]

812 close conn2

807 close conn2

813

808

@@ -836,7 +831,7 @@ testKill newTransport numThreads = do

836 done <- newEmptyMVar

831 done <- newEmptyMVar

837 tid <- forkIO $ do

832 tid <- forkIO $ do

838 randomThreadDelay 10

833 randomThreadDelay 10

839− Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered

834+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints

840 randomThreadDelay 10

835 randomThreadDelay 10

841 Right () <- send conn ["ping"]

836 Right () <- send conn ["ping"]

842 randomThreadDelay 10

837 randomThreadDelay 10

@@ -869,8 +864,13 @@ testCrossing :: Transport -> Int -> IO ()

869testCrossing transport numRepeats = do

864testCrossing transport numRepeats = do

870 [aAddr, bAddr] <- replicateM 2 newEmptyMVar

865 [aAddr, bAddr] <- replicateM 2 newEmptyMVar

871 [aDone, bDone] <- replicateM 2 newEmptyMVar

866 [aDone, bDone] <- replicateM 2 newEmptyMVar

867+ [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar

872 go <- newEmptyMVar

868 go <- newEmptyMVar

873

869

870+ let hints = defaultConnectHints {

871+ connectTimeout = Just 5000000

872+ }

873+

874 -- A

875 forkTry $ do

876 Right endpoint <- newEndPoint transport

@@ -879,8 +879,16 @@ testCrossing transport numRepeats = do

879

880 replicateM_ numRepeats $ do

881 takeMVar go >> yield

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.

882− Right conn <- connect endpoint theirAddress ReliableOrdered

886+ connectResult <- connect endpoint theirAddress ReliableOrdered hints

887+ case connectResult of

883− close conn

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

884 putMVar aDone ()

892 putMVar aDone ()

885

893

886 -- B

894 -- B

@@ -891,12 +899,19 @@ testCrossing transport numRepeats = do

891

899

892 replicateM_ numRepeats $ do

900 replicateM_ numRepeats $ do

893 takeMVar go >> yield

901 takeMVar go >> yield

894− Right conn <- connect endpoint theirAddress ReliableOrdered

902+ connectResult <- connect endpoint theirAddress ReliableOrdered hints

903+ case connectResult of

895− close conn

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

896 putMVar bDone ()

908 putMVar bDone ()

897

909

898 -- Driver

910 -- Driver

899 forM_ [1 .. numRepeats] $ \_i -> do

911 forM_ [1 .. numRepeats] $ \_i -> do

912+ -- putStrLn $ "Round " ++ show _i

913+ tryTakeMVar aTimeout

914+ tryTakeMVar bTimeout

900 putMVar go ()

915 putMVar go ()

901 putMVar go ()

916 putMVar go ()

902 takeMVar aDone

917 takeMVar aDone