Merge pull request #50 from avieth/avieth/separate_bind_address

Separate bind address

Author: facundominguez

src/Network/Transport/TCP.hs

@@ -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 =
@@ -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
@@ -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)

tests/TestTCP.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE RebindableSyntax, TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Main where
 
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)
 
@@ -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)
@@ -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
@@ -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
 
@@ -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
 
@@ -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
@@ -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
@@ -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