network-run 0.6.0 → 0.8.0
raw patch · 10 files changed
Files
- CHANGELOG.md +39/−0
- Network/Run/Core.hs +104/−20
- Network/Run/TCP.hs +32/−10
- Network/Run/TCP/Timeout.hs +29/−7
- Network/Run/UDP.hs +37/−16
- network-run.cabal +7/−5
- test/CoreSpec.hs +23/−3
- test/TCPSpec.hs +109/−6
- test/TimeoutSpec.hs +3/−2
- test/UDPSpec.hs +44/−7
CHANGELOG.md view
@@ -1,5 +1,44 @@ # Revision history for network-run +## 0.8.0++A server told to stop returns only after its connections are done.++* Wait for the connections once the server is told to stop+ [#21](https://github.com/kazu-yamamoto/network-run/pull/21)++## 0.7.1++* Sockets this library owns and has not handed to anyone are closed with+ `close(2)` rather than with `close`, which goes through the IO manager+ to tell a waiter that is not there.+* `settingsUnsafeClose` lets a server close its connections with+ `unsafeGracefulClose` or `unsafeClose`. The default keeps `close`,+ since only the caller knows whether its handler leaves a thread on the+ socket.+* Requires network 3.2.12.++## 0.7.0++* The accept loop is stopped by being told, through the new+ `settingsInstallShutdownHandler`, rather than by having the listening+ socket closed under it. It accepts with `acceptWith`, which gives up+ on the accept itself, so nothing has to be closed or interrupted. A+ closed socket still stops the loop, now by returning rather than by+ throwing.+* The UDP server's receive loop is stopped the same way, through+ `recvFromWith`, rather than by an asynchronous exception.+* Breaking change: `ServerSettings` gains `settingsInstallShutdownHandler`.+* Breaking change: the TCP servers return `IO ()` rather than `IO a`,+ since they can now return.+* `Listener` and `makeListener` are exported for servers with an accept+ loop of their own.+* Which errno `accept` may be retried on comes from network's+ `isTransientAcceptError` rather than from a list here, and this one+ was the shorter of the two: `ECONNABORTED` and `EINTR` only, where+ accept(2) names six more.+* Requires network 3.2.10 for `acceptWith`.+ ## 0.6.0 * Fixing a bug that the `[(SocketOption, Int)]` variants
Network/Run/Core.hs view
@@ -16,9 +16,14 @@ labelMe, safeAccept, safeAcceptWith,+ Listener (..),+ makeListener, ServerSettings (..), defaultServerSettings, gcloseWith,+ Connections,+ newConnections,+ waitConnections, forkWith, forkConnection, forkDatagram,@@ -27,13 +32,12 @@ import Control.Arrow hiding (loop) import Control.Concurrent+import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad (void, when) import Data.List.NonEmpty (NonEmpty)-import Foreign.C.Error (Errno (..), eCONNABORTED) import Foreign.C.Types (CInt) import GHC.Conc.Sync-import GHC.IO.Exception (IOErrorType (Interrupted), ioe_errno) import Network.Socket import System.IO.Error (ioeGetErrorType, isFullError) @@ -80,7 +84,7 @@ -- The options are set before 'connect'. openClientSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket-openClientSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do+openClientSocketWithOpts opts addr = E.bracketOnError (openSocket addr) unsafeClose $ \sock -> do mapM_ (uncurry $ setSockOptValue sock) opts connect sock $ addrAddress addr return sock@@ -126,7 +130,7 @@ -- cannot be cleared. openServerSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket-openServerSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do+openServerSocketWithOpts opts addr = E.bracketOnError (openSocket addr) unsafeClose $ \sock -> do setSocketOption sock ReuseAddr 1 #if !defined(openbsd_HOST_OS) when (addrFamily addr == AF_INET6) $ setSocketOption sock IPv6Only 1@@ -205,9 +209,33 @@ -- connection handler returns. Zero or less uses 'close' instead, -- which releases the file descriptor immediately. The default is -- 5000.+ , settingsUnsafeClose :: Bool+ -- ^ Closing a connected socket with 'unsafeGracefulClose' or+ -- 'unsafeClose', which skip the IO manager that 'close' goes through+ -- to tell a thread waiting on the socket. Set this only when the+ -- connection handler leaves no thread and no registered wait on the+ -- socket by the time it returns. The default is 'False'. , settingsAcceptRetryDelay :: Int -- ^ Microseconds to wait before retrying 'accept' after running -- out of file descriptors. The default is 100000.+ , settingsInstallShutdownHandler :: IO () -> IO ()+ -- ^ An action to install a handler (a Unix signal handler, say) which+ -- stops the server. The first argument is the action which does that:+ -- it stops the loop accepting, and the listening socket is closed+ -- afterwards by whoever opened it. It is not an action which closes+ -- that socket, and should not be used as one. The default does+ -- nothing, and the server is then stopped the other way, by an+ -- asynchronous exception to the thread running it.+ --+ -- __The server returns once the connections it is serving are+ -- done.__ Stopping ends the accepting, not the handlers: they have+ -- to end on their own, and a caller which cannot wait for them puts+ -- a limit around the server. A server stopped by an asynchronous+ -- exception does not wait.+ --+ -- This is installed once per server, and a TCP and a UDP server+ -- share nothing but these settings, so running both with one+ -- 'ServerSettings' installs it twice. } -- | Default settings. 'settingsOnException' does nothing, so the@@ -217,7 +245,9 @@ ServerSettings { settingsOnException = \_ _ -> return () , settingsGracefulCloseTimeout = 5000+ , settingsUnsafeClose = False , settingsAcceptRetryDelay = 100000+ , settingsInstallShutdownHandler = const $ return () } -- | Calling 'settingsOnException', never letting it throw. A hook@@ -234,11 +264,52 @@ -- | Closing a connected socket according to the settings. gcloseWith :: ServerSettings -> Socket -> IO () gcloseWith ServerSettings{..} sock- | settingsGracefulCloseTimeout <= 0 = close sock- | otherwise = gracefulClose sock settingsGracefulCloseTimeout+ | settingsGracefulCloseTimeout <= 0 = closer sock+ | otherwise = gracefulCloser sock settingsGracefulCloseTimeout+ where+ (closer, gracefulCloser)+ | settingsUnsafeClose = (unsafeClose, unsafeGracefulClose)+ | otherwise = (close, gracefulClose) ---------------------------------------------------------------- +-- | What an accept loop accepts through.+data Listener = Listener+ { acceptOrStop :: IO (Maybe (Socket, SockAddr))+ -- ^ Accepts a connection. 'Nothing' instead once the server has+ -- been told to stop.+ }++-- | The listener for a socket an accept loop is about to run on.+--+-- The loop is stopped by being told, through+-- 'settingsInstallShutdownHandler', not by having the socket closed+-- under it. A close ends a thread blocked on a descriptor only because+-- the event manager tells the waiter so, and that is being removed;+-- after it is, a waiter left behind on a number which has been handed to+-- someone else since would accept on that someone else's socket.+--+-- 'acceptWith' gives up on the accept itself, so nothing has to be+-- closed and nothing has to be interrupted, on any platform.+makeListener :: ServerSettings -> Socket -> IO Listener+makeListener set@ServerSettings{..} sock = do+ stopping <- newTVarIO False+ settingsInstallShutdownHandler $ atomically $ writeTVar stopping True+ return Listener{acceptOrStop = accepting stopping}+ where+ -- Closing the listening socket is how a server was stopped before+ -- there was anything to tell, and callers which do it are still out+ -- there. It means what the shutdown action means: stop accepting.+ closedAsStopped = E.handle $ \e ->+ if isClosedSocketError e then return Nothing else E.throwIO e+ accepting stopping =+ closedAsStopped $+ either (const Nothing) Just+ <$> safeAcceptWith set (acceptWith sock $ told stopping)+ told stopping = check =<< readTVar stopping++----------------------------------------------------------------+ -- | Accepting a connection, retrying on transient errors. -- -- 'accept' fails routinely for reasons which do not mean that the@@ -262,8 +333,7 @@ -- | 'safeAccept' with the accepting action passed explicitly. The -- error paths described above cannot be provoked on a real listening -- socket, so the test suite reaches them through this.-safeAcceptWith- :: ServerSettings -> IO (Socket, SockAddr) -> IO (Socket, SockAddr)+safeAcceptWith :: ServerSettings -> IO a -> IO a safeAcceptWith set@ServerSettings{..} accept' = loop where loop = do@@ -278,30 +348,42 @@ report set Nothing $ E.toException e threadDelay settingsAcceptRetryDelay loop- -- These cost nothing; retry immediately.- | ioeGetErrorType e == Interrupted -> loop- | ioe_errno e == Just connAborted -> loop+ -- One connection's failure, which costs nothing to retry.+ | isTransientAcceptError e -> loop | otherwise -> E.throwIO e - Errno connAborted = eCONNABORTED- ---------------------------------------------------------------- +-- | The threads a server has forked and which have not finished.+newtype Connections = Connections (TVar Int)++newConnections :: IO Connections+newConnections = Connections <$> newTVarIO 0++-- | Waiting until every thread forked has finished.+waitConnections :: Connections -> IO ()+waitConnections (Connections var) = atomically $ readTVar var >>= check . (== 0)+ -- | Forking a thread for an accepted socket. An exception which -- escapes the action is reported, and the socket is closed by the--- given closer in either case.+-- given closer in either case. The thread is counted from before it+-- is forked until after the socket is closed. forkWith :: ServerSettings+ -> Connections -> (Socket -> IO ()) -> Socket -> SockAddr -> IO a -> IO ()-forkWith set closer sock peer action = void $ forkFinally action finish+forkWith set (Connections var) closer sock peer action = E.mask $ \restore -> do+ atomically $ modifyTVar' var (+ 1)+ void (forkIO $ E.try (restore action) >>= finish) `E.onException` done where -- The socket must be closed even if the hook throws, which it does -- when an asynchronous exception arrives while it is running.- finish er = reporting er `E.finally` closing+ finish er = (reporting er `E.finally` closing) `E.finally` done+ done = atomically $ modifyTVar' var (subtract 1) reporting (Right _) = return () reporting (Left se) = report set (Just peer) se@@ -312,9 +394,11 @@ onCloseError e = report set (Just peer) $ E.toException e -- | 'forkWith' closing the socket gracefully. For TCP.-forkConnection :: ServerSettings -> Socket -> SockAddr -> IO a -> IO ()-forkConnection set = forkWith set (gcloseWith set)+forkConnection+ :: ServerSettings -> Connections -> Socket -> SockAddr -> IO a -> IO ()+forkConnection set conns = forkWith set conns (gcloseWith set) -- | 'forkWith' closing the socket immediately. For UDP.-forkDatagram :: ServerSettings -> Socket -> SockAddr -> IO a -> IO ()-forkDatagram set = forkWith set close+forkDatagram+ :: ServerSettings -> Connections -> Socket -> SockAddr -> IO a -> IO ()+forkDatagram set conns = forkWith set conns close
Network/Run/TCP.hs view
@@ -27,7 +27,7 @@ ) where import qualified Control.Exception as E-import Control.Monad (forever)+import Control.Monad (when) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Network.Socket@@ -42,7 +42,7 @@ -- created by this function listens on a single address family. Use -- 'runTCPServerWithSocket' with one socket per address to serve both -- IPv4 and IPv6.-runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a+runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO () runTCPServer = runTCPServerWithSettings defaultServerSettings -- | Running a TCP server with the given settings.@@ -51,11 +51,13 @@ -> Maybe HostName -> ServiceName -> (Socket -> IO a)- -> IO a+ -> IO () runTCPServerWithSettings set mhost port server = do addr <- resolve Stream mhost port [AI_PASSIVE] NE.head- E.bracket (openTCPServerSocket addr) close $ \sock ->- runTCPServerWithSocketAndSettings set sock server+ -- Closed before the connections are waited for, so that the port is+ -- free while they finish; the bracket closes it if that is not reached.+ E.bracket (openTCPServerSocket addr) unsafeClose $ \sock ->+ serve set (unsafeClose sock) sock server -- | Running a TCP server on a given listen socket. runTCPServerWithSocket@@ -63,7 +65,7 @@ -- ^ A listening socket created by 'openTCPServerSocket'. -> (Socket -> IO a) -- ^ Called for each incoming connection, in a new thread- -> IO a+ -> IO () runTCPServerWithSocket = runTCPServerWithSocketAndSettings defaultServerSettings -- | Running a TCP server on a given listen socket with the given@@ -74,10 +76,30 @@ -- ^ A listening socket created by 'openTCPServerSocket'. -> (Socket -> IO a) -- ^ Called for each incoming connection, in a new thread- -> IO a-runTCPServerWithSocketAndSettings set sock server = forever $- E.bracketOnError (safeAccept set sock) (close . fst) $ \(conn, peer) ->- forkConnection set conn peer (labelMe "TCP server" >> server conn)+ -> IO ()+runTCPServerWithSocketAndSettings set = serve set (return ())++-- | Running the accept loop, then the given action, then waiting for+-- the connections.+serve :: ServerSettings -> IO () -> Socket -> (Socket -> IO a) -> IO ()+serve set stopped sock server = do+ listener <- makeListener set sock+ conns <- newConnections+ loop listener conns+ stopped+ waitConnections conns+ where+ -- Accepting inside the acquire: once it has returned, the socket+ -- is closed if anything goes wrong before the thread owning it has+ -- been forked.+ loop listener conns = do+ more <- E.bracketOnError (acceptOrStop listener) (mapM_ (unsafeClose . fst)) $ \maccepted ->+ case maccepted of+ Nothing -> return False+ Just (conn, peer) -> do+ forkConnection set conns conn peer (labelMe "TCP server" >> server conn)+ return True+ when more $ loop listener conns ----------------------------------------------------------------
Network/Run/TCP/Timeout.hs view
@@ -16,7 +16,7 @@ ) where import qualified Control.Exception as E-import Control.Monad (forever)+import Control.Monad (when) import qualified Data.List.NonEmpty as NE import Network.Socket import qualified System.TimeManager as T@@ -59,8 +59,10 @@ -> IO () runTCPServerWithSettings set tm mhost port server = do addr <- resolve Stream mhost port [AI_PASSIVE] NE.head- E.bracket (openTCPServerSocket addr) close $ \sock ->- runTCPServerWithSocketAndSettings set tm sock server+ -- Closed before the connections are waited for, so that the port is+ -- free while they finish; the bracket closes it if that is not reached.+ E.bracket (openTCPServerSocket addr) unsafeClose $ \sock ->+ serve set (unsafeClose sock) tm sock server -- | Running a TCP server on a given listen socket. runTCPServerWithSocket@@ -82,11 +84,31 @@ -- ^ A listening socket created by 'openTCPServerSocket'. -> TimeoutServer () -> IO ()-runTCPServerWithSocketAndSettings set tm sock server =- T.withManager (tm * 1000000) $ \mgr -> forever $- E.bracketOnError (safeAccept set sock) (close . fst) $ \(conn, peer) ->- forkConnection set conn peer (runServer mgr conn)+runTCPServerWithSocketAndSettings set = serve set (return ())++-- | Running the accept loop, then the given action, then waiting for+-- the connections, which use the manager until they are done.+serve+ :: ServerSettings -> IO () -> Int -> Socket -> TimeoutServer () -> IO ()+serve set stopped tm sock server = do+ listener <- makeListener set sock+ conns <- newConnections+ T.withManager (tm * 1000000) $ \mgr -> do+ loop listener conns mgr+ stopped+ waitConnections conns where+ -- Accepting inside the acquire: once it has returned, the socket+ -- is closed if anything goes wrong before the thread owning it has+ -- been forked.+ loop listener conns mgr = do+ more <- E.bracketOnError (acceptOrStop listener) (mapM_ (unsafeClose . fst)) $ \maccepted ->+ case maccepted of+ Nothing -> return False+ Just (conn, peer) -> do+ forkConnection set conns conn peer (runServer mgr conn)+ return True+ when more $ loop listener conns mgr runServer mgr conn = do labelMe "TCP timeout server" T.withHandleKillThread mgr (return ()) $ \th -> server mgr th conn
Network/Run/UDP.hs view
@@ -12,9 +12,10 @@ resolve, ) where -import Control.Concurrent (forkIO)+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM import qualified Control.Exception as E-import Control.Monad (forever)+import Control.Monad (forM) import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE import Network.Socket@@ -51,7 +52,9 @@ :: [HostName] -> ServiceName -> (Socket -> ByteString -> IO ()) -> IO () runUDPServerFork = runUDPServerForkWithSettings defaultServerSettings --- | 'runUDPServerFork' with the given settings.+-- | 'runUDPServerFork' with the given settings. Once stopped, it+-- returns when the loops of all the hosts and the threads they forked+-- are done. runUDPServerForkWithSettings :: ServerSettings -> [HostName]@@ -60,23 +63,41 @@ -> IO () runUDPServerForkWithSettings _ [] _ _ = return () runUDPServerForkWithSettings set (h : hs) port server = do- mapM_ (forkIO . run) hs- run h+ -- One variable for all of the hosts: the shutdown action stops the+ -- server, which is all of these loops.+ stopping <- newTVarIO False+ settingsInstallShutdownHandler set $ atomically $ writeTVar stopping True+ conns <- newConnections+ dones <- forM hs $ \host -> do+ done <- newEmptyMVar+ -- What escapes is left to the thread, as before, to be printed.+ _ <- forkIO $ run stopping conns host `E.finally` putMVar done ()+ return done+ run stopping conns h+ mapM_ takeMVar dones+ waitConnections conns where- run host = do+ run stopping conns host = do labelMe $ "UDP server for " ++ host- runUDPServer (Just host) port $ \lsock -> forever $ do- -- An error from 'recvFrom' means that the listening socket- -- itself is gone, so it is left to propagate as before.- (bs0, peeraddr) <- recvFrom lsock 2048- -- Everything below is per-datagram work. A failure here- -- must not take the entire server down.- dispatch peeraddr bs0 `E.catch` onDispatchError peeraddr+ runUDPServer (Just host) port $ \lsock -> loop stopping conns lsock + -- The receive and the stop variable are waited for at once, so+ -- nothing has to be closed under this thread and nothing has to be+ -- thrown into it.+ loop stopping conns lsock = do+ r <- recvFromWith lsock 2048 $ check =<< readTVar stopping+ case r of+ Left () -> return ()+ Right (bs0, peeraddr) -> do+ -- Everything below is per-datagram work. A failure here+ -- must not take the entire server down.+ dispatch conns peeraddr bs0 `E.catch` onDispatchError peeraddr+ loop stopping conns lsock+ onDispatchError peeraddr e = report set (Just peeraddr) $ E.toException (e :: E.IOException) - dispatch peeraddr bs0 = case familyOf peeraddr of+ dispatch conns peeraddr bs0 = case familyOf peeraddr of -- Neither IPv4 nor IPv6. Just drop the datagram. Nothing -> return () Just family -> do@@ -90,9 +111,9 @@ -- If 'connect' throws, the socket is closed here. On -- success it is owned by the new thread and is closed by -- its finalizer.- E.bracketOnError (openServerSocket addr) close $ \s -> do+ E.bracketOnError (openServerSocket addr) unsafeClose $ \s -> do connect s peeraddr- forkDatagram set s peeraddr $+ forkDatagram set conns s peeraddr $ labelMe "UDP server" >> server s bs0 familyOf SockAddrInet{} = Just AF_INET
network-run.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: network-run-version: 0.6.0+version: 0.8.0 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -31,8 +31,9 @@ build-depends: base >=4 && <5, bytestring >=0.10 && <0.13,- network >=3.2.4 && <3.3,- time-manager >=0.2 && <0.4+ network >=3.2.12 && <3.3,+ stm >=2.5 && <2.6,+ time-manager >=0.2 && <0.6 executable tcp-client main-is: tcpClient.hs@@ -113,6 +114,7 @@ bytestring, directory, hspec,- network >=3.2.4,- time-manager >=0.2 && <0.4,+ network >=3.2.10,+ stm >=2.5 && <2.6,+ time-manager >=0.2 && <0.6, network-run
test/CoreSpec.hs view
@@ -102,7 +102,8 @@ (set, getReports) <- collecting withDummySocket $ \sock -> do closed <- newEmptyMVar- forkWith set (\_ -> putMVar closed ()) sock fakePeer $+ conns <- newConnections+ forkWith set conns (\_ -> putMVar closed ()) sock fakePeer $ E.throwIO $ userError "boom" takeMVar closed `shouldReturn` ()@@ -116,16 +117,35 @@ } withDummySocket $ \sock -> do closed <- newEmptyMVar- forkWith set (\_ -> putMVar closed ()) sock fakePeer $+ conns <- newConnections+ forkWith set conns (\_ -> putMVar closed ()) sock fakePeer $ E.throwIO $ userError "boom" r <- timeout 1000000 $ takeMVar closed r `shouldBe` Just () + it "counts the thread until its socket is closed" $ limited $ do+ conns <- newConnections+ release <- newEmptyMVar+ closed <- newIORef False+ withDummySocket $ \sock ->+ forkWith+ defaultServerSettings+ conns+ (\_ -> writeIORef closed True)+ sock+ fakePeer $+ takeMVar release+ timeout 200000 (waitConnections conns) `shouldReturn` Nothing+ putMVar release ()+ timeout 1000000 (waitConnections conns) `shouldReturn` Just ()+ readIORef closed `shouldReturn` True+ it "reports a failure of the closer" $ limited $ do (set, getReports) <- collecting+ conns <- newConnections withDummySocket $ \sock ->- forkWith set (\_ -> ioError $ userError "close failed") sock fakePeer $+ forkWith set conns (\_ -> ioError $ userError "close failed") sock fakePeer $ return () reports <- waitFor 1 getReports case reports of
test/TCPSpec.hs view
@@ -10,7 +10,8 @@ import Data.IORef import Data.List (nub) import qualified Data.List.NonEmpty as NE-import GHC.IO.Exception (IOErrorType (InvalidArgument))+import Data.Maybe (isJust)+import GHC.IO.Exception (IOErrorType (InvalidArgument), ioe_errno) import Network.Socket import Network.Socket.ByteString import System.IO.Error (ioeGetErrorType)@@ -76,10 +77,82 @@ close lsock r <- timeout 2000000 $ takeMVar done case r of- Just (Left _) -> return ()- Just (Right _) -> expectationFailure "the accept loop returned"+ Just (Right _) -> return ()+ Just (Left e) ->+ expectationFailure $ "the accept loop threw: " ++ show e Nothing -> expectationFailure "the accept loop did not stop" + it "stops when the shutdown handler is run" $ limited $ do+ told <- newEmptyMVar+ done <- newEmptyMVar+ let set =+ defaultServerSettings+ { settingsInstallShutdownHandler = putMVar told+ }+ withListenSocket $ \lsock _ -> do+ void $+ forkFinally+ (runTCPServerWithSocketAndSettings set lsock echo)+ (putMVar done)+ stop <- takeMVar told+ threadDelay 100000+ stop+ r <- timeout 2000000 $ takeMVar done+ case r of+ Just (Right _) -> return ()+ Just (Left e) ->+ expectationFailure $ "the accept loop threw: " ++ show e+ Nothing -> expectationFailure "the accept loop did not stop"++ it "waits for its connections once told to stop" $ limited $ do+ told <- newEmptyMVar+ done <- newEmptyMVar+ let set = defaultServerSettings{settingsInstallShutdownHandler = putMVar told}+ withListenSocket $ \lsock port -> do+ void $+ forkFinally+ (runTCPServerWithSocketAndSettings set lsock echo)+ (putMVar done)+ stop <- takeMVar told+ client port $ \sock -> do+ sendAll sock "hello"+ _ <- recv sock 1024+ stop+ isJust <$> timeout 300000 (readMVar done) `shouldReturn` False+ r <- timeout 2000000 $ takeMVar done+ fmap (either (Left . show) Right) r `shouldBe` Just (Right ())++ it "frees its port while waiting for its connections" $ limited $ do+ told <- newEmptyMVar+ done <- newEmptyMVar+ port <- freeTCPPort+ let set = defaultServerSettings{settingsInstallShutdownHandler = putMVar told}+ void $+ forkFinally+ (runTCPServerWithSettings set (Just loopback) (show port) echo)+ (putMVar done)+ stop <- takeMVar told+ threadDelay 200000+ client port $ \sock -> do+ sendAll sock "hello"+ _ <- recv sock 1024+ stop+ threadDelay 200000+ addr <- resolve Stream (Just loopback) (show port) [AI_PASSIVE] NE.head+ E.bracket (openTCPServerSocket addr) close $ \_ -> return ()+ void $ timeout 2000000 $ takeMVar done++ it "does not wait for its connections when killed" $ limited $ do+ done <- newEmptyMVar+ withListenSocket $ \lsock port -> do+ tid <-+ forkFinally (runTCPServerWithSocket lsock echo) (putMVar done)+ client port $ \sock -> do+ sendAll sock "hello"+ _ <- recv sock 1024+ killThread tid+ isJust <$> timeout 1000000 (takeMVar done) `shouldReturn` True+ it "listens on a single address family" $ limited $ do port <- freeTCPPort let hints =@@ -127,6 +200,26 @@ putMVar gate () recv sock 1024 `shouldThrow` anyIOException + it "drains a connection with unsafeGracefulClose when asked to" $ limited $ do+ gate <- newEmptyMVar+ let set = defaultServerSettings{settingsGracefulCloseTimeout = 500, settingsUnsafeClose = True}+ withTCPServer set (\_ -> takeMVar gate) $ \port ->+ client port $ \sock -> do+ sendAll sock "hello"+ threadDelay 200000+ putMVar gate ()+ recv sock 1024 `shouldReturn` ""++ it "resets a connection with unsafeClose when asked to" $ limited $ do+ gate <- newEmptyMVar+ let set = defaultServerSettings{settingsGracefulCloseTimeout = 0, settingsUnsafeClose = True}+ withTCPServer set (\_ -> takeMVar gate) $ \port ->+ client port $ \sock -> do+ sendAll sock "hello"+ threadDelay 200000+ putMVar gate ()+ recv sock 1024 `shouldThrow` anyIOException+ it "serves many connections concurrently" $ limited $ withTCPServer defaultServerSettings echo $ \port -> do@@ -153,8 +246,11 @@ it "sets ReuseAddr" $ limited $ withListenSocket $ \lsock _ -> getSocketOption lsock ReuseAddr `shouldNotReturn` 0 - it "sets close-on-exec" $ limited $ withListenSocket $ \lsock _ ->- withFdSocket lsock getCloseOnExec `shouldReturn` True+ it "sets close-on-exec" $ limited $+ if os == "mingw32"+ then pendingWith "Windows has no close-on-exec"+ else withListenSocket $ \lsock _ ->+ withFdSocket lsock getCloseOnExec `shouldReturn` True it "sets a composite option" $ limited $ do addr <- resolve Stream (Just loopback) "0" [AI_PASSIVE] NE.head@@ -270,8 +366,15 @@ ---------------------------------------------------------------- -- | 'accept' on a socket which is not listening fails with @EINVAL@.+--+-- Winsock numbers its errors apart from @errno@ and network reports them+-- all as 'GHC.IO.Exception.OtherError', so on Windows the code is what+-- there is to look at. invalidArgument :: Selector E.IOException-invalidArgument e = ioeGetErrorType e == InvalidArgument+invalidArgument e =+ ioeGetErrorType e == InvalidArgument || ioe_errno e == Just wsaEINVAL+ where+ wsaEINVAL = 10022 -- | A handler which fails the first connection and echoes the rest. failFirst :: IORef Int -> Socket -> IO ()
test/TimeoutSpec.hs view
@@ -75,8 +75,9 @@ close lsock r <- timeout 2000000 $ takeMVar done case r of- Just (Left _) -> return ()- Just (Right _) -> expectationFailure "the accept loop returned"+ Just (Right _) -> return ()+ Just (Left e) ->+ expectationFailure $ "the accept loop threw: " ++ show e Nothing -> expectationFailure "the accept loop did not stop" ----------------------------------------------------------------
test/UDPSpec.hs view
@@ -4,6 +4,7 @@ module UDPSpec (spec) where import Control.Concurrent+import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString)@@ -25,11 +26,20 @@ it "serves a datagram" $ limited $ do port <- freeUDPPort- let server sock = forever $ do- (bs, peer) <- recvFrom sock 2048- void $ sendTo sock bs peer- withServerThread (runUDPServer (Just loopback) port server) $+ -- The loop is told to stop rather than killed: on Windows+ -- killThread does not reach a thread blocked in recvFrom,+ -- and withServerThread would wait for it for ever.+ stop <- newTVarIO False+ let server sock = loop+ where+ loop = do+ r <- recvFromWith sock 2048 $ check =<< readTVar stop+ case r of+ Left () -> return ()+ Right (bs, peer) -> sendTo sock bs peer >> loop+ withServerThread (runUDPServer (Just loopback) port server) $ do udpRequest loopback port "hello" `shouldReturn` Just "hello"+ atomically $ writeTVar stop True describe "runUDPServerFork" $ do it "serves a datagram" $@@ -37,6 +47,29 @@ withUDPServerFork defaultServerSettings [loopback] echoDatagram $ \port -> udpRequest loopback port "hello" `shouldReturn` Just "hello" + it "stops when the shutdown handler is run" $ limited $ do+ told <- newEmptyMVar+ done <- newEmptyMVar+ port <- freeUDPPort+ let set =+ defaultServerSettings+ { settingsInstallShutdownHandler = putMVar told+ }+ void $+ forkFinally+ (runUDPServerForkWithSettings set [loopback] port echoDatagram)+ (putMVar done)+ stop <- takeMVar told+ -- Served, so the loop is in its receive, and then told to stop.+ udpRequest loopback port "hello" `shouldReturn` Just "hello"+ stop+ r <- timeout 2000000 $ takeMVar done+ case r of+ Just (Right ()) -> return ()+ Just (Left e) ->+ expectationFailure $ "the server threw: " ++ show e+ Nothing -> expectationFailure "the server did not stop"+ it "returns at once when no host is given" $ limited $ do r <- timeout 1000000 $ runUDPServerFork [] "0" $ \_ _ -> return () r `shouldBe` Just ()@@ -136,7 +169,11 @@ go 0 _ _ = return Nothing go n sock server = do void $ sendTo sock bs server- mr <- timeout 200000 $ fst <$> recvFrom sock 2048+ -- Not System.Timeout: on Windows an asynchronous exception does+ -- not reach a thread blocked in recvFrom, so the retry below+ -- would never come.+ late <- registerDelay 200000+ mr <- recvFromWith sock 2048 $ check =<< readTVar late case mr of- Just r -> return $ Just r- Nothing -> go (n - 1) sock server+ Right (r, _) -> return $ Just r+ Left () -> go (n - 1) sock server