diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,27 @@ # Revision history for http2-tls +## 0.5.7 + +* A server can be stopped through `settingsInstallShutdownHandler`: the + accept loop of network-run is told to stop, and each HTTP/2 connection + is sent GOAWAY through http2's `runWith` and `runIOWith`. A connection + being served used to run on until its idle timeout. +* `settingsUnsafeClose` is passed to network-run. The entry points which + run http2 set it themselves; `runTLS` and `runTLSWithSocket` leave it to + the caller. +* `IOBackend` gains `sendWith` and `recvWith`, a send and a receive which + give up when an `STM` action fires first. They wait in STM, so the + timeout's kill reaches them on Windows too. The http2 library is given + them as `confSendAllWith` and `confReadNWith`, on the server and the + client, so that it stops a receiver without interrupting it. +* The client runs over the same backends as the server. +* All of a frame is sent over h2c. A single send could take part of the + bytes and drop the rest. +* A send after the peer's close_notify is dropped. The client's closing + GOAWAY used to escape `run` as `PostHandshake Error_EOF`. +* Requires http2 5.4.13, network 3.2.12 and network-run 0.7.1. + ## 0.5.6 * Requires network-run 0.7, whose accept loop is stopped by being told diff --git a/Network/HTTP2/TLS/Client.hs b/Network/HTTP2/TLS/Client.hs --- a/Network/HTTP2/TLS/Client.hs +++ b/Network/HTTP2/TLS/Client.hs @@ -50,6 +50,7 @@ settingsRstRateLimit, ) where +import Control.Concurrent.STM (newTVarIO, retry) import qualified Control.Exception as E import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS.C8 @@ -120,15 +121,31 @@ -- ^ ALPN -> (Context -> SockAddr -> SockAddr -> IO a) -> IO a -runTLSWithConfig cliconf settings@Settings{..} serverName port alpn action = +runTLSWithConfig cliconf settings serverName port alpn action = + runTLSWithBackend cliconf settings serverName port alpn $ \ctx IOBackend{..} -> + action ctx mySockAddr peerSockAddr + +-- | 'runTLSWithConfig' handing over an 'IOBackend' too, whose send and +-- receive can be given up on, as the server's. +runTLSWithBackend + :: ClientConfig + -> Settings + -> HostName + -> PortNumber + -> ByteString + -> (Context -> IOBackend -> IO a) + -> IO a +runTLSWithBackend cliconf settings@Settings{..} serverName port alpn action = runTCPClientWithSettings tcpSettings serverName (show port) $ \sock -> do - mysa <- getSocketName sock - peersa <- getPeerName sock params <- getClientParams settings sni port alpn - ctx <- contextNew sock params + giveUpVar <- newTVarIO retry + recvGiveUpVar <- newTVarIO retry + backend <- mkBackend Server.defaultSettings giveUpVar recvGiveUpVar sock + ctx <- contextNew backend params handshake ctx - r <- action ctx mysa peersa - bye ctx + iobackend <- tlsIOBackend giveUpVar recvGiveUpVar ctx sock + r <- action ctx iobackend + byeGivingUp ctx return r where sni = fromMaybe (H2Client.authority cliconf) $ settingsServerNameOverride @@ -141,15 +158,8 @@ runWithConfig :: ClientConfig -> Settings -> HostName -> PortNumber -> Client a -> IO a runWithConfig cliconf settings serverName port client = - runTLSWithConfig cliconf settings serverName port "h2" $ \ctx mysa peersa -> - run' - cliconf' - (settingsTimeout settings) - (sendTLS ctx) - (recvTLS ctx) - mysa - peersa - client + runTLSWithBackend cliconf settings serverName port "h2" $ \_ iobackend -> + run' cliconf' (settingsTimeout settings) iobackend client where cliconf' :: ClientConfig cliconf' = cliconf{H2Client.scheme = "https"} @@ -159,10 +169,8 @@ :: ClientConfig -> Settings -> HostName -> PortNumber -> Client a -> IO a runH2CWithConfig cliconf Settings{..} serverName port client = runTCPClientWithSettings tcpSettings serverName (show port) $ \sock -> do - mysa <- getSocketName sock - peersa <- getPeerName sock - recv <- mkRecvTCP Server.defaultSettings sock - run' cliconf' settingsTimeout (sendTCP sock) recv mysa peersa client + iobackend <- tcpIOBackend Server.defaultSettings sock + run' cliconf' settingsTimeout iobackend client where cliconf' :: ClientConfig cliconf' = cliconf{H2Client.scheme = "http"} @@ -171,18 +179,10 @@ { TCP.settingsOpenClientSocket = settingsOpenClientSocket } -run' - :: ClientConfig - -> Int - -> (ByteString -> IO ()) - -> IO ByteString - -> SockAddr - -> SockAddr - -> Client a - -> IO a -run' cliconf tout send recv mysa peersa client = +run' :: ClientConfig -> Int -> IOBackend -> Client a -> IO a +run' cliconf tout IOBackend{..} client = E.bracket - (allocConfigForClient tout send recv mysa peersa) + (allocConfigForClient tout send sendWith recv recvWith mySockAddr peerSockAddr) freeConfigForClient (\conf -> H2Client.run cliconf conf client) diff --git a/Network/HTTP2/TLS/Config.hs b/Network/HTTP2/TLS/Config.hs --- a/Network/HTTP2/TLS/Config.hs +++ b/Network/HTTP2/TLS/Config.hs @@ -3,7 +3,11 @@ module Network.HTTP2.TLS.Config where +import Control.Concurrent.STM (STM) +import qualified Control.Exception as E import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.IORef import Foreign.Marshal.Alloc (free, mallocBytes) import Network.HTTP2.Client (Config) import qualified Network.HTTP2.Client as C @@ -17,19 +21,23 @@ :: Settings -> T.Manager -> (ByteString -> IO ()) + -> (STM () -> ByteString -> IO (Either () ())) -> IO ByteString + -> (STM () -> IO (Either () ByteString)) -> SockAddr -> SockAddr -> IO Config -allocConfigForServer Settings{..} mgr send recv mysa peersa = do +allocConfigForServer Settings{..} mgr send sendWith recv recvWith mysa peersa = do buf <- mallocBytes settingsSendBufferSize - recvN <- makeRecvN "" recv + (recvN, recvNWith) <- makeRecvNs recv recvWith let config = C.defaultConfig { C.confWriteBuffer = buf , C.confBufferSize = settingsSendBufferSize , C.confSendAll = send + , C.confSendAllWith = Just sendWith , C.confReadN = recvN + , C.confReadNWith = Just recvNWith , C.confPositionReadMaker = C.defaultPositionReadMaker , C.confTimeoutManager = mgr , C.confMySockAddr = mysa @@ -38,16 +46,40 @@ } return config +-- | 'makeRecvN' over the receive, and the same over the one which gives +-- up, sharing what is left over. One given up on part-way answers with +-- an empty string, as at end of input. +makeRecvNs + :: IO ByteString + -> (STM () -> IO (Either () ByteString)) + -> IO (RecvN, STM () -> RecvN) +makeRecvNs recv recvWith = do + stopRef <- newIORef Nothing + let recv' = readIORef stopRef >>= maybe recv (fmap (either (const "") id) . recvWith) + recvN <- makeRecvN "" recv' + let recvNWith stop n = do + writeIORef stopRef $ Just stop + bs <- recvN n `E.finally` writeIORef stopRef Nothing + return $ if BS.length bs == n then bs else "" + return (recvN, recvNWith) + -- | Deallocating the resource of the simple configuration. freeConfigForServer :: Config -> IO () freeConfigForServer conf = free $ C.confWriteBuffer conf allocConfigForClient - :: Int -> (ByteString -> IO ()) -> IO ByteString -> SockAddr -> SockAddr -> IO Config -allocConfigForClient tout send recv mysa peersa = do + :: Int + -> (ByteString -> IO ()) + -> (STM () -> ByteString -> IO (Either () ())) + -> IO ByteString + -> (STM () -> IO (Either () ByteString)) + -> SockAddr + -> SockAddr + -> IO Config +allocConfigForClient tout send sendWith recv recvWith mysa peersa = do let wbufsiz = 4096 -- fixme buf <- mallocBytes wbufsiz - recvN <- makeRecvN "" recv + (recvN, recvNWith) <- makeRecvNs recv recvWith -- A global manager does not exist. -- So, a timeout manager is created per connection. -- The receiver of http2 uses it as an idle timeout. @@ -57,7 +89,9 @@ { C.confWriteBuffer = buf , C.confBufferSize = wbufsiz , C.confSendAll = send + , C.confSendAllWith = Just sendWith , C.confReadN = recvN + , C.confReadNWith = Just recvNWith , C.confPositionReadMaker = C.defaultPositionReadMaker , C.confTimeoutManager = mgr , C.confMySockAddr = mysa diff --git a/Network/HTTP2/TLS/IO.hs b/Network/HTTP2/TLS/IO.hs --- a/Network/HTTP2/TLS/IO.hs +++ b/Network/HTTP2/TLS/IO.hs @@ -3,15 +3,18 @@ module Network.HTTP2.TLS.IO where +import Control.Concurrent.STM import qualified Control.Exception as E -import Control.Monad (void, when) +import Control.Monad (when) import Data.ByteString (ByteString) +import Data.Either (isRight) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Network.Socket import Network.Socket.BufferPool import qualified Network.Socket.ByteString as NSB import Network.TLS hiding (HostName) +import Network.HTTP2.Client (HTTP2Error (..)) import System.IO.Error (isEOFError) import qualified System.IO.Error as E import qualified System.TimeManager as T @@ -25,14 +28,30 @@ ---------------------------------------------------------------- -mkRecvTCP :: Settings -> Socket -> IO (IO ByteString) -mkRecvTCP Settings{..} sock = do +-- | A receiving function which gives up when the 'STM' action fires +-- first. It waits in 'STM', so the timeout's kill reaches it on +-- Windows too. +mkRecvTCP :: Settings -> STM () -> Socket -> IO (IO ByteString) +mkRecvTCP settings giveUp sock = do + recvWith' <- mkRecvTCPWith settings sock + return $ recvWith' giveUp >>= orTimeout + +-- | A receiving function which takes what it gives up on at each call. +mkRecvTCPWith :: Settings -> Socket -> IO (STM () -> IO (Either () ByteString)) +mkRecvTCPWith Settings{..} sock = do pool <- newBufferPool settingsReadBufferLowerLimit settingsReadBufferSize - return $ receive sock pool + return $ receiveWith sock pool +orTimeout :: Either () a -> IO a +orTimeout = either (\_ -> E.throwIO ConnectionIsTimeout) return + sendTCP :: Socket -> ByteString -> IO () sendTCP sock = NSB.sendAll sock +-- | 'sendTCP' which gives up when the 'STM' action fires first. +sendTCPWith :: Socket -> STM () -> ByteString -> IO (Either () ()) +sendTCPWith sock giveUp bs = NSB.sendAllWith sock bs giveUp + ---------------------------------------------------------------- -- | Sending and receiving functions. @@ -42,10 +61,22 @@ data IOBackend = IOBackend { send :: ByteString -> IO () -- ^ Sending. + , sendWith :: STM () -> ByteString -> IO (Either () ()) + -- ^ Sending which gives up when the 'STM' action fires first, + -- answering 'Left'. Part of the data may have gone by then, so the + -- connection is to be closed. + -- + -- @since 0.5.7 , sendMany :: [ByteString] -> IO () -- ^ Sending many. , recv :: IO ByteString -- ^ Receiving. + , recvWith :: STM () -> IO (Either () ByteString) + -- ^ Receiving which gives up when the 'STM' action fires first, + -- answering 'Left'. Part of a TLS record may have been read by + -- then, so the connection is to be closed. + -- + -- @since 0.5.7 , requestSock :: Socket -- ^ The socket for the request , mySockAddr :: SockAddr @@ -54,24 +85,49 @@ timeoutIOBackend :: T.Handle -> Settings -> IOBackend -> IOBackend timeoutIOBackend th Settings{..} IOBackend{..} = - IOBackend send' sendMany' recv' requestSock mySockAddr peerSockAddr + IOBackend + { send = send' + , sendWith = sendWith' + , sendMany = sendMany' + , recv = recv' + , recvWith = recvWith' + , .. + } where send' bs = send bs >> T.tickle th + sendWith' giveUp bs = do + r <- sendWith giveUp bs + when (isRight r) $ T.tickle th + return r sendMany' bss = sendMany bss >> T.tickle th recv' = do bs <- recv - when (BS.length bs > settingsSlowlorisSize) $ T.tickle th + tickleIfLarge bs return bs + recvWith' giveUp = do + r <- recvWith giveUp + either (\_ -> return ()) tickleIfLarge r + return r + tickleIfLarge bs = when (BS.length bs > settingsSlowlorisSize) $ T.tickle th -tlsIOBackend :: Context -> Socket -> IO IOBackend -tlsIOBackend ctx sock = do +-- | The 'TVar's are the ones given to 'mkBackend': what a send and a +-- receive of the backend give up on. +tlsIOBackend :: TVar (STM ()) -> TVar (STM ()) -> Context -> Socket -> IO IOBackend +tlsIOBackend giveUpVar recvGiveUpVar ctx sock = do mysa <- getSocketName sock peersa <- getPeerName sock return $ IOBackend { send = sendTLS ctx + , sendWith = \giveUp bs -> do + atomically $ writeTVar giveUpVar giveUp + (Right () <$ sendTLS ctx bs) `E.catch` gaveUp , sendMany = sendManyTLS ctx , recv = recvTLS ctx + , recvWith = \giveUp -> do + atomically $ writeTVar recvGiveUpVar giveUp + ((Right <$> recvTLS ctx) `E.catch` gaveUp) + `E.finally` atomically (writeTVar recvGiveUpVar retry) , requestSock = sock , mySockAddr = mysa , peerSockAddr = peersa @@ -79,14 +135,16 @@ tcpIOBackend :: Settings -> Socket -> IO IOBackend tcpIOBackend settings sock = do - recv' <- mkRecvTCP settings sock + recvWith' <- mkRecvTCPWith settings sock mysa <- getSocketName sock peersa <- getPeerName sock return $ IOBackend - { send = void . NSB.send sock + { send = sendTCP sock + , sendWith = sendTCPWith sock , sendMany = \_ -> return () - , recv = recv' + , recv = recvWith' retry >>= orTimeout + , recvWith = recvWith' , requestSock = sock , mySockAddr = mysa , peerSockAddr = peersa @@ -95,11 +153,18 @@ ---------------------------------------------------------------- sendTLS :: Context -> ByteString -> IO () -sendTLS ctx = sendData ctx . LBS.fromStrict +sendTLS ctx = afterCloseNotify . sendData ctx . LBS.fromStrict sendManyTLS :: Context -> [ByteString] -> IO () -sendManyTLS ctx = sendData ctx . LBS.fromChunks +sendManyTLS ctx = afterCloseNotify . sendData ctx . LBS.fromChunks +-- | tls answers the peer's close_notify with its own, so a send after it +-- has nowhere to go: dropped, as the GOAWAY which closes the connection. +afterCloseNotify :: IO () -> IO () +afterCloseNotify = E.handle $ \e -> case e of + PostHandshake Error_EOF -> return () + _ -> E.throwIO e + -- TLS version of recv (decrypting) without a cache. recvTLS :: Context -> IO ByteString recvTLS ctx = E.handle onEOF $ recvData ctx @@ -111,10 +176,17 @@ ---------------------------------------------------------------- -mkBackend :: Settings -> Socket -> IO Backend -mkBackend settings sock = do - let send' = sendTCP sock - recv' <- mkRecvTCP settings sock +-- | A send of the backend gives up on what the first 'TVar' holds, which +-- the http2 library sets once it sends through 'sendWith', and a +-- receive on what the second holds, which 'recvWith' sets. +mkBackend :: Settings -> TVar (STM ()) -> TVar (STM ()) -> Socket -> IO Backend +mkBackend settings giveUpVar recvGiveUpVar sock = do + let send' bs = do + giveUp <- readTVarIO giveUpVar + sendTCPWith sock giveUp bs + >>= either (\_ -> E.throwIO ConnectionIsTimeout) return + recvWith' <- mkRecvTCPWith settings sock + let recv' = readTVarIO recvGiveUpVar >>= recvWith' >>= orTimeout recvN <- makeRecvN "" recv' return Backend @@ -124,3 +196,12 @@ , backendSend = send' , backendRecv = recvN } + +-- | close_notify, as a last word: a send which the http2 library has +-- given up on is not an error here. +byeGivingUp :: Context -> IO () +byeGivingUp ctx = bye ctx `E.catch` \e -> () <$ gaveUp e + +gaveUp :: HTTP2Error -> IO (Either () a) +gaveUp ConnectionIsTimeout = return $ Left () +gaveUp e = E.throwIO e diff --git a/Network/HTTP2/TLS/Server.hs b/Network/HTTP2/TLS/Server.hs --- a/Network/HTTP2/TLS/Server.hs +++ b/Network/HTTP2/TLS/Server.hs @@ -34,12 +34,16 @@ settingsEmptyFrameRateLimit, settingsSettingsRateLimit, settingsRstRateLimit, + settingsInstallShutdownHandler, + settingsUnsafeClose, -- * IO backend IOBackend, send, + sendWith, sendMany, recv, + recvWith, requestSock, mySockAddr, peerSockAddr, @@ -51,6 +55,7 @@ ServerIO (..), ) where +import Control.Concurrent.STM (STM, atomically, check, newTVarIO, readTVar, retry, writeTVar) import qualified Control.Exception as E import Data.ByteString (ByteString) import Network.HTTP2.Server ( @@ -68,7 +73,8 @@ import qualified Network.HTTP2.Server as H2Server import Network.HTTP2.Server.Internal (ServerIO, Stream) import qualified Network.HTTP2.Server.Internal as H2I -import Network.Run.TCP.Timeout +import Network.Run.TCP.Timeout hiding (ServerSettings (..)) +import qualified Network.Run.TCP.Timeout as TCP import Network.Socket ( HostName, PortNumber, @@ -95,17 +101,20 @@ -> (T.Manager -> IOBackend -> IO ()) -> IO () runTLS settings creds host port alpn action = - runTCPServer + runTCPServerWithSettings + (tcpSettings settings) (settingsTimeout settings) (Just host) (show port) $ \mgr th sock -> do - backend <- mkBackend settings sock + giveUpVar <- newTVarIO retry + recvGiveUpVar <- newTVarIO retry + backend <- mkBackend settings giveUpVar recvGiveUpVar sock ctx <- contextNew backend params handshake ctx - iobackend <- timeoutIOBackend th settings <$> tlsIOBackend ctx sock + iobackend <- timeoutIOBackend th settings <$> tlsIOBackend giveUpVar recvGiveUpVar ctx sock action mgr iobackend - bye ctx + byeGivingUp ctx where params = getServerParams settings creds alpn @@ -121,16 +130,19 @@ -> (T.Manager -> IOBackend -> IO ()) -> IO () runTLSWithSocket settings creds s alpn action = - runTCPServerWithSocket + runTCPServerWithSocketAndSettings + (tcpSettings settings) (settingsTimeout settings) s $ \mgr th sock -> do - backend <- mkBackend settings sock + giveUpVar <- newTVarIO retry + recvGiveUpVar <- newTVarIO retry + backend <- mkBackend settings giveUpVar recvGiveUpVar sock ctx <- contextNew backend params handshake ctx - iobackend <- timeoutIOBackend th settings <$> tlsIOBackend ctx sock + iobackend <- timeoutIOBackend th settings <$> tlsIOBackend giveUpVar recvGiveUpVar ctx sock r <- action mgr iobackend - bye ctx + byeGivingUp ctx return r where params = getServerParams settings creds alpn @@ -138,44 +150,50 @@ -- | Running an HTTP\/2 client over TLS (over TCP). -- ALPN is "h2". run :: Settings -> Credentials -> HostName -> PortNumber -> Server -> IO () -run settings creds host port server = - runTLS settings creds host port "h2" $ run' settings server +run settings0 creds host port server = do + (settings, goAway) <- goingAway settings0 + runTLS (byHTTP2 settings) creds host port "h2" $ run' settings goAway server -- | Running an HTTP\/2 client over TLS (over TCP). -- ALPN is "h2". runWithSocket :: Settings -> Credentials -> Socket -> Server -> IO () -runWithSocket settings creds s server = - runTLSWithSocket settings creds s "h2" $ run' settings server +runWithSocket settings0 creds s server = do + (settings, goAway) <- goingAway settings0 + runTLSWithSocket (byHTTP2 settings) creds s "h2" $ run' settings goAway server -- | Running an HTTP\/2 client over TCP. runH2C :: Settings -> HostName -> PortNumber -> Server -> IO () -runH2C settings@Settings{..} host port server = - runTCPServer - settingsTimeout +runH2C settings0 host port server = do + (settings, goAway) <- goingAway settings0 + runTCPServerWithSettings + (tcpSettings $ byHTTP2 settings) + (settingsTimeout settings) (Just host) (show port) $ \mgr th sock -> do iobackend0 <- tcpIOBackend settings sock let iobackend = timeoutIOBackend th settings iobackend0 - run' settings server mgr iobackend + run' settings goAway server mgr iobackend -- | Running an HTTP\/2 client over TCP. runH2CWithSocket :: Settings -> Socket -> Server -> IO () -runH2CWithSocket settings@Settings{..} s server = - runTCPServerWithSocket - settingsTimeout +runH2CWithSocket settings0 s server = do + (settings, goAway) <- goingAway settings0 + runTCPServerWithSocketAndSettings + (tcpSettings $ byHTTP2 settings) + (settingsTimeout settings) s $ \mgr th sock -> do iobackend0 <- tcpIOBackend settings sock let iobackend = timeoutIOBackend th settings iobackend0 - run' settings server mgr iobackend + run' settings goAway server mgr iobackend -run' :: Settings -> Server -> T.Manager -> IOBackend -> IO () -run' settings0@Settings{..} server mgr IOBackend{..} = +run' :: Settings -> STM () -> Server -> T.Manager -> IOBackend -> IO () +run' settings0@Settings{..} goAway server mgr IOBackend{..} = E.bracket - (allocConfigForServer settings0 mgr send recv mySockAddr peerSockAddr) + (allocConfigForServer settings0 mgr send sendWith recv recvWith mySockAddr peerSockAddr) freeConfigForServer - (\conf -> H2Server.run sconf conf server) + (\conf -> H2Server.runWith goAway sconf conf server) where sconf = defaultServerConfig @@ -197,17 +215,23 @@ -> Socket -> (ServerIO Stream -> IO (IO ())) -> IO () -runIO settings creds s action = - runTLSWithSocket settings creds s "h2" $ \mgr iobackend -> - runIO' settings action mgr iobackend +runIO settings0 creds s action = do + (settings, goAway) <- goingAway settings0 + runTLSWithSocket (byHTTP2 settings) creds s "h2" $ \mgr iobackend -> + runIO' settings goAway action mgr iobackend runIO' - :: Settings -> (ServerIO Stream -> IO (IO ())) -> T.Manager -> IOBackend -> IO () -runIO' settings0@Settings{..} action mgr IOBackend{..} = + :: Settings + -> STM () + -> (ServerIO Stream -> IO (IO ())) + -> T.Manager + -> IOBackend + -> IO () +runIO' settings0@Settings{..} goAway action mgr IOBackend{..} = E.bracket - (allocConfigForServer settings0 mgr send recv mySockAddr peerSockAddr) + (allocConfigForServer settings0 mgr send sendWith recv recvWith mySockAddr peerSockAddr) freeConfigForServer - (\conf -> H2I.runIO sconf conf action) + (\conf -> H2I.runIOWith goAway sconf conf action) where sconf = defaultServerConfig @@ -225,14 +249,40 @@ runIOH2C :: Settings -> Socket -> (ServerIO Stream -> IO (IO ())) -> IO () -runIOH2C settings0@Settings{..} s action = - runTCPServerWithSocket - settingsTimeout +runIOH2C settings0 s action = do + (settings, goAway) <- goingAway settings0 + runTCPServerWithSocketAndSettings + (tcpSettings $ byHTTP2 settings) + (settingsTimeout settings) s $ \mgr th sock -> do - iobackend0 <- tcpIOBackend settings0 sock - let iobackend = timeoutIOBackend th settings0 iobackend0 - runIO' settings0 action mgr iobackend + iobackend0 <- tcpIOBackend settings sock + let iobackend = timeoutIOBackend th settings iobackend0 + runIO' settings goAway action mgr iobackend + +---------------------------------------------------------------- + +tcpSettings :: Settings -> TCP.ServerSettings +tcpSettings settings = + TCP.defaultServerSettings + { TCP.settingsInstallShutdownHandler = settingsInstallShutdownHandler settings + , TCP.settingsUnsafeClose = settingsUnsafeClose settings + } + +-- | For the entry points which run http2, which waits for its threads. +byHTTP2 :: Settings -> Settings +byHTTP2 settings = settings{settingsUnsafeClose = True} + +-- | Stopping the server also tells each HTTP\/2 connection to go away: +-- GOAWAY, and closing once the streams it has taken are done. +goingAway :: Settings -> IO (Settings, STM ()) +goingAway settings = do + var <- newTVarIO False + let install stop = + settingsInstallShutdownHandler settings $ + stop >> atomically (writeTVar var True) + return + (settings{settingsInstallShutdownHandler = install}, readTVar var >>= check) ---------------------------------------------------------------- diff --git a/Network/HTTP2/TLS/Server/Settings.hs b/Network/HTTP2/TLS/Server/Settings.hs --- a/Network/HTTP2/TLS/Server/Settings.hs +++ b/Network/HTTP2/TLS/Server/Settings.hs @@ -85,6 +85,22 @@ -- -- >>> settingsRstRateLimit defaultSettings -- 4 + , settingsInstallShutdownHandler :: IO () -> IO () + -- ^ An action to install a handler which stops the server. The + -- first argument stops accepting; the connections being served are + -- not waited for. Under the entry points which run HTTP\/2, it also + -- sends each connection GOAWAY, which closes it once the streams it + -- has taken are done. The default does nothing. + -- + -- @since 0.5.7 + , settingsUnsafeClose :: Bool + -- ^ Closing a connection with network's unsafe close, which skips the + -- IO manager. Set this only when the action given to 'runTLS' or + -- 'runTLSWithSocket' leaves no thread and no registered wait on the + -- socket by the time it returns. The other entry points run http2, + -- which does not, and set it themselves. The default is 'False'. + -- + -- @since 0.5.7 } {-# DEPRECATED settingsNumberOfWorkers "This field is meaningless now" #-} @@ -109,4 +125,6 @@ , settingsEmptyFrameRateLimit = 4 , settingsSettingsRateLimit = 4 , settingsRstRateLimit = 4 + , settingsInstallShutdownHandler = const $ return () + , settingsUnsafeClose = False } diff --git a/http2-tls.cabal b/http2-tls.cabal --- a/http2-tls.cabal +++ b/http2-tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-tls -version: 0.5.6 +version: 0.5.7 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -42,13 +42,14 @@ crypton-x509-store >=1.9.0 && <1.11, crypton-x509-system >=1.9.0 && <1.11, crypton-x509-validation >=1.9 && <1.11, - http2 >=5.4 && <5.5, - network >=3.1.4, + http2 >=5.4.13 && <5.5, + network >=3.2.12, network-control >=0.1 && <0.2, - network-run >=0.7 && <0.8, - recv >=0.1.0 && <0.2, + network-run >=0.7.1 && <0.8, + recv >=0.1.3 && <0.2, + stm >=2.4, time-manager >=0.5 && <0.6, - tls >=2.3.0 && <2.5, + tls >=2.3.0 && <2.6, utf8-string >=1.0 && <1.1 executable h2-client