{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import Prelude hiding ( (>>=) , return , fail , (>>) #if ! MIN_VERSION_base(4,6,0) , catch #endif ) import Network.Transport import Network.Transport.TCP ( createTransport , createTransportExposeInternals , TransportInternals(..) , TCPParameters(..) , defaultTCPParameters , LightweightConnectionId ) import Control.Concurrent (threadDelay, killThread) import Control.Concurrent.MVar ( MVar , newEmptyMVar , putMVar , takeMVar , readMVar , isEmptyMVar , newMVar , modifyMVar , modifyMVar_ , swapMVar ) import Control.Monad (replicateM, guard, forM_, replicateM_, when) import Control.Applicative ((<$>)) import Control.Exception (throwIO, try, SomeException) import Network.Transport.TCP ( socketToEndPoint ) import Network.Transport.Internal ( prependLength , tlog , tryIO , void ) import Network.Transport.TCP.Internal ( ControlHeader(..) , encodeControlHeader , decodeControlHeader , ConnectionRequestResponse(..) , encodeConnectionRequestResponse , decodeConnectionRequestResponse , encodeWord32 , recvWord32 , forkServer , recvWithLength , encodeEndPointAddress , decodeEndPointAddress ) #ifdef USE_MOCK_NETWORK import qualified Network.Transport.TCP.Mock.Socket as N #else import qualified Network.Socket as N #endif ( sClose , ServiceName , Socket , AddrInfo , shutdown , ShutdownCmd(ShutdownSend) , SockAddr(..) , SocketType(Stream) , AddrInfo(..) , getAddrInfo , defaultHints , defaultProtocol , socket , connect , close ) #ifdef USE_MOCK_NETWORK import Network.Transport.TCP.Mock.Socket.ByteString (sendMany) #else import Network.Socket.ByteString (sendMany) #endif import qualified Data.ByteString as BS (length, concat) import Data.String (fromString) import GHC.IO.Exception (ioe_errno) import Foreign.C.Error (Errno(..), eADDRNOTAVAIL) import System.Timeout (timeout) import Network.Transport.Tests (testTransport) import Network.Transport.Tests.Auxiliary (forkTry, runTests) import Network.Transport.Tests.Traced instance Traceable ControlHeader where trace = traceShow instance Traceable ConnectionRequestResponse where trace = traceShow instance Traceable N.Socket where trace = traceShow instance Traceable N.AddrInfo where trace = traceShow instance Traceable TransportInternals where trace = const Nothing -- Test that the server gets a ConnectionClosed message when the client closes -- the socket without sending an explicit control message to the server first testEarlyDisconnect :: IO () testEarlyDisconnect = do clientAddr <- newEmptyMVar serverAddr <- newEmptyMVar serverDone <- newEmptyMVar tlog "testEarlyDisconnect" forkTry $ server serverAddr clientAddr serverDone forkTry $ client serverAddr clientAddr takeMVar serverDone where server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO () server serverAddr clientAddr serverDone = do tlog "Server" Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) theirAddr <- readMVar clientAddr -- TEST 1: they connect to us, then drop the connection do ConnectionOpened _ _ addr <- receive endpoint True <- return $ addr == theirAddr ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint True <- return $ addr' == theirAddr return () -- TEST 2: after they dropped their connection to us, we now try to -- establish a connection to them. This should re-establish the broken -- TCP connection. tlog "Trying to connect to client" Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- TEST 3: To test the connection, we do a simple ping test; as before, -- however, the remote client won't close the connection nicely but just -- closes the socket do Right () <- send conn ["ping"] ConnectionOpened cid _ addr <- receive endpoint True <- return $ addr == theirAddr Received cid' ["pong"] <- receive endpoint True <- return $ cid == cid' ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint True <- return $ addr' == theirAddr return () -- TEST 4: A subsequent send on an already-open connection will now break Left (TransportError SendFailed _) <- send conn ["ping2"] -- *Pfew* putMVar serverDone () client :: MVar EndPointAddress -> MVar EndPointAddress -> IO () client serverAddr clientAddr = do tlog "Client" -- Listen for incoming messages (clientPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do -- Initial setup 0 <- recvWord32 sock _ <- recvWithLength maxBound sock sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] -- Server opens a logical connection Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId -- Server sends a message 1024 <- recvWord32 sock ["ping"] <- recvWithLength maxBound sock -- Reply sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 10002 ] sendMany sock (encodeWord32 10002 : prependLength ["pong"]) -- Close the socket N.sClose sock let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0 putMVar clientAddr ourAddress -- Connect to the server Right (_, sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True False False Nothing Nothing -- Open a new connection sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 10003 ] -- Close the socket without closing the connection explicitly -- The server should receive an error event N.sClose sock -- | Test the behaviour of a premature CloseSocket request testEarlyCloseSocket :: IO () testEarlyCloseSocket = do clientAddr <- newEmptyMVar serverAddr <- newEmptyMVar serverDone <- newEmptyMVar tlog "testEarlyDisconnect" forkTry $ server serverAddr clientAddr serverDone forkTry $ client serverAddr clientAddr takeMVar serverDone where server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO () server serverAddr clientAddr serverDone = do tlog "Server" Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) theirAddr <- readMVar clientAddr -- TEST 1: they connect to us, then send a CloseSocket. Since we don't -- have any outgoing connections, this means we will agree to close the -- socket do ConnectionOpened cid _ addr <- receive endpoint True <- return $ addr == theirAddr ConnectionClosed cid' <- receive endpoint True <- return $ cid' == cid return () -- TEST 2: after they dropped their connection to us, we now try to -- establish a connection to them. This should re-establish the broken -- TCP connection. tlog "Trying to connect to client" Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- TEST 3: To test the connection, we do a simple ping test; as before, -- however, the remote client won't close the connection nicely but just -- sends a CloseSocket -- except that now we *do* have outgoing -- connections, so we won't agree and hence will receive an error when -- the socket gets closed do Right () <- send conn ["ping"] ConnectionOpened cid _ addr <- receive endpoint True <- return $ addr == theirAddr Received cid' ["pong"] <- receive endpoint True <- return $ cid' == cid ConnectionClosed cid'' <- receive endpoint True <- return $ cid'' == cid ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint True <- return $ addr' == theirAddr return () -- TEST 4: A subsequent send on an already-open connection will now break Left (TransportError SendFailed _) <- send conn ["ping2"] -- *Pfew* putMVar serverDone () client :: MVar EndPointAddress -> MVar EndPointAddress -> IO () client serverAddr clientAddr = do tlog "Client" -- Listen for incoming messages (clientPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do -- Initial setup 0 <- recvWord32 sock _ <- recvWithLength maxBound sock sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] -- Server opens a logical connection Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId -- Server sends a message 1024 <- recvWord32 sock ["ping"] <- recvWithLength maxBound sock -- Reply sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 10002 ] sendMany sock (encodeWord32 10002 : prependLength ["pong"]) -- Send a CloseSocket even though there are still connections *in both -- directions* sendMany sock [ encodeWord32 (encodeControlHeader CloseSocket) , encodeWord32 1024 ] N.sClose sock let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0 putMVar clientAddr ourAddress -- Connect to the server Right (_, sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True False False Nothing Nothing -- Open a new connection sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 10003 ] -- Send a CloseSocket without sending a closeconnecton -- The server should still receive a ConnectionClosed message sendMany sock [ encodeWord32 (encodeControlHeader CloseSocket) , encodeWord32 0 ] N.sClose sock -- | Test the creation of a transport with an invalid address testInvalidAddress :: IO () testInvalidAddress = do Left _ <- createTransport "invalidHostName" "0" ((,) "invalidHostName") defaultTCPParameters return () -- | Test connecting to invalid or non-existing endpoints testInvalidConnect :: IO () testInvalidConnect = do Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport -- Syntax error in the endpoint address Left (TransportError ConnectFailed _) <- connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints -- Syntax connect, but invalid hostname (TCP address lookup failure) Left (TransportError ConnectNotFound _) <- connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints -- TCP address correct, but nobody home at that address Left (TransportError ConnectNotFound _) <- connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints -- Valid TCP address but invalid endpoint number Left (TransportError ConnectNotFound _) <- connect endpoint (encodeEndPointAddress "127.0.0.1" "0" 1) ReliableOrdered defaultConnectHints return () -- | Test that an endpoint can ignore CloseSocket requests (in "reality" this -- would happen when the endpoint sends a new connection request before -- receiving an (already underway) CloseSocket request) testIgnoreCloseSocket :: IO () testIgnoreCloseSocket = do serverAddr <- newEmptyMVar clientAddr <- newEmptyMVar clientDone <- newEmptyMVar serverDone <- newEmptyMVar connectionEstablished <- newEmptyMVar Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters -- Server forkTry $ do tlog "Server" Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) let ourAddress = address endpoint theirAddress <- readMVar clientAddr -- Wait for the client to set up the TCP connection to us takeMVar connectionEstablished -- Connect then disconnect to the client Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints close conn -- At this point the server will have sent a CloseSocket request to the -- client, which however ignores it, instead it requests and closes -- another connection tlog "Waiting for ConnectionOpened" ConnectionOpened _ _ _ <- receive endpoint tlog "Waiting for ConnectionClosed" ConnectionClosed _ <- receive endpoint putMVar serverDone () -- Client forkTry $ do tlog "Client" Right endpoint <- newEndPoint transport putMVar clientAddr (address endpoint) let ourAddress = address endpoint theirAddress <- readMVar serverAddr -- Connect to the server Right (_, sock, ConnectionRequestAccepted) <- socketToEndPoint ourAddress theirAddress True False False Nothing Nothing putMVar connectionEstablished () -- Server connects to us, and then closes the connection Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId Just CloseConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId -- Server will now send a CloseSocket request as its refcount reached 0 tlog "Waiting for CloseSocket request" Just CloseSocket <- decodeControlHeader <$> recvWord32 sock _ <- recvWord32 sock :: IO LightweightConnectionId -- But we ignore it and request another connection in the other direction tlog "Ignoring it, requesting another connection" sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 1024 ] -- Close it again tlog "Closing connection" sendMany sock [ encodeWord32 (encodeControlHeader CloseConnection) , encodeWord32 1024 ] -- And close the connection completely tlog "Closing socket" sendMany sock [ encodeWord32 (encodeControlHeader CloseSocket) , encodeWord32 1024 ] N.sClose sock putMVar clientDone () takeMVar clientDone takeMVar serverDone -- | Like 'testIgnoreSocket', but now the server requests a connection after the -- client closed their connection. In the meantime, the server will have sent a -- CloseSocket request to the client, and must block until the client responds. testBlockAfterCloseSocket :: IO () testBlockAfterCloseSocket = do serverAddr <- newEmptyMVar clientAddr <- newEmptyMVar clientDone <- newEmptyMVar serverDone <- newEmptyMVar connectionEstablished <- newEmptyMVar Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters -- Server forkTry $ do tlog "Server" Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) let ourAddress = address endpoint theirAddress <- readMVar clientAddr -- Wait for the client to set up the TCP connection to us takeMVar connectionEstablished -- Connect then disconnect to the client Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints close conn -- At this point the server will have sent a CloseSocket request to the -- client, and must block until the client responds Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints putMVar serverDone () -- Client forkTry $ do tlog "Client" Right endpoint <- newEndPoint transport putMVar clientAddr (address endpoint) let ourAddress = address endpoint theirAddress <- readMVar serverAddr -- Connect to the server Right (_, sock, ConnectionRequestAccepted) <- socketToEndPoint ourAddress theirAddress True False False Nothing Nothing putMVar connectionEstablished () -- Server connects to us, and then closes the connection Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId Just CloseConnection <- decodeControlHeader <$> recvWord32 sock 1024 <- recvWord32 sock :: IO LightweightConnectionId -- Server will now send a CloseSocket request as its refcount reached 0 tlog "Waiting for CloseSocket request" Just CloseSocket <- decodeControlHeader <$> recvWord32 sock _ <- recvWord32 sock :: IO LightweightConnectionId unblocked <- newMVar False -- We should not hear from the server until we unblock him by -- responding to the CloseSocket request (in this case, we -- respond by sending a ConnectionRequest) forkTry $ do recvWord32 sock readMVar unblocked >>= guard putMVar clientDone () threadDelay 1000000 tlog "Client ignores close socket and sends connection request" tlog "This should unblock the server" modifyMVar_ unblocked $ \_ -> return True sendMany sock [ encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 1024 ] takeMVar clientDone takeMVar serverDone -- | Test what happens when a remote endpoint sends a connection request to our -- transport for an endpoint it already has a connection to testUnnecessaryConnect :: Int -> IO () testUnnecessaryConnect numThreads = do clientDone <- newEmptyMVar serverAddr <- newEmptyMVar forkTry $ do Right transport <- createTransport "127.0.0.1" "0" ((,) "128.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport -- Since we're lying about the server's address, we have to manually -- construct the proper address. If we used its actual address, the clients -- would try to resolve "128.0.0.1" and then would fail due to invalid -- address. Just (_, port, epid) <- return $ decodeEndPointAddress (address endpoint) putMVar serverAddr $ encodeEndPointAddress "127.0.0.1" port epid forkTry $ do -- We pick an address < 128.0.0.1 so that this is not rejected purely because of the "crossed" check let ourAddress = encodeEndPointAddress "127.0.0.1" "1234" 0 -- We should only get a single 'Accepted' reply gotAccepted <- newEmptyMVar dones <- replicateM numThreads $ do done <- newEmptyMVar forkTry $ do -- It is possible that the remote endpoint just rejects the request by closing the socket -- immediately (depending on far the remote endpoint got with the initialization) response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True False False Nothing Nothing case response of Right (_, _, ConnectionRequestAccepted) -> -- We don't close this socket because we want to keep this connection open putMVar gotAccepted () -- We might get either Invalid or Crossed (the transport does not -- maintain enough history to be able to tell) Right (_, sock, ConnectionRequestInvalid) -> N.sClose sock Right (_, sock, ConnectionRequestCrossed) -> N.sClose sock Left _ -> return () putMVar done () return done mapM_ readMVar (gotAccepted : dones) putMVar clientDone () takeMVar clientDone -- | Test that we can create "many" transport instances testMany :: IO () testMany = do Right masterTransport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right masterEndPoint <- newEndPoint masterTransport replicateM_ 10 $ do mTransport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters case mTransport of Left ex -> do putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex) case (ioe_errno ex) of Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)" _ -> return () throwIO ex Right transport -> replicateM_ 2 $ do Right endpoint <- newEndPoint transport Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered defaultConnectHints return () -- | Test what happens when the transport breaks completely testBreakTransport :: IO () testBreakTransport = do Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport killThread (transportThread internals) -- Uh oh ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint return () -- Used in testReconnect to block until a socket is closed. newtype is needed -- for the Traceable instance. newtype WaitSocketFree = WaitSocketFree (IO ()) instance Traceable WaitSocketFree where trace = const Nothing -- | Test that a second call to 'connect' might succeed even if the first -- failed. This is a TCP specific test rather than an endpoint specific test -- because we must manually create the endpoint address to match an endpoint we -- have yet to set up. -- Then test that we get a connection lost message after the remote endpoint -- suddenly closes the socket, and that a subsequent 'connect' allows us to -- re-establish a connection to the same endpoint testReconnect :: IO () testReconnect = do serverDone <- newEmptyMVar endpointCreated <- newEmptyMVar -- The server will put the 'socketFree' IO in here, so that the client can -- block until the server has closed the socket. socketClosed <- newEmptyMVar counter <- newMVar (0 :: Int) -- Server (serverPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do -- Accept the connection Right 0 <- tryIO $ recvWord32 sock Right _ <- tryIO $ recvWithLength maxBound sock -- The first time we close the socket before accepting the logical connection count <- modifyMVar counter $ \i -> return (i + 1, i) -- Wait 100ms after the socket closes, to (hopefully) ensure that the client -- knows the connection is closed, and sending on that socket will therefore -- fail. putMVar socketClosed (WaitSocketFree (socketFree >> threadDelay 100000)) when (count > 0) $ do -- The second, third, and fourth connections are accepted according to the -- protocol. -- On the second request, the socket then closes. Right () <- tryIO $ sendMany sock [ encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted) ] -- Client requests a logical connection when (count > 1) $ do -- On the third and fourth requests, a new logical connection is -- accepted. -- On the third request the socket then closes. Right (Just CreatedNewConnection) <- tryIO $ decodeControlHeader <$> recvWord32 sock connId <- recvWord32 sock :: IO LightweightConnectionId when (count > 2) $ do -- On the fourth request, a message is received and then the socket -- is closed. Right connId' <- tryIO $ (recvWord32 sock :: IO LightweightConnectionId) True <- return $ connId == connId' Right ["ping"] <- tryIO $ recvWithLength maxBound sock putMVar serverDone () return () putMVar endpointCreated () -- Client forkTry $ do Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0 takeMVar endpointCreated -- First attempt: fails because the server closes the socket without -- doing the handshake. resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints case resultConnect of Left (TransportError ConnectFailed _) -> return () Left err -> throwIO err Right _ -> throwIO $ userError "testConnect: unexpected connect success" WaitSocketFree wait <- takeMVar socketClosed wait -- Second attempt: server accepts the connection but then closes the socket. -- We expect a failed connection if the socket is closed *before* -- CreatedNewConnection is sent, or a successful connection such that a -- subsequent send will fail in case CreatedNewConnection was sent before -- the close. resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- We must be sure that the socket has closed before trying to send. WaitSocketFree wait <- takeMVar socketClosed wait case resultConnect of Left (TransportError ConnectFailed _) -> return () Left err -> throwIO err Right c -> do ev <- send c ["ping"] case ev of Left _ -> return () Right _ -> throwIO $ userError "testConnect: unexpected send success" -- In any case, since a heavyweight connection was made, we'll get a -- connection lost event. ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint -- Third attempt: server accepts the heavyweight and the lightweight -- connection (CreatedNewConnection) but then closes the socket. -- The connection must succeed, but sending after the socket is closed -- must fail. resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- Wait until close before trying to send. WaitSocketFree wait <- takeMVar socketClosed wait case resultConnect of Left err -> throwIO err Right c -> do ev <- send c ["ping"] case ev of Left (TransportError SendFailed _) -> return () Left err -> throwIO err Right _ -> throwIO $ userError "testConnect: unexpected send success" ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint -- But a subsequent call to connect should reestablish the connection Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- Send should now succeed Right () <- send conn2 ["ping"] WaitSocketFree wait <- takeMVar socketClosed wait return () takeMVar serverDone -- Test what happens if we close the socket one way only. This means that the -- 'recv' in 'handleIncomingMessages' will not fail, but a 'send' or 'connect' -- *will* fail. We are testing that error handling everywhere does the right -- thing. testUnidirectionalError :: IO () testUnidirectionalError = do clientDone <- newEmptyMVar serverGotPing <- newEmptyMVar -- Server (serverPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do -- We accept connections, but when an exception occurs we don't do -- anything (in particular, we don't close the socket). This is important -- because when we shutdown one direction of the socket a recv here will -- fail, but we don't want to close that socket at that point (which -- would shutdown the socket in the other direction) void . (try :: IO () -> IO (Either SomeException ())) $ do 0 <- recvWord32 sock _ <- recvWithLength maxBound sock () <- sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock connId <- recvWord32 sock :: IO LightweightConnectionId connId' <- recvWord32 sock :: IO LightweightConnectionId True <- return $ connId == connId' ["ping"] <- recvWithLength maxBound sock putMVar serverGotPing () -- Must read the clientDone MVar so that we don't close the socket -- (forkServer will close it once this action ends). readMVar clientDone -- Client forkTry $ do Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right endpoint <- newEndPoint transport let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0 -- Establish a connection to the server Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints send conn1 ["ping"] takeMVar serverGotPing -- Close the *outgoing* part of the socket only sock <- socketBetween internals (address endpoint) theirAddr N.shutdown sock N.ShutdownSend -- At this point we cannot notice the problem yet so we shouldn't receive an event yet Nothing <- timeout 500000 $ receive endpoint -- But when we send we find the error Left (TransportError SendFailed _) <- send conn1 ["ping"] ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint -- A call to connect should now re-establish the connection Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints send conn2 ["ping"] takeMVar serverGotPing -- Again, close the outgoing part of the socket sock' <- socketBetween internals (address endpoint) theirAddr N.shutdown sock' N.ShutdownSend -- We now find the error when we attempt to close the connection Nothing <- timeout 500000 $ receive endpoint close conn2 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint Right conn3 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints send conn3 ["ping"] takeMVar serverGotPing -- We repeat once more. sock'' <- socketBetween internals (address endpoint) theirAddr N.shutdown sock'' N.ShutdownSend -- Now we notice the problem when we try to connect Nothing <- timeout 500000 $ receive endpoint Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint Right conn4 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints send conn4 ["ping"] takeMVar serverGotPing putMVar clientDone () readMVar clientDone testInvalidCloseConnection :: IO () testInvalidCloseConnection = do Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters serverAddr <- newEmptyMVar clientDone <- newEmptyMVar serverDone <- newEmptyMVar -- Server forkTry $ do Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) ConnectionOpened _ _ _ <- receive endpoint -- At this point the client sends an invalid request, so we terminate the -- connection ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint putMVar serverDone () -- Client forkTry $ do Right endpoint <- newEndPoint transport let ourAddr = address endpoint -- Connect so that we have a TCP connection theirAddr <- readMVar serverAddr Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints -- Get a handle on the TCP connection and manually send an invalid CloseConnection request sock <- socketBetween internals ourAddr theirAddr sendMany sock [ encodeWord32 (encodeControlHeader CloseConnection) , encodeWord32 (12345 :: LightweightConnectionId) ] putMVar clientDone () mapM_ takeMVar [clientDone, serverDone] testUseRandomPort :: IO () testUseRandomPort = do testDone <- newEmptyMVar forkTry $ do Right transport1 <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right ep1 <- newEndPoint transport1 -- Same as transport1, but is strict in the port. Right transport2 <- createTransport "127.0.0.1" "0" (\(!port) -> ("127.0.0.1", port)) defaultTCPParameters Right ep2 <- newEndPoint transport2 Right conn1 <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints ConnectionOpened _ _ _ <- receive ep1 putMVar testDone () takeMVar testDone -- | Verify that if a peer sends an address or data which exceeds the maximum -- length, that peer's connection will be terminated, but other peers will -- not be affected. testMaxLength :: IO () testMaxLength = do Right serverTransport <- createTransport "127.0.0.1" "9998" ((,) "127.0.0.1") $ defaultTCPParameters { -- 17 bytes should fit every valid address at 127.0.0.1. -- Port is at most 5 bytes (65536) and id is a base-10 Word32 so -- at most 10 bytes. We'll have one client with a 5-byte port to push it -- over the chosen limit of 16 tcpMaxAddressLength = 16 , tcpMaxReceiveLength = 8 } Right goodClientTransport <- createTransport "127.0.0.1" "9999" ((,) "127.0.0.1") defaultTCPParameters Right badClientTransport <- createTransport "127.0.0.1" "10000" ((,) "127.0.0.1") defaultTCPParameters serverAddress <- newEmptyMVar testDone <- newEmptyMVar goodClientConnected <- newEmptyMVar goodClientDone <- newEmptyMVar badClientDone <- newEmptyMVar forkTry $ do Right serverEp <- newEndPoint serverTransport putMVar serverAddress (address serverEp) readMVar badClientDone ConnectionOpened _ _ _ <- receive serverEp Received _ _ <- receive serverEp -- Will lose the connection when the good client sends 9 bytes. ErrorEvent (TransportError (EventConnectionLost _) _) <- receive serverEp readMVar goodClientDone putMVar testDone () forkTry $ do Right badClientEp <- newEndPoint badClientTransport address <- readMVar serverAddress -- Wait until the good client connects, then try to connect. It'll fail, -- but the good client should still be OK. readMVar goodClientConnected Left (TransportError ConnectFailed _) <- connect badClientEp address ReliableOrdered defaultConnectHints closeEndPoint badClientEp putMVar badClientDone () forkTry $ do Right goodClientEp <- newEndPoint goodClientTransport address <- readMVar serverAddress Right conn <- connect goodClientEp address ReliableOrdered defaultConnectHints putMVar goodClientConnected () -- Wait until the bad client has tried and failed to connect before -- attempting a send, to ensure that its failure did not affect us. readMVar badClientDone Right () <- send conn ["00000000"] -- The send which breaches the limit does not appear to fail, but the -- (heavyweight) connection is now severed. We can reliably determine that -- by receiving. Right () <- send conn ["000000000"] ErrorEvent (TransportError (EventConnectionLost _) _) <- receive goodClientEp closeEndPoint goodClientEp putMVar goodClientDone () readMVar testDone closeTransport badClientTransport closeTransport goodClientTransport closeTransport serverTransport -- | Ensure that an end point closes up OK even if the peer disobeys the -- protocol. testCloseEndPoint :: IO () testCloseEndPoint = do serverAddress <- newEmptyMVar serverFinished <- newEmptyMVar -- A server which accepts one connection and then attempts to close the -- end point. forkTry $ do Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters Right ep <- newEndPoint transport putMVar serverAddress (address ep) ConnectionOpened _ _ _ <- receive ep Just () <- timeout 5000000 (closeEndPoint ep) putMVar serverFinished () return () -- A nefarious client which connects to the server then stops responding. forkTry $ do Just (hostName, serviceName, endPointId) <- decodeEndPointAddress <$> readMVar serverAddress addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just hostName) (Just serviceName) sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol N.connect sock (N.addrAddress addr) let endPointAddress = "127.0.0.1:0:0" -- Version 0x00000000 handshake data. v0handshake = [ encodeWord32 endPointId , encodeWord32 (fromIntegral (BS.length endPointAddress)) , endPointAddress ] -- Version, and total length of the versioned handshake. handshake = [ encodeWord32 0x00000000 , encodeWord32 (fromIntegral (BS.length (BS.concat v0handshake))) ] sendMany sock $ handshake ++ v0handshake ++ [ -- Create a lightweight connection. encodeWord32 (encodeControlHeader CreatedNewConnection) , encodeWord32 1024 ] readMVar serverFinished N.close sock readMVar serverFinished -- | Ensure that if the peer's claimed host doesn't match its actual host, -- the connection is rejected (when tcpCheckPeerHost is enabled). testCheckPeerHostReject :: IO () testCheckPeerHostReject = do let params = defaultTCPParameters { tcpCheckPeerHost = True } Right transport1 <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") params -- This transport claims 127.0.0.2 as its host, but connections from it to -- an EndPoint on transport1 will show 127.0.0.1 as the socket's source host. Right transport2 <- createTransport "127.0.0.1" "0" ((,) "127.0.0.2") defaultTCPParameters Right ep1 <- newEndPoint transport1 Right ep2 <- newEndPoint transport2 Left err <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints TransportError ConnectFailed _ <- return err return () -- | Ensure that if peer host checking works through name resolution: if the -- peer claims "localhost", and connects to a transport also on localhost, -- it should be accepted. testCheckPeerHostResolve :: IO () testCheckPeerHostResolve = do let params = defaultTCPParameters { tcpCheckPeerHost = True } Right transport1 <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") params -- EndPoints on this transport have addresses with "localhost" host part. Right transport2 <- createTransport "127.0.0.1" "0" ((,) "localhost") defaultTCPParameters Right ep1 <- newEndPoint transport1 Right ep2 <- newEndPoint transport2 Right conn <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints close conn return () main :: IO () main = do tcpResult <- tryIO $ runTests [ ("Use random port", testUseRandomPort) , ("EarlyDisconnect", testEarlyDisconnect) , ("EarlyCloseSocket", testEarlyCloseSocket) , ("IgnoreCloseSocket", testIgnoreCloseSocket) , ("BlockAfterCloseSocket", testBlockAfterCloseSocket) , ("UnnecessaryConnect", testUnnecessaryConnect 10) , ("InvalidAddress", testInvalidAddress) , ("InvalidConnect", testInvalidConnect) , ("Many", testMany) , ("BreakTransport", testBreakTransport) , ("Reconnect", testReconnect) , ("UnidirectionalError", testUnidirectionalError) , ("InvalidCloseConnection", testInvalidCloseConnection) , ("MaxLength", testMaxLength) , ("CloseEndPoint", testCloseEndPoint) , ("CheckPeerHostReject", testCheckPeerHostReject) , ("CheckPeerHostResolve", testCheckPeerHostResolve) ] -- Run the generic tests even if the TCP specific tests failed.. testTransport (either (Left . show) (Right) <$> createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters) -- ..but if the generic tests pass, still fail if the specific tests did not case tcpResult of Left err -> throwIO err Right () -> return ()