diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2014-12-09 Tim Watson 0.4.1 + +* Update dependencies + 2014-05-30 Tim Watson 0.4.0 * Update dependencies diff --git a/network-transport-tcp.cabal b/network-transport-tcp.cabal --- a/network-transport-tcp.cabal +++ b/network-transport-tcp.cabal @@ -1,6 +1,6 @@ Name: network-transport-tcp -Version: 0.4.0 -Cabal-Version: >=1.8 +Version: 0.4.1 +Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-file: LICENSE @@ -12,7 +12,7 @@ Bug-Reports: https://cloud-haskell.atlassian.net/browse/NTTCP Synopsis: TCP instantiation of Network.Transport Description: TCP instantiation of Network.Transport -Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2 +Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2 GHC==7.6.2 Category: Network extra-source-files: ChangeLog @@ -26,14 +26,16 @@ Library Build-Depends: base >= 4.3 && < 5, - network-transport >= 0.4.0.0 && < 0.5, + network-transport >= 0.4.1.0 && < 0.5, data-accessor >= 0.2 && < 0.3, containers >= 0.4 && < 0.6, bytestring >= 0.9 && < 0.11, - network >= 2.3 && < 2.5 + network >= 2.3 && < 2.7 Exposed-modules: Network.Transport.TCP, Network.Transport.TCP.Internal - Extensions: CPP + Default-Extensions: CPP + default-language: Haskell2010 + Other-Extensions: RecursiveDo ghc-options: -Wall -fno-warn-unused-do-bind HS-Source-Dirs: src If flag(use-mock-network) @@ -45,14 +47,15 @@ Type: exitcode-stdio-1.0 Main-Is: TestTCP.hs Build-Depends: base >= 4.3 && < 5, - network-transport-tests >= 0.1.0.1 && < 0.2, - network >= 2.3 && < 2.5, - network-transport >= 0.4.0.0 && < 0.5, + network-transport-tests >= 0.2.1.0 && < 0.3, + network >= 2.3 && < 2.7, + network-transport >= 0.4.1.0 && < 0.5, network-transport-tcp >= 0.3 && < 0.5 ghc-options: -threaded -rtsopts -with-rtsopts=-N HS-Source-Dirs: tests Extensions: CPP, OverloadedStrings + default-language: Haskell2010 If flag(use-mock-network) CPP-Options: -DUSE_MOCK_NETWORK @@ -86,3 +89,4 @@ OverloadedStrings DeriveDataTypeable MultiParamTypeClasses + default-language: Haskell2010 diff --git a/src/Network/Transport/TCP.hs b/src/Network/Transport/TCP.hs --- a/src/Network/Transport/TCP.hs +++ b/src/Network/Transport/TCP.hs @@ -10,6 +10,10 @@ -- Applications that use the TCP transport should use -- 'Network.Socket.withSocketsDo' in their main function for Windows -- compatibility (see "Network.Socket"). + +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} + module Network.Transport.TCP ( -- * Main API createTransport @@ -480,20 +484,26 @@ { _localEndPoints = Map.empty , _nextEndPointId = 0 } - let transport = TCPTransport { transportState = state - , transportHost = host - , transportPort = port - , transportParams = params - } - tryIO $ bracketOnError (forkServer + tryIO $ mdo + -- We don't know for sure the actual port 'forkServer' binded until it + -- 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 + } + bracketOnError (forkServer host port (tcpBacklog params) (tcpReuseServerAddr params) (terminationHandler transport) (handleConnectionRequest transport)) - killThread - (mkTransport transport) + (\(_port', tid) -> killThread tid) + (\(port'', tid) -> (port'',) <$> mkTransport transport tid) + return result where mkTransport :: TCPTransport -> ThreadId diff --git a/src/Network/Transport/TCP/Internal.hs b/src/Network/Transport/TCP/Internal.hs --- a/src/Network/Transport/TCP/Internal.hs +++ b/src/Network/Transport/TCP/Internal.hs @@ -34,6 +34,7 @@ , setSocketOption , accept , sClose + , socketPort ) #ifdef USE_MOCK_NETWORK @@ -45,7 +46,7 @@ import Control.Concurrent (ThreadId) import Control.Monad (forever, when) import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS (length, concat, null) import Data.Int (Int32) @@ -68,13 +69,17 @@ -- or the server will block. Once a thread has been spawned it will be the -- responsibility of the new thread to close the socket when an exception -- occurs. +-- +-- The return value includes the port was bound to. This is not always the same +-- port as that given in the argument. For example, binding to port 0 actually +-- binds to a random port, selected by the OS. forkServer :: N.HostName -- ^ Host -> N.ServiceName -- ^ Port -> Int -- ^ Backlog (maximum number of queued connections) -> Bool -- ^ Set ReuseAddr option? -> (SomeException -> IO ()) -- ^ Termination handler -> (N.Socket -> IO ()) -- ^ Request handler - -> IO ThreadId + -> IO (N.ServiceName, ThreadId) forkServer host port backlog reuseAddr terminationHandler requestHandler = do -- Resolve the specified address. By specification, getAddrInfo will never -- return an empty list (but will throw an exception instead) and will return @@ -91,10 +96,11 @@ -- /before/ any asynchronous exception occurs. So we mask_, then fork -- (the child thread inherits the masked state from the parent), then -- unmask only inside the catch. - mask_ $ forkIOWithUnmask $ \unmask -> - catch (unmask (forever $ acceptRequest sock)) $ \ex -> do - tryCloseSocket sock - terminationHandler ex + (,) <$> fmap show (N.socketPort sock) <*> + (mask_ $ forkIOWithUnmask $ \unmask -> + catch (unmask (forever $ acceptRequest sock)) $ \ex -> do + tryCloseSocket sock + terminationHandler ex) where acceptRequest :: N.Socket -> IO () acceptRequest sock = bracketOnError (N.accept sock) diff --git a/tests/TestTCP.hs b/tests/TestTCP.hs --- a/tests/TestTCP.hs +++ b/tests/TestTCP.hs @@ -773,6 +773,20 @@ mapM_ takeMVar [clientDone, serverDone] +testUseRandomPort :: IO () +testUseRandomPort = do + testDone <- newEmptyMVar + forkTry $ do + Right transport1 <- createTransport "127.0.0.1" "0" defaultTCPParameters + Right ep1 <- newEndPoint transport1 + Right transport2 <- createTransport "127.0.0.1" "0" defaultTCPParameters + Right ep2 <- newEndPoint transport2 + Right conn1 <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive ep1 + putMVar testDone () + takeMVar testDone + + main :: IO () main = do portMVar <- newEmptyMVar @@ -791,6 +805,7 @@ , ("Reconnect", testReconnect nextPort) , ("UnidirectionalError", testUnidirectionalError nextPort) , ("InvalidCloseConnection", testInvalidCloseConnection nextPort) + , ("Use random port" , testUseRandomPort) ] -- Run the generic tests even if the TCP specific tests failed.. testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)