b231245 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix testUnnecessaryConnect

b231245Edsko de Vries14 years ago

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

compare with master

unifiedsplit

@@ -872,9 +872,10 @@ handleConnectionRequest transport sock = handle tryCloseSocket $ do

872 , sendOn = sendMany sock

873 }

874 sendMany sock [encodeInt32 ConnectionRequestAccepted]

875− -- TODO: this putMVar might block if the remote endpoint sends a

875+ -- If the remote endpoint (due to a bug) attempts to connect the

876− -- connection request for a local endpoint that it is already

876+ -- same local endpoint twice, the sceond attempt wil have been

877− -- connected to

877+ -- rejected with ConnectionRequestCrossed and so will never get to

878+ -- this point

878 putMVar (remoteState theirEndPoint) (RemoteEndPointValid vst)

879 putMVar (remoteState theirEndPoint) (RemoteEndPointValid vst)

879 return (Just theirEndPoint)

880 return (Just theirEndPoint)

880 -- If we left the scope of the exception handler with a return value of

881 -- If we left the scope of the exception handler with a return value of

network-transport/tests/TestAuxiliary.hs+1−1

@@ -32,7 +32,7 @@ runTest :: String -> IO () -> IO Bool

32runTest description test = do

33 putStr $ "Running " ++ show description ++ ": "

34 hFlush stdout

35− done <- try . timeout 20000000 $ test

35+ done <- try . timeout 20000000 $ test -- 20 seconds

36 case done of

37 Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"

38 Right Nothing -> failed $ "(timeout)"

network-transport/tests/TestTCP.hs+27−2

@@ -10,7 +10,7 @@ import Network.Transport.TCP (createTransport, encodeEndPointAddress)

10import Data.Int (Int32)

11import Control.Concurrent (threadDelay)

12import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar, isEmptyMVar)

13−import Control.Monad (replicateM, guard, forM_)

13+import Control.Monad (replicateM, guard, forM_, replicateM_)

14import Control.Applicative ((<$>))

15import Control.Exception (throw)

16import Network.Transport.TCP ( ControlHeader(..)

@@ -27,6 +27,8 @@ import qualified Network.Socket as N ( sClose

27import Network.Socket.ByteString (sendMany)

28import Data.String (fromString)

29import Traced

30+import GHC.IO.Exception (ioe_errno)

31+import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)

31instance Traceable ControlHeader where

33instance Traceable ControlHeader where

32 trace = traceShow

34 trace = traceShow

@@ -465,11 +467,33 @@ testUnnecessaryConnect nextPort = do

465 forkTry $ do

467 forkTry $ do

466 let ourAddress = EndPointAddress "ourAddress"

468 let ourAddress = EndPointAddress "ourAddress"

467 Right (_, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

469 Right (_, ConnectionRequestAccepted) <- readMVar serverAddr >>= socketToEndPoint ourAddress

468− Right (_, ConnectionRequestEndPointInvalid) <- readMVar serverAddr >>= socketToEndPoint ourAddress

470+ Right (_, ConnectionRequestCrossed) <- readMVar serverAddr >>= socketToEndPoint ourAddress

469 putMVar clientDone ()

471 putMVar clientDone ()

470

472

471 takeMVar clientDone

473 takeMVar clientDone

472

474

475+-- | Test that we can create "many" transport instances

476+testMany :: IO N.ServiceName -> IO ()

477+testMany nextPort = do

478+ Right masterTransport <- nextPort >>= createTransport "127.0.0.1"

479+ Right masterEndPoint <- newEndPoint masterTransport

480+

481+ replicateM_ 20 $ do

482+ mTransport <- nextPort >>= createTransport "127.0.0.1"

483+ threadDelay 2000000

484+ case mTransport of

485+ Left ex -> do

486+ putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)

487+ case (ioe_errno ex) of

488+ Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"

489+ _ -> return ()

490+ throw ex

491+ Right transport ->

492+ replicateM_ 3 $ do

493+ Right endpoint <- newEndPoint transport

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

495+ return ()

496+

473main :: IO ()

497main :: IO ()

474main = do

498main = do

475 portMVar <- newEmptyMVar

499 portMVar <- newEmptyMVar

@@ -483,5 +507,6 @@ main = do

483 , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort)

507 , ("TestUnnecessaryConnect", testUnnecessaryConnect nextPort)

484 , ("InvalidAddress", testInvalidAddress nextPort)

508 , ("InvalidAddress", testInvalidAddress nextPort)

485 , ("InvalidConnect", testInvalidConnect nextPort)

509 , ("InvalidConnect", testInvalidConnect nextPort)

510+ , ("TestMany", testMany nextPort)

486 ]

511 ]

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

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

network-transport/tests/TestTransport.hs+1−14

@@ -703,25 +703,12 @@ testCloseTransport newTransport = do

703

704 mapM_ takeMVar [serverDone, clientDone]

705

706−testMany :: IO (Either String Transport) -> IO ()

707−testMany newTransport = do

708− Right masterTransport <- newTransport

709− Right masterEndPoint <- newEndPoint masterTransport

710−

711− replicateM_ 20 $ do

712− Right transport <- newTransport

713− replicateM_ 2 $ do

714− Right endpoint <- newEndPoint transport

715− Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered

716− return ()

717−

718-- Transport tests

706-- Transport tests

719testTransport :: IO (Either String Transport) -> IO ()

707testTransport :: IO (Either String Transport) -> IO ()

720testTransport newTransport = do

708testTransport newTransport = do

721 Right transport <- newTransport

709 Right transport <- newTransport

722 runTests

710 runTests

723− [ ("Many", testMany newTransport)

724− , ("PingPong", testPingPong transport numPings)

711+ [ ("PingPong", testPingPong transport numPings)

725 , ("EndPoints", testEndPoints transport numPings)

712 , ("EndPoints", testEndPoints transport numPings)

726 , ("Connections", testConnections transport numPings)

713 , ("Connections", testConnections transport numPings)

727 , ("CloseOneConnection", testCloseOneConnection transport numPings)

714 , ("CloseOneConnection", testCloseOneConnection transport numPings)