diff --git a/Network/Run/Core.hs b/Network/Run/Core.hs --- a/Network/Run/Core.hs +++ b/Network/Run/Core.hs @@ -2,22 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Run.Core ( - resolve - , openSocket - , openServerSocket - ) where + resolve, + openSocket, + openServerSocket, + gclose, +) where import qualified Control.Exception as E import Network.Socket resolve :: SocketType -> Maybe HostName -> ServiceName -> Bool -> IO AddrInfo resolve socketType mhost port passive = - head <$> getAddrInfo (Just hints) mhost (Just port) + head <$> getAddrInfo (Just hints) mhost (Just port) where - hints = defaultHints { - addrSocketType = socketType - , addrFlags = if passive then [AI_PASSIVE] else [] - } + hints = + defaultHints + { addrSocketType = socketType + , addrFlags = if passive then [AI_PASSIVE] else [] + } #if !MIN_VERSION_network(3,1,2) openSocket :: AddrInfo -> IO Socket @@ -30,3 +32,10 @@ withFdSocket sock $ setCloseOnExecIfNeeded bind sock $ addrAddress addr return sock + +gclose :: Socket -> IO () +#if MIN_VERSION_network(3,1,1) +gclose sock = gracefulClose sock 5000 +#else +gclose = close +#endif diff --git a/Network/Run/TCP.hs b/Network/Run/TCP.hs --- a/Network/Run/TCP.hs +++ b/Network/Run/TCP.hs @@ -1,21 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -- | Simple functions to run TCP clients and servers. module Network.Run.TCP ( - runTCPClient - , runTCPServer - ) where + runTCPClient, + runTCPServer, +) where import Control.Concurrent (forkFinally) import qualified Control.Exception as E import Control.Monad (forever, void) import Network.Socket -#if defined(mingw32_HOST_OS) -import Control.Concurrent.MVar -import Control.Concurrent -import qualified Control.Exception -#endif import Network.Run.Core @@ -23,11 +17,7 @@ runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a runTCPClient host port client = withSocketsDo $ do addr <- resolve Stream (Just host) port False -#if MIN_VERSION_network(3,1,1) - E.bracket (open addr) (\sock -> gracefulClose sock 5000) client -#else - E.bracket (open addr) close client -#endif + E.bracket (open addr) gclose client where open addr = E.bracketOnError (openSocket addr) close $ \sock -> do connect sock $ addrAddress addr @@ -42,25 +32,7 @@ open addr = E.bracketOnError (openServerSocket addr) close $ \sock -> do listen sock 1024 return sock - loop sock = forever $ E.bracketOnError (windowsThreadBlockHack (accept sock)) (close . fst) $ - \(conn, _peer) -> -#if MIN_VERSION_network(3,1,1) - void $ forkFinally (server conn) (const $ gracefulClose conn 5000) -#else - void $ forkFinally (server conn) (const $ close conn) -#endif - - -#if defined(mingw32_HOST_OS) -windowsThreadBlockHack :: IO a -> IO a -windowsThreadBlockHack act = do - var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a)) - void . forkIO $ Control.Exception.try act >>= putMVar var - res <- takeMVar var - case res of - Left e -> Control.Exception.throwIO e - Right r -> return r -#else -windowsThreadBlockHack :: IO a -> IO a -windowsThreadBlockHack = id -#endif + loop sock = forever $ + E.bracketOnError (accept sock) (close . fst) $ + \(conn, _peer) -> + void $ forkFinally (server conn) (const $ gclose conn) diff --git a/Network/Run/TCP/Timeout.hs b/Network/Run/TCP/Timeout.hs new file mode 100644 --- /dev/null +++ b/Network/Run/TCP/Timeout.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Simple functions to run TCP clients and servers. +module Network.Run.TCP.Timeout ( + runTCPServer, + TimeoutServer, +) where + +import Control.Concurrent (forkFinally) +import qualified Control.Exception as E +import Control.Monad (forever, void) +import Network.Socket +import qualified System.TimeManager as T + +import Network.Run.Core + +-- | A server type +type TimeoutServer a = + T.Manager + -- ^ A global timeout manager + -> T.Handle + -- ^ A thread-local timeout handler + -> Socket + -- ^ A connected socket + -> IO a + +-- | Running a TCP server with an accepted socket and its peer name. +runTCPServer + :: Int + -- ^ Timeout in second. + -> Maybe HostName + -> ServiceName + -> TimeoutServer a + -> IO a +runTCPServer tm mhost port server = withSocketsDo $ do + T.withManager (tm * 1000000) $ \mgr -> do + addr <- resolve Stream mhost port True + E.bracket (open addr) close $ loop mgr + where + open addr = E.bracketOnError (openServerSocket 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 diff --git a/Network/Run/UDP.hs b/Network/Run/UDP.hs --- a/Network/Run/UDP.hs +++ b/Network/Run/UDP.hs @@ -1,11 +1,11 @@ -- | Simple functions to run UDP clients and servers. module Network.Run.UDP ( - runUDPClient - , runUDPServer - , runUDPServerFork - ) where + runUDPClient, + runUDPServer, + runUDPServerFork, +) where -import Control.Concurrent (forkIO, forkFinally) +import Control.Concurrent (forkFinally, forkIO) import qualified Control.Exception as E import Control.Monad (forever, void) import Data.ByteString (ByteString) @@ -39,23 +39,25 @@ -- resulting in __(UDP,addrS:portS,addrC:portC)__ where -- __addrS__ is given magically. -- This approach is fragile due to NAT rebidings. -runUDPServerFork :: [HostName] -> ServiceName -> (Socket -> ByteString -> IO ()) -> IO () +runUDPServerFork + :: [HostName] -> ServiceName -> (Socket -> ByteString -> IO ()) -> IO () runUDPServerFork [] _ _ = return () -runUDPServerFork (h:hs) port server = do +runUDPServerFork (h : hs) port server = do mapM_ (forkIO . run) hs run h where run host = runUDPServer (Just host) port $ \lsock -> forever $ do - (bs0,peeraddr) <- recvFrom lsock 2048 + (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] - } + 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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/network-run.cabal b/network-run.cabal --- a/network-run.cabal +++ b/network-run.cabal @@ -1,5 +1,5 @@ name: network-run -version: 0.2.5 +version: 0.2.6 synopsis: Simple network runner library description: Simple functions to run network clients and servers. -- bug-reports: @@ -14,12 +14,14 @@ 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 - , network >= 3.1.0 , bytestring + , network >= 3.1.0 + , time-manager -- hs-source-dirs: default-language: Haskell2010