566d9bc · distributed-process

git.iko.soy/distributed-process

Relax RELY conditions for send and close

commit566d9bc7df30decb44f40436e8b546621691f246 authorEdsko de Vries <edsko@edsko.net> dateWed 16 May 2012, 16:57 (14 years ago) parentb76094b

3 files changed+56−42

compare with master

unifiedsplit

network-transport/src/Network/Transport/TCP.hs+16−8 network-transport/tests/TestAuxiliary.hs+1−1 network-transport/tests/TestTransport.hs+39−33

network-transport/src/Network/Transport/TCP.hs+16−8

@@ -384,7 +384,7 @@ apiConnect ourEndPoint theirAddress _ = try $ do

384384

385385-- | Close a connection

386386--

387−-- RELY: Remote endpoint must be in 'RemoteEndPointValid' or 'RemoteEndPointClosed'

387+-- RELY: The endpoint must not be invalid

388388-- GUARANTEE: If the connection is alive on entry then the remote endpoint will

389389-- either be RemoteEndPointValid or RemoteEndPointClosing. Otherwise, the state

390390-- of the remote endpoint will not be changed.

@@ -405,14 +405,15 @@ apiClose theirEndPoint connId connAlive = void . tryIO $ do

405405 RemoteEndPointClosed -> do

406406 return st

407407 RemoteEndPointClosing _ _ ->

408− fail "apiClose RELY violation"

408+ -- See discussion in apiSend why we must allow for this case

409+ return st

409410 RemoteEndPointInvalid _ ->

410411 fail "apiClose RELY violation"

411412 closeIfUnused theirEndPoint

412413

413414-- | Send data across a connection

414415--

415−-- RELY: The remote endpoint must be in state 'RemoteEndPointValid' or 'RemoteEndPointClosed'

416+-- RELY: The endpoint must not be in invalid state.

416417-- GUARANTEE: The state of the remote endpoint will not be changed.

417418apiSend :: RemoteEndPoint -> ConnectionId -> IORef Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())

418419apiSend theirEndPoint connId connAlive payload = do

@@ -423,9 +424,16 @@ apiSend theirEndPoint connId connAlive payload = do

423424 then mapExceptionIO sendFailed $ sendOn vst (encodeInt32 connId : prependLength payload)

424425 else throw $ TransportError SendFailed "Connection closed"

425426 RemoteEndPointClosed -> do

426− return (Left $ TransportError SendFailed "Endpoint closed")

427+ return (Left $ TransportError SendFailed "Connection closed")

427428 RemoteEndPointClosing _ _ ->

428− error "apiSend RELY violation"

429+ -- The only way for the endpoint to be in closing state, while a

430+ -- connection is still active, is for the application to call 'close'

431+ -- on the connection triggering "garbage collection" of the TCP channel

432+ -- (CloseSocket request to the remote endpoint) which hasn't completed

433+ -- yet. Even if the remote endpoint comes back with "please don't

434+ -- close", this still means that our *outgoing* connection has been

435+ -- closed

436+ return (Left $ TransportError SendFailed "Connection closed")

429437 RemoteEndPointInvalid _ ->

430438 error "apiSend RELY violation"

431439 where

@@ -960,9 +968,9 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

960968 _ ->

961969 error "handleIncomingMessages RELY violation"

962970 sendOn vst ( encodeInt32 ControlResponse

963− : encodeInt32 reqId

964− : prependLength [encodeInt32 newId]

965− )

971+ : encodeInt32 reqId

972+ : prependLength [encodeInt32 newId]

973+ )

966974 -- We add the new connection ID to the list of open connections only once the

967975 -- endpoint has been notified of the new connection (sendOn may fail)

968976 return (RemoteEndPointValid vst)

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

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

3232runTest description test = do

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

3434 hFlush stdout

35− done <- try . timeout 10000000 $ test

35+ done <- try . timeout 20000000 $ test

3636 case done of

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

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

network-transport/tests/TestTransport.hs+39−33

@@ -374,7 +374,7 @@ testParallelConnects transport numPings = do

374374

375375-- | Test that sending on a closed connection gives an error

376376testSendAfterClose :: Transport -> Int -> IO ()

377−testSendAfterClose transport _ = do

377+testSendAfterClose transport numRepeats = do

378378 server <- spawn transport echoServer

379379 clientDone <- newEmptyMVar

380380

@@ -382,19 +382,22 @@ testSendAfterClose transport _ = do

382382 Right endpoint <- newEndPoint transport

383383

384384 -- We request two lightweight connections

385− Right conn1 <- connect endpoint server ReliableOrdered

386− Right conn2 <- connect endpoint server ReliableOrdered

387−

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

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

390− -- connection open)

391− close conn2

392− Left (TransportError SendFailed _) <- send conn2 ["ping2"]

385+ replicateM numRepeats $ do

386+ Right conn1 <- connect endpoint server ReliableOrdered

387+ Right conn2 <- connect endpoint server ReliableOrdered

388+

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

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

391+ -- connection open)

392+ close conn2

393+ Left (TransportError SendFailed _) <- send conn2 ["ping2"]

394+

395+ -- Now close the first connection, and output on it (i.e., output while

396+ -- there are no lightweight connection at all anymore)

397+ close conn1

398+ Left (TransportError SendFailed _) <- send conn2 ["ping2"]

393399

394− -- Now close the first connection, and output on it (i.e., output while

395− -- there are no lightweight connection at all anymore)

396− close conn1

397− Left (TransportError SendFailed _) <- send conn2 ["ping2"]

400+ return ()

398401

399402 putMVar clientDone ()

400403

@@ -402,32 +405,35 @@ testSendAfterClose transport _ = do

402405

403406-- | Test that closing the same connection twice has no effect

404407testCloseTwice :: Transport -> Int -> IO ()

405−testCloseTwice transport _ = do

408+testCloseTwice transport numRepeats = do

406409 server <- spawn transport echoServer

407410 clientDone <- newEmptyMVar

408411

409412 forkTry $ do

410413 Right endpoint <- newEndPoint transport

411414

412− -- We request two lightweight connections

413− Right conn1 <- connect endpoint server ReliableOrdered

414− Right conn2 <- connect endpoint server ReliableOrdered

415−

416− -- Close the second one twice

417− close conn2

418− close conn2

419−

420− -- Then send a message on the first and close that too

421− send conn1 ["ping"]

422− close conn1

423−

424− -- Verify expected response from the echo server

425− ConnectionOpened cid1 _ _ <- receive endpoint

426− ConnectionOpened cid2 _ _ <- receive endpoint

427− ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2

428− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1

429− ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1

415+ replicateM numRepeats $ do

416+ -- We request two lightweight connections

417+ Right conn1 <- connect endpoint server ReliableOrdered

418+ Right conn2 <- connect endpoint server ReliableOrdered

419+

420+ -- Close the second one twice

421+ close conn2

422+ close conn2

423+

424+ -- Then send a message on the first and close that twice too

425+ send conn1 ["ping"]

426+ close conn1

430427

428+ -- Verify expected response from the echo server

429+ ConnectionOpened cid1 _ _ <- receive endpoint

430+ ConnectionOpened cid2 _ _ <- receive endpoint

431+ ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2

432+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1

433+ ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1

434+

435+ return ()

436+

431437 putMVar clientDone ()

432438

433439 takeMVar clientDone

@@ -722,7 +728,7 @@ testTransport newTransport = do

722728 , ("ConnectToSelf", testConnectToSelf transport numPings)

723729 , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)

724730 , ("CloseEndPoint", testCloseEndPoint transport numPings)

725− , ("CloseTransport", testCloseTransport newTransport)

731+ , ("CloseTransport", testCloseTransport newTransport)

726732 ]

727733 where

728734 numPings = 10000 :: Int