diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,38 @@ # Revision history for network-run +## 0.5.0 + +* Fixing a bug that TimeoutServer is not killed. +* Breaking change: the signatures of Timeout.runTCPServer and + Timeout.runTCPServerWithSocket are changed. + +## 0.4.3 + +* Using time-manager >= 0.2. + +## 0.4.2 + +* Using `withHandle` of time-manager. + +## 0.4.1 + +* Make sure to cancel Handles. + [#13](https://github.com/kazu-yamamoto/network-run/pull/13) +* New API: `openClientSocketWithOpts`, `openServerSocketWithOpts` + and `openTCPServerSocketWithOpts`. + [#12](https://github.com/kazu-yamamoto/network-run/pull/12) + +## 0.4.0 + +* New API: `openTCPServerSocket`, `runTCPClientWithSettings`, etc. +* Breaking change: runTCPServerSocket takes a socket itself + +## 0.3.2 + +* Add `openServerSocketWithOptions`, `openClientSocketWithOptions`, + `runTCPServerWithSocketOptions`, `runTCPClientWithSocketOptions`. + [#6](https://github.com/kazu-yamamoto/network-run/pull/6) + ## 0.3.1 * Using close instead of gracefulClose for client diff --git a/Network/Run/Core.hs b/Network/Run/Core.hs --- a/Network/Run/Core.hs +++ b/Network/Run/Core.hs @@ -1,16 +1,27 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Run.Core ( resolve, openSocket, openClientSocket, + openClientSocketWithOptions, + openClientSocketWithOpts, openServerSocket, + openServerSocketWithOptions, + openServerSocketWithOpts, + openTCPServerSocket, + openTCPServerSocketWithOptions, + openTCPServerSocketWithOpts, gclose, + labelMe, ) where +import Data.List.NonEmpty (NonEmpty) +import Control.Arrow +import Control.Concurrent import qualified Control.Exception as E import Control.Monad (when) +import GHC.Conc.Sync import Network.Socket resolve @@ -18,9 +29,10 @@ -> Maybe HostName -> ServiceName -> [AddrInfoFlag] + -> (NonEmpty AddrInfo -> AddrInfo) -> IO AddrInfo -resolve socketType mhost port flags = - head <$> getAddrInfo (Just hints) mhost (Just port) +resolve socketType mhost port flags select = + select <$> getAddrInfo (Just hints) mhost (Just port) where hints = defaultHints @@ -33,32 +45,117 @@ openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) #endif +-- | This is the same as +-- +-- @ +-- 'openClientSocketWithOptions' [] +-- @ openClientSocket :: AddrInfo -> IO Socket -openClientSocket ai = do - sock <- openSocket ai - connect sock $ addrAddress ai +openClientSocket = openClientSocketWithOptions [] + +-- | Open a client socket with the given options +-- +-- The options are set before 'connect'. This is equivalent to +-- +-- @ +-- 'openClientSocketWithOpts' . 'map' ('second' 'SockOptValue') +-- @ +openClientSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket +openClientSocketWithOptions = openClientSocketWithOpts . map (second SockOptValue) + +-- | Open a client socket with the given options +-- +-- This must be used rather than 'openClientSocketWithOptions' for options such +-- as 'Network.Socket.Linger' which require a composite value +-- ('Network.Socket.StructLinger'). +-- +-- The options are set before 'connect'. +openClientSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket +openClientSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do + mapM_ (uncurry $ setSockOptValue sock) opts + connect sock $ addrAddress addr return sock -- | Open socket for server use -- --- The socket is configured to +-- This is the same as: -- +-- @ +-- 'openServerSocketWithOptions' [] +-- @ +openServerSocket :: AddrInfo -> IO Socket +openServerSocket = openServerSocketWithOptions [] + +-- | Open socket for server use, and set the provided options before binding. +-- +-- This is equivalent to +-- +-- @ +-- 'openServerSocketWithOpts' . 'map' ('second' 'SockOptValue') +-- @ +openServerSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket +openServerSocketWithOptions = openServerSocketWithOpts . map (second SockOptValue) + +-- | Open socket for server use, and set the provided options before binding. +-- +-- In addition to the given options, the socket is configured to +-- -- * allow reuse of local addresses (SO_REUSEADDR) -- * automatically be closed during a successful @execve@ (FD_CLOEXEC) -- * bind to the address specified -openServerSocket :: AddrInfo -> IO Socket -openServerSocket addr = E.bracketOnError (openSocket addr) close $ \sock -> do +openServerSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket +openServerSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do setSocketOption sock ReuseAddr 1 #if !defined(openbsd_HOST_OS) when (addrFamily addr == AF_INET6) $ setSocketOption sock IPv6Only 1 #endif - withFdSocket sock $ setCloseOnExecIfNeeded + mapM_ (uncurry $ setSockOptValue sock) opts + withFdSocket sock setCloseOnExecIfNeeded bind sock $ addrAddress addr return sock +-- | Open TCP socket for server use +-- +-- This is the same as: +-- +-- @ +-- 'openTCPServerSocketWithOptions' [] +-- @ +openTCPServerSocket :: AddrInfo -> IO Socket +openTCPServerSocket = openTCPServerSocketWithOptions [] + +-- | Open socket for server use, and set the provided options before binding. +-- +-- This is equivalent to +-- +-- @ +-- 'openTCPServerSocketWithOpts' . 'map' ('second' 'SockOptValue') +-- @ +openTCPServerSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket +openTCPServerSocketWithOptions = openTCPServerSocketWithOpts . map (second SockOptValue) + +-- | Open socket for server use, and set the provided options before binding. +-- +-- In addition to the given options, the socket is configured to +-- +-- * allow reuse of local addresses (SO_REUSEADDR) +-- * automatically be closed during a successful @execve@ (FD_CLOEXEC) +-- * bind to the address specified +-- * listen with queue length with 1024 +openTCPServerSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket +openTCPServerSocketWithOpts opts addr = do + sock <- openServerSocketWithOpts opts addr + listen sock 1024 + return sock + gclose :: Socket -> IO () #if MIN_VERSION_network(3,1,1) gclose sock = gracefulClose sock 5000 #else gclose = close #endif + +labelMe :: String -> IO () +labelMe name = do + tid <- myThreadId + labelThread tid name diff --git a/Network/Run/TCP.hs b/Network/Run/TCP.hs --- a/Network/Run/TCP.hs +++ b/Network/Run/TCP.hs @@ -1,58 +1,93 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Simple functions to run TCP clients and servers. module Network.Run.TCP ( - runTCPClient, + -- * Server runTCPServer, - - -- * Generalized API runTCPServerWithSocket, - openServerSocket, + openTCPServerSocket, + openTCPServerSocketWithOptions, + openTCPServerSocketWithOpts, + resolve, + + -- * Client + runTCPClient, + Settings, + defaultSettings, + settingsOpenClientSocket, + settingsSelectAddrInfo, + runTCPClientWithSettings, + openClientSocket, + openClientSocketWithOptions, + openClientSocketWithOpts, ) where import Control.Concurrent (forkFinally) import qualified Control.Exception as E import Control.Monad (forever, void) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Network.Socket import Network.Run.Core --- | Running a TCP client with a connected socket. -runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a -runTCPClient host port client = withSocketsDo $ do - addr <- resolve Stream (Just host) port [AI_ADDRCONFIG] - E.bracket (open addr) close client - where - open addr = E.bracketOnError (openClientSocket addr) close return +---------------------------------------------------------------- -- | Running a TCP server with an accepted socket and its peer name. runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a -runTCPServer = runTCPServerWithSocket openServerSocket +runTCPServer mhost port server = do + addr <- resolve Stream mhost port [AI_PASSIVE] NE.head + E.bracket (openTCPServerSocket addr) close $ \sock -> + runTCPServerWithSocket sock server +-- | Running a TCP client with a connected socket for a given listen +-- socket. +runTCPServerWithSocket + :: Socket + -> (Socket -> IO a) + -- ^ Called for each incoming connection, in a new thread + -> IO a +runTCPServerWithSocket sock server = forever $ + E.bracketOnError (accept sock) (close . fst) $ + \(conn, _peer) -> + void $ forkFinally (labelMe "TCP server" >> server conn) (const $ gclose conn) + ---------------------------------------------------------------- --- Generalized API --- | Generalization of 'runTCPServer' -runTCPServerWithSocket - :: (AddrInfo -> IO Socket) - -- ^ Initialize socket. - -- - -- This function is called while exceptions are masked. - -- - -- The default (used by 'runTCPServer') is 'openServerSocket'. - -> Maybe HostName +-- | Settings for client. +data Settings = Settings + { settingsOpenClientSocket :: AddrInfo -> IO Socket + -- ^ Opening a socket. Use 'openClientSocketWithOptions' to specify 'SocketOption' + , settingsSelectAddrInfo :: NonEmpty AddrInfo -> AddrInfo + -- ^ Selecting 'AddrInfo'. + } + +-- | Default settings. +defaultSettings :: Settings +defaultSettings = + Settings + { settingsOpenClientSocket = openClientSocket + , settingsSelectAddrInfo = NE.head + } + +-- | Running a TCP client with a connected socket. +-- +-- This is the same as: +-- +-- @ +-- 'runTCPClientWithSettings' 'defaultSettings' +-- @ +runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPClient = runTCPClientWithSettings defaultSettings + +-- | Running a TCP client with a connected socket. +runTCPClientWithSettings + :: Settings + -> HostName -> ServiceName -> (Socket -> IO a) - -- ^ Called for each incoming connection, in a new thread -> IO a -runTCPServerWithSocket initSocket mhost port server = withSocketsDo $ do - addr <- resolve Stream mhost port [AI_PASSIVE] - E.bracket (open addr) close loop - where - open addr = E.bracketOnError (initSocket addr) close $ \sock -> do - listen sock 1024 - return sock - loop sock = forever $ - E.bracketOnError (accept sock) (close . fst) $ - \(conn, _peer) -> - void $ forkFinally (server conn) (const $ gclose conn) +runTCPClientWithSettings Settings{..} host port client = do + addr <- resolve Stream (Just host) port [AI_ADDRCONFIG] settingsSelectAddrInfo + E.bracket (settingsOpenClientSocket addr) close client diff --git a/Network/Run/TCP/Timeout.hs b/Network/Run/TCP/Timeout.hs --- a/Network/Run/TCP/Timeout.hs +++ b/Network/Run/TCP/Timeout.hs @@ -7,13 +7,15 @@ -- * Generalized API runTCPServerWithSocket, - openClientSocket, openServerSocket, + openServerSocketWithOptions, + openServerSocketWithOpts, ) where import Control.Concurrent (forkFinally) import qualified Control.Exception as E import Control.Monad (forever, void) +import qualified Data.List.NonEmpty as NE import Network.Socket import qualified System.TimeManager as T @@ -29,42 +31,32 @@ -- ^ A connected socket -> IO a --- | Running a TCP server with an accepted socket and its peer name. +-- | Running a TCP server with a connected socket. runTCPServer :: Int -- ^ Timeout in second. -> Maybe HostName -> ServiceName - -> TimeoutServer a - -> IO a -runTCPServer = runTCPServerWithSocket openServerSocket - ----------------------------------------------------------------- --- Generalized API + -> TimeoutServer () + -> IO () +runTCPServer tm mhost port server = do + addr <- resolve Stream mhost port [AI_PASSIVE] NE.head + E.bracket (openTCPServerSocket addr) close $ \sock -> + runTCPServerWithSocket tm sock server --- | Generalization of 'runTCPServer' --- --- See 'Network.Run.TCP.runTCPServerWithSocket' for additional discussion. +-- | Running a TCP client with a connected socket for a given listen +-- socket. runTCPServerWithSocket - :: (AddrInfo -> IO Socket) - -> Int + :: Int -- ^ Timeout in second. - -> Maybe HostName - -> ServiceName - -> TimeoutServer a - -> IO a -runTCPServerWithSocket initSocket tm mhost port server = withSocketsDo $ do - T.withManager (tm * 1000000) $ \mgr -> do - addr <- resolve Stream mhost port [AI_PASSIVE] - E.bracket (open addr) close $ loop mgr + -> Socket + -> TimeoutServer () + -> IO () +runTCPServerWithSocket tm sock server = do + T.withManager (tm * 1000000) $ \mgr -> forever $ + E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> + void $ forkFinally (runServer mgr conn) (const $ gclose conn) where - open addr = E.bracketOnError (initSocket addr) close $ \sock -> do - listen sock 1024 - return sock - loop mgr sock = forever $ - E.bracketOnError (accept sock) (close . fst) $ - \(conn, _peer) -> - void $ forkFinally (server' mgr conn) (const $ gclose conn) - server' mgr conn = do - th <- T.registerKillThread mgr $ return () - server mgr th conn + runServer mgr conn = do + labelMe "TCP timeout server" + T.withHandleKillThread mgr (return ()) $ \th -> server mgr th conn diff --git a/Network/Run/UDP.hs b/Network/Run/UDP.hs --- a/Network/Run/UDP.hs +++ b/Network/Run/UDP.hs @@ -9,6 +9,7 @@ import qualified Control.Exception as E import Control.Monad (forever, void) import Data.ByteString (ByteString) +import qualified Data.List.NonEmpty as NE import Network.Socket import Network.Socket.ByteString @@ -19,15 +20,15 @@ -- server's socket address. -- They should be used with 'sendTo'. runUDPClient :: HostName -> ServiceName -> (Socket -> SockAddr -> IO a) -> IO a -runUDPClient host port client = withSocketsDo $ do - addr <- resolve Datagram (Just host) port [AI_ADDRCONFIG] +runUDPClient host port client = do + addr <- resolve Datagram (Just host) port [AI_ADDRCONFIG] NE.head let sockAddr = addrAddress addr E.bracket (openSocket addr) close $ \sock -> client sock sockAddr -- | Running a UDP server with an open socket in a single Haskell thread. runUDPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a -runUDPServer mhost port server = withSocketsDo $ do - addr <- resolve Datagram mhost port [AI_PASSIVE] +runUDPServer mhost port server = do + addr <- resolve Datagram mhost port [AI_PASSIVE] NE.head E.bracket (openServerSocket addr) close server -- | Running a UDP server with a connected socket in each Haskell thread. @@ -46,19 +47,21 @@ mapM_ (forkIO . run) hs run h where - run host = runUDPServer (Just host) port $ \lsock -> forever $ do - (bs0, peeraddr) <- recvFrom lsock 2048 - let family = case peeraddr of - SockAddrInet{} -> AF_INET - SockAddrInet6{} -> AF_INET6 - _ -> error "family" - hints = - defaultHints - { addrSocketType = Datagram - , addrFamily = family - , addrFlags = [AI_PASSIVE] - } - addr <- head <$> getAddrInfo (Just hints) Nothing (Just port) - s <- openServerSocket addr - connect s peeraddr - void $ forkFinally (server s bs0) (\_ -> close s) + run host = do + labelMe $ "UDP server for " ++ h + runUDPServer (Just host) port $ \lsock -> forever $ do + (bs0, peeraddr) <- recvFrom lsock 2048 + let family = case peeraddr of + SockAddrInet{} -> AF_INET + SockAddrInet6{} -> AF_INET6 + _ -> error "family" + hints = + defaultHints + { addrSocketType = Datagram + , addrFamily = family + , addrFlags = [AI_PASSIVE] + } + addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just port) + s <- openServerSocket addr + connect s peeraddr + void $ forkFinally (labelMe "UDP server" >> server s bs0) (\_ -> close s) diff --git a/network-run.cabal b/network-run.cabal --- a/network-run.cabal +++ b/network-run.cabal @@ -1,30 +1,30 @@ -name: network-run -version: 0.3.1 -synopsis: Simple network runner library -description: Simple functions to run network clients and servers. --- bug-reports: -license: BSD3 -license-file: LICENSE -author: Kazu Yamamoto -maintainer: kazu@iij.ad.jp -category: Network -build-type: Simple -extra-source-files: CHANGELOG.md -cabal-version: >=1.10 +cabal-version: >=1.10 +name: network-run +version: 0.5.0 +license: BSD3 +license-file: LICENSE +maintainer: kazu@iij.ad.jp +author: Kazu Yamamoto +synopsis: Simple network runner library +description: Simple functions to run network clients and servers. +category: Network +build-type: Simple +extra-source-files: CHANGELOG.md +source-repository head + type: git + location: https://github.com/kazu-yamamoto/network-run + library - exposed-modules: Network.Run.TCP - Network.Run.TCP.Timeout - Network.Run.UDP - other-modules: Network.Run.Core - -- other-extensions: - build-depends: base >= 4 && < 5 - , bytestring - , network >= 3.1.0 - , time-manager - -- hs-source-dirs: - default-language: Haskell2010 + exposed-modules: + Network.Run.TCP + Network.Run.TCP.Timeout + Network.Run.UDP -source-repository head - type: git - location: https://github.com/kazu-yamamoto/network-run + other-modules: Network.Run.Core + default-language: Haskell2010 + build-depends: + base >=4 && <5, + bytestring, + network >=3.2.4, + time-manager >=0.2 && <0.4