git.iko.soy/distributed-process
on master help sign in
Test that CloseSocket requests can be ignored
b7aacf8Edsko de Vries
network-transport-2/tests/TestTCP.hs+94−1
compare with master
unifiedsplit
@@ -7,8 +7,9 @@ import Data.Int (Int32)
7import Data.Maybe (fromJust)
7import Data.Maybe (fromJust)
8import Control.Concurrent (forkIO)
8import Control.Concurrent (forkIO)
9import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
9import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar)
10+import Control.Monad (replicateM)
10import Network.Transport.TCP (decodeEndPointAddress, EndPointId, ControlHeader(..), ConnectionRequestResponse(..))
11import Network.Transport.TCP (decodeEndPointAddress, EndPointId, ControlHeader(..), ConnectionRequestResponse(..))
11−import Network.Transport.Internal (encodeInt32, prependLength)
12+import Network.Transport.Internal (encodeInt32, prependLength, tlog)
12import Network.Transport.Internal.TCP (recvInt32)
13import Network.Transport.Internal.TCP (recvInt32)
13import qualified Network.Socket as N ( getAddrInfo
14import qualified Network.Socket as N ( getAddrInfo
14 , socket
15 , socket
@@ -71,6 +72,97 @@ testEarlyDisconnect = do
71 -- The server should still receive a ConnectionClosed message
72 -- The server should still receive a ConnectionClosed message
72 N.sClose sock
73 N.sClose sock
73
74
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+
74-- | Test the creation of a transport with an invalid address
166-- | Test the creation of a transport with an invalid address
75testInvalidAddress :: IO ()
167testInvalidAddress :: IO ()
76testInvalidAddress = do
168testInvalidAddress = do
@@ -106,5 +198,6 @@ main = do
106 runTestIO "EarlyDisconnect" testEarlyDisconnect
198 runTestIO "EarlyDisconnect" testEarlyDisconnect
107 runTestIO "InvalidAddress" testInvalidAddress
199 runTestIO "InvalidAddress" testInvalidAddress
108 runTestIO "InvalidConnect" testInvalidConnect
200 runTestIO "InvalidConnect" testInvalidConnect
201+ runTestIO "IgnoreCloseSocket" testIgnoreCloseSocket
109 Right transport <- createTransport "127.0.0.1" "8080"
202 Right transport <- createTransport "127.0.0.1" "8080"
110 testTransport transport
203 testTransport transport
network-transport-2/tests/TestTransport.hs−2
@@ -26,7 +26,6 @@ echoServer endpoint = do
26 go :: Map ConnectionId Connection -> IO ()
26 go :: Map ConnectionId Connection -> IO ()
27 go cs = do
27 go cs = do
28 event <- receive endpoint
28 event <- receive endpoint
29− tlog $ "Got event " ++ show event
30 case event of
29 case event of
31 ConnectionOpened cid rel addr -> do
30 ConnectionOpened cid rel addr -> do
32 Right conn <- connect endpoint addr rel
31 Right conn <- connect endpoint addr rel
@@ -44,7 +43,6 @@ echoServer endpoint = do
44expect :: EndPoint -> (Event -> Bool) -> IO ()
43expect :: EndPoint -> (Event -> Bool) -> IO ()
45expect endpoint predicate = do
44expect endpoint predicate = do
46 event <- receive endpoint
45 event <- receive endpoint
47− tlog $ "Got event " ++ show event
48 mbool <- catch (Right <$> evaluate (predicate event)) (return . Left)
46 mbool <- catch (Right <$> evaluate (predicate event)) (return . Left)
49 case mbool of
47 case mbool of
50 Left err -> do tlog $ "Unexpected event " ++ show event
48 Left err -> do tlog $ "Unexpected event " ++ show event