@@ -7,8 +7,9 @@ import Data.Int (Int32)
77import Data.Maybe (fromJust)
88import Control.Concurrent (forkIO)
99import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
10+import Control.Monad (replicateM)
1011import Network.Transport.TCP (decodeEndPointAddress, EndPointId, ControlHeader(..), ConnectionRequestResponse(..))
11−import Network.Transport.Internal (encodeInt32, prependLength)
12+import Network.Transport.Internal (encodeInt32, prependLength, tlog)
1213import Network.Transport.Internal.TCP (recvInt32)
1314import qualified Network.Socket as N ( getAddrInfo
1415 , socket
@@ -71,6 +72,97 @@ testEarlyDisconnect = do
7172 -- The server should still receive a ConnectionClosed message
7273 N.sClose sock
7374
75+-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
76+-- would happen when the endpoint sends a new connection request before
77+-- receiving an (already underway) CloseSocket request)
78+testIgnoreCloseSocket :: IO ()
79+testIgnoreCloseSocket = do
80+ serverAddr <- newEmptyMVar
81+ clientDone <- newEmptyMVar
82+ Right transport <- createTransport "127.0.0.1" "8084"
83+
84+ forkIO $ server transport serverAddr
85+ forkIO $ client transport serverAddr clientDone
86+
87+ takeMVar clientDone
88+
89+ where
90+ server :: Transport -> MVar (N.HostName, N.ServiceName, EndPointId) -> IO ()
91+ server transport serverAddr = do
92+ tlog "Server"
93+ Right endpoint <- newEndPoint transport
94+ putMVar serverAddr (fromJust . decodeEndPointAddress . address $ endpoint)
95+
96+ -- Wait for the client to connect and disconnect
97+ tlog "Waiting for ConnectionOpened"
98+ ConnectionOpened _ _ _ <- receive endpoint
99+ tlog "Waiting for ConnectionClosed"
100+ ConnectionClosed _ <- receive endpoint
101+
102+ -- At this point the server will have sent a CloseSocket request to the
103+ -- client, which however ignores it, instead it requests and closes
104+ -- another connection
105+ tlog "Waiting for ConnectionOpened"
106+ ConnectionOpened _ _ _ <- receive endpoint
107+ tlog "Waiting for ConnectionClosed"
108+ ConnectionClosed _ <- receive endpoint
109+
110+
111+ tlog "Server waiting.."
112+
113+ client :: Transport -> MVar (N.HostName, N.ServiceName, EndPointId) -> MVar () -> IO ()
114+ client transport serverAddr clientDone = do
115+ tlog "Client"
116+ Right endpoint <- newEndPoint transport
117+ let EndPointAddress myAddress = address endpoint
118+
119+ -- Connect to the server
120+ addr:_ <- N.getAddrInfo Nothing (Just "127.0.0.1") (Just "8084")
121+ sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
122+ N.setSocketOption sock N.ReuseAddr 1
123+ N.connect sock (N.addrAddress addr)
124+
125+ tlog "Connecting to endpoint"
126+ (_, _, endPointIx) <- readMVar serverAddr
127+ sendMany sock (encodeInt32 endPointIx : prependLength [myAddress])
128+
129+ -- Wait for acknowledgement
130+ ConnectionRequestAccepted <- recvInt32 sock
131+
132+ -- Request a new connection
133+ tlog "Requesting connection"
134+ let reqId = 0 :: Int32
135+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId]
136+ response <- replicateM 4 $ recvInt32 sock :: IO [Int32]
137+
138+ -- Close the connection again
139+ tlog "Closing connection"
140+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
141+
142+ -- Server will now send a CloseSocket request as its refcount reached 0
143+ tlog "Waiting for CloseSocket request"
144+ CloseSocket <- recvInt32 sock
145+
146+ -- But we ignore it and request another connection
147+ tlog "Ignoring it, requesting another connection"
148+ let reqId' = 1 :: Int32
149+ sendMany sock [encodeInt32 RequestConnectionId, encodeInt32 reqId']
150+ response' <- replicateM 4 $ recvInt32 sock :: IO [Int32]
151+
152+ -- Close it again
153+ tlog "Closing connection"
154+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (response !! 3)]
155+
156+ -- We now get a CloseSocket again, and this time we heed it
157+ tlog "Waiting for second CloseSocket request"
158+ CloseSocket <- recvInt32 sock
159+
160+ tlog "Closing socket"
161+ sendMany sock [encodeInt32 CloseSocket]
162+ N.sClose sock
163+
164+ putMVar clientDone ()
165+
74166-- | Test the creation of a transport with an invalid address
75167testInvalidAddress :: IO ()
76168testInvalidAddress = do
@@ -106,5 +198,6 @@ main = do
106198 runTestIO "EarlyDisconnect" testEarlyDisconnect
107199 runTestIO "InvalidAddress" testInvalidAddress
108200 runTestIO "InvalidConnect" testInvalidConnect
201+ runTestIO "IgnoreCloseSocket" testIgnoreCloseSocket
109202 Right transport <- createTransport "127.0.0.1" "8080"
110203 testTransport transport