Skip to content

Commit

Permalink
Merge pull request #50 from avieth/avieth/separate_bind_address
Browse files Browse the repository at this point in the history 
Separate bind address
  • Loading branch information
@facundominguez
facundominguez committed Feb 25, 2017
2 parents f2f761b + db3a3b8 commit 6f8bf9d
Show file tree
Hide file tree
Showing 2 changed files with 43 additions and 31 deletions.
40 changes: 25 additions & 15 deletions src/Network/Transport/TCP.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -275,10 +275,12 @@ import qualified Data.ByteString as BS (length)
-- ValidRemoteEndPointState).

data TCPTransport = TCPTransport
{ transportHost :: !N.HostName
, transportPort :: !N.ServiceName
, transportState :: !(MVar TransportState)
, transportParams :: !TCPParameters
{ transportHost :: !N.HostName
, transportPort :: !N.ServiceName
, transportBindHost :: !N.HostName
, transportBindPort :: !N.ServiceName
, transportState :: !(MVar TransportState)
, transportParams :: !TCPParameters
}

data TransportState =
Expand Down Expand Up @@ -497,20 +499,25 @@ data TransportInternals = TransportInternals
--------------------------------------------------------------------------------

-- | Create a TCP transport
createTransport :: N.HostName
-> N.ServiceName
createTransport :: N.HostName -- ^ Bind host name.
-> N.ServiceName -- ^ Bind port.
-> (N.ServiceName -> (N.HostName, N.ServiceName))
-- ^ External address host name and port, computed from the
-- actual bind port.
-> TCPParameters
-> IO (Either IOException Transport)
createTransport host port params =
either Left (Right . fst) <$> createTransportExposeInternals host port params
createTransport bindHost bindPort mkExternal params =
either Left (Right . fst) <$>
createTransportExposeInternals bindHost bindPort mkExternal params

-- | You should probably not use this function (used for unit testing only)
createTransportExposeInternals
:: N.HostName
-> N.ServiceName
-> (N.ServiceName -> (N.HostName, N.ServiceName))
-> TCPParameters
-> IO (Either IOException (Transport, TransportInternals))
createTransportExposeInternals host port params = do
createTransportExposeInternals bindHost bindPort mkExternal params = do
state <- newMVar . TransportValid $ ValidTransportState
{ _localEndPoints = Map.empty
, _nextEndPointId = 0
Expand All @@ -526,14 +533,17 @@ createTransportExposeInternals host port params = do
-- completes (see description of 'forkServer'), yet we need the port to
-- construct a transport. So we tie a recursive knot.
(port', result) <- do
let transport = TCPTransport { transportState = state
, transportHost = host
, transportPort = port'
, transportParams = params
let (externalHost, externalPort) = mkExternal port'
let transport = TCPTransport { transportState = state
, transportHost = externalHost
, transportPort = externalPort
, transportBindHost = bindHost
, transportBindPort = port'
, transportParams = params
}
bracketOnError (forkServer
host
port
bindHost
bindPort
(tcpBacklog params)
(tcpReuseServerAddr params)
(terminationHandler transport)
Expand Down
34 changes: 18 additions & 16 deletions tests/TestTCP.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE RebindableSyntax, TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

Expand Down Expand Up @@ -111,7 +112,7 @@ testEarlyDisconnect = do
server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
server serverAddr clientAddr serverDone = do
tlog "Server"
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right endpoint <- newEndPoint transport
putMVar serverAddr (address endpoint)
theirAddr <- readMVar clientAddr
Expand Down Expand Up @@ -216,7 +217,7 @@ testEarlyCloseSocket = do
server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO ()
server serverAddr clientAddr serverDone = do
tlog "Server"
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right endpoint <- newEndPoint transport
putMVar serverAddr (address endpoint)
theirAddr <- readMVar clientAddr
Expand Down Expand Up @@ -324,13 +325,13 @@ testEarlyCloseSocket = do
-- | Test the creation of a transport with an invalid address
testInvalidAddress :: IO ()
testInvalidAddress = do
Left _ <- createTransport "invalidHostName" "0" defaultTCPParameters
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" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right endpoint <- newEndPoint transport

-- Syntax error in the endpoint address
Expand Down Expand Up @@ -361,7 +362,7 @@ testIgnoreCloseSocket = do
clientDone <- newEmptyMVar
serverDone <- newEmptyMVar
connectionEstablished <- newEmptyMVar
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters

-- Server
forkTry $ do
Expand Down Expand Up @@ -451,7 +452,7 @@ testBlockAfterCloseSocket = do
clientDone <- newEmptyMVar
serverDone <- newEmptyMVar
connectionEstablished <- newEmptyMVar
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters

-- Server
forkTry $ do
Expand Down Expand Up @@ -531,7 +532,7 @@ testUnnecessaryConnect numThreads = do
serverAddr <- newEmptyMVar

forkTry $ do
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right endpoint <- newEndPoint transport
putMVar serverAddr (address endpoint)

Expand Down Expand Up @@ -570,11 +571,11 @@ testUnnecessaryConnect numThreads = do
-- | Test that we can create "many" transport instances
testMany :: IO ()
testMany = do
Right masterTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters
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" defaultTCPParameters
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)
Expand All @@ -591,7 +592,7 @@ testMany = do
-- | Test what happens when the transport breaks completely
testBreakTransport :: IO ()
testBreakTransport = do
Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" defaultTCPParameters
Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right endpoint <- newEndPoint transport

killThread (transportThread internals) -- Uh oh
Expand Down Expand Up @@ -647,7 +648,7 @@ testReconnect = do

-- Client
forkTry $ do
Right transport <- createTransport "127.0.0.1" "0" defaultTCPParameters
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

Expand Down Expand Up @@ -723,7 +724,7 @@ testUnidirectionalError = do

-- Client
forkTry $ do
Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" defaultTCPParameters
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

Expand Down Expand Up @@ -778,7 +779,7 @@ testUnidirectionalError = do

testInvalidCloseConnection :: IO ()
testInvalidCloseConnection = do
Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" defaultTCPParameters
Right (transport, internals) <- createTransportExposeInternals "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
serverAddr <- newEmptyMVar
clientDone <- newEmptyMVar
serverDone <- newEmptyMVar
Expand Down Expand Up @@ -820,9 +821,10 @@ testUseRandomPort :: IO ()
testUseRandomPort = do
testDone <- newEmptyMVar
forkTry $ do
Right transport1 <- createTransport "127.0.0.1" "0" defaultTCPParameters
Right transport1 <- createTransport "127.0.0.1" "0" ((,) "127.0.0.1") defaultTCPParameters
Right ep1 <- newEndPoint transport1
Right transport2 <- createTransport "127.0.0.1" "0" defaultTCPParameters
-- 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
Expand All @@ -848,7 +850,7 @@ main = do
]
-- Run the generic tests even if the TCP specific tests failed..
testTransport (either (Left . show) (Right) <$>
createTransport "127.0.0.1" "0" defaultTCPParameters)
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
Expand Down

0 comments on commit 6f8bf9d

Please sign in to comment.