http2-tls 0.5.6 → 0.5.7

raw patch · 7 files changed

+301/−96 lines, 7 filesdep +stmdep ~http2dep ~networkdep ~network-runPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: stm

Dependency ranges changed: http2, network, network-run, recv

API changes (from Hackage documentation)

Files

• ChangeLog.md +21/−0
• Network/HTTP2/TLS/Client.hs +30/−30
• Network/HTTP2/TLS/Config.hs +39/−5
• Network/HTTP2/TLS/IO.hs +98/−17
• Network/HTTP2/TLS/Server.hs +88/−38
• Network/HTTP2/TLS/Server/Settings.hs +18/−0
• http2-tls.cabal +7/−6

@@ -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

@@ -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) 

@@ -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

@@ -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

@@ -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)  ---------------------------------------------------------------- 

@@ -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         }

@@ -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 <kazu@iij.ad.jp>@@ -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