network-run 0.2.5 → 0.2.6
raw patch · 6 files changed
+98/−63 lines, 6 filesdep +time-managersetup-changed
Dependencies added: time-manager
Files
- Network/Run/Core.hs +18/−9
- Network/Run/TCP.hs +8/−36
- Network/Run/TCP/Timeout.hs +49/−0
- Network/Run/UDP.hs +18/−16
- Setup.hs +1/−0
- network-run.cabal +4/−2
Network/Run/Core.hs view
@@ -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
Network/Run/TCP.hs view
@@ -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)
+ Network/Run/TCP/Timeout.hs view
@@ -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
Network/Run/UDP.hs view
@@ -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
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
network-run.cabal view
@@ -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