diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,316 @@ +# ChangeLog for http2 + +## 5.4.7 + +* A valid request could close the whole connection, with every other + stream on it: + - a Huffman-coded field value longer than 4096 octets, such as a long + token in `authorization`, was taken for a truncated block + [#201](https://github.com/kazu-yamamoto/http2/pull/201); + - so was a header block with no fields, which is what empty trailers + are sent as [#202](https://github.com/kazu-yamamoto/http2/pull/202); + - a malformed field (an upper-case name, a pseudo-header out of place, + more than 200 fields) left the rest of its block undecoded, and the + HPACK tables out of step. The block is now decoded to the end and the + message refused with RST_STREAM(PROTOCOL_ERROR) on its stream alone + (RFC 9113, section 8.1.1). + [#211](https://github.com/kazu-yamamoto/http2/pull/211) +* Flow control lost octets, so that a long-lived connection could stall: + - the padding of DATA frames was charged to both windows and never + given back [#204](https://github.com/kazu-yamamoto/http2/pull/204); + - DATA refused on a stream in the wrong state, or ignored on a stream we + had reset, was not charged to the connection window, though the peer + had charged it [#205](https://github.com/kazu-yamamoto/http2/pull/205); + - on a client, the rest of a response that `processResponse` did not + read to the end, or that it threw on, was never given back, and its + stream held a slot of the server's SETTINGS_MAX_CONCURRENT_STREAMS. + Such a stream is now reset with CANCEL. + [#207](https://github.com/kazu-yamamoto/http2/pull/207) + - on a client, the DATA of a push nobody asked for was held against the + connection window for good. Pushes now give it back as it arrives. + [#208](https://github.com/kazu-yamamoto/http2/pull/208) +* A padded body that matched its content-length was reset as malformed: + the padding was counted into its length. + [#203](https://github.com/kazu-yamamoto/http2/pull/203) +* A response carrying a push waited for ever when the client announced + SETTINGS_MAX_CONCURRENT_STREAMS of 0, the way to refuse pushes. A push + there is no room for is now not made. + [#206](https://github.com/kazu-yamamoto/http2/pull/206) +* GOAWAY: + - the last stream identifier of the server's GOAWAY left out streams + whose handlers were still running, so a client could send again a + request that had been acted on + [#209](https://github.com/kazu-yamamoto/http2/pull/209); + - a GOAWAY with NO_ERROR closed the connection at once, failing every + stream in flight. Streams up to its last stream identifier now go + on, those above it fail with `ConnectionIsClosed`, no new stream is + opened, and the connection closes once nothing is left; on a client, + the client function is let finish. + [#210](https://github.com/kazu-yamamoto/http2/pull/210) +* With the connection window shut, nothing went out at all, though only + DATA is flow-controlled: not the response to a request with no body, + not RST_STREAM. DATA now waits for the window on its own. + [#212](https://github.com/kazu-yamamoto/http2/pull/212) + +## 5.4.6 + +* Security: a regression in 5.4.5. Since stream errors reset the stream + rather than the connection, a peer could have the server reset streams + for it -- with a PRIORITY on a stream depending on itself, DATA on a + half-closed stream, and the like -- and so free concurrency slots while + the handlers went on running, without ever sending RST_STREAM itself + (MadeYouReset, CVE-2025-8671). Resets we send because of the peer now + count against `rstRateLimit` with the peer's own. + [#190](https://github.com/kazu-yamamoto/http2/pull/190) +* Security: a PRIORITY frame for a stream that was never opened created + the stream and took a concurrency slot for good, so 64 PRIORITY frames + were enough to have every later request refused. + [#195](https://github.com/kazu-yamamoto/http2/pull/195) +* Security: a SETTINGS_INITIAL_WINDOW_SIZE that overflowed a stream's + window stopped the sender without a word, leaving the connection open + and silent. It is now a connection error of type FLOW_CONTROL_ERROR, + and any failure of the sender closes the connection. + [#196](https://github.com/kazu-yamamoto/http2/pull/196) +* The HPACK dynamic table lost entries, or had the encoder send the wrong + one (index 61 of the static table), once it held as many entries as it + has room for -- which a small or odd SETTINGS_HEADER_TABLE_SIZE from the + peer makes easy. Headers were silently wrong on both sides. + [#192](https://github.com/kazu-yamamoto/http2/pull/192) +* A Huffman-coded string of 16K or more was corrupted by the encoder: the + length's fourth octet overwrote the start of the code. + [#188](https://github.com/kazu-yamamoto/http2/pull/188) +* Header blocks and trailers larger than a frame are sent and received as + HEADERS and CONTINUATION frames, and the header blocks of streams that + are already reset are still decoded, so that the HPACK tables stay in + step. Thanks to Edsko de Vries. + [#187](https://github.com/kazu-yamamoto/http2/pull/187) + [#189](https://github.com/kazu-yamamoto/http2/pull/189) +* A race between the receiver and the sender lost a stream's half-closed + state, so that it was never removed from the stream table: with both + ends streaming, a client ran out of streams and a server refused every + new one. + [#193](https://github.com/kazu-yamamoto/http2/pull/193) +* A client no longer rejects a response that has no content but a + non-zero content-length, as responses to HEAD and 304 responses do. + [#194](https://github.com/kazu-yamamoto/http2/pull/194) +* A client request that failed before it was queued -- a `requestFile` for + a file that cannot be opened, say -- made every later request on the + connection wait for ever. + [#198](https://github.com/kazu-yamamoto/http2/pull/198) +* Server push: a PUSH_PROMISE could come after the response it belongs + to, and pushed streams were never closed, so a connection stopped after + 64 pushes. + [#199](https://github.com/kazu-yamamoto/http2/pull/199) +* An upload through `runIO` larger than the stream's window was cut short + with END_STREAM after the first window's worth. + [#200](https://github.com/kazu-yamamoto/http2/pull/200) +* GHC 9.12 and later, with `-O`, miscompile a value holding a + never-returning streaming body into one with no body + ([GHC #27857](https://gitlab.haskell.org/ghc/ghc/-/work_items/27857)). + The test suite works around it. + [#197](https://github.com/kazu-yamamoto/http2/pull/197) + +## 5.4.5 + +* Security: frame payload decoders read their fixed-size fields without + checking that the payload holds them, so a truncated frame, or padding + covering a field, read past the end of the buffer -- and an empty payload + is the shared empty `ByteString`, whose pointer is null. An + unauthenticated peer could segfault the process with 33 bytes. + [#182](https://github.com/kazu-yamamoto/http2/pull/182) +* Security: HPACK integer decoding overflowed `Int` silently, so a long + enough encoding decoded to whatever value the sender aimed at and two + different byte strings could decode to the same header. Integers are now + bounded and over-long encodings are a decoding error, as RFC 7541 + section 5.1 requires. + [#181](https://github.com/kazu-yamamoto/http2/pull/181) +* A RST_STREAM gave a stream's concurrency slot back twice, so a peer could + walk `SETTINGS_MAX_CONCURRENT_STREAMS` upwards and hold open as many + streams as it liked. + [#178](https://github.com/kazu-yamamoto/http2/pull/178) +* A stream reset while its response was still being produced left the + worker blocked until the timeout manager killed it, one thread per reset + stream. + [#179](https://github.com/kazu-yamamoto/http2/pull/179) +* Stream errors now reset the stream and the connection carries on, as + RFC 9113 section 5.4.2 requires. A field block abandoned part-way is + still a connection error, since the HPACK tables have diverged by then. + [#183](https://github.com/kazu-yamamoto/http2/pull/183) +* A stream over `SETTINGS_MAX_CONCURRENT_STREAMS` is refused with + RST_STREAM(REFUSED_STREAM) rather than ending the connection. + [#184](https://github.com/kazu-yamamoto/http2/pull/184) +* `DecodeError` has a new constructor, `TooLargeInteger`. Strictly this is + a breaking change -- an exhaustive match on `DecodeError` no longer + compiles -- but it ships as a patch version on purpose: no package on + Hackage names any constructor of that type, while a minor bump would + shut out every dependant carrying a `< 5.5` bound, these security fixes + along with it. +* A malformed request now reaches a client as `StreamResetIsReceived` on + the stream it concerns, where it used to arrive as + `ConnectionErrorIsReceived` on the connection. + +## 5.4.4 + +* Improvements for dealing with RST_STREAM + [#172](https://github.com/kazu-yamamoto/http2/pull/172) + +## 5.4.3 + +* auxSendInformational: gate usage with CPP to http-semantics >= 0.4.1 + [#170](https://github.com/kazu-yamamoto/http2/pull/170) + +## 5.4.2 + +* Support informational (1xx) responses, e.g. 103 Early Hints. Servers can send + them via `auxSendInformational`; clients can observe them via the new + `confOnInformational` callback in `Config`. + [#168](https://github.com/kazu-yamamoto/http2/pull/168) + +## 5.4.1 + +* Ensure sender notices when receiver has terminated. + [#167](https://github.com/kazu-yamamoto/http2/pull/167) + +## 5.4.0 + +* Providing `defaultConfig`. +* Except the item above, this version is identical to v5.3.11 which + includes breaking changes and is thus deprecated. + +## 5.3.11 + +* Implementing `auxSendPing` for client. +* Server and client terminates their threads in the right order. +* Using `copy` in frame decoders to avoid potential fragmentation of + `ByteString`. +* Defining `confReadNTimeout` (default to `False`). If `confReadN` + implements timeout by itself, set it to `True`. +* TCP closing is now treaated as `ConnectionIsClosed` instead of + `ConnectionIsTimeout`. +* GOAWAY now contains a right last streamd ID. + +## 5.3.10 + +* Introducing closure. + [#157](https://github.com/kazu-yamamoto/http2/pull/157) + +## 5.3.9 + +* Using `ThreadManager` of `time-manager`. + +## 5.3.8 + +* `forkManagedTimeout` ensures that only one asynchronous exception is + thrown. Fixing the thread leak via `Weak ThreadId` and `modifyTVar'`. + [#156](https://github.com/kazu-yamamoto/http2/pull/156) + +## 5.3.7 + +* Using `withHandle` of time-manager. +* Getting `Handle` for each thread. +* Providing allocSimpleConfig' to enable customizing WAI tiemout manager. +* Monitor option (-m) for h2c-client and h2c-server. + +## 5.3.6 + +* Making `runIO` friendly with the new synchronism mechanism. + [#152](https://github.com/kazu-yamamoto/http2/pull/152) +* Re-throwing asynchronous exceptions to prevent thread leak. +* Simplifying the synchronism mechanism between workers and the sender. + [#148](https://github.com/kazu-yamamoto/http2/pull/148) + +## 5.3.5 + +* Using `http-semantics` v0.3. +* Deprecating `numberOfWorkers`. +* Removing `unliftio`. +* Avoid `undefined` in client. + [#146](https://github.com/kazu-yamamoto/http2/pull/146) + +## 5.3.4 + +* Support stream cancellation + [#142](https://github.com/kazu-yamamoto/http2/pull/142) + +## 5.3.3 + +* Enclosing IPv6 literal authority with square brackets. + [#143](https://github.com/kazu-yamamoto/http2/pull/143) + +## 5.3.2 + +* Avoid unnecessary empty data frames at end of stream + [#140](https://github.com/kazu-yamamoto/http2/pull/140) +* Removing unnecessary API from ServerIO + +## 5.3.1 + +* Fix treatment of async exceptions + [#138](https://github.com/kazu-yamamoto/http2/pull/138) +* Avoid race condition + [#137](https://github.com/kazu-yamamoto/http2/pull/137) + +## 5.3.0 + +* New server architecture: spawning worker on demand instead of the + worker pool. This reduce huge numbers of threads for streaming into + only 2. No API changes but workers do not terminate quicly. Rather + workers collaborate with the sender after queuing a response and + finish after all response data are sent. +* All threads are labeled with `labelThread`. You can see them by + `listThreads` if necessary. + +## 5.2.6 + +* Recover rxflow on closing. + [#126](https://github.com/kazu-yamamoto/http2/pull/126) +* Fixing ClientSpec for stream errors. +* Allowing negative window. (h2spec http2/6.9.2) +* Update for latest http-semantics + [#122](https://github.com/kazu-yamamoto/http2/pull/124) + +## 5.2.5 + +* Setting peer initial window size properly. + [#123](https://github.com/kazu-yamamoto/http2/pull/123) + +## 5.2.4 + +* Update for latest http-semantics + [#122](https://github.com/kazu-yamamoto/http2/pull/122) +* Measuring performance concurrently for h2c-client + +## 5.2.3 + +* Update for latest http-semantics + [#120](https://github.com/kazu-yamamoto/http2/pull/120) +* Enable containers 0.7 (ghc 9.10) + [#117](https://github.com/kazu-yamamoto/http2/pull/117) + +## 5.2.2 + +* Mark final chunk as final + [#116](https://github.com/kazu-yamamoto/http2/pull/116) + +## 5.2.1 + +* Using time-manager v0.1.0. + [#115](https://github.com/kazu-yamamoto/http2/pull/115) + +## 5.2.0 + +* Using http-semantics + [#114](https://github.com/kazu-yamamoto/http2/pull/114) +* `Header` of `http-types` should be used as high-level header. +* `TokenHeader` of `http-semantics` should be used as low-level header. +* Breaking change: `encodeHeader` takes `Header` of `http-types`. +* Breaking change: `decodeHeader` returns `Header` of `http-types`. +* Breaking change: `HeaderName` as `ByteString` is removed. + +## 5.1.4 + +* Using network-control v0.1. + ## 5.1.3 * Defining SendRequest type synonym. @@ -59,7 +372,7 @@ [#80](https://github.com/kazu-yamamoto/http2/pull/80) * Introducing `KilledByHttp2ThreadManager` instead of `ThreadKilled`. [#79](https://github.com/kazu-yamamoto/http2/pull/79) - [#81](https://github.com/kazu-yamamoto/http2/pull/82) + [#81](https://github.com/kazu-yamamoto/http2/pull/81) [#82](https://github.com/kazu-yamamoto/http2/pull/82) * Handle RST_STREAM with NO_ERROR. [#78](https://github.com/kazu-yamamoto/http2/pull/78) diff --git a/Imports.hs b/Imports.hs --- a/Imports.hs +++ b/Imports.hs @@ -14,9 +14,13 @@ module Data.String, module Data.Word, module Numeric, + module Network.HTTP.Semantics, + module Network.HTTP.Types, + module Data.CaseInsensitive, GCBuffer, withForeignPtr, mallocPlainForeignPtrBytes, + labelMe, ) where import Control.Applicative @@ -24,6 +28,7 @@ import Data.Bits hiding (Bits) import Data.ByteString.Internal (ByteString (..)) import Data.ByteString.Short (ShortByteString) +import Data.CaseInsensitive (foldedCase, mk, original) import Data.Either import Data.Foldable import Data.Int @@ -34,7 +39,15 @@ import Data.String import Data.Word import Foreign.ForeignPtr +import GHC.Conc.Sync import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Network.HTTP.Semantics +import Network.HTTP.Types import Numeric type GCBuffer = ForeignPtr Word8 + +labelMe :: String -> IO () +labelMe l = do + tid <- myThreadId + labelThread tid l diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -5,6 +5,10 @@ -- * Encoding and decoding encodeHeader, decodeHeader, + Header, + original, + foldedCase, + mk, -- * Encoding and decoding with token encodeTokenHeader, @@ -28,37 +32,30 @@ DecodeError (..), BufferOverrun (..), - -- * Headers - HeaderList, - Header, - HeaderName, - HeaderValue, - TokenHeaderList, + -- * Token header + FieldValue, TokenHeader, + TokenHeaderList, + toTokenHeaderTable, -- * Value table ValueTable, - HeaderTable, + TokenHeaderTable, + getFieldValue, getHeaderValue, - toHeaderTable, -- * Basic types Size, Index, Buffer, BufferSize, - - -- * Re-exports - original, - foldedCase, - mk, ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif -import Data.CaseInsensitive +import Imports import Network.HPACK.HeaderBlock import Network.HPACK.Table import Network.HPACK.Types diff --git a/Network/HPACK/HeaderBlock.hs b/Network/HPACK/HeaderBlock.hs --- a/Network/HPACK/HeaderBlock.hs +++ b/Network/HPACK/HeaderBlock.hs @@ -2,9 +2,9 @@ decodeHeader, decodeTokenHeader, ValueTable, - HeaderTable, - toHeaderTable, - getHeaderValue, + TokenHeaderTable, + toTokenHeaderTable, + getFieldValue, encodeHeader, encodeTokenHeader, ) where diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -5,56 +5,43 @@ decodeHeader, decodeTokenHeader, ValueTable, - HeaderTable, - toHeaderTable, - getHeaderValue, + TokenHeaderTable, + toTokenHeaderTable, + getFieldValue, decodeString, decodeS, decodeSophisticated, decodeSimple, -- testing ) where -import Control.Exception (catch, throwIO) -import Data.Array (Array) -import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite) +import qualified Control.Exception as E +import Data.Array.Base (unsafeRead, unsafeWrite) import qualified Data.Array.IO as IOA import qualified Data.Array.Unsafe as Unsafe import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -import Data.CaseInsensitive (CI (..)) import Data.Char (isUpper) import Network.ByteOrder +import Network.HTTP.Semantics import Imports hiding (empty) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table -import Network.HPACK.Token import Network.HPACK.Types --- | An array to get 'HeaderValue' quickly. --- 'getHeaderValue' should be used. --- Internally, the key is 'tokenIx'. -type ValueTable = Array Int (Maybe HeaderValue) - --- | Accessing 'HeaderValue' with 'Token'. -{-# INLINE getHeaderValue #-} -getHeaderValue :: Token -> ValueTable -> Maybe HeaderValue -getHeaderValue t tbl = tbl `unsafeAt` tokenIx t - ---------------------------------------------------------------- --- | Converting the HPACK format to 'HeaderList'. +-- | Converting the HPACK format to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken. --- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeHeader :: DynamicTable -> ByteString -- ^ An HPACK format - -> IO HeaderList + -> IO [Header] decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl)) -- | Converting the HPACK format to 'TokenHeaderList' @@ -69,15 +56,19 @@ -- 'IllegalHeaderName' is thrown. -- * If a header key contains capital letters, -- 'IllegalHeaderName' is thrown. +-- * If the number of header fields is too large, +-- 'TooLargeHeader' is thrown. +-- * 'IllegalHeaderName' and 'TooLargeHeader' are thrown only once the +-- whole block has been decoded, so that the dynamic table is up to +-- date: the message is malformed, not the block. -- * 'DecodeError' would be thrown if the HPACK format is broken. --- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeTokenHeader :: DynamicTable -> ByteString -- ^ An HPACK format - -> IO HeaderTable + -> IO TokenHeaderTable decodeTokenHeader dyntbl inp = - decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `catch` \BufferOverrun -> throwIO HeaderBlockTruncated + decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `E.catch` \BufferOverrun -> E.throwIO HeaderBlockTruncated decodeHPACK :: DynamicTable @@ -87,24 +78,31 @@ decodeHPACK dyntbl inp dec = withReadBuffer inp chkChange where chkChange rbuf = do - w <- read8 rbuf - if isTableSizeUpdate w - then do - tableSizeUpdate dyntbl w rbuf - chkChange rbuf + -- A block can be empty, or hold nothing but table size updates: + -- no fields, which is what empty trailers are sent as. Reading + -- on regardless threw 'BufferOverrun', reported as a truncated + -- block, so the connection was closed over them. + leftover <- remainingSize rbuf + if leftover < 1 + then dec rbuf else do - ff rbuf (-1) - dec rbuf + w <- read8 rbuf + if isTableSizeUpdate w + then do + tableSizeUpdate dyntbl w rbuf + chkChange rbuf + else do + ff rbuf (-1) + dec rbuf --- | Converting to 'HeaderList'. +-- | Converting to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken. --- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer - -> IO HeaderList + -> IO [Header] decodeSimple decTokenHeader rbuf = go empty where go builder = do @@ -117,7 +115,7 @@ go builder' else do let tvs = run builder - kvs = map (\(t, v) -> let k = tokenFoldedKey t in (k, v)) tvs + kvs = map (\(t, v) -> let k = tokenKey t in (k, v)) tvs return kvs headerLimit :: Int @@ -136,12 +134,14 @@ -- 'IllegalHeaderName' is thrown. -- * If the number of header fields is too large, -- 'TooLargeHeader' is thrown +-- * 'IllegalHeaderName' and 'TooLargeHeader' are thrown only once the +-- whole block has been decoded, so that the dynamic table is up to +-- date: the message is malformed, not the block. -- * 'DecodeError' would be thrown if the HPACK format is broken. --- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer - -> IO HeaderTable + -> IO TokenHeaderTable decodeSophisticated decTokenHeader rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing @@ -149,7 +149,7 @@ tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where - pseudoNormal :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList + pseudoNormal :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList pseudoNormal arr = pseudo where pseudo = do @@ -162,34 +162,34 @@ then do mx <- unsafeRead arr tokenIx -- duplicated - when (isJust mx) $ throwIO IllegalHeaderName + when (isJust mx) $ malformed IllegalHeaderName -- unknown - when (isMaxTokenIx tokenIx) $ throwIO IllegalHeaderName + when (isMaxTokenIx tokenIx) $ malformed IllegalHeaderName unsafeWrite arr tokenIx (Just v) pseudo else do -- 0-Length Headers Leak - CVE-2019-9516 - when (tokenKey == "") $ throwIO IllegalHeaderName + when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ - throwIO IllegalHeaderName + malformed IllegalHeaderName unsafeWrite arr tokenIx (Just v) if isCookieTokenIx tokenIx then normal 0 empty (empty << v) else normal 0 (empty << tv) empty else return [] normal n builder cookie - | n > headerLimit = throwIO TooLargeHeader + | n > headerLimit = malformed TooLargeHeader | otherwise = do leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf tv@(Token{..}, v) <- decTokenHeader w rbuf - when isPseudo $ throwIO IllegalHeaderName + when isPseudo $ malformed IllegalHeaderName -- 0-Length Headers Leak - CVE-2019-9516 - when (tokenKey == "") $ throwIO IllegalHeaderName + when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ - throwIO IllegalHeaderName + malformed IllegalHeaderName unsafeWrite arr tokenIx (Just v) if isCookieTokenIx tokenIx then normal (n + 1) builder (cookie << v) @@ -205,11 +205,27 @@ unsafeWrite arr cookieTokenIx (Just v) return tvs + -- A field that makes the message malformed, as opposed to the block. + -- The rest of the block is decoded all the same, and only then is the + -- error thrown: every field of it may change the dynamic table, and one + -- left undecoded leaves our table out of step with the peer's encoder, + -- so that nothing after it on the connection decodes. So decoded, a + -- malformed message can be refused on its own (RFC 9113, section 8.1.1: + -- a stream error), rather than with the connection. + malformed :: DecodeError -> IO a + malformed err = skipRest >> E.throwIO err + skipRest = do + leftover <- remainingSize rbuf + when (leftover >= 1) $ do + w <- read8 rbuf + _ <- decTokenHeader w rbuf + skipRest + toTokenHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader toTokenHeader dyntbl w rbuf | w `testBit` 7 = indexed dyntbl w rbuf | w `testBit` 6 = incrementalIndexing dyntbl w rbuf - | w `testBit` 5 = throwIO IllegalTableSizeUpdate + | w `testBit` 5 = E.throwIO IllegalTableSizeUpdate | w `testBit` 4 = neverIndexing dyntbl w rbuf | otherwise = withoutIndexing dyntbl w rbuf @@ -218,7 +234,7 @@ let w' = mask5 w siz <- decodeI 5 w' rbuf suitable <- isSuitableSize siz dyntbl - unless suitable $ throwIO TooLargeTableSize + unless suitable $ E.throwIO TooLargeTableSize renewDynamicTable siz dyntbl ---------------------------------------------------------------- @@ -334,23 +350,19 @@ ---------------------------------------------------------------- --- | A pair of token list and value table. -type HeaderTable = (TokenHeaderList, ValueTable) - -- | Converting a header list of the http-types style to -- 'TokenHeaderList' and 'ValueTable'. -toHeaderTable :: [(CI HeaderName, HeaderValue)] -> IO HeaderTable -toHeaderTable kvs = do +toTokenHeaderTable :: [Header] -> IO TokenHeaderTable +toTokenHeaderTable kvs = do arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing tvs <- conv arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where - conv :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList + conv :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList conv arr = go kvs empty where - go - :: [(CI HeaderName, HeaderValue)] -> Builder TokenHeader -> IO TokenHeaderList + go :: [Header] -> Builder TokenHeader -> IO TokenHeaderList go [] builder = return $ run builder go ((k, v) : xs) builder = do let t = toToken (foldedCase k) diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.HPACK.HeaderBlock.Encode ( @@ -8,7 +7,6 @@ encodeS, ) where -import Control.Exception (bracket, throwIO) import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.ByteString.Internal (create) @@ -17,12 +15,12 @@ import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (minusPtr) import Network.ByteOrder +import Network.HTTP.Semantics import Imports import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table -import Network.HPACK.Token import Network.HPACK.Types ---------------------------------------------------------------- @@ -41,7 +39,7 @@ ---------------------------------------------------------------- --- | Converting 'HeaderList' to the HPACK format. +-- | Converting '[Header]' to the HPACK format. -- This function has overhead of allocating/freeing a temporary buffer. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader @@ -49,14 +47,17 @@ -> Size -- ^ The size of a temporary buffer. -> DynamicTable - -> HeaderList + -> [Header] -> IO ByteString -- ^ An HPACK format encodeHeader stgy siz dyntbl hs = encodeHeader' stgy siz dyntbl hs' where - hs' = map (\(k, v) -> let t = toToken k in (t, v)) hs + mk' (k, v) = (t, v) + where + t = toToken $ foldedCase k + hs' = map mk' hs --- | Converting 'HeaderList' to the HPACK format. +-- | Converting 'TokenHeaderList' to the HPACK format. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader' :: EncodeStrategy @@ -66,13 +67,13 @@ -> TokenHeaderList -> IO ByteString -- ^ An HPACK format -encodeHeader' stgy siz dyntbl hs = bracket (mallocBytes siz) free enc +encodeHeader' stgy siz dyntbl hs = E.bracket (mallocBytes siz) free enc where enc buf = do (hs', len) <- encodeTokenHeader buf siz stgy True dyntbl hs case hs' of [] -> create len $ \p -> copyBytes p buf len - _ -> throwIO BufferOverrun + _ -> E.throwIO BufferOverrun ---------------------------------------------------------------- @@ -135,26 +136,26 @@ ---------------------------------------------------------------- naiveStep - :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO () + :: (FieldName -> FieldValue -> IO ()) -> Token -> FieldValue -> IO () naiveStep fe t v = fe (tokenFoldedKey t) v ---------------------------------------------------------------- -staticStep :: FA -> FD -> FE -> Token -> HeaderValue -> IO () +staticStep :: FA -> FD -> FE -> Token -> FieldValue -> IO () staticStep fa fd fe t v = lookupRevIndex' t v fa fd fe ---------------------------------------------------------------- -linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> HeaderValue -> IO () +linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> FieldValue -> IO () linearStep rev fa fb fc fd t v = lookupRevIndex t v fa fb fc fd rev ---------------------------------------------------------------- type FA = HIndex -> IO () -type FB = HeaderValue -> Entry -> HIndex -> IO () -type FC = HeaderName -> HeaderValue -> Entry -> IO () -type FD = HeaderValue -> HIndex -> IO () -type FE = HeaderName -> HeaderValue -> IO () +type FB = FieldValue -> Entry -> HIndex -> IO () +type FC = FieldName -> FieldValue -> Entry -> IO () +type FD = FieldValue -> HIndex -> IO () +type FE = FieldName -> FieldValue -> IO () -- 6.1. Indexed Header Field Representation -- Indexed Header Field @@ -194,7 +195,7 @@ newName wbuf huff set0000 k v literalHeaderFieldWithoutIndexingNewName' - :: DynamicTable -> WriteBuffer -> Bool -> HeaderName -> HeaderValue -> IO () + :: DynamicTable -> WriteBuffer -> Bool -> FieldName -> FieldValue -> IO () literalHeaderFieldWithoutIndexingNewName' _ wbuf huff k v = newName wbuf huff set0000 k v @@ -211,14 +212,14 @@ -- Using Huffman encoding {-# INLINE indexedName #-} indexedName - :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO () + :: WriteBuffer -> Bool -> Int -> Setter -> FieldValue -> Index -> IO () indexedName wbuf huff n set v idx = do encodeI wbuf set n idx encStr wbuf huff v -- Using Huffman encoding {-# INLINE newName #-} -newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO () +newName :: WriteBuffer -> Bool -> Setter -> FieldName -> FieldValue -> IO () newName wbuf huff set k v = do write8 wbuf $ set 0 encStr wbuf huff k @@ -296,49 +297,23 @@ -> IO ByteString encodeString h bs = withWriteBuffer 4096 $ \wbuf -> encStr wbuf h bs -{- -N+ 1 2 3 <- bytes -8 254 382 16638 -7 126 254 16510 -6 62 190 16446 -5 30 158 16414 -4 14 142 16398 -3 6 134 16390 -2 2 130 16386 -1 0 128 16384 --} - +-- | The number of octets 'encodeI' produces for @l@ with an N-bit prefix. +-- +-- 'encodeS' reserves this much before it knows the Huffman-coded length, and +-- moves the code if the guess was wrong, so it has to be exact. It used to +-- stop at three octets, which is enough only up to 2^N - 1 + 2^14 - 1: +-- a Huffman-coded string of 16K or more needs four, and 'encodeI' then wrote +-- the last of them over the first octet of the code. +-- +-- >>> map (integerLength 7) [126, 127, 254, 255, 16510, 16511] +-- [1,2,2,3,3,4] {-# INLINE integerLength #-} integerLength :: Int -> Int -> Int -integerLength 8 l - | l <= 254 = 1 - | l <= 382 = 2 - | otherwise = 3 -integerLength 7 l - | l <= 126 = 1 - | l <= 254 = 2 - | otherwise = 3 -integerLength 6 l - | l <= 62 = 1 - | l <= 190 = 2 - | otherwise = 3 -integerLength 5 l - | l <= 30 = 1 - | l <= 158 = 2 - | otherwise = 3 -integerLength 4 l - | l <= 14 = 1 - | l <= 142 = 2 - | otherwise = 3 -integerLength 3 l - | l <= 6 = 1 - | l <= 134 = 2 - | otherwise = 3 -integerLength 2 l - | l <= 2 = 1 - | l <= 130 = 2 - | otherwise = 3 -integerLength _ l - | l <= 0 = 1 - | l <= 128 = 2 - | otherwise = 3 +integerLength n l + | l < p = 1 + | otherwise = go 2 (l - p) + where + p = (1 `shiftL` n) - 1 + go k r + | r < 128 = k + | otherwise = go (k + 1) (r `shiftR` 7) diff --git a/Network/HPACK/HeaderBlock/Integer.hs b/Network/HPACK/HeaderBlock/Integer.hs --- a/Network/HPACK/HeaderBlock/Integer.hs +++ b/Network/HPACK/HeaderBlock/Integer.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.HPACK.HeaderBlock.Integer ( encodeI, encodeInteger, decodeI, decodeInteger, + integerLimit, ) where +import qualified Control.Exception as E import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.ByteOrder import Imports +import Network.HPACK.Types (DecodeError (..)) -- $setup -- >>> import qualified Data.ByteString as BS @@ -129,9 +130,36 @@ p = powerArray `unsafeAt` (n - 1) i = fromIntegral w decode :: Int -> Int -> IO Int - decode m j = do - b <- fromIntegral <$> read8 rbuf - let j' = j + (b .&. 0x7f) * 2 ^ m - m' = m + 7 - cont = b `testBit` 7 - if cont then decode m' j' else return j' + decode m j + -- Checked before the shift rather than after: shifting an 'Int' by a + -- word width or more is not defined to give zero, and the value would + -- have wrapped long before there were anything to notice. + | m > maxShift = E.throwIO TooLargeInteger + | otherwise = do + b <- fromIntegral <$> read8 rbuf + let d = b .&. 0x7f + -- d * 2^m > integerLimit - j, without evaluating the product. + when (d > (integerLimit - j) `shiftR` m) $ E.throwIO TooLargeInteger + let j' = j + (d `shiftL` m) + if b `testBit` 7 then decode (m + 7) j' else return j' + +-- | The largest integer 'decodeI' will return. +-- +-- HPACK's integer encoding carries no bound of its own, so a decoder has to +-- impose one. RFC 7541, section 5.1: "Integer encodings that exceed +-- implementation limits -- in value or octet length -- MUST be treated as +-- decoding errors." +-- +-- 2^30 - 1 is far above anything HTTP\/2 can ask for -- a frame payload is at +-- most 2^24 - 1 octets, so no length or index comes near it -- and it still +-- fits in an 'Int' on a platform where that is 32 bits wide. +-- +-- >>> integerLimit +-- 1073741823 +integerLimit :: Int +integerLimit = 1073741823 + +-- | The largest shift that can carry a continuation octet into +-- 'integerLimit'; past it every further octet is an overflow. +maxShift :: Int +maxShift = 28 diff --git a/Network/HPACK/Huffman/Decode.hs b/Network/HPACK/Huffman/Decode.hs --- a/Network/HPACK/Huffman/Decode.hs +++ b/Network/HPACK/Huffman/Decode.hs @@ -9,7 +9,7 @@ GCBuffer, ) where -import Control.Exception (throwIO) +import qualified Control.Exception as E import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import qualified Data.ByteString as BS @@ -59,26 +59,41 @@ -> Int -- ^ The target length -> IO ByteString -decodeH gcbuf bufsiz rbuf len = withForeignPtr gcbuf $ \buf -> do - wbuf <- newWriteBuffer buf bufsiz - decH wbuf rbuf len - toByteString wbuf +decodeH gcbuf bufsiz rbuf len + -- The working space is only a cache. A value that may not fit gets a + -- buffer of its own: running out of room part-way used to throw + -- 'BufferOverrun', which the header block decoder reported as a + -- truncated block, so a valid field longer than the working space + -- (a long Huffman-coded @authorization@, say) closed the connection. + | maxDecodedLength len > bufsiz = + withWriteBuffer (maxDecodedLength len) $ \wbuf -> decH wbuf rbuf len + | otherwise = withForeignPtr gcbuf $ \buf -> do + wbuf <- newWriteBuffer buf bufsiz + decH wbuf rbuf len + toByteString wbuf +-- | The longest a Huffman-coded string of this many octets can decode to. +-- +-- The shortest code is 5 bits long (RFC 7541, Appendix B), so each +-- decoded octet takes at least 5 of the input's bits. +maxDecodedLength :: Int -> Int +maxDecodedLength len = len * 8 `div` 5 + -- | Low devel Huffman decoding in a write buffer. decH :: WriteBuffer -> ReadBuffer -> Int -> IO () decH wbuf rbuf len = go len (way256 `unsafeAt` 0) where go 0 way0 = case way0 of - WayStep Nothing _ -> throwIO IllegalEos + WayStep Nothing _ -> E.throwIO IllegalEos WayStep (Just i) _ | i <= 8 -> return () - | otherwise -> throwIO TooLongEos + | otherwise -> E.throwIO TooLongEos go n way0 = do w <- read8 rbuf way <- doit way0 w go (n - 1) way doit way w = case next way w of - EndOfString -> throwIO EosInTheMiddle + EndOfString -> E.throwIO EosInTheMiddle Forward n -> return $ way256 `unsafeAt` fromIntegral n GoBack n v -> do write8 wbuf v @@ -88,9 +103,9 @@ write8 wbuf v2 return $ way256 `unsafeAt` fromIntegral n --- | Huffman decoding with a temporary buffer whose size is 4096. +-- | Huffman decoding. decodeHuffman :: ByteString -> IO ByteString -decodeHuffman bs = withWriteBuffer 4096 $ \wbuf -> +decodeHuffman bs = withWriteBuffer (max 1 $ maxDecodedLength $ BS.length bs) $ \wbuf -> withReadBuffer bs $ \rbuf -> decH wbuf rbuf $ BS.length bs ---------------------------------------------------------------- diff --git a/Network/HPACK/Huffman/Encode.hs b/Network/HPACK/Huffman/Encode.hs --- a/Network/HPACK/Huffman/Encode.hs +++ b/Network/HPACK/Huffman/Encode.hs @@ -6,7 +6,7 @@ encodeHuffman, ) where -import Control.Exception (throwIO) +import qualified Control.Exception as E import Data.Array.Base (unsafeAt) import Data.Array.IArray (listArray) import Data.Array.Unboxed (UArray) @@ -75,7 +75,7 @@ off' = off - len {-# INLINE write #-} write p w = do - when (p >= limit) $ throwIO BufferOverrun + when (p >= limit) $ E.throwIO BufferOverrun let w8 = fromIntegral (w `shiftR` shiftForWrite) :: Word8 poke p w8 let p' = p `plusPtr` 1 diff --git a/Network/HPACK/Huffman/Tree.hs b/Network/HPACK/Huffman/Tree.hs --- a/Network/HPACK/Huffman/Tree.hs +++ b/Network/HPACK/Huffman/Tree.hs @@ -72,9 +72,13 @@ (cnt2, r) = build cnt1 ts in (cnt2, Bin Nothing cnt0 l r) where - (fs', ts') = partition ((==) F . head . snd) xs - fs = map (second tail) fs' - ts = map (second tail) ts' + (fs', ts') = partition (isHeadF . snd) xs + fs = map (second (drop 1)) fs' + ts = map (second (drop 1)) ts' + +isHeadF :: Bits -> Bool +isHeadF [] = error "isHeadF" +isHeadF (b : _) = b == F -- | Marking the EOS path mark :: Int -> Bits -> HTree -> HTree diff --git a/Network/HPACK/Internal.hs b/Network/HPACK/Internal.hs --- a/Network/HPACK/Internal.hs +++ b/Network/HPACK/Internal.hs @@ -7,6 +7,9 @@ module Network.HPACK.HeaderBlock.Decode, module Network.HPACK.Huffman, module Network.HPACK.Table.Entry, + + -- * Types + module Network.HPACK.Types, ) where import Network.HPACK.HeaderBlock.Decode ( @@ -14,8 +17,10 @@ decodeSimple, decodeSophisticated, decodeString, + toTokenHeaderTable, ) import Network.HPACK.HeaderBlock.Encode (encodeS, encodeString) import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table.Entry +import Network.HPACK.Types (CompressionAlgo (..), EncodeStrategy (..)) diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -24,7 +24,7 @@ getRevIndex, ) where -import Control.Exception (throwIO) +import qualified Control.Exception as E import Data.Array.Base (unsafeRead, unsafeWrite) import Data.Array.IO (IOArray, newArray) import qualified Data.ByteString.Char8 as BS @@ -43,7 +43,7 @@ {-# INLINE toIndexedEntry #-} toIndexedEntry :: DynamicTable -> Index -> IO Entry toIndexedEntry dyntbl idx - | idx <= 0 = throwIO $ IndexOverrun idx + | idx <= 0 = E.throwIO $ IndexOverrun idx | idx <= staticTableSize = return $ toStaticEntry idx | otherwise = toDynamicEntry dyntbl idx @@ -55,7 +55,13 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset x <- adj maxN (didx - off) - return $ x + staticTableSize + -- Entries sit at off+1 .. off+n, so the relative position is 1 .. n. + -- When the ring is full, n is maxN and the oldest entry is at off+maxN, + -- which is off itself: the modulus makes that 0 rather than maxN, and 0 + -- is index 61 of the static table. 'toDynamicEntry', going the other + -- way, lands on the right slot either way. + let x' = if x == 0 then maxN else x + return $ x' + staticTableSize ---------------------------------------------------------------- @@ -121,7 +127,7 @@ {-# INLINE adj #-} adj :: Int -> Int -> IO Int adj maxN x - | maxN == 0 = throwIO TooSmallTableSize + | maxN == 0 = E.throwIO TooSmallTableSize | otherwise = let ret = (x + maxN) `mod` maxN in return ret @@ -156,9 +162,9 @@ putStr "] (s = " putStr $ show $ entrySize e putStr ") " - BS.putStr $ entryHeaderName e + BS.putStr $ original $ entryHeaderName e putStr ": " - BS.putStrLn $ entryHeaderValue e + BS.putStrLn $ entryFieldValue e ---------------------------------------------------------------- @@ -216,7 +222,8 @@ :: Size -- ^ The dynamic table size -> Size - -- ^ The size of temporary buffer for Huffman decoding + -- ^ The size of temporary buffer for Huffman decoding. + -- A longer value is decoded in a buffer of its own. -> IO DynamicTable newDynamicTableForDecoding maxsiz huftmpsiz = do lim <- newIORef maxsiz @@ -303,7 +310,8 @@ :: Size -- ^ The dynamic table size -> Size - -- ^ The size of temporary buffer for Huffman + -- ^ The size of temporary buffer for Huffman decoding. + -- A longer value is decoded in a buffer of its own. -> (DynamicTable -> IO a) -> IO a withDynamicTableForDecoding maxsiz huftmpsiz action = @@ -312,17 +320,49 @@ ---------------------------------------------------------------- -- | Inserting 'Entry' to 'DynamicTable'. --- New 'DynamicTable', the largest new 'Index' --- and a set of dropped OLD 'Index' --- are returned. +-- +-- Entries are evicted first and the new one added after, as RFC 7541 +-- section 4.4 has it: "Before a new entry is added to the dynamic table, +-- entries are evicted from the end of the dynamic table until the size of +-- the dynamic table is less than or equal to (maximum size - new entry +-- size) or until the table is empty." An entry larger than the table +-- empties it and is not added. +-- +-- The order matters to the ring. It has room for maxNumbers entries, and +-- the table holds that many whenever they are all close to the 32-octet +-- minimum -- at a size of 40 or 100, say. Added first, the new entry +-- landed on the oldest one's slot, and the eviction that followed read that +-- slot back and took out the new entry instead, leaving a dummy. After +-- evicting there is always a free slot: every entry is 32 octets or more, +-- so the entries left and the new one come to at most maxNumbers. insertEntry :: Entry -> DynamicTable -> IO () insertEntry e dyntbl@DynamicTable{..} = do - insertFront e dyntbl - es <- adjustTableSize dyntbl + es <- evictFor (entrySize e) dyntbl + -- Before the new entry goes in: the reverse index is keyed by name and + -- value, so an evicted entry equal to the new one would take its + -- mapping out with it. case codeInfo of CIE (EncodeInfo rev _) -> deleteRevIndexList es rev _ -> return () + maxdsize <- readIORef maxDynamicTableSize + when (entrySize e <= maxdsize) $ insertFront e dyntbl +-- | Evicting entries until one of the given size fits, or the table is +-- empty. +evictFor :: Size -> DynamicTable -> IO [Entry] +evictFor siz dyntbl@DynamicTable{..} = evict [] + where + evict :: [Entry] -> IO [Entry] + evict es = do + n <- readIORef numOfEntries + dsize <- readIORef dynamicTableSize + maxdsize <- readIORef maxDynamicTableSize + if n == 0 || dsize + siz <= maxdsize + then return es + else do + e <- removeEnd dyntbl + evict (e : es) + insertFront :: Entry -> DynamicTable -> IO () insertFront e DynamicTable{..} = do maxN <- readIORef maxNumOfEntries @@ -344,21 +384,9 @@ CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev _ -> return () -adjustTableSize :: DynamicTable -> IO [Entry] -adjustTableSize dyntbl@DynamicTable{..} = adjust [] - where - adjust :: [Entry] -> IO [Entry] - adjust es = do - dsize <- readIORef dynamicTableSize - maxdsize <- readIORef maxDynamicTableSize - if dsize <= maxdsize - then return es - else do - e <- removeEnd dyntbl - adjust (e : es) - ---------------------------------------------------------------- +-- Used in copyEntries. insertEnd :: Entry -> DynamicTable -> IO () insertEnd e DynamicTable{..} = do maxN <- readIORef maxNumOfEntries @@ -400,7 +428,7 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset n <- readIORef numOfEntries - when (idx > n + staticTableSize) $ throwIO $ IndexOverrun idx + when (idx > n + staticTableSize) $ E.throwIO $ IndexOverrun idx didx <- adj maxN (idx + off - staticTableSize) table <- readIORef circularTable unsafeRead table didx diff --git a/Network/HPACK/Table/Entry.hs b/Network/HPACK/Table/Entry.hs --- a/Network/HPACK/Table/Entry.hs +++ b/Network/HPACK/Table/Entry.hs @@ -4,9 +4,7 @@ -- * Type Size, Entry (..), - Header, -- re-exporting - HeaderName, -- re-exporting - HeaderValue, -- re-exporting + FieldValue, -- re-exporting Index, -- re-exporting -- * Header and Entry @@ -18,7 +16,7 @@ entryTokenHeader, entryToken, entryHeaderName, - entryHeaderValue, + entryFieldValue, -- * For initialization dummyEntry, @@ -26,16 +24,18 @@ ) where import qualified Data.ByteString as BS -import Network.HPACK.Token import Network.HPACK.Types +import Network.HTTP.Semantics +import Imports + ---------------------------------------------------------------- -- | Size in bytes. type Size = Int -- | Type for table entry. Size includes the 32 bytes magic number. -data Entry = Entry Size Token HeaderValue deriving (Show) +data Entry = Entry Size Token FieldValue deriving (Show) ---------------------------------------------------------------- @@ -44,11 +44,11 @@ headerSize :: Header -> Size headerSize (k, v) = - BS.length k + BS.length (foldedCase k) + BS.length v + headerSizeMagicNumber -headerSize' :: Token -> HeaderValue -> Size +headerSize' :: Token -> FieldValue -> Size headerSize' t v = BS.length (tokenFoldedKey t) + BS.length v @@ -60,10 +60,10 @@ toEntry :: Header -> Entry toEntry kv@(k, v) = Entry siz t v where - t = toToken k + t = toToken $ foldedCase k siz = headerSize kv -toEntryToken :: Token -> HeaderValue -> Entry +toEntryToken :: Token -> FieldValue -> Entry toEntryToken t v = Entry siz t v where siz = headerSize' t v @@ -84,11 +84,11 @@ -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName -entryHeaderName (Entry _ t _) = tokenFoldedKey t +entryHeaderName (Entry _ t _) = tokenKey t -- xxx --- | Getting 'HeaderValue'. -entryHeaderValue :: Entry -> HeaderValue -entryHeaderValue (Entry _ _ v) = v +-- | Getting 'FieldValue'. +entryFieldValue :: Entry -> FieldValue +entryFieldValue (Entry _ _ v) = v ---------------------------------------------------------------- diff --git a/Network/HPACK/Table/RevIndex.hs b/Network/HPACK/Table/RevIndex.hs --- a/Network/HPACK/Table/RevIndex.hs +++ b/Network/HPACK/Table/RevIndex.hs @@ -15,16 +15,17 @@ import Data.Array (Array) import qualified Data.Array as A import Data.Array.Base (unsafeAt) -import Data.CaseInsensitive (foldedCase) import Data.Function (on) import Data.IORef +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Network.HTTP.Semantics import Imports import Network.HPACK.Table.Entry import Network.HPACK.Table.Static -import Network.HPACK.Token import Network.HPACK.Types ---------------------------------------------------------------- @@ -33,7 +34,7 @@ type DynamicRevIndex = Array Int (IORef ValueMap) -data KeyValue = KeyValue HeaderName HeaderValue deriving (Eq, Ord) +data KeyValue = KeyValue FieldName FieldValue deriving (Eq, Ord) -- We always create an index for a pair of an unknown header and its value -- in Linear{H}. @@ -55,29 +56,29 @@ data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show) -type ValueMap = Map HeaderValue HIndex +type ValueMap = Map FieldValue HIndex ---------------------------------------------------------------- staticRevIndex :: StaticRevIndex staticRevIndex = A.array (minTokenIx, maxStaticTokenIx) $ map toEnt zs where - toEnt (k, xs) = (tokenIx (toToken k), m) + toEnt (k, xs) = (tokenIx $ toToken $ foldedCase k, m) where m = case xs of - [] -> error "staticRevIndex" - [("", i)] -> StaticEntry i Nothing - (_, i) : _ -> - let vs = M.fromList xs + ("", i) :| [] -> StaticEntry i Nothing + (_, i) :| _ -> + let vs = M.fromList $ NE.toList xs in StaticEntry i (Just vs) - zs = map extract $ groupBy ((==) `on` fst) lst + zs = map extract $ NE.groupBy ((==) `on` fst) lst where lst = zipWith (\(k, v) i -> (k, (v, i))) staticTableList $ map SIndex [1 ..] - extract xs = (fst (head xs), map snd xs) + extract xs = (fst (NE.head xs), NE.map snd xs) + {-# INLINE lookupStaticRevIndex #-} lookupStaticRevIndex - :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO () + :: Int -> FieldValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO () lookupStaticRevIndex ix v fa' fbd' = case staticRevIndex `unsafeAt` ix of StaticEntry i Nothing -> fbd' i StaticEntry i (Just m) -> case M.lookup v m of @@ -87,9 +88,9 @@ ---------------------------------------------------------------- newDynamicRevIndex :: IO DynamicRevIndex -newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk lst +newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk' lst where - mk _ = newIORef M.empty + mk' _ = newIORef M.empty lst = [minTokenIx .. maxStaticTokenIx] renewDynamicRevIndex :: DynamicRevIndex -> IO () @@ -100,7 +101,7 @@ {-# INLINE lookupDynamicStaticRevIndex #-} lookupDynamicStaticRevIndex :: Int - -> HeaderValue + -> FieldValue -> DynamicRevIndex -> (HIndex -> IO ()) -> (HIndex -> IO ()) @@ -114,13 +115,13 @@ {-# INLINE insertDynamicRevIndex #-} insertDynamicRevIndex - :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO () + :: Token -> FieldValue -> HIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i where ref = drev `unsafeAt` tokenIx t {-# INLINE deleteDynamicRevIndex #-} -deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO () +deleteDynamicRevIndex :: Token -> FieldValue -> DynamicRevIndex -> IO () deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v where ref = drev `unsafeAt` tokenIx t @@ -135,19 +136,19 @@ {-# INLINE lookupOtherRevIndex #-} lookupOtherRevIndex - :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO () + :: (FieldName, FieldValue) -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO () lookupOtherRevIndex (k, v) ref fa' fc' = do oth <- readIORef ref maybe fc' fa' $ M.lookup (KeyValue k v) oth {-# INLINE insertOtherRevIndex #-} -insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO () +insertOtherRevIndex :: Token -> FieldValue -> HIndex -> OtherRevIdex -> IO () insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i where k = tokenFoldedKey t {-# INLINE deleteOtherRevIndex #-} -deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO () +deleteOtherRevIndex :: Token -> FieldValue -> OtherRevIdex -> IO () deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v) where k = tokenFoldedKey t @@ -165,11 +166,11 @@ {-# INLINE lookupRevIndex #-} lookupRevIndex :: Token - -> HeaderValue + -> FieldValue -> (HIndex -> IO ()) - -> (HeaderValue -> Entry -> HIndex -> IO ()) - -> (HeaderName -> HeaderValue -> Entry -> IO ()) - -> (HeaderValue -> HIndex -> IO ()) + -> (FieldValue -> Entry -> HIndex -> IO ()) + -> (FieldName -> FieldValue -> Entry -> IO ()) + -> (FieldValue -> HIndex -> IO ()) -> RevIndex -> IO () lookupRevIndex t@Token{..} v fa fb fc fd (RevIndex dyn oth) @@ -189,10 +190,10 @@ {-# INLINE lookupRevIndex' #-} lookupRevIndex' :: Token - -> HeaderValue + -> FieldValue -> (HIndex -> IO ()) - -> (HeaderValue -> HIndex -> IO ()) - -> (HeaderName -> HeaderValue -> IO ()) + -> (FieldValue -> HIndex -> IO ()) + -> (FieldName -> FieldValue -> IO ()) -> IO () lookupRevIndex' Token{..} v fa fd fe | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd' diff --git a/Network/HPACK/Table/Static.hs b/Network/HPACK/Table/Static.hs --- a/Network/HPACK/Table/Static.hs +++ b/Network/HPACK/Table/Static.hs @@ -9,6 +9,7 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry +import Network.HTTP.Types (Header) ---------------------------------------------------------------- diff --git a/Network/HPACK/Token.hs b/Network/HPACK/Token.hs --- a/Network/HPACK/Token.hs +++ b/Network/HPACK/Token.hs @@ -1,485 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.HPACK.Token ( - -- * Data type - Token (..), - tokenCIKey, - tokenFoldedKey, - toToken, - - -- * Ix - minTokenIx, - maxStaticTokenIx, - maxTokenIx, - cookieTokenIx, - - -- * Utilities - isMaxTokenIx, - isCookieTokenIx, - isStaticTokenIx, - isStaticToken, - - -- * Defined tokens - tokenAuthority, - tokenMethod, - tokenPath, - tokenScheme, - tokenStatus, - tokenAcceptCharset, - tokenAcceptEncoding, - tokenAcceptLanguage, - tokenAcceptRanges, - tokenAccept, - tokenAccessControlAllowOrigin, - tokenAge, - tokenAllow, - tokenAuthorization, - tokenCacheControl, - tokenContentDisposition, - tokenContentEncoding, - tokenContentLanguage, - tokenContentLength, - tokenContentLocation, - tokenContentRange, - tokenContentType, - tokenCookie, - tokenDate, - tokenEtag, - tokenExpect, - tokenExpires, - tokenFrom, - tokenHost, - tokenIfMatch, - tokenIfModifiedSince, - tokenIfNoneMatch, - tokenIfRange, - tokenIfUnmodifiedSince, - tokenLastModified, - tokenLink, - tokenLocation, - tokenMaxForwards, - tokenProxyAuthenticate, - tokenProxyAuthorization, - tokenRange, - tokenReferer, - tokenRefresh, - tokenRetryAfter, - tokenServer, - tokenSetCookie, - tokenStrictTransportSecurity, - tokenTransferEncoding, - tokenUserAgent, - tokenVary, - tokenVia, - tokenWwwAuthenticate, - tokenConnection, - tokenTE, - tokenMax, - tokenAccessControlAllowCredentials, - tokenAccessControlAllowHeaders, - tokenAccessControlAllowMethods, - tokenAccessControlExposeHeaders, - tokenAccessControlRequestHeaders, - tokenAccessControlRequestMethod, - tokenAltSvc, - tokenContentSecurityPolicy, - tokenEarlyData, - tokenExpectCt, - tokenForwarded, - tokenOrigin, - tokenPurpose, - tokenTimingAllowOrigin, - tokenUpgradeInsecureRequests, - tokenXContentTypeOptions, - tokenXForwardedFor, - tokenXFrameOptions, - tokenXXssProtection, + module Network.HTTP.Semantics.Token, ) where -import qualified Data.ByteString as B -import Data.ByteString.Internal (ByteString (..), memcmp) -import Data.CaseInsensitive (CI (..), mk, original) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (plusPtr) -import System.IO.Unsafe (unsafeDupablePerformIO) - --- $setup --- >>> :set -XOverloadedStrings - --- | Internal representation for header keys. -data Token = Token - { tokenIx :: Int - -- ^ Index for value table - , shouldBeIndexed :: Bool - -- ^ should be indexed in HPACK - , isPseudo :: Bool - -- ^ is this a pseudo header key? - , tokenKey :: CI ByteString - -- ^ Case insensitive header key - } - deriving (Eq, Show) - --- | Extracting a case insensitive header key from a token. -{-# INLINE tokenCIKey #-} -tokenCIKey :: Token -> ByteString -tokenCIKey (Token _ _ _ ci) = original ci - --- | Extracting a folded header key from a token. -{-# INLINE tokenFoldedKey #-} -tokenFoldedKey :: Token -> ByteString -tokenFoldedKey (Token _ _ _ ci) = foldedCase ci - -{- FOURMOLU_DISABLE -} -tokenAuthority :: Token -tokenMethod :: Token -tokenPath :: Token -tokenScheme :: Token -tokenStatus :: Token -tokenAcceptCharset :: Token -tokenAcceptEncoding :: Token -tokenAcceptLanguage :: Token -tokenAcceptRanges :: Token -tokenAccept :: Token -tokenAccessControlAllowOrigin :: Token -tokenAge :: Token -tokenAllow :: Token -tokenAuthorization :: Token -tokenCacheControl :: Token -tokenContentDisposition :: Token -tokenContentEncoding :: Token -tokenContentLanguage :: Token -tokenContentLength :: Token -tokenContentLocation :: Token -tokenContentRange :: Token -tokenContentType :: Token -tokenCookie :: Token -tokenDate :: Token -tokenEtag :: Token -tokenExpect :: Token -tokenExpires :: Token -tokenFrom :: Token -tokenHost :: Token -tokenIfMatch :: Token -tokenIfModifiedSince :: Token -tokenIfNoneMatch :: Token -tokenIfRange :: Token -tokenIfUnmodifiedSince :: Token -tokenLastModified :: Token -tokenLink :: Token -tokenLocation :: Token -tokenMaxForwards :: Token -tokenProxyAuthenticate :: Token -tokenProxyAuthorization :: Token -tokenRange :: Token -tokenReferer :: Token -tokenRefresh :: Token -tokenRetryAfter :: Token -tokenServer :: Token -tokenSetCookie :: Token -tokenStrictTransportSecurity :: Token -tokenTransferEncoding :: Token -tokenUserAgent :: Token -tokenVary :: Token -tokenVia :: Token -tokenWwwAuthenticate :: Token -tokenConnection :: Token -- Warp -tokenTE :: Token -- Warp -tokenAccessControlAllowCredentials :: Token -- QPACK -tokenAccessControlAllowHeaders :: Token -- QPACK -tokenAccessControlAllowMethods :: Token -- QPACK -tokenAccessControlExposeHeaders :: Token -- QPACK -tokenAccessControlRequestHeaders :: Token -- QPACK -tokenAccessControlRequestMethod :: Token -- QPACK -tokenAltSvc :: Token -- QPACK -tokenContentSecurityPolicy :: Token -- QPACK -tokenEarlyData :: Token -- QPACK -tokenExpectCt :: Token -- QPACK -tokenForwarded :: Token -- QPACK -tokenOrigin :: Token -- QPACK -tokenPurpose :: Token -- QPACK -tokenTimingAllowOrigin :: Token -- QPACK -tokenUpgradeInsecureRequests :: Token -- QPACK -tokenXContentTypeOptions :: Token -- QPACK -tokenXForwardedFor :: Token -- QPACK -tokenXFrameOptions :: Token -- QPACK -tokenXXssProtection :: Token -- QPACK - -tokenMax :: Token -- Other tokens - -tokenAuthority = Token 0 True True ":authority" -tokenMethod = Token 1 True True ":method" -tokenPath = Token 2 False True ":path" -tokenScheme = Token 3 True True ":scheme" -tokenStatus = Token 4 True True ":status" -tokenAcceptCharset = Token 5 True False "Accept-Charset" -tokenAcceptEncoding = Token 6 True False "Accept-Encoding" -tokenAcceptLanguage = Token 7 True False "Accept-Language" -tokenAcceptRanges = Token 8 True False "Accept-Ranges" -tokenAccept = Token 9 True False "Accept" -tokenAccessControlAllowOrigin = Token 10 True False "Access-Control-Allow-Origin" -tokenAge = Token 11 True False "Age" -tokenAllow = Token 12 True False "Allow" -tokenAuthorization = Token 13 True False "Authorization" -tokenCacheControl = Token 14 True False "Cache-Control" -tokenContentDisposition = Token 15 True False "Content-Disposition" -tokenContentEncoding = Token 16 True False "Content-Encoding" -tokenContentLanguage = Token 17 True False "Content-Language" -tokenContentLength = Token 18 False False "Content-Length" -tokenContentLocation = Token 19 False False "Content-Location" -tokenContentRange = Token 20 True False "Content-Range" -tokenContentType = Token 21 True False "Content-Type" -tokenCookie = Token 22 True False "Cookie" -tokenDate = Token 23 True False "Date" -tokenEtag = Token 24 False False "Etag" -tokenExpect = Token 25 True False "Expect" -tokenExpires = Token 26 True False "Expires" -tokenFrom = Token 27 True False "From" -tokenHost = Token 28 True False "Host" -tokenIfMatch = Token 29 True False "If-Match" -tokenIfModifiedSince = Token 30 True False "If-Modified-Since" -tokenIfNoneMatch = Token 31 True False "If-None-Match" -tokenIfRange = Token 32 True False "If-Range" -tokenIfUnmodifiedSince = Token 33 True False "If-Unmodified-Since" -tokenLastModified = Token 34 True False "Last-Modified" -tokenLink = Token 35 True False "Link" -tokenLocation = Token 36 True False "Location" -tokenMaxForwards = Token 37 True False "Max-Forwards" -tokenProxyAuthenticate = Token 38 True False "Proxy-Authenticate" -tokenProxyAuthorization = Token 39 True False "Proxy-Authorization" -tokenRange = Token 40 True False "Range" -tokenReferer = Token 41 True False "Referer" -tokenRefresh = Token 42 True False "Refresh" -tokenRetryAfter = Token 43 True False "Retry-After" -tokenServer = Token 44 True False "Server" -tokenSetCookie = Token 45 False False "Set-Cookie" -tokenStrictTransportSecurity = Token 46 True False "Strict-Transport-Security" -tokenTransferEncoding = Token 47 True False "Transfer-Encoding" -tokenUserAgent = Token 48 True False "User-Agent" -tokenVary = Token 49 True False "Vary" -tokenVia = Token 50 True False "Via" -tokenWwwAuthenticate = Token 51 True False "Www-Authenticate" - --- | A place holder to hold header keys not defined in the static table. --- | For Warp -tokenConnection = Token 52 False False "Connection" -tokenTE = Token 53 False False "TE" --- | For QPACK -tokenAccessControlAllowCredentials = Token 54 True False "Access-Control-Allow-Credentials" -tokenAccessControlAllowHeaders = Token 55 True False "Access-Control-Allow-Headers" -tokenAccessControlAllowMethods = Token 56 True False "Access-Control-Allow-Methods" -tokenAccessControlExposeHeaders = Token 57 True False "Access-Control-Expose-Headers" -tokenAccessControlRequestHeaders = Token 58 True False "Access-Control-Request-Headers" -tokenAccessControlRequestMethod = Token 59 True False "Access-Control-Request-Method" -tokenAltSvc = Token 60 True False "Alt-Svc" -tokenContentSecurityPolicy = Token 61 True False "Content-Security-Policy" -tokenEarlyData = Token 62 True False "Early-Data" -tokenExpectCt = Token 63 True False "Expect-Ct" -tokenForwarded = Token 64 True False "Forwarded" -tokenOrigin = Token 65 True False "Origin" -tokenPurpose = Token 66 True False "Purpose" -tokenTimingAllowOrigin = Token 67 True False "Timing-Allow-Origin" -tokenUpgradeInsecureRequests = Token 68 True False "Upgrade-Insecure-Requests" -tokenXContentTypeOptions = Token 69 True False "X-Content-Type-Options" -tokenXForwardedFor = Token 70 True False "X-Forwarded-For" -tokenXFrameOptions = Token 71 True False "X-Frame-Options" -tokenXXssProtection = Token 72 True False "X-Xss-Protection" - -tokenMax = Token 73 True False "for other tokens" -{- FOURMOLU_ENABLE -} - --- | Minimum token index. -minTokenIx :: Int -minTokenIx = 0 - --- | Maximun token index defined in the static table. -maxStaticTokenIx :: Int -maxStaticTokenIx = 51 - --- | Maximum token index. -maxTokenIx :: Int -maxTokenIx = 73 - --- | Token index for 'tokenCookie'. -cookieTokenIx :: Int -cookieTokenIx = 22 - --- | Is this token ix for Cookie? -{-# INLINE isCookieTokenIx #-} -isCookieTokenIx :: Int -> Bool -isCookieTokenIx n = n == cookieTokenIx - --- | Is this token ix to be held in the place holder? -{-# INLINE isMaxTokenIx #-} -isMaxTokenIx :: Int -> Bool -isMaxTokenIx n = n == maxTokenIx - --- | Is this token ix for a header not defined in the static table? -{-# INLINE isStaticTokenIx #-} -isStaticTokenIx :: Int -> Bool -isStaticTokenIx n = n <= maxStaticTokenIx - --- | Is this token for a header not defined in the static table? -{-# INLINE isStaticToken #-} -isStaticToken :: Token -> Bool -isStaticToken n = tokenIx n <= maxStaticTokenIx - --- | Making a token from a header key. --- --- >>> toToken ":authority" == tokenAuthority --- True --- >>> toToken "foo" --- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"} --- >>> toToken ":bar" --- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = True, tokenKey = ":bar"} -toToken :: ByteString -> Token -toToken "" = Token maxTokenIx True False "" -toToken bs = case len of - 2 -> if bs === "te" then tokenTE else mkTokenMax bs - 3 -> case lst of - 97 | bs === "via" -> tokenVia - 101 | bs === "age" -> tokenAge - _ -> mkTokenMax bs - 4 -> case lst of - 101 | bs === "date" -> tokenDate - 103 | bs === "etag" -> tokenEtag - 107 | bs === "link" -> tokenLink - 109 | bs === "from" -> tokenFrom - 116 | bs === "host" -> tokenHost - 121 | bs === "vary" -> tokenVary - _ -> mkTokenMax bs - 5 -> case lst of - 101 | bs === "range" -> tokenRange - 104 | bs === ":path" -> tokenPath - 119 | bs === "allow" -> tokenAllow - _ -> mkTokenMax bs - 6 -> case lst of - 101 | bs === "cookie" -> tokenCookie - 110 | bs === "origin" -> tokenOrigin - 114 | bs === "server" -> tokenServer - 116 - | bs === "expect" -> tokenExpect - | bs === "accept" -> tokenAccept - _ -> mkTokenMax bs - 7 -> case lst of - 99 | bs === "alt-svc" -> tokenAltSvc - 100 | bs === ":method" -> tokenMethod - 101 - | bs === ":scheme" -> tokenScheme - | bs === "purpose" -> tokenPurpose - 104 | bs === "refresh" -> tokenRefresh - 114 | bs === "referer" -> tokenReferer - 115 - | bs === "expires" -> tokenExpires - | bs === ":status" -> tokenStatus - _ -> mkTokenMax bs - 8 -> case lst of - 101 | bs === "if-range" -> tokenIfRange - 104 | bs === "if-match" -> tokenIfMatch - 110 | bs === "location" -> tokenLocation - _ -> mkTokenMax bs - 9 -> case lst of - 100 | bs === "forwarded" -> tokenForwarded - 116 | bs === "expect-ct" -> tokenExpectCt - _ -> mkTokenMax bs - 10 -> case lst of - 97 | bs === "early-data" -> tokenEarlyData - 101 | bs === "set-cookie" -> tokenSetCookie - 110 | bs === "connection" -> tokenConnection - 116 | bs === "user-agent" -> tokenUserAgent - 121 | bs === ":authority" -> tokenAuthority - _ -> mkTokenMax bs - 11 -> case lst of - 114 | bs === "retry-after" -> tokenRetryAfter - _ -> mkTokenMax bs - 12 -> case lst of - 101 | bs === "content-type" -> tokenContentType - 115 | bs === "max-forwards" -> tokenMaxForwards - _ -> mkTokenMax bs - 13 -> case lst of - 100 | bs === "last-modified" -> tokenLastModified - 101 | bs === "content-range" -> tokenContentRange - 104 | bs === "if-none-match" -> tokenIfNoneMatch - 108 | bs === "cache-control" -> tokenCacheControl - 110 | bs === "authorization" -> tokenAuthorization - 115 | bs === "accept-ranges" -> tokenAcceptRanges - _ -> mkTokenMax bs - 14 -> case lst of - 104 | bs === "content-length" -> tokenContentLength - 116 | bs === "accept-charset" -> tokenAcceptCharset - _ -> mkTokenMax bs - 15 -> case lst of - 101 | bs === "accept-language" -> tokenAcceptLanguage - 103 | bs === "accept-encoding" -> tokenAcceptEncoding - 114 | bs === "x-forwarded-for" -> tokenXForwardedFor - 115 | bs === "x-frame-options" -> tokenXFrameOptions - _ -> mkTokenMax bs - 16 -> case lst of - 101 - | bs === "content-language" -> tokenContentLanguage - | bs === "www-authenticate" -> tokenWwwAuthenticate - 103 | bs === "content-encoding" -> tokenContentEncoding - 110 - | bs === "content-location" -> tokenContentLocation - | bs === "x-xss-protection" -> tokenXXssProtection - _ -> mkTokenMax bs - 17 -> case lst of - 101 | bs === "if-modified-since" -> tokenIfModifiedSince - 103 | bs === "transfer-encoding" -> tokenTransferEncoding - _ -> mkTokenMax bs - 18 -> case lst of - 101 | bs === "proxy-authenticate" -> tokenProxyAuthenticate - _ -> mkTokenMax bs - 19 -> case lst of - 101 | bs === "if-unmodified-since" -> tokenIfUnmodifiedSince - 110 - | bs === "proxy-authorization" -> tokenProxyAuthorization - | bs === "content-disposition" -> tokenContentDisposition - | bs === "timing-allow-origin" -> tokenTimingAllowOrigin - _ -> mkTokenMax bs - 22 -> case lst of - 115 | bs === "x-content-type-options" -> tokenXContentTypeOptions - _ -> mkTokenMax bs - 23 -> case lst of - 121 | bs === "content-security-policy" -> tokenContentSecurityPolicy - _ -> mkTokenMax bs - 25 -> case lst of - 115 | bs === "upgrade-insecure-requests" -> tokenUpgradeInsecureRequests - 121 | bs === "strict-transport-security" -> tokenStrictTransportSecurity - _ -> mkTokenMax bs - 27 -> case lst of - 110 | bs === "access-control-allow-origin" -> tokenAccessControlAllowOrigin - _ -> mkTokenMax bs - 28 -> case lst of - 115 - | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders - | bs === "access-control-allow-methods" -> tokenAccessControlAllowMethods - _ -> mkTokenMax bs - 29 -> case lst of - 100 | bs === "access-control-request-method" -> tokenAccessControlRequestMethod - 115 | bs === "access-control-expose-headers" -> tokenAccessControlExposeHeaders - _ -> mkTokenMax bs - 30 -> case lst of - 115 | bs === "access-control-request-headers" -> tokenAccessControlRequestHeaders - _ -> mkTokenMax bs - 32 -> case lst of - 115 - | bs === "access-control-allow-credentials" -> - tokenAccessControlAllowCredentials - _ -> mkTokenMax bs - _ -> mkTokenMax bs - where - len = B.length bs - lst = B.last bs - PS fp1 off1 siz === PS fp2 off2 _ = unsafeDupablePerformIO $ - withForeignPtr fp1 $ \p1 -> - withForeignPtr fp2 $ \p2 -> do - i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz - return $ i == 0 - -mkTokenMax :: ByteString -> Token -mkTokenMax bs = Token maxTokenIx True p (mk bs) - where - p - | B.length bs == 0 = False - | B.head bs == 58 = True - | otherwise = False +import Network.HTTP.Semantics.Token diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} - module Network.HPACK.Types ( -- * Header - HeaderName, - HeaderValue, - Header, - HeaderList, + FieldValue, TokenHeader, TokenHeaderList, @@ -25,35 +20,13 @@ BufferOverrun (..), ) where -import Control.Exception as E -import Data.Typeable +import qualified Control.Exception as E import Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize) import Imports -import Network.HPACK.Token (Token) ---------------------------------------------------------------- --- | Header name. -type HeaderName = ByteString - --- | Header value. -type HeaderValue = ByteString - --- | Header. -type Header = (HeaderName, HeaderValue) - --- | Header list. -type HeaderList = [Header] - --- | TokenBased header. -type TokenHeader = (Token, HeaderValue) - --- | TokenBased header list. -type TokenHeaderList = [TokenHeader] - ----------------------------------------------------------------- - -- | Index for table. type Index = Int @@ -103,6 +76,9 @@ IllegalEos | -- | Eos of huffman string is more than 7 bits TooLongEos + | -- | An integer is encoded above the limit this decoder accepts, + -- or in more octets than reaching that limit can take + TooLargeInteger | -- | A peer set the dynamic table size less than 32 TooSmallTableSize | -- | A peer tried to change the dynamic table size over the limit @@ -112,6 +88,6 @@ | HeaderBlockTruncated | IllegalHeaderName | TooLargeHeader - deriving (Eq, Show, Typeable) + deriving (Eq, Show) -instance Exception DecodeError +instance E.Exception DecodeError diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | HTTP\/2 client library. @@ -10,11 +9,11 @@ -- > -- > module Main where -- > --- > import Control.Concurrent.Async --- > import qualified Control.Exception as E -- > import qualified Data.ByteString.Char8 as C8 -- > import Network.HTTP.Types -- > import Network.Run.TCP (runTCPClient) -- network-run +-- > import Control.Concurrent.Async +-- > import qualified Control.Exception as E -- > -- > import Network.HTTP2.Client -- > @@ -24,7 +23,7 @@ -- > main :: IO () -- > main = runTCPClient serverName "80" $ runHTTP2Client serverName -- > where --- > cliconf host = defaultClientConfig { authority = C8.pack host } +-- > cliconf host = defaultClientConfig { authority = host } -- > runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096) -- > freeSimpleConfig -- > (\conf -> run (cliconf host) conf client) @@ -47,8 +46,6 @@ run, -- * Client configuration - Scheme, - Authority, ClientConfig, defaultClientConfig, scheme, @@ -66,56 +63,34 @@ initialWindowSize, maxFrameSize, maxHeaderListSize, + + -- ** Rate limits pingRateLimit, + settingsRateLimit, + emptyFrameRateLimit, + rstRateLimit, -- * Common configuration - Config (..), + Config, + defaultConfig, + confWriteBuffer, + confBufferSize, + confSendAll, + confReadN, + confPositionReadMaker, + confTimeoutManager, + confMySockAddr, + confPeerSockAddr, + confReadNTimeout, + confOnInformational, allocSimpleConfig, + allocSimpleConfig', freeSimpleConfig, - - -- * HTTP\/2 client - Client, - SendRequest, - - -- * Request - Request, - - -- * Creating request - requestNoBody, - requestFile, - requestStreaming, - requestStreamingUnmask, - requestBuilder, - - -- ** Trailers maker - TrailersMaker, - NextTrailersMaker (..), - defaultTrailersMaker, - setRequestTrailersMaker, - - -- * Response - Response, - - -- ** Accessing response - responseStatus, - responseHeaders, - responseBodySize, - getResponseBodyChunk, - getResponseTrailers, - - -- * Aux - Aux, - auxPossibleClientStreams, - - -- * Types - Method, - Path, - FileSpec (..), - FileOffset, - ByteCount, + module Network.HTTP.Semantics.Client, -- * Error HTTP2Error (..), + StreamTerminated (..), ReasonPhrase, ErrorCode ( ErrorCode, @@ -134,98 +109,11 @@ InadequateSecurity, HTTP11Required ), - - -- * RecvN - defaultReadN, - - -- * Position read for files - PositionReadMaker, - PositionRead, - Sentinel (..), - defaultPositionReadMaker, ) where -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.IORef (readIORef) -import Network.HTTP.Types +import Network.HTTP.Semantics.Client -import Network.HPACK import Network.HTTP2.Client.Run -import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 hiding (authority, scheme) - ----------------------------------------------------------------- - --- | Creating request without body. -requestNoBody :: Method -> Path -> RequestHeaders -> Request -requestNoBody m p hdr = Request $ OutObj hdr' OutBodyNone defaultTrailersMaker - where - hdr' = addHeaders m p hdr - --- | Creating request with file. -requestFile :: Method -> Path -> RequestHeaders -> FileSpec -> Request -requestFile m p hdr fileSpec = Request $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker - where - hdr' = addHeaders m p hdr - --- | Creating request with builder. -requestBuilder :: Method -> Path -> RequestHeaders -> Builder -> Request -requestBuilder m p hdr builder = Request $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker - where - hdr' = addHeaders m p hdr - --- | Creating request with streaming. -requestStreaming - :: Method - -> Path - -> RequestHeaders - -> ((Builder -> IO ()) -> IO () -> IO ()) - -> Request -requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker - where - hdr' = addHeaders m p hdr - --- | Like 'requestStreaming', but run the action with exceptions masked -requestStreamingUnmask - :: Method - -> Path - -> RequestHeaders - -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) - -> Request -requestStreamingUnmask m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingUnmask strmbdy) defaultTrailersMaker - where - hdr' = addHeaders m p hdr - -addHeaders :: Method -> Path -> RequestHeaders -> RequestHeaders -addHeaders m p hdr = (":method", m) : (":path", p) : hdr - --- | Setting 'TrailersMaker' to 'Response'. -setRequestTrailersMaker :: Request -> TrailersMaker -> Request -setRequestTrailersMaker (Request req) tm = Request req{outObjTrailers = tm} - ----------------------------------------------------------------- - --- | Getting the status of a response. -responseStatus :: Response -> Maybe Status -responseStatus (Response rsp) = getStatus $ inpObjHeaders rsp - --- | Getting the headers from a response. -responseHeaders :: Response -> HeaderTable -responseHeaders (Response rsp) = inpObjHeaders rsp - --- | Getting the body size from a response. -responseBodySize :: Response -> Maybe Int -responseBodySize (Response rsp) = inpObjBodySize rsp - --- | Reading a chunk of the response body. --- An empty 'ByteString' returned when finished. -getResponseBodyChunk :: Response -> IO ByteString -getResponseBodyChunk (Response rsp) = inpObjBody rsp - --- | Reading response trailers. --- This function must be called after 'getResponseBodyChunk' --- returns an empty. -getResponseTrailers :: Response -> IO (Maybe HeaderTable) -getResponseTrailers (Response rsp) = readIORef (inpObjTrailers rsp) +import Network.HTTP2.H2.OutBodyIface diff --git a/Network/HTTP2/Client/Internal.hs b/Network/HTTP2/Client/Internal.hs --- a/Network/HTTP2/Client/Internal.hs +++ b/Network/HTTP2/Client/Internal.hs @@ -1,6 +1,7 @@ module Network.HTTP2.Client.Internal ( Request (..), Response (..), + Config (..), ClientConfig (..), Settings (..), Aux (..), @@ -11,6 +12,8 @@ runIO, ) where +import Network.HTTP.Semantics.Client +import Network.HTTP.Semantics.Client.Internal + import Network.HTTP2.Client.Run -import Network.HTTP2.Client.Types import Network.HTTP2.H2 diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -1,26 +1,28 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Client.Run where -import Control.Concurrent.STM (check) -import Control.Exception -import Data.ByteString.Builder (Builder) +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Control.Exception as E import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef +import Data.IP (IPv6) import Network.Control (RxFlow (..), defaultMaxData) +import Network.HTTP.Semantics.Client +import Network.HTTP.Semantics.Client.Internal +import Network.HTTP.Semantics.IO import Network.Socket (SockAddr) -import UnliftIO.Async -import UnliftIO.Concurrent -import UnliftIO.STM +import qualified System.ThreadManager as T +import Text.Read (readMaybe) import Imports -import Network.HTTP.Types (Header) -import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 +import Network.HTTP2.H2.OutBodyIface -- | Client configuration data ClientConfig = ClientConfig @@ -52,7 +54,7 @@ -- @userinfo\@@ as part of the authority. -- -- >>> defaultClientConfig --- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}} +-- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultClientConfig :: ClientConfig defaultClientConfig = ClientConfig @@ -66,8 +68,8 @@ -- | Running HTTP/2 client. run :: ClientConfig -> Config -> Client a -> IO a run cconf@ClientConfig{..} conf client = do - (ctx, mgr) <- setup cconf conf - runH2 conf ctx mgr $ runClient ctx mgr + ctx <- setup cconf conf + runH2 conf ctx $ runClient ctx where serverMaxStreams ctx = do mx <- maxConcurrentStreams <$> readIORef (peerSettings ctx) @@ -79,44 +81,74 @@ n <- oddConc <$> readTVarIO (oddStreamTable ctx) return (x - n) aux ctx = - Aux + defaultAux { auxPossibleClientStreams = possibleClientStream ctx + , auxSendPing = + sendPing + ctx + False + "Haskell!" -- 8 bytes } - clientCore ctx mgr req processResponse = do - strm <- sendRequest ctx mgr scheme authority req + clientCore ctx req processResponse = counted ctx $ do + (strm, moutobj) <- makeStream ctx scheme authority req + case moutobj of + Nothing -> return () + Just outobj -> sendRequest conf ctx strm outobj False rsp <- getResponse strm - processResponse rsp - runClient ctx mgr = do - x <- client (clientCore ctx mgr) $ aux ctx - waitCounter0 mgr - let frame = goawayFrame 0 NoError "graceful closing" - mvar <- newMVar () - enqueueControl (controlQ ctx) $ CGoaway frame mvar - takeMVar mvar - return x + processResponse rsp `E.finally` doneWithStream ctx strm + -- After a GOAWAY, the connection lasts as long as a request is in + -- 'activeRequests' ('drained'). + counted ctx = + E.bracket_ + (atomically $ modifyTVar' (activeRequests ctx) (+ 1)) + (atomically $ modifyTVar' (activeRequests ctx) (subtract 1)) + runClient ctx = client (clientCore ctx) $ aux ctx -- | Launching a receiver and a sender. runIO :: ClientConfig -> Config -> (ClientIO -> IO (IO a)) -> IO a runIO cconf@ClientConfig{..} conf@Config{..} action = do - (ctx@Context{..}, mgr) <- setup cconf conf + ctx@Context{..} <- setup cconf conf let putB bs = enqueueControl controlQ $ CFrames Nothing [bs] putR req = do - strm <- sendRequest ctx mgr scheme authority req + (strm, moutobj) <- makeStream ctx scheme authority req + case moutobj of + Nothing -> return () + Just outobj -> sendRequest conf ctx strm outobj True return (streamNumber strm, strm) get = getResponse create = openOddStreamWait ctx runClient <- action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create - runH2 conf ctx mgr runClient + runH2 conf ctx runClient +-- | Called once 'processResponse' is done with a stream, however it ended. +-- +-- A response it did not read to the end left its stream open. The server +-- went on sending the rest of the body, which nobody would read: it held +-- the stream's slot of the server's SETTINGS_MAX_CONCURRENT_STREAMS, and +-- the octets that came in were never given back to the connection window. +-- Enough such requests, or ones whose 'processResponse' threw, and new +-- requests waited for a slot, or the connection stalled. So such a stream +-- is reset (CANCEL), and what was left of its body is given back. +doneWithStream :: Context -> Stream -> IO () +doneWithStream ctx strm = do + cancelled <- + closeIfReceiving ctx strm $ ResetByMe $ E.toException CancelledStream + if cancelled + then do + enqueueControl (controlQ ctx) $ + CFrames Nothing [resetFrame Cancel $ streamNumber strm] + giveBackUnread ctx strm + else adjustRxWindow ctx strm + getResponse :: Stream -> IO Response getResponse strm = do mRsp <- takeMVar $ streamInput strm case mRsp of - Left err -> throwIO err + Left err -> E.throwIO err Right rsp -> return $ Response rsp -setup :: ClientConfig -> Config -> IO (Context, Manager) +setup :: ClientConfig -> Config -> IO Context setup ClientConfig{..} conf@Config{..} = do let clientInfo = newClientInfo scheme authority ctx <- @@ -126,102 +158,175 @@ cacheLimit connectionWindowSize settings - mgr <- start confTimeoutManager + confTimeoutManager + Nothing exchangeSettings ctx - return (ctx, mgr) + return ctx -runH2 :: Config -> Context -> Manager -> IO a -> IO a -runH2 conf ctx mgr runClient = - stopAfter mgr (race runBackgroundThreads runClient) $ \res -> do - closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $ - either Just (const Nothing) res - case res of - Left err -> - throwIO err - Right (Left ()) -> - undefined -- never reach - Right (Right x) -> - return x +runH2 :: Config -> Context -> IO a -> IO a +runH2 conf ctx runClient = do + T.stopAfter mgr (E.try runAll >>= closureClient conf ctx) $ \res -> + closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res where + mgr = threadManager ctx runReceiver = frameReceiver ctx conf - runSender = frameSender ctx conf mgr - runBackgroundThreads = concurrently_ runReceiver runSender + runSender = frameSender ctx conf + runClientReceiver = do + labelMe "H2 ClientReceiver" + withAsync runReceiver $ \ar -> + withAsync runClient $ \ac -> do + er <- waitEither ar ac + case er of + Right r -> return r + Left err -> do + goingaway <- isJust <$> readTVarIO (peerGoAway ctx) + case E.fromException err of + -- The connection has run its course after the + -- server's GOAWAY. The client function is let + -- finish, rather than killed with it: every + -- request it makes from here is refused, and + -- one still waiting is failed now. + Just ConnectionIsClosed + | goingaway -> do + closeAllStreams + (oddStreamTable ctx) + (evenStreamTable ctx) + (Just err) + wait ac + _ -> E.throwIO err -sendRequest + -- When 'runClientReceiver' terminates, it is important we give the sender + -- a chance to terminate cleanly also (it's possible the client terminated + -- but there are still some messages in the queue to be sent). + -- + -- If the client terminated successfully, we ignore any other errors in the + -- sender (indeed, any exception here might simply be that the background + -- threads were cancelled /because/ the client terminated). + -- + -- If the sender terminates first, it failed, and no request can go out + -- any more: the client is stopped and the sender's error reported, rather + -- than the client left waiting on a connection nothing sends on. + runAll = + withAsync runSender $ \as -> + withAsync runClientReceiver $ \ac -> do + r <- waitEither as ac + case r of + Right x -> wait as >> return x + Left e -> do + -- The sender also finishes, normally, as soon as the + -- receiver is done and the queues are empty, and may + -- get there before the client side is seen to. Only + -- with the receiver still running did it fail. + done <- readTVarIO $ receiverDone ctx + case done of + Just _ -> wait ac + Nothing -> E.throwIO e + +makeStream :: Context - -> Manager -> Scheme -> Authority -> Request - -> IO Stream -sendRequest ctx@Context{..} mgr scheme auth (Request req) = do + -> IO (Stream, Maybe OutObj) +makeStream ctx@Context{..} scheme auth (Request req) = do -- Checking push promises let hdr0 = outObjHeaders req - method = fromMaybe (error "sendRequest:method") $ lookup ":method" hdr0 - path = fromMaybe (error "sendRequest:path") $ lookup ":path" hdr0 + method = fromMaybe (error "makeStream:method") $ lookup ":method" hdr0 + path = fromMaybe (error "makeStream:path") $ lookup ":path" hdr0 mstrm0 <- lookupEvenCache evenStreamTable method path case mstrm0 of Just strm0 -> do deleteEvenCache evenStreamTable method path - return strm0 + return (strm0, Nothing) Nothing -> do -- Arch/Sender is originally implemented for servers where -- the ordering of responses can be out-of-order. -- But for clients, the ordering must be maintained. -- To implement this, 'outputQStreamID' is used. - -- Also, for 'OutBodyStreaming', TBQ must not be empty - -- when its 'Output' is enqueued into 'outputQ'. - -- Otherwise, it would be re-enqueue because of empty - -- resulting in out-of-order. - -- To implement this, 'tbqNonEmpty' is used. + let isIPv6 = isJust (readMaybe auth :: Maybe IPv6) + auth' + | isIPv6 = "[" <> UTF8.fromString auth <> "]" + | otherwise = UTF8.fromString auth let hdr1, hdr2 :: [Header] hdr1 | scheme /= "" = (":scheme", scheme) : hdr0 | otherwise = hdr0 hdr2 - | auth /= "" = (":authority", UTF8.fromString auth) : hdr1 + | auth /= "" = (":authority", auth') : hdr1 | otherwise = hdr1 req' = req{outObjHeaders = hdr2} -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit - (sid, newstrm) <- openOddStreamWait ctx - case outObjBody req of - OutBodyStreaming strmbdy -> - sendStreaming ctx mgr req' sid newstrm $ \unmask push flush -> - unmask $ strmbdy push flush - OutBodyStreamingUnmask strmbdy -> - sendStreaming ctx mgr req' sid newstrm strmbdy - _ -> atomically $ do - sidOK <- readTVar outputQStreamID - check (sidOK == sid) - writeTVar outputQStreamID (sid + 2) - writeTQueue outputQ $ Output newstrm req' OObj Nothing (return ()) - return newstrm + (_sid, newstrm) <- openOddStreamWait ctx + writeIORef (streamRequestMethod newstrm) $ Just method + return (newstrm, Just req') +sendRequest :: Config -> Context -> Stream -> OutObj -> Bool -> IO () +sendRequest Config{..} ctx@Context{..} strm OutObj{..} io = do + let sid = streamNumber strm + (mnext, mtbq) <- (`E.onException` abandon sid) $ case outObjBody of + OutBodyNone -> return (Nothing, Nothing) + OutBodyFile (FileSpec path fileoff bytecount) -> do + (pread, sentinel) <- confPositionReadMaker path + let next = fillFileBodyGetNext pread fileoff bytecount sentinel + return (Just next, Nothing) + OutBodyBuilder builder -> do + let next = fillBuilderBodyGetNext builder + return (Just next, Nothing) + OutBodyStreaming strmbdy -> do + q <- sendStreaming ctx strm $ \iface -> + outBodyUnmask iface $ strmbdy (outBodyPush iface) (outBodyFlush iface) + let next = nextForStreaming q + return (Just next, Just q) + OutBodyStreamingIface strmbdy -> do + q <- sendStreaming ctx strm strmbdy + let next = nextForStreaming q + return (Just next, Just q) + let ot = OHeader outObjHeaders mnext outObjTrailers + if io + then do + let out = makeOutputIO ctx strm mtbq ot + pushOutput sid out `E.onException` abandon sid + else do + (pop, out) <- makeOutput strm ot + pushOutput sid out `E.onException` abandon sid + lc <- newLoopCheck strm mtbq + T.forkManaged threadManager label $ syncWithSender' ctx pop lc + where + label = "H2 request sender for stream " ++ show (streamNumber strm) + pushOutput sid out = atomically $ do + sidOK <- readTVar outputQStreamID + check (sidOK == sid) + writeTVar outputQStreamID (sid + 2) + enqueueOutputSTM outputQ out + -- The request failed before it was queued -- the file of a + -- 'requestFile' could not be opened, say, or the thread was killed while + -- waiting for its turn. Its stream id was taken but nothing went out on + -- it, and requests go out in stream id order: 'pushOutput' waits for + -- 'outputQStreamID' to reach its own id. Left as it was, that turn never + -- came, so every later request waited for ever, and the stream held its + -- concurrency slot. So the stream is taken out of the table, and a + -- thread passes its turn on once it arrives; the id goes unused, which a + -- later, higher one closes implicitly (RFC 9113, section 5.1.1). + abandon sid = do + closed ctx strm Killed + T.forkManaged threadManager ("H2 skipping stream " ++ show sid) $ + atomically $ do + sidOK <- readTVar outputQStreamID + check (sidOK == sid) + writeTVar outputQStreamID (sid + 2) + sendStreaming :: Context - -> Manager - -> OutObj - -> StreamId -> Stream - -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) - -> IO () -sendStreaming Context{..} mgr req sid newstrm strmbdy = do + -> (OutBodyIface -> IO ()) + -> IO (TBQueue StreamingChunk) +sendStreaming ctx@Context{..} strm strmbdy = do tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 - tbqNonEmpty <- newTVarIO False - forkManagedUnmask mgr $ \unmask -> do - let push b = atomically $ do - writeTBQueue tbq (StreamingBuilder b) - writeTVar tbqNonEmpty True - flush = atomically $ writeTBQueue tbq StreamingFlush - finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr) - incCounter mgr - strmbdy unmask push flush `finally` finished - atomically $ do - sidOK <- readTVar outputQStreamID - ready <- readTVar tbqNonEmpty - check (sidOK == sid && ready) - writeTVar outputQStreamID (sid + 2) - writeTQueue outputQ $ Output newstrm req OObj (Just tbq) (return ()) + T.forkManagedUnmask threadManager label $ \unmask -> + withOutBodyIface ctx strm tbq unmask strmbdy + return tbq + where + label = "H2 request streaming sender for stream " ++ show (streamNumber strm) exchangeSettings :: Context -> IO () exchangeSettings Context{..} = do diff --git a/Network/HTTP2/Client/Types.hs b/Network/HTTP2/Client/Types.hs deleted file mode 100644 --- a/Network/HTTP2/Client/Types.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module Network.HTTP2.Client.Types where - -import Network.HTTP2.H2 - ----------------------------------------------------------------- - --- | Send a request and receive its response. -type SendRequest = forall r. Request -> (Response -> IO r) -> IO r - --- | Client type. -type Client a = SendRequest -> Aux -> IO a - --- | Request from client. -newtype Request = Request OutObj deriving (Show) - --- | Response from server. -newtype Response = Response InpObj deriving (Show) - --- | Additional information. -data Aux = Aux - { auxPossibleClientStreams :: IO Int - -- ^ How many streams can be created without blocking. - } diff --git a/Network/HTTP2/Frame.hs b/Network/HTTP2/Frame.hs --- a/Network/HTTP2/Frame.hs +++ b/Network/HTTP2/Frame.hs @@ -73,7 +73,7 @@ SettingsList, SettingsKey ( SettingsKey, - SettingsHeaderTableSize, + SettingsTokenHeaderTableSize, SettingsEnablePush, SettingsMaxConcurrentStreams, SettingsInitialWindowSize, diff --git a/Network/HTTP2/Frame/Decode.hs b/Network/HTTP2/Frame/Decode.hs --- a/Network/HTTP2/Frame/Decode.hs +++ b/Network/HTTP2/Frame/Decode.hs @@ -24,7 +24,7 @@ decodeContinuationFrame, ) where -import Control.Exception (Exception) +import qualified Control.Exception as E import Data.Array (Array, listArray, (!)) import qualified Data.ByteString as BS import Foreign.Ptr (Ptr, plusPtr) @@ -39,7 +39,7 @@ data FrameDecodeError = FrameDecodeError ErrorCode StreamId ShortByteString deriving (Eq, Show) -instance Exception FrameDecodeError +instance E.Exception FrameDecodeError ---------------------------------------------------------------- @@ -93,6 +93,10 @@ Left $ FrameDecodeError ProtocolError streamId "cannot used in non-zero stream" | otherwise = checkType typ where + checkType FrameData + | testPadded flags && payloadLength < 1 = + Left $ + FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length" checkType FrameHeaders | testPadded flags && payloadLength < 1 = Left $ @@ -143,6 +147,18 @@ ProtocolError streamId "push promise must be used with an odd stream identifier" + | testPadded flags && payloadLength < 5 = + Left $ + FrameDecodeError + FrameSizeError + streamId + "insufficient payload for Pad Length and promised stream id" + | not (testPadded flags) && payloadLength < 4 = + Left $ + FrameDecodeError + FrameSizeError + streamId + "insufficient payload for promised stream id" checkType FramePing | payloadLength /= 8 = Left $ @@ -207,39 +223,52 @@ decodeFramePayload :: FrameType -> FramePayloadDecoder decodeFramePayload ftyp | ftyp > maxFrameType = checkFrameSize $ decodeUnknownFrame ftyp -decodeFramePayload ftyp = checkFrameSize decoder - where - decoder = payloadDecoders ! ftyp +decodeFramePayload ftyp = payloadDecoders ! ftyp -- each one checks its own size ---------------------------------------------------------------- -- | Frame payload decoder for DATA frame. decodeDataFrame :: FramePayloadDecoder -decodeDataFrame header bs = decodeWithPadding header bs DataFrame +decodeDataFrame = checkFrameSize $ \header bs -> + decodeWithPadding header bs $ Right . DataFrame -- | Frame payload decoder for HEADERS frame. decodeHeadersFrame :: FramePayloadDecoder -decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' -> - if hasPriority - then - let (bs0, bs1) = BS.splitAt 5 bs' - p = priority bs0 - in HeadersFrame (Just p) bs1 - else HeadersFrame Nothing bs' - where - hasPriority = testPriority $ flags header +decodeHeadersFrame = checkFrameSize $ \header@FrameHeader{streamId} bs -> + decodeWithPadding header bs $ \bs' -> + if testPriority $ flags header + then + -- The header check knows the payload is long enough to hold + -- the priority fields, but not that the padding leaves them + -- there: Pad Length may cover the lot. + if BS.length bs' < 5 + then + Left $ + FrameDecodeError + FrameSizeError + streamId + "no room for priority fields" + else + let (bs0, bs1) = BS.splitAt 5 bs' + in Right $ HeadersFrame (Just (priority bs0)) bs1 + else Right $ HeadersFrame Nothing bs' -- | Frame payload decoder for PRIORITY frame. decodePriorityFrame :: FramePayloadDecoder -decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs +decodePriorityFrame = checkFrameSize $ requireBytes 5 $ \_ bs -> + Right $ PriorityFrame $ priority bs -- | Frame payload decoder for RST_STREAM frame. decodeRSTStreamFrame :: FramePayloadDecoder -decodeRSTStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode (N.word32 bs) +decodeRSTStreamFrame = checkFrameSize $ requireBytes 4 $ \_ bs -> + Right $ RSTStreamFrame $ toErrorCode $ N.word32 bs -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder -decodeSettingsFrame FrameHeader{..} (PS fptr off _) +decodeSettingsFrame = checkFrameSize decodeSettingsFrame' + +decodeSettingsFrame' :: FramePayloadDecoder +decodeSettingsFrame' FrameHeader{..} (PS fptr off _) | num > 10 = Left $ FrameDecodeError EnhanceYourCalm streamId "Settings is too large" | otherwise = Right $ SettingsFrame alist @@ -259,19 +288,33 @@ -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder -decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' -> - let (bs0, bs1) = BS.splitAt 4 bs' - sid = streamIdentifier (N.word32 bs0) - in PushPromiseFrame sid bs1 +decodePushPromiseFrame = checkFrameSize $ \header@FrameHeader{streamId} bs -> + decodeWithPadding header bs $ \bs' -> + -- As in HEADERS: the padding may cover the promised stream id. + if BS.length bs' < 4 + then + Left $ + FrameDecodeError + FrameSizeError + streamId + "no room for the promised stream id" + else + let (bs0, bs1) = BS.splitAt 4 bs' + sid = streamIdentifier (N.word32 bs0) + in Right $ PushPromiseFrame sid bs1 -- | Frame payload decoder for PING frame. decodePingFrame :: FramePayloadDecoder -decodePingFrame _ bs = Right $ PingFrame bs +decodePingFrame = checkFrameSize $ \_ _bs -> Right $ PingFrame $ BS.copy _bs -- | Frame payload decoder for GOAWAY frame. decodeGoAwayFrame :: FramePayloadDecoder -decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2 +decodeGoAwayFrame = checkFrameSize $ requireBytes 8 decodeGoAwayFrame' + +decodeGoAwayFrame' :: FramePayloadDecoder +decodeGoAwayFrame' _ _bs = Right $ GoAwayFrame sid ecid bs2 where + bs = BS.copy _bs (bs0, bs1') = BS.splitAt 4 bs (bs1, bs2) = BS.splitAt 4 bs1' sid = streamIdentifier (N.word32 bs0) @@ -279,7 +322,10 @@ -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder -decodeWindowUpdateFrame FrameHeader{..} bs +decodeWindowUpdateFrame = checkFrameSize $ requireBytes 4 decodeWindowUpdateFrame' + +decodeWindowUpdateFrame' :: FramePayloadDecoder +decodeWindowUpdateFrame' FrameHeader{..} bs | wsi == 0 = Left $ FrameDecodeError ProtocolError streamId "window update must not be 0" | otherwise = Right $ WindowUpdateFrame wsi @@ -288,10 +334,12 @@ -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder -decodeContinuationFrame _ bs = Right $ ContinuationFrame bs +decodeContinuationFrame = checkFrameSize $ \_ _bs -> Right $ ContinuationFrame $ BS.copy _bs decodeUnknownFrame :: FrameType -> FramePayloadDecoder -decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs +decodeUnknownFrame typ _ _bs = Right $ UnknownFrame typ bs + where + bs = BS.copy _bs ---------------------------------------------------------------- @@ -301,6 +349,22 @@ Left $ FrameDecodeError FrameSizeError streamId "payload is too short" | otherwise = func header body +-- | Require the payload to actually hold the fixed fields about to be read +-- from it. +-- +-- The reads below sit at fixed offsets and never consult the length of the +-- 'ByteString' they read from, so a payload shorter than the field runs off +-- the end of the buffer -- and an empty one is the shared empty +-- 'ByteString', whose pointer is null. 'checkFrameHeader' pins these lengths +-- down, but it is a separate function that a caller of the decoders is free +-- not to have used, and 'checkFrameSize' only compares the payload against +-- the length the frame header claims, which may itself be wrong. +requireBytes :: Int -> FramePayloadDecoder -> FramePayloadDecoder +requireBytes n func header@FrameHeader{streamId} body + | BS.length body < n = + Left $ FrameDecodeError FrameSizeError streamId "payload is too short" + | otherwise = func header body + -- | Helper function to pull off the padding if its there, and will -- eat up the trailing padding automatically. Calls the decoder func -- passed in with the length of the unpadded portion between the @@ -308,18 +372,25 @@ decodeWithPadding :: FrameHeader -> ByteString - -> (ByteString -> FramePayload) + -> (ByteString -> Either FrameDecodeError FramePayload) -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body - | padded = - let (w8, rest) = fromMaybe (error "decodeWithPadding") $ BS.uncons bs - padlen = intFromWord8 w8 - bodylen = payloadLength - padlen - 1 - in if bodylen < 0 - then Left $ FrameDecodeError ProtocolError streamId "padding is not enough" - else Right . body $ BS.take bodylen rest - | otherwise = Right $ body bs + | padded = case BS.uncons bs' of + -- The header checks rule this out for every frame type that can be + -- padded, but the type does not, and the reply to a payload with no + -- room for its Pad Length is an error, never a crash. + Nothing -> + Left $ + FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length" + Just (w8, rest) + | bodylen < 0 -> + Left $ FrameDecodeError ProtocolError streamId "padding is not enough" + | otherwise -> body $ BS.take bodylen rest + where + bodylen = payloadLength - intFromWord8 w8 - 1 + | otherwise = body bs' where + bs' = BS.copy bs padded = testPadded flags streamIdentifier :: Word32 -> StreamId diff --git a/Network/HTTP2/Frame/Types.hs b/Network/HTTP2/Frame/Types.hs --- a/Network/HTTP2/Frame/Types.hs +++ b/Network/HTTP2/Frame/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -114,8 +113,8 @@ maxSettingsKey = SettingsKey 6 {- FOURMOLU_DISABLE -} -pattern SettingsHeaderTableSize :: SettingsKey -pattern SettingsHeaderTableSize = SettingsKey 1 +pattern SettingsTokenHeaderTableSize :: SettingsKey +pattern SettingsTokenHeaderTableSize = SettingsKey 1 pattern SettingsEnablePush :: SettingsKey pattern SettingsEnablePush = SettingsKey 2 @@ -135,7 +134,7 @@ {- FOURMOLU_DISABLE -} instance Show SettingsKey where - show SettingsHeaderTableSize = "SettingsHeaderTableSize" + show SettingsTokenHeaderTableSize = "SettingsTokenHeaderTableSize" show SettingsEnablePush = "SettingsEnablePush" show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams" show SettingsInitialWindowSize = "SettingsInitialWindowSize" @@ -150,7 +149,7 @@ Ident idnt <- lexP readSK idnt where - readSK "SettingsHeaderTableSize" = return SettingsHeaderTableSize + readSK "SettingsTokenHeaderTableSize" = return SettingsTokenHeaderTableSize readSK "SettingsEnablePush" = return SettingsEnablePush readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams readSK "SettingsInitialWindowSize" = return SettingsInitialWindowSize @@ -190,7 +189,7 @@ -- >>> isWindowOverflow (maxWindowSize + 1) -- True isWindowOverflow :: WindowSize -> Bool -isWindowOverflow w = testBit w 31 +isWindowOverflow w = w > maxWindowSize -- | Default concurrency. -- @@ -541,6 +540,6 @@ type SettingsKeyId = SettingsKey type FrameTypeId = FrameType {- FOURMOLU_ENABLE -} -{- DEPRECATED ErrorCodeId "Use ErrorCode instead" -} -{- DEPRECATED SettingsKeyId "Use SettingsKey instead" -} -{- DEPRECATED FrameTypeId "Use FrameType instead" -} +{-# DEPRECATED ErrorCodeId "Use ErrorCode instead" #-} +{-# DEPRECATED SettingsKeyId "Use SettingsKey instead" #-} +{-# DEPRECATED FrameTypeId "Use FrameType instead" #-} diff --git a/Network/HTTP2/H2.hs b/Network/HTTP2/H2.hs --- a/Network/HTTP2/H2.hs +++ b/Network/HTTP2/H2.hs @@ -2,17 +2,14 @@ module Network.HTTP2.H2.Config, module Network.HTTP2.H2.Context, module Network.HTTP2.H2.EncodeFrame, - module Network.HTTP2.H2.File, module Network.HTTP2.H2.HPACK, - module Network.HTTP2.H2.Manager, module Network.HTTP2.H2.Queue, - module Network.HTTP2.H2.ReadN, module Network.HTTP2.H2.Receiver, module Network.HTTP2.H2.Sender, module Network.HTTP2.H2.Settings, - module Network.HTTP2.H2.Status, module Network.HTTP2.H2.Stream, module Network.HTTP2.H2.StreamTable, + module Network.HTTP2.H2.Sync, module Network.HTTP2.H2.Types, module Network.HTTP2.H2.Window, ) where @@ -20,16 +17,13 @@ import Network.HTTP2.H2.Config import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame -import Network.HTTP2.H2.File import Network.HTTP2.H2.HPACK -import Network.HTTP2.H2.Manager import Network.HTTP2.H2.Queue -import Network.HTTP2.H2.ReadN import Network.HTTP2.H2.Receiver import Network.HTTP2.H2.Sender import Network.HTTP2.H2.Settings -import Network.HTTP2.H2.Status import Network.HTTP2.H2.Stream import Network.HTTP2.H2.StreamTable +import Network.HTTP2.H2.Sync import Network.HTTP2.H2.Types import Network.HTTP2.H2.Window diff --git a/Network/HTTP2/H2/Config.hs b/Network/HTTP2/H2/Config.hs --- a/Network/HTTP2/H2/Config.hs +++ b/Network/HTTP2/H2/Config.hs @@ -1,37 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} + module Network.HTTP2.H2.Config where import Data.IORef import Foreign.Marshal.Alloc (free, mallocBytes) +import Network.HTTP.Semantics.Client import Network.Socket import Network.Socket.ByteString (sendAll) import qualified System.TimeManager as T import Network.HPACK -import Network.HTTP2.H2.File -import Network.HTTP2.H2.ReadN import Network.HTTP2.H2.Types -- | Making simple configuration whose IO is not efficient. -- A write buffer is allocated internally. +-- WAI timeout manger is initialized with 30_000_000 microseconds. allocSimpleConfig :: Socket -> BufferSize -> IO Config -allocSimpleConfig s bufsiz = do - buf <- mallocBytes bufsiz - ref <- newIORef Nothing - timmgr <- T.initialize $ 30 * 1000000 - mysa <- getSocketName s - peersa <- getPeerName s - let config = - Config - { confWriteBuffer = buf - , confBufferSize = bufsiz - , confSendAll = sendAll s - , confReadN = defaultReadN s ref - , confPositionReadMaker = defaultPositionReadMaker - , confTimeoutManager = timmgr - , confMySockAddr = mysa - , confPeerSockAddr = peersa - } - return config +allocSimpleConfig s bufsiz = allocSimpleConfig' s bufsiz (30 * 1000000) + +-- | Making simple configuration whose IO is not efficient. +-- A write buffer is allocated internally. +-- The third argument is microseconds to initialize WAI +-- timeout manager. +allocSimpleConfig' :: Socket -> BufferSize -> Int -> IO Config +allocSimpleConfig' s bufsiz usec = do + confWriteBuffer <- mallocBytes bufsiz + let confBufferSize = bufsiz + let confSendAll = sendAll s + confReadN <- defaultReadN s <$> newIORef Nothing + let confPositionReadMaker = defaultPositionReadMaker + confTimeoutManager <- T.initialize usec + confMySockAddr <- getSocketName s + confPeerSockAddr <- getPeerName s + let confReadNTimeout = False + let confOnInformational = \_ _ -> return () + return Config{..} -- | Deallocating the resource of the simple configuration. freeSimpleConfig :: Config -> IO () diff --git a/Network/HTTP2/H2/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -4,13 +4,13 @@ module Network.HTTP2.H2.Context where -import Control.Exception +import Control.Concurrent.STM +import qualified Control.Exception as E import Data.IORef +import qualified Data.IntMap.Strict as IntMap import Network.Control -import Network.HTTP.Types (Method) import Network.Socket (SockAddr) -import qualified UnliftIO.Exception as E -import UnliftIO.STM +import qualified System.ThreadManager as T import Imports hiding (insert) import Network.HPACK @@ -26,8 +26,10 @@ data RoleInfo = RIS ServerInfo | RIC ClientInfo -data ServerInfo = ServerInfo - { inputQ :: TQueue (Input Stream) +type Launch = Context -> Stream -> InpObj -> IO () + +newtype ServerInfo = ServerInfo + { launch :: Launch } data ClientInfo = ClientInfo @@ -43,110 +45,140 @@ toClientInfo (RIC x) = x toClientInfo _ = error "toClientInfo" -newServerInfo :: IO RoleInfo -newServerInfo = RIS . ServerInfo <$> newTQueueIO +newServerInfo :: Launch -> RoleInfo +newServerInfo = RIS . ServerInfo newClientInfo :: ByteString -> Authority -> RoleInfo newClientInfo scm auth = RIC $ ClientInfo scm auth ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} -- | The context for HTTP/2 connection. data Context = Context - { role :: Role - , roleInfo :: RoleInfo + { role :: Role + , roleInfo :: RoleInfo , -- Settings - mySettings :: Settings - , myFirstSettings :: IORef Bool - , peerSettings :: IORef Settings - , oddStreamTable :: TVar OddStreamTable - , evenStreamTable :: TVar EvenStreamTable - , continued :: IORef (Maybe StreamId) - -- ^ RFC 9113 says "Other frames (from any stream) MUST NOT - -- occur between the HEADERS frame and any CONTINUATION - -- frames that might follow". This field is used to implement - -- this requirement. - , myStreamId :: TVar StreamId - , peerStreamId :: IORef StreamId - , outputBufferLimit :: IORef Int - , outputQ :: TQueue (Output Stream) - , outputQStreamID :: TVar StreamId - , controlQ :: TQueue Control + mySettings :: Settings + , myFirstSettings :: IORef Bool + , peerSettings :: IORef Settings + , oddStreamTable :: TVar OddStreamTable + , evenStreamTable :: TVar EvenStreamTable + , continued :: IORef (Maybe HeaderContinuation) + , myStreamId :: TVar StreamId + , peerStreamId :: IORef StreamId + , peerLastStreamId :: IORef StreamId + , outputBufferLimit :: IORef Int + , outputQ :: TQueue Output + -- ^ Invariant: Each stream will only ever have at most one 'Output' + -- object in this queue at any moment. + , outputQStreamID :: TVar StreamId + , controlQ :: TQueue Control , encodeDynamicTable :: DynamicTable , decodeDynamicTable :: DynamicTable , -- the connection window for sending data - txFlow :: TVar TxFlow - , rxFlow :: IORef RxFlow - , pingRate :: Rate - , settingsRate :: Rate - , emptyFrameRate :: Rate - , rstRate :: Rate - , mySockAddr :: SockAddr - , peerSockAddr :: SockAddr + txFlow :: TVar TxFlow + , rxFlow :: IORef RxFlow + , pingRate :: Rate + , settingsRate :: Rate + , emptyFrameRate :: Rate + , rstRate :: Rate + , mySockAddr :: SockAddr + , peerSockAddr :: SockAddr + , threadManager :: T.ThreadManager + , receiverDone :: TVar (Maybe E.SomeException) + , workersDone :: STM Bool + , informationalCallback :: StreamId -> TokenHeaderTable -> IO () + -- ^ Client only: called when a 1xx informational response (e.g. 103 Early + -- Hints) is received, ahead of the final response. Copied from + -- 'confOnInformational'; no-op by default. + , peerGoAway :: TVar (Maybe StreamId) + -- ^ The last stream identifier of the peer's GOAWAY(NO_ERROR), once + -- one has come: see 'goingAway'. + , activeRequests :: TVar Int + -- ^ Client only: requests whose 'processResponse' has not returned. + -- A response can be complete, its stream gone from the table, and + -- its body still being read. } +{- FOURMOLU_ENABLE -} +-- | Header/trailer continuation +-- +-- RFC 9113 says "Other frames (from any stream) MUST NOT occur between the +-- HEADERS frame and any CONTINUATION frames that might follow". This is used to +-- implement this requirement. +-- +-- It also accumulates the fragments of the block. These are connection-level +-- state: the block must be decoded even if its stream is reset before the +-- block is complete, since it may modify the dynamic table. +data HeaderContinuation = HeaderContinuation + { hcStreamId :: StreamId + , hcBlock :: PartialHeaderBlock + , hcEndOfStream :: Bool + -- ^ END_STREAM, from the HEADERS frame that started the block + } + ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} newContext :: RoleInfo -> Config -> Int -> Int -> Settings + -> T.Manager + -> Maybe (STM Bool) -> IO Context -newContext rinfo Config{..} cacheSiz connRxWS settings = +newContext roleInfo Config{..} cacheSiz connRxWS mySettings timmgr mdone = do -- My: Use this even if ack has not been received yet. - Context rl rinfo settings - <$> newIORef False - -- Peer: The spec defines max concurrency is infinite unless - -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged. - -- But it is vulnerable, so we set the limitations. - <*> newIORef settings - <*> newTVarIO emptyOddStreamTable - <*> newTVarIO (emptyEvenStreamTable cacheSiz) - <*> newIORef Nothing - <*> newTVarIO sid0 - <*> newIORef 0 - <*> newIORef buflim - <*> newTQueueIO - <*> newTVarIO sid0 - <*> newTQueueIO - -- My SETTINGS_HEADER_TABLE_SIZE - <*> newDynamicTableForEncoding defaultDynamicTableSize - <*> newDynamicTableForDecoding (headerTableSize settings) 4096 - <*> newTVarIO (newTxFlow defaultWindowSize) -- 64K - <*> newIORef (newRxFlow connRxWS) - <*> newRate - <*> newRate - <*> newRate - <*> newRate - <*> return confMySockAddr - <*> return confPeerSockAddr + myFirstSettings <- newIORef False + -- Peer: The spec defines max concurrency is infinite unless + -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged. + -- But it is vulnerable, so we set the limitations. + peerSettings <- + newIORef baseSettings{maxConcurrentStreams = Just defaultMaxStreams} + oddStreamTable <- newTVarIO emptyOddStreamTable + evenStreamTable <- newTVarIO (emptyEvenStreamTable cacheSiz) + continued <- newIORef Nothing + myStreamId <- newTVarIO sid0 + peerStreamId <- newIORef 0 + peerLastStreamId <- newIORef 0 + outputBufferLimit <- newIORef buflim + outputQ <- newTQueueIO + outputQStreamID <- newTVarIO sid0 + controlQ <- newTQueueIO + -- My SETTINGS_HEADER_TABLE_SIZE + encodeDynamicTable <- newDynamicTableForEncoding defaultDynamicTableSize + decodeDynamicTable <- + newDynamicTableForDecoding (headerTableSize mySettings) 4096 + txFlow <- newTVarIO (newTxFlow defaultWindowSize) -- 64K + rxFlow <- newIORef (newRxFlow connRxWS) + pingRate <- newRate + settingsRate <- newRate + emptyFrameRate <- newRate + rstRate <- newRate + let mySockAddr = confMySockAddr + let peerSockAddr = confPeerSockAddr + threadManager <- T.newThreadManager timmgr + receiverDone <- newTVarIO Nothing + let informationalCallback = confOnInformational + let workersDone = fromMaybe (T.isAllGone threadManager) mdone + peerGoAway <- newTVarIO Nothing + activeRequests <- newTVarIO 0 + return Context{..} where - rl = case rinfo of + role = case roleInfo of RIC{} -> Client _ -> Server sid0 - | rl == Client = 1 + | role == Client = 1 | otherwise = 2 dlim = defaultPayloadLength + frameHeaderLength buflim | confBufferSize >= dlim = dlim | otherwise = confBufferSize - -makeMySettingsList :: Config -> Int -> WindowSize -> [(SettingsKey, Int)] -makeMySettingsList Config{..} maxConc winSiz = myInitialAlist - where - -- confBufferSize is the size of the write buffer. - -- But we assume that the size of the read buffer is the same size. - -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE. - len = confBufferSize - frameHeaderLength - payloadLen = max defaultPayloadLength len - myInitialAlist = - [ (SettingsMaxFrameSize, payloadLen) - , (SettingsMaxConcurrentStreams, maxConc) - , (SettingsInitialWindowSize, winSiz) - ] +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- @@ -173,48 +205,125 @@ ---------------------------------------------------------------- +getPeerLastStreamId :: Context -> IO StreamId +getPeerLastStreamId ctx = readIORef $ peerLastStreamId ctx + +modifyPeerLastStreamId :: Context -> StreamId -> IO () +modifyPeerLastStreamId ctx sid = atomicModifyIORef' (peerLastStreamId ctx) $ \n -> if sid > n then (sid, ()) else (n, ()) + +---------------------------------------------------------------- + {-# INLINE setStreamState #-} setStreamState :: Context -> Stream -> StreamState -> IO () -setStreamState _ Stream{streamState} newState = do - oldState <- readIORef streamState +setStreamState _ Stream{streamNumber, streamState} newState = atomically $ do + oldState <- readTVar streamState + informReplaced streamNumber oldState newState + writeTVar streamState newState + +-- | Replacing the open state of a stream as the receiver moves it on, from +-- headers to body. +-- +-- The receiver reads a stream's state, works out the next one from the +-- frame, and writes it back -- in a transaction of its own. In between, the +-- sender may have half-closed the stream on our side ('halfClosedLocal', +-- which records it as @Open (Just cc) _@) or closed it. Writing the whole +-- state back undid that: the half-close was lost, the peer's END_STREAM then +-- took the stream to half-closed (remote) rather than closed, and it stayed +-- in the stream table, holding its concurrency slot for good. With both ends +-- streaming at once -- gRPC-style -- a client ran out of streams and a +-- server refused every new one. +-- +-- So only the open state is replaced, keeping whatever the sender recorded +-- about our side, and a stream that is no longer open is left alone. +setOpenState :: Context -> Stream -> OpenState -> IO () +setOpenState _ Stream{streamNumber, streamState} o = atomically $ do + oldState <- readTVar streamState + case oldState of + Open hcl _ -> do + let newState = Open hcl o + informReplaced streamNumber oldState newState + writeTVar streamState newState + _otherwise -> return () + +-- | Inform consumers of any streams that we close +informReplaced :: StreamId -> StreamState -> StreamState -> STM () +informReplaced streamNumber oldState newState = case (oldState, newState) of - (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) | q == q' -> - -- The stream stays open with the same body; nothing to do - return () - (Open _ (Body q _ _ _), _) -> - -- The stream is either closed, or is open with a /new/ body - -- We need to close the old queue so that any reads from it won't block - atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed - _otherwise -> - -- The stream wasn't open to start with; nothing to do - return () - writeIORef streamState newState + (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) + | q == q' -> + -- The stream stays open with the same body; nothing to do + return () + (Open _ (Body q _ _ _), Closed cc) -> + writeTQueue q $ Left $ E.toException $ closedCodeToError streamNumber cc + (Open _ (Body q _ _ _), _) -> + -- The stream is opened with a /new/ body + writeTQueue q $ Left $ E.toException ConnectionIsClosed + _otherwise -> + -- The stream wasn't open to start with; nothing to do + return () +-- | Opening an idle stream. +-- +-- Only an idle one: the receiver checks that the stream is idle and then +-- opens it, and a client's request stream stays idle while the request is +-- being sent -- so by the time it opens the stream for the response's +-- HEADERS, the sender may already have half-closed it ('halfClosedLocal' +-- turns an idle stream into @Open (Just cc) JustOpened@). Opening it over +-- that lost the half-close, with the same result as described at +-- 'setOpenState'. opened :: Context -> Stream -> IO () -opened ctx strm = setStreamState ctx strm (Open Nothing JustOpened) +opened _ Stream{streamState} = atomically $ modifyTVar' streamState open + where + open Idle = Open Nothing JustOpened + open st = st halfClosedRemote :: Context -> Stream -> IO () halfClosedRemote ctx stream@Stream{streamState} = do - closingCode <- atomicModifyIORef streamState closeHalf + closingCode <- atomically $ stateTVar streamState closeHalf traverse_ (closed ctx stream) closingCode where - closeHalf :: StreamState -> (StreamState, Maybe ClosedCode) - closeHalf x@(Closed _) = (x, Nothing) - closeHalf (Open (Just cc) _) = (Closed cc, Just cc) - closeHalf _ = (HalfClosedRemote, Nothing) + closeHalf :: StreamState -> (Maybe ClosedCode, StreamState) + closeHalf x@(Closed _) = (Nothing, x) + closeHalf (Open (Just cc) _) = (Just cc, Closed cc) + closeHalf _ = (Nothing, HalfClosedRemote) halfClosedLocal :: Context -> Stream -> ClosedCode -> IO () halfClosedLocal ctx stream@Stream{streamState} cc = do - shouldFinalize <- atomicModifyIORef streamState closeHalf + shouldFinalize <- atomically $ stateTVar streamState closeHalf when shouldFinalize $ closed ctx stream cc where - closeHalf :: StreamState -> (StreamState, Bool) - closeHalf x@(Closed _) = (x, False) - closeHalf HalfClosedRemote = (Closed cc, True) - closeHalf (Open Nothing o) = (Open (Just cc) o, False) - closeHalf _ = (Open (Just cc) JustOpened, False) + closeHalf :: StreamState -> (Bool, StreamState) + closeHalf x@(Closed _) = (False, x) + closeHalf HalfClosedRemote = (True, Closed cc) + closeHalf (Open Nothing o) = (False, Open (Just cc) o) + closeHalf _ = (False, Open (Just cc) JustOpened) +-- | Closing a stream whose response is still coming in, and saying +-- whether it was. +-- +-- Decided and done in one transaction, so that a stream the peer finishes +-- meanwhile is not taken for one still open. A response whose END_STREAM +-- the receiver has already queued, and not yet recorded in the state, can +-- still be taken for one coming in; the reset that follows is one RFC 9113 +-- section 5.1 has the peer ignore ("for a short period after a DATA or +-- HEADERS frame containing an END_STREAM flag is sent"). +closeIfReceiving :: Context -> Stream -> ClosedCode -> IO Bool +closeIfReceiving ctx strm@Stream{streamNumber, streamState} cc = do + receiving <- atomically $ do + st <- readTVar streamState + case st of + -- END_STREAM came with the headers. + Open _ (NoBody _) -> return False + Open{} -> do + informReplaced streamNumber st (Closed cc) + writeTVar streamState (Closed cc) + return True + _otherwise -> return False + -- Out of the stream table, giving its concurrency slot back. + when receiving $ closed ctx strm cc + return receiving + closed :: Context -> Stream -> ClosedCode -> IO () closed ctx@Context{oddStreamTable, evenStreamTable} strm@Stream{streamNumber} cc = do if isServerInitiated streamNumber @@ -222,19 +331,20 @@ else deleteOdd oddStreamTable streamNumber err setStreamState ctx strm (Closed cc) -- anyway where - err :: SomeException - err = toException (closedCodeToError streamNumber cc) + err :: E.SomeException + err = E.toException (closedCodeToError streamNumber cc) ---------------------------------------------------------------- -- From peer -- Server +-- +-- Note that this does not apply SETTINGS_MAX_CONCURRENT_STREAMS. A stream +-- over the limit still has to be admitted this far, because its field block +-- has to be decoded before it can be refused; 'checkOddConcurrency' does the +-- refusing once that has happened. openOddStreamCheck :: Context -> StreamId -> FrameType -> IO Stream openOddStreamCheck ctx@Context{oddStreamTable, peerSettings, mySettings} sid ftyp = do - -- My SETTINGS_MAX_CONCURRENT_STREAMS - when (ftyp == FrameHeaders) $ do - conc <- getOddConcurrency oddStreamTable - checkMyConcurrency sid mySettings (conc + 1) txws <- initialWindowSize <$> readIORef peerSettings let rxws = initialWindowSize mySettings newstrm <- newOddStream sid txws rxws @@ -253,6 +363,25 @@ newstrm <- newEvenStream sid txws rxws insertEvenCache evenStreamTable method path newstrm +-- | Refuse a peer-initiated stream that puts us over the limit we advertised +-- in SETTINGS_MAX_CONCURRENT_STREAMS. +-- +-- Checked once the stream's field block has been decoded, rather than when +-- its HEADERS frame arrived. A block has to be decoded whatever becomes of +-- its stream -- RFC 9113 section 10.5.1, "The field block MUST be processed +-- to ensure a consistent connection state" -- and refusing at arrival meant +-- throwing before the frame's payload had even been read, which left nothing +-- to do but drop the connection. From here the throw lands inside the +-- receiver's per-frame reset handler, so the answer is +-- RST_STREAM(REFUSED_STREAM) and the connection carries on, which is what +-- section 5.1.2 asks for and what section 8.7 lets the peer retry against. +-- +-- The stream is in the table by the time we get here, so it counts itself. +checkOddConcurrency :: Context -> StreamId -> IO () +checkOddConcurrency Context{oddStreamTable, mySettings} sid = do + conc <- getOddConcurrency oddStreamTable + checkMyConcurrency sid mySettings conc + checkMyConcurrency :: StreamId -> Settings -> Int -> IO () checkMyConcurrency sid settings conc = do @@ -275,13 +404,16 @@ let rxws = initialWindowSize mySettings case mMaxConc of Nothing -> do - sid <- atomically $ getMyNewStreamId ctx + sid <- atomically $ do + refuseIfGoingAway ctx + getMyNewStreamId ctx txws <- initialWindowSize <$> readIORef peerSettings newstrm <- newOddStream sid txws rxws insertOdd oddStreamTable sid newstrm return (sid, newstrm) Just maxConc -> do sid <- atomically $ do + refuseIfGoingAway ctx waitIncOdd oddStreamTable maxConc getMyNewStreamId ctx txws <- initialWindowSize <$> readIORef peerSettings @@ -290,8 +422,21 @@ return (sid, newstrm) -- Server -openEvenStreamWait :: Context -> IO (StreamId, Stream) -openEvenStreamWait ctx@Context{..} = do + +-- | Opening a stream for a push, if the peer's +-- SETTINGS_MAX_CONCURRENT_STREAMS leaves room for one. +-- +-- Not waiting for room: the response the push belongs to waits for its +-- PUSH_PROMISE to go out, and with no room -- a peer can announce 0 to +-- refuse pushes (RFC 9113, section 8.4) -- it waited for ever. A push is +-- only ever an offer, so one there is no room for is not made. +openEvenStreamTry :: Context -> IO (Maybe (StreamId, Stream)) +openEvenStreamTry ctx@Context{..} = do + goingaway <- isJust <$> readTVarIO peerGoAway + if goingaway then return Nothing else openEvenStreamTry' ctx + +openEvenStreamTry' :: Context -> IO (Maybe (StreamId, Stream)) +openEvenStreamTry' ctx@Context{..} = do -- Peer SETTINGS_MAX_CONCURRENT_STREAMS mMaxConc <- maxConcurrentStreams <$> readIORef peerSettings let rxws = initialWindowSize mySettings @@ -301,12 +446,74 @@ txws <- initialWindowSize <$> readIORef peerSettings newstrm <- newEvenStream sid txws rxws insertEven evenStreamTable sid newstrm - return (sid, newstrm) + return $ Just (sid, newstrm) Just maxConc -> do - sid <- atomically $ do - waitIncEven evenStreamTable maxConc - getMyNewStreamId ctx - txws <- initialWindowSize <$> readIORef peerSettings - newstrm <- newEvenStream sid txws rxws - insertEven' evenStreamTable sid newstrm - return (sid, newstrm) + msid <- atomically $ do + let open = do + waitIncEven evenStreamTable maxConc + Just <$> getMyNewStreamId ctx + open `orElse` return Nothing + forM msid $ \sid -> do + txws <- initialWindowSize <$> readIORef peerSettings + newstrm <- newEvenStream sid txws rxws + insertEven' evenStreamTable sid newstrm + return (sid, newstrm) + +---------------------------------------------------------------- +-- GOAWAY from the peer + +-- | No new stream once the peer has sent GOAWAY: "Receivers of a GOAWAY +-- frame MUST NOT open additional streams on the connection" (RFC 9113, +-- section 6.8). A request that has not got a stream yet is answered as +-- one on a stream above the last stream identifier would be. +refuseIfGoingAway :: Context -> STM () +refuseIfGoingAway Context{peerGoAway} = do + goingaway <- isJust <$> readTVar peerGoAway + when goingaway $ throwSTM ConnectionIsClosed + +-- | Taking the peer's GOAWAY(NO_ERROR) on board. +-- +-- The peer has said it will go no further than the last stream identifier, +-- not that it is going at once. Streams of ours above it will not be +-- processed, and are closed with 'ConnectionIsClosed', which a client may +-- retry elsewhere; no stream is opened from now on. The others go on +-- until they are done, and then so is the connection: 'drained' tells +-- when. It used to be closed right away, cutting off every stream in +-- flight, even those the peer had promised to finish. +-- +-- A later GOAWAY can lower the last stream identifier, not raise it. +-- Answers whether this is the first. +goingAway :: Context -> StreamId -> IO Bool +goingAway ctx@Context{peerGoAway, oddStreamTable, evenStreamTable} lastSid = do + first <- atomically $ do + old <- readTVar peerGoAway + writeTVar peerGoAway $ Just $ maybe lastSid (min lastSid) old + return $ isNothing old + mine <- + if isClient ctx + then getOddStreams oddStreamTable + else getEvenStreams evenStreamTable + let (_, above) = IntMap.split lastSid mine + forM_ above $ \strm -> closed ctx strm Finished + return first + +-- | Waiting until nothing is left in flight after the peer's GOAWAY: +-- neither a stream of the peer's, nor one of ours the peer is to process, +-- nor -- on a client -- a response still being read. Streams of ours above +-- the last stream identifier are not waited for; those that got their +-- identifier too late to be closed by 'goingAway' are closed with the +-- connection. +drained :: Context -> STM () +drained ctx@Context{peerGoAway, oddStreamTable, evenStreamTable, activeRequests} = do + mlast <- readTVar peerGoAway + case mlast of + Nothing -> retry + Just lastSid -> do + odds <- oddTable <$> readTVar oddStreamTable + evens <- evenTable <$> readTVar evenStreamTable + active <- readTVar activeRequests + let (mine, theirs) + | isClient ctx = (odds, evens) + | otherwise = (evens, odds) + noneOfMine = maybe True ((> lastSid) . fst) $ IntMap.lookupMin mine + check $ IntMap.null theirs && noneOfMine && active == 0 diff --git a/Network/HTTP2/H2/EncodeFrame.hs b/Network/HTTP2/H2/EncodeFrame.hs --- a/Network/HTTP2/H2/EncodeFrame.hs +++ b/Network/HTTP2/H2/EncodeFrame.hs @@ -23,10 +23,10 @@ where einfo = encodeInfo func 0 -pingFrame :: ByteString -> ByteString -pingFrame bs = encodeFrame einfo $ PingFrame bs +pingFrame :: Bool -> ByteString -> ByteString +pingFrame ack bs = encodeFrame einfo $ PingFrame bs where - einfo = encodeInfo setAck 0 + einfo = encodeInfo (if ack then setAck else id) 0 windowUpdateFrame :: StreamId -> WindowSize -> ByteString windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz diff --git a/Network/HTTP2/H2/File.hs b/Network/HTTP2/H2/File.hs deleted file mode 100644 --- a/Network/HTTP2/H2/File.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Network.HTTP2.H2.File where - -import System.IO - -import Imports -import Network.HPACK - --- | Offset for file. -type FileOffset = Int64 - --- | How many bytes to read -type ByteCount = Int64 - --- | Position read for files. -type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount - --- | Manipulating a file resource. -data Sentinel - = -- | Closing a file resource. Its refresher is automatiaclly generated by - -- the internal timer. - Closer (IO ()) - | -- | Refreshing a file resource while reading. - -- Closing the file must be done by its own timer or something. - Refresher (IO ()) - --- | Making a position read and its closer. -type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel) - --- | Position read based on 'Handle'. -defaultPositionReadMaker :: PositionReadMaker -defaultPositionReadMaker file = do - hdl <- openBinaryFile file ReadMode - return (pread hdl, Closer $ hClose hdl) - where - pread :: Handle -> PositionRead - pread hdl off bytes buf = do - hSeek hdl AbsoluteSeek $ fromIntegral off - fromIntegral <$> hGetBufSome hdl buf (fromIntegral bytes) diff --git a/Network/HTTP2/H2/HPACK.hs b/Network/HTTP2/H2/HPACK.hs --- a/Network/HTTP2/H2/HPACK.hs +++ b/Network/HTTP2/H2/HPACK.hs @@ -3,20 +3,26 @@ module Network.HTTP2.H2.HPACK ( hpackEncodeHeader, - hpackEncodeHeaderLoop, + hpackEncodeHeaderRest, hpackDecodeHeader, hpackDecodeTrailer, + hpackDiscardHeader, just, fixHeaders, ) where import qualified Control.Exception as E +import qualified Data.ByteString as BS +import Data.ByteString.Internal (create) +import qualified Data.ByteString.Lazy as BS.Lazy +import Foreign.Marshal.Alloc (free, mallocBytes) +import Foreign.Marshal.Utils (copyBytes) import Network.ByteOrder -import qualified Network.HTTP.Types as H +import Network.HTTP.Semantics +import Network.HTTP.Types import Imports import Network.HPACK -import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.Types @@ -26,17 +32,17 @@ ---------------------------------------------------------------- -fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders +fixHeaders :: ResponseHeaders -> ResponseHeaders fixHeaders hdr = deleteUnnecessaryHeaders hdr -deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders +deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders deleteUnnecessaryHeaders hdr = filter del hdr where del (k, _) = k `notElem` headersToBeRemoved -headersToBeRemoved :: [H.HeaderName] +headersToBeRemoved :: [HeaderName] headersToBeRemoved = - [ H.hConnection + [ hConnection , "Transfer-Encoding" -- Keep-Alive -- Proxy-Connection @@ -68,25 +74,89 @@ hpackEncodeHeaderLoop Context{..} buf siz hs = encodeTokenHeader buf siz strategy False encodeDynamicTable hs +-- | Encode the rest of a header block whose start 'hpackEncodeHeader' wrote +-- +-- For a block that did not fit where it was being written. Grows the buffer +-- as needed: a header that does not fit is retried with a larger buffer (the +-- encoder does not modify the dynamic table for a header it could not write). +hpackEncodeHeaderRest + :: Context + -> BufferSize + -- ^ Initial buffer size + -> TokenHeaderList + -> IO BS.Lazy.ByteString +hpackEncodeHeaderRest ctx = go [] + where + go acc _ [] = return $ BS.Lazy.fromChunks (reverse acc) + go acc siz ths = do + (chunk, ths') <- E.bracket (mallocBytes siz) free $ \buf -> do + (ths', len) <- hpackEncodeHeaderLoop ctx buf siz ths + chunk <- create len $ \p -> copyBytes p buf len + return (chunk, ths') + if BS.null chunk + then go acc (siz * 2) ths -- no progress: grow + else go (chunk : acc) siz ths' + ---------------------------------------------------------------- hpackDecodeHeader - :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable + :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeHeader hdrblk sid ctx = do - tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx + tbl@(_, vt) <- hpackDecode "illegal header" hdrblk sid ctx if isClient ctx || checkRequestHeader vt then return tbl else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header" hpackDecodeTrailer - :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable -hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl + :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable +hpackDecodeTrailer = hpackDecode "illegal trailer" + +-- | Decode a field block for a stream we no longer have, and discard the result +-- +-- The block must still be decoded: it may modify the dynamic table. +hpackDiscardHeader :: HeaderBlockFragment -> StreamId -> Context -> IO () +hpackDiscardHeader hdrblk sid ctx = + void (hpackDecode "illegal header" hdrblk sid ctx) `E.catch` ignore where + -- Decoded to the end, so there is nothing to refuse: the message goes + -- nowhere anyway. + ignore StreamErrorIsSent{} = return () + ignore e = E.throwIO e + +-- | Decode a field block, reporting a block we could not get through as a +-- connection error, and a malformed message in a block decoded to the end +-- as a stream error. +-- +-- The first argument says which kind of block it was, since the peer reads +-- this in the GOAWAY and "illegal trailer" about a request's headers is a +-- confusing thing to be told. +hpackDecode + :: ReasonPhrase + -> HeaderBlockFragment + -> StreamId + -> Context + -> IO TokenHeaderTable +hpackDecode illegal hdrblk sid Context{..} = + decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl + where + -- A malformed message: 'decodeTokenHeader' says so only once it has + -- decoded the whole block, so the dynamic table is up to date and the + -- connection can go on. A stream error, as RFC 9113 section 8.1.1 has + -- it. This used to be a connection error, as the block was abandoned + -- at the malformed field; one request with an upper-case field name + -- closed the connection, every other stream on it with it. handl IllegalHeaderName = - E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal trailer" + E.throwIO $ StreamErrorIsSent ProtocolError sid illegal + handl TooLargeHeader = + E.throwIO $ StreamErrorIsSent ProtocolError sid "too many fields" + -- A block we could not get through: our dynamic table now holds the + -- entries decoded before the throw and nothing after them -- no longer + -- what the peer's encoder believes we have. Section 10.5.1: "The field + -- block MUST be processed to ensure a consistent connection state, + -- unless the connection is closed." We did not, so it must be. handl e = do let msg = fromString $ show e - E.throwIO $ StreamErrorIsSent CompressionError sid msg + E.throwIO $ ConnectionErrorIsSent CompressionError sid msg {-# INLINE checkRequestHeader #-} checkRequestHeader :: ValueTable -> Bool @@ -101,14 +171,14 @@ | just mTE (/= "trailers") = False | otherwise = checkAuth mAuthority mHost where - mStatus = getHeaderValue tokenStatus reqvt - mScheme = getHeaderValue tokenScheme reqvt - mPath = getHeaderValue tokenPath reqvt - mMethod = getHeaderValue tokenMethod reqvt - mConnection = getHeaderValue tokenConnection reqvt - mTE = getHeaderValue tokenTE reqvt - mAuthority = getHeaderValue tokenAuthority reqvt - mHost = getHeaderValue tokenHost reqvt + mStatus = getFieldValue tokenStatus reqvt + mScheme = getFieldValue tokenScheme reqvt + mPath = getFieldValue tokenPath reqvt + mMethod = getFieldValue tokenMethod reqvt + mConnection = getFieldValue tokenConnection reqvt + mTE = getFieldValue tokenTE reqvt + mAuthority = getFieldValue tokenAuthority reqvt + mHost = getFieldValue tokenHost reqvt checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool checkAuth Nothing Nothing = False diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs deleted file mode 100644 --- a/Network/HTTP2/H2/Manager.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | A thread manager. --- The manager has responsibility to spawn and kill --- worker threads. -module Network.HTTP2.H2.Manager ( - Manager, - Action, - start, - setAction, - stopAfter, - spawnAction, - forkManaged, - forkManagedUnmask, - timeoutKillThread, - timeoutClose, - KilledByHttp2ThreadManager (..), - incCounter, - decCounter, - waitCounter0, -) where - -import Control.Exception -import Data.Foldable -import Data.IORef -import Data.Set (Set) -import qualified Data.Set as Set -import qualified System.TimeManager as T -import UnliftIO.Concurrent -import qualified UnliftIO.Exception as E -import UnliftIO.STM - -import Imports - ----------------------------------------------------------------- - --- | Action to be spawned by the manager. -type Action = IO () - -noAction :: Action -noAction = return () - -data Command = Stop (Maybe SomeException) | Spawn | Add ThreadId | Delete ThreadId - --- | Manager to manage the thread and the timer. -data Manager = Manager (TQueue Command) (IORef Action) (TVar Int) T.Manager - --- | Starting a thread manager. --- Its action is initially set to 'return ()' and should be set --- by 'setAction'. This allows that the action can include --- the manager itself. -start :: T.Manager -> IO Manager -start timmgr = do - q <- newTQueueIO - ref <- newIORef noAction - cnt <- newTVarIO 0 - void $ forkIO $ go q Set.empty ref - return $ Manager q ref cnt timmgr - where - go q tset0 ref = do - x <- atomically $ readTQueue q - case x of - Stop err -> kill tset0 err - Spawn -> next tset0 - Add newtid -> - let tset = add newtid tset0 - in go q tset ref - Delete oldtid -> - let tset = del oldtid tset0 - in go q tset ref - where - next tset = do - action <- readIORef ref - newtid <- forkFinally action $ \_ -> do - mytid <- myThreadId - atomically $ writeTQueue q $ Delete mytid - let tset' = add newtid tset - go q tset' ref - --- | Setting the action to be spawned. -setAction :: Manager -> Action -> IO () -setAction (Manager _ ref _ _) action = writeIORef ref action - --- | Stopping the manager. -stopAfter :: Manager -> IO a -> (Either SomeException a -> IO b) -> IO b -stopAfter (Manager q _ _ _) action cleanup = do - mask $ \unmask -> do - ma <- try $ unmask action - atomically $ writeTQueue q $ Stop (either Just (const Nothing) ma) - cleanup ma - --- | Spawning the action. -spawnAction :: Manager -> IO () -spawnAction (Manager q _ _ _) = atomically $ writeTQueue q Spawn - ----------------------------------------------------------------- - --- | Fork managed thread --- --- This guarantees that the thread ID is added to the manager's queue before --- the thread starts, and is removed again when the thread terminates --- (normally or abnormally). -forkManaged :: Manager -> IO () -> IO () -forkManaged mgr io = - forkManagedUnmask mgr $ \unmask -> unmask io - --- | Like 'forkManaged', but run action with exceptions masked -forkManagedUnmask :: Manager -> ((forall x. IO x -> IO x) -> IO ()) -> IO () -forkManagedUnmask mgr io = - void $ mask_ $ forkIOWithUnmask $ \unmask -> do - addMyId mgr - -- We catch the exception and do not rethrow it: we don't want the - -- exception printed to stderr. - io unmask `catch` \(_e :: SomeException) -> return () - deleteMyId mgr - --- | Adding my thread id to the kill-thread list on stopping. --- --- This is not part of the public API; see 'forkManaged' instead. -addMyId :: Manager -> IO () -addMyId (Manager q _ _ _) = do - tid <- myThreadId - atomically $ writeTQueue q $ Add tid - --- | Deleting my thread id from the kill-thread list on stopping. --- --- This is /only/ necessary when you want to remove the thread's ID from --- the manager /before/ the thread terminates (thereby assuming responsibility --- for thread cleanup yourself). -deleteMyId :: Manager -> IO () -deleteMyId (Manager q _ _ _) = do - tid <- myThreadId - atomically $ writeTQueue q $ Delete tid - ----------------------------------------------------------------- - -add :: ThreadId -> Set ThreadId -> Set ThreadId -add tid set = set' - where - set' = Set.insert tid set - -del :: ThreadId -> Set ThreadId -> Set ThreadId -del tid set = set' - where - set' = Set.delete tid set - -kill :: Set ThreadId -> Maybe SomeException -> IO () -kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadManager err) set - --- | Killing the IO action of the second argument on timeout. -timeoutKillThread :: Manager -> (T.Handle -> IO a) -> IO a -timeoutKillThread (Manager _ _ _ tmgr) action = E.bracket register T.cancel action - where - register = T.registerKillThread tmgr noAction - --- | Registering closer for a resource and --- returning a timer refresher. -timeoutClose :: Manager -> IO () -> IO (IO ()) -timeoutClose (Manager _ _ _ tmgr) closer = do - th <- T.register tmgr closer - return $ T.tickle th - -data KilledByHttp2ThreadManager = KilledByHttp2ThreadManager (Maybe SomeException) - deriving (Show) - -instance Exception KilledByHttp2ThreadManager where - toException = asyncExceptionToException - fromException = asyncExceptionFromException - ----------------------------------------------------------------- - -incCounter :: Manager -> IO () -incCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (+ 1) - -decCounter :: Manager -> IO () -decCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (subtract 1) - -waitCounter0 :: Manager -> IO () -waitCounter0 (Manager _ _ cnt _) = atomically $ do - n <- readTVar cnt - checkSTM (n < 1) diff --git a/Network/HTTP2/H2/OutBodyIface.hs b/Network/HTTP2/H2/OutBodyIface.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/H2/OutBodyIface.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +module Network.HTTP2.H2.OutBodyIface ( + StreamTerminated (..), + withOutBodyIface, +) where + +import Control.Concurrent.STM +import Control.Exception +import Network.HTTP.Semantics +import Network.HTTP.Semantics.IO +import Network.HTTP2.H2.Context +import Network.HTTP2.H2.Sync +import Network.HTTP2.H2.Types + +---------------------------------------------------------------- + +data StreamTerminated + = StreamPushedFinal + | StreamCancelled + | StreamOutOfScope + | StreamRemoteReset ClosedCode + deriving (Show) + deriving anyclass (Exception) + +---------------------------------------------------------------- + +withOutBodyIface + :: Context + -> Stream + -> TBQueue StreamingChunk + -> (forall a. IO a -> IO a) + -> (OutBodyIface -> IO r) + -> IO r +withOutBodyIface ctx@Context{outputQ} strm tbq unmask k = do + terminated <- newTVarIO Nothing + let checkNotTerminated :: STM () + checkNotTerminated = do + mTerminated <- readTVar terminated + maybe (return ()) throwSTM mTerminated + + -- Check if the peer is still listening for messages + -- + -- It is important to call 'checkNotClosed' prior to enqueuing stream + -- chunks to ensure that 'writeTBQueue' will not block indefinitely + -- (because nothing is consuming elements from the queue anymore). + -- + -- Assumes 'checkNotTerminated'. + checkNotClosed :: STM () + checkNotClosed = do + mClosed <- getIsClosed + case mClosed of + Just code -> + -- When the stream is closed, but /we/ did not close it (or + -- 'checkNotTerminated' would have thrown an exception), it + -- must mean that our peer send us a RST_STREAM, indicating + -- that they do not want to receive any further messages. + throwSTM $ StreamRemoteReset code + _otherwise -> + return () + + getIsClosed :: STM (Maybe ClosedCode) + getIsClosed = do + st <- readTVar (streamState strm) + case st of + Closed code -> return $ Just code + _otherwise -> return Nothing + + cancelAfterFinish :: Maybe SomeException -> STM () + cancelAfterFinish mErr = + writeTQueue outputQ $ makeOutputIO ctx strm Nothing (OReset mErr) + + iface :: OutBodyIface + iface = + OutBodyIface + { outBodyUnmask = unmask + , outBodyPush = \b -> atomically $ do + checkNotTerminated + checkNotClosed + writeTBQueue tbq $ StreamingBuilder b NotEndOfStream + , outBodyPushFinal = \b -> atomically $ do + checkNotTerminated + checkNotClosed + writeTVar terminated (Just StreamPushedFinal) + writeTBQueue tbq $ StreamingBuilder b (EndOfStream Nothing) + writeTBQueue tbq $ StreamingFinished Nothing + , outBodyFlush = atomically $ do + checkNotTerminated + checkNotClosed + writeTBQueue tbq StreamingFlush + , outBodyCancel = \mErr -> atomically $ do + mTerminated <- readTVar terminated + mClosed <- getIsClosed + case (mClosed, mTerminated) of + (Nothing, Nothing) -> do + writeTVar terminated (Just StreamCancelled) + writeTBQueue tbq $ StreamingCancelled mErr + (Nothing, Just StreamCancelled) -> + -- Already cancelled + return () + (Nothing, Just _) -> do + -- We finished streaming (that is, sending messages to the peer), + -- but we must still be able to cancel the stream entirely + -- (that is, tell the peer that we no longer want to /receive/ messages: RST_STREAM) + writeTVar terminated (Just StreamCancelled) + cancelAfterFinish mErr + (Just _code, _) -> + -- Peer already closed + return () + } + + finished :: IO () + finished = atomically $ do + mTerminated <- readTVar terminated + mClosed <- getIsClosed + case (mClosed, mTerminated) of + (Nothing, Nothing) -> do + writeTVar terminated (Just StreamOutOfScope) + writeTBQueue tbq $ StreamingFinished Nothing + (Nothing, Just _) -> + -- We already terminated + return () + (Just _code, _) -> + -- Peer already closed + return () + + k iface `finally` finished diff --git a/Network/HTTP2/H2/Queue.hs b/Network/HTTP2/H2/Queue.hs --- a/Network/HTTP2/H2/Queue.hs +++ b/Network/HTTP2/H2/Queue.hs @@ -1,23 +1,16 @@ -{-# LANGUAGE RecordWildCards #-} - module Network.HTTP2.H2.Queue where -import UnliftIO.STM +import Control.Concurrent.STM -import Network.HTTP2.H2.Manager import Network.HTTP2.H2.Types -{-# INLINE forkAndEnqueueWhenReady #-} -forkAndEnqueueWhenReady - :: IO () -> TQueue (Output Stream) -> Output Stream -> Manager -> IO () -forkAndEnqueueWhenReady wait outQ out mgr = - forkManaged mgr $ do - wait - enqueueOutput outQ out - {-# INLINE enqueueOutput #-} -enqueueOutput :: TQueue (Output Stream) -> Output Stream -> IO () +enqueueOutput :: TQueue Output -> Output -> IO () enqueueOutput outQ out = atomically $ writeTQueue outQ out + +{-# INLINE enqueueOutputSTM #-} +enqueueOutputSTM :: TQueue Output -> Output -> STM () +enqueueOutputSTM outQ out = writeTQueue outQ out {-# INLINE enqueueControl #-} enqueueControl :: TQueue Control -> Control -> IO () diff --git a/Network/HTTP2/H2/ReadN.hs b/Network/HTTP2/H2/ReadN.hs deleted file mode 100644 --- a/Network/HTTP2/H2/ReadN.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Network.HTTP2.H2.ReadN where - -import qualified Data.ByteString as B -import Data.IORef -import Network.Socket -import qualified Network.Socket.ByteString as N - --- | Naive implementation for readN. -defaultReadN :: Socket -> IORef (Maybe B.ByteString) -> Int -> IO B.ByteString -defaultReadN _ _ 0 = return B.empty -defaultReadN s ref n = do - mbs <- readIORef ref - writeIORef ref Nothing - case mbs of - Nothing -> do - bs <- N.recv s n - if B.null bs - then return B.empty - else - if B.length bs == n - then return bs - else loop bs - Just bs - | B.length bs == n -> return bs - | B.length bs > n -> do - let (bs0, bs1) = B.splitAt n bs - writeIORef ref (Just bs1) - return bs0 - | otherwise -> loop bs - where - loop bs = do - let n' = n - B.length bs - bs1 <- N.recv s n' - if B.null bs1 - then return B.empty - else do - let bs2 = bs `B.append` bs1 - if B.length bs2 == n - then return bs2 - else loop bs2 diff --git a/Network/HTTP2/H2/Receiver.hs b/Network/HTTP2/H2/Receiver.hs --- a/Network/HTTP2/H2/Receiver.hs +++ b/Network/HTTP2/H2/Receiver.hs @@ -2,24 +2,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP2.H2.Receiver ( frameReceiver, + closureClient, + closureServer, + sendPing, ) where +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception as E import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Short as Short import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef +import Data.Void import Network.Control -import UnliftIO.Concurrent -import qualified UnliftIO.Exception as E -import UnliftIO.STM +import Network.HTTP.Semantics +import qualified System.IO.Error as E +import qualified System.ThreadManager as T import Imports hiding (delete, insert) -import Network.HPACK -import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame @@ -39,58 +45,48 @@ headerFragmentLimit :: Int headerFragmentLimit = 51200 -- 50K -settingsRateLimit :: Int -settingsRateLimit = 4 - -emptyFrameRateLimit :: Int -emptyFrameRateLimit = 4 - -rstRateLimit :: Int -rstRateLimit = 4 - ---------------------------------------------------------------- -frameReceiver :: Context -> Config -> IO () -frameReceiver ctx@Context{..} conf@Config{..} = loop 0 `E.catch` sendGoaway +frameReceiver :: Context -> Config -> IO E.SomeException +frameReceiver ctx@Context{receiverDone} conf@Config{..} = + E.mask $ \unmask -> do + -- This catches an asynchronous exception. + -- It is re-thrown by "runH2" + mErr <- E.try $ unmask switch + case mErr of + Left err -> do + atomically $ writeTVar receiverDone $ Just err + return err + Right x -> do + absurd x -- We only terminate due to exceptions where - loop :: Int -> IO () - loop n - | n == 6 = do - yield - loop 0 - | otherwise = do - hd <- confReadN frameHeaderLength - if BS.null hd - then enqueueControl controlQ $ CFinish ConnectionIsClosed - else do - processFrame ctx conf $ decodeFrameHeader hd - loop (n + 1) + switch :: IO Void + switch = do + labelMe "H2 receiver" + tid <- myThreadId + if confReadNTimeout + then + loop1 + else + T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2 - sendGoaway se - | Just e@ConnectionIsClosed <- E.fromException se = - enqueueControl controlQ $ CFinish e - | Just e@(ConnectionErrorIsReceived _ _ _) <- E.fromException se = - enqueueControl controlQ $ CFinish e - | Just e@(ConnectionErrorIsSent err sid msg) <- E.fromException se = do - let frame = goawayFrame sid err $ Short.fromShort msg - enqueueControl controlQ $ CFrames Nothing [frame] - enqueueControl controlQ $ CFinish e - | Just e@(StreamErrorIsSent err sid msg) <- E.fromException se = do - let frame = resetFrame err sid - enqueueControl controlQ $ CFrames Nothing [frame] - let frame' = goawayFrame sid err $ Short.fromShort msg - enqueueControl controlQ $ CFrames Nothing [frame'] - enqueueControl controlQ $ CFinish e - | Just e@(StreamErrorIsReceived err sid) <- E.fromException se = do - let frame = goawayFrame sid err "treat a stream error as a connection error" - enqueueControl controlQ $ CFrames Nothing [frame] - enqueueControl controlQ $ CFinish e - -- this never happens - | Just e@(BadThingHappen _) <- E.fromException se = - enqueueControl controlQ $ CFinish e - | otherwise = - enqueueControl controlQ $ CFinish $ BadThingHappen se + loop1 :: IO Void + loop1 = do + hd <- confReadN frameHeaderLength -- throwing an exception on timeout + when (BS.null hd) $ E.throwIO ConnectionIsClosed + processFrame ctx conf $ decodeFrameHeader hd + loop1 + loop2 :: T.Handle -> IO Void + loop2 th = do + -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown + -- to destroy the thread trees. + hd <- confReadN frameHeaderLength + T.tickle th + when (BS.null hd) $ E.throwIO ConnectionIsClosed + processFrame ctx conf $ decodeFrameHeader hd + loop2 th + ---------------------------------------------------------------- processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO () @@ -104,13 +100,13 @@ | isServer ctx = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "push promise is not allowed" -processFrame Context{..} Config{..} (ftyp, FrameHeader{payloadLength, streamId}) +processFrame Context{..} conf (ftyp, FrameHeader{payloadLength, streamId}) | ftyp > maxFrameType = do mx <- readIORef continued case mx of Nothing -> do -- ignoring unknown frame - void $ confReadN payloadLength + void $ readPayload conf payloadLength Just _ -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "unknown frame" processFrame ctx@Context{..} conf typhdr@(ftyp, header) = do -- My SETTINGS_MAX_FRAME_SIZE @@ -130,105 +126,249 @@ ---------------------------------------------------------------- +-- | Read a frame payload in full. +-- +-- 'confReadN' answers with an empty string at end of input, so a payload that +-- comes back short means the peer hung up in the middle of the frame. Saying +-- so here keeps every decoder below from being handed fewer bytes than the +-- frame header promised it. +readPayload :: Config -> Int -> IO ByteString +readPayload Config{..} len = do + bs <- confReadN len + when (BS.length bs /= len) $ E.throwIO ConnectionIsClosed + return bs + controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO () -controlOrStream ctx@Context{..} Config{..} ftyp header@FrameHeader{streamId, payloadLength} +controlOrStream ctx@Context{..} conf ftyp header@FrameHeader{flags, streamId, payloadLength} | isControl streamId = do - bs <- confReadN payloadLength + bs <- readPayload conf payloadLength control ftyp header bs ctx | ftyp == FramePushPromise = do - bs <- confReadN payloadLength - push header bs ctx + bs <- readPayload conf payloadLength + -- A promised stream can be refused over concurrency too, and by the + -- time 'push' gets that far it has decoded the field block, so the + -- same reasoning as 'resettable' applies: reset the promised stream + -- and read on. There is no 'Stream' to close -- it was refused + -- before one was made -- so this resets by identifier alone. + push header bs ctx `E.catch` resetPromised | otherwise = do - checkContinued + mcont <- checkContinued mstrm <- getStream ctx ftyp streamId - bs <- confReadN payloadLength - case mstrm of - Just strm -> do - state0 <- readStreamState strm - state <- stream ftyp header bs ctx state0 strm - resetContinued - set <- processState state ctx strm streamId - when set setContinued - Nothing - | ftyp == FramePriority -> do - -- for h2spec only - PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs - checkPriority newpri streamId - | otherwise -> return () + bs <- readPayload conf payloadLength + case mcont of + Just hc -> continuation hc bs mstrm + Nothing -> + case mstrm of + Just strm -> resettable strm $ do + state0 <- readStreamState strm + state <- stream ftyp header bs ctx state0 strm + processState state ctx strm streamId + Nothing + | ftyp == FramePriority -> do + -- for h2spec only + PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs + checkPriority newpri streamId + | ftyp == FrameData -> + -- Dropped, but still paid for. + informIgnoredData ctx streamId payloadLength + | ftyp == FrameHeaders -> do + HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs + if testEndHeader flags + then hpackDiscardHeader frag streamId ctx + else startHeaderBlock ctx streamId (testEndStream flags) frag + | otherwise -> return () where - setContinued = writeIORef continued $ Just streamId resetContinued = writeIORef continued Nothing + resetPromised (StreamErrorIsSent err sid _msg) = + enqueueControl controlQ $ CFrames Nothing [resetFrame err sid] + resetPromised e = E.throwIO e + -- Answer a stream error by resetting that stream and reading on, which is + -- what RFC 9113 section 5.4.2 asks for: "an error related to a specific + -- stream that does not affect processing of other streams". + -- + -- Safe only here, after the payload has been read and any field block in + -- it decoded, so that the connection sits at a frame boundary and the + -- HPACK tables still agree with the peer's. Where neither holds -- a + -- field block abandoned part-way, a stream refused before its payload was + -- read -- the error is raised as a connection error where it is detected, + -- and travels straight past this handler. + resettable strm act = act `E.catch` reset + where + reset e@(StreamErrorIsSent err sid _msg) = do + -- MadeYouReset: CVE-2025-8671. A reset we send because of + -- what the peer sent frees the stream's concurrency slot just as + -- one the peer sends does, while a handler already launched for + -- the stream runs on. Counted with the peer's own resets, or a + -- peer that never sends RST_STREAM -- a PRIORITY on the stream + -- depending on itself is enough -- could keep any number of + -- handlers running past SETTINGS_MAX_CONCURRENT_STREAMS. + -- + -- REFUSED_STREAM is left out: it launches nothing, and it is the + -- answer section 8.7 means a peer to be able to retry. + when (err /= RefusedStream) $ do + rate <- getRate rstRate + when (rate > rstRateLimit mySettings) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm sid "too many stream errors" + resetContinued + -- 'closed' hands the exception to whoever is reading the stream + -- and takes it out of the stream table. + closed ctx strm $ ResetByMe $ E.toException e + enqueueControl controlQ $ CFrames Nothing [resetFrame err sid] + reset e = E.throwIO e + + checkContinued :: IO (Maybe HeaderContinuation) checkContinued = do mx <- readIORef continued case mx of Nothing -> return () - Just sid - | sid == streamId && ftyp == FrameContinuation -> return () + Just hc + | hcStreamId hc == streamId && ftyp == FrameContinuation -> return () | otherwise -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continuation frame must follow" + return mx + continuation + :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO () + continuation hc frag mstrm + | frag == "" && not (testEndHeader flags) = do + -- Empty Frame Flooding - CVE-2019-9518 + rate <- getRate emptyFrameRate + when (rate > emptyFrameRateLimit mySettings) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation" + | otherwise = do + phb' <- addFragment streamId frag (hcBlock hc) + if testEndHeader flags + then completeBlock hc (completeHeaderBlock phb') mstrm + else writeIORef continued $ Just hc{hcBlock = phb'} + + completeBlock + :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO () + completeBlock hc blk mstrm = do + resetContinued + case mstrm of + Just strm -> resettable strm $ do + state0 <- readStreamState strm + case state0 of + Open hcl JustOpened -> do + tbl <- hpackDecodeHeader blk streamId ctx + state <- onResponseHeaders ctx streamId hcl (hcEndOfStream hc) tbl + processState state ctx strm streamId + Open _ (Body q _ _ tlr) -> do + state <- onTrailers ctx streamId blk q tlr + processState state ctx strm streamId + _otherwise -> + -- The block began on a stream that was open for + -- headers or trailers, and the sender has since + -- closed it -- a reset crossing the block. There is + -- nothing to deliver, but the block still has to go + -- through the decoder, since it may have changed the + -- dynamic table. Handing it to 'stream' as a + -- CONTINUATION would get it refused as one that + -- cannot come here, closing the connection. + hpackDiscardHeader blk streamId ctx + Nothing -> + hpackDiscardHeader blk streamId ctx + +-- | Is this a response that is defined to have no content? +-- +-- RFC 9113, section 8.1.1: "A response that is defined to have no content, +-- as described in Section 6.4.1 of [HTTP], can have a non-zero +-- content-length header field, even though no content is included in DATA +-- frames." Those are the responses to HEAD, 204 and 304, and 2xx to +-- CONNECT; the content-length of one to HEAD, in particular, is that of the +-- content a GET would have had. Checking it against the content that +-- arrived made every such response to HEAD a stream error. +hasNoContent :: Context -> Stream -> ValueTable -> IO Bool +hasNoContent ctx Stream{streamRequestMethod} vt + | isServer ctx = return False + | otherwise = do + mmethod <- readIORef streamRequestMethod + let status = getFieldValue tokenStatus vt + return $ + mmethod == Just "HEAD" + || status `elem` [Just "204", Just "304"] + || (mmethod == Just "CONNECT" && maybe False ("2" `BS.isPrefixOf`) status) + ---------------------------------------------------------------- -processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool +processState :: StreamState -> Context -> Stream -> StreamId -> IO () -- Transition (process1) -processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do - let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt) - when (just mcl (/= (0 :: Int))) $ +processState (Open _ (NoBody tbl@(_, reqvt))) ctx strm@Stream{streamInput} streamId = do + -- My SETTINGS_MAX_CONCURRENT_STREAMS + when (isServer ctx) $ checkOddConcurrency ctx streamId + noContent <- hasNoContent ctx strm reqvt + let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) + when (not noContent && just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent ProtocolError streamId "no body but content-length is not zero" tlr <- newIORef Nothing - let inpObj = InpObj tbl (Just 0) (return "") tlr + let inpObj = InpObj tbl (Just 0) (return (mempty, True)) tlr if isServer ctx then do - let si = toServerInfo roleInfo - atomically $ writeTQueue (inputQ si) $ Input strm inpObj + launchHandler ctx strm inpObj else putMVar streamInput $ Right inpObj halfClosedRemote ctx strm - return False -- Transition (process2) -processState (Open hcl (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} _streamId = do - let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt) +processState (Open _ (HasBody tbl@(_, reqvt))) ctx strm@Stream{streamInput, streamRxQ} _streamId = do + -- My SETTINGS_MAX_CONCURRENT_STREAMS + when (isServer ctx) $ checkOddConcurrency ctx _streamId + noContent <- hasNoContent ctx strm reqvt + let mcl + -- Its content-length describes content it does not have. + | noContent = Just 0 + | otherwise = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) bodyLength <- newIORef 0 tlr <- newIORef Nothing q <- newTQueueIO - setStreamState ctx strm $ Open hcl (Body q mcl bodyLength tlr) + writeIORef streamRxQ $ Just q + setOpenState ctx strm $ Body q mcl bodyLength tlr -- FLOW CONTROL: WINDOW_UPDATE 0: recv: announcing my limit properly -- FLOW CONTROL: WINDOW_UPDATE: recv: announcing my limit properly bodySource <- mkSource q $ informWindowUpdate ctx strm let inpObj = InpObj tbl mcl (readSource bodySource) tlr if isServer ctx then do - let si = toServerInfo roleInfo - atomically $ writeTQueue (inputQ si) $ Input strm inpObj + launchHandler ctx strm inpObj else putMVar streamInput $ Right inpObj - return False --- Transition (process3) -processState s@(Open _ Continued{}) ctx strm _streamId = do - setStreamState ctx strm s - return True - -- Transition (process4) processState HalfClosedRemote ctx strm _streamId = do halfClosedRemote ctx strm - return False -- Transition (process5) processState (Closed cc) ctx strm _streamId = do closed ctx strm cc - return False -- Transition (process6) +processState (Open _ o) ctx strm _streamId = + -- Open JustOpened, Open Body. Not the whole state: see 'setOpenState'. + setOpenState ctx strm o processState s ctx strm _streamId = do - -- Idle, Open Body, Closed + -- Idle setStreamState ctx strm s - return False +-- | Handing a request to the server's handler. +-- +-- The stream counts towards the last stream identifier of our GOAWAY from +-- here on: from now its request "might have been processed" (RFC 9113, +-- section 6.8), and a client is free to retry, on another connection, any +-- request on a stream above it. It used to be counted once the handler +-- had returned, so a GOAWAY sent while handlers were running left their +-- streams out, and a client could send again a request -- a POST, say -- +-- that had been acted on. +launchHandler :: Context -> Stream -> InpObj -> IO () +launchHandler ctx@Context{roleInfo} strm inpObj = do + modifyPeerLastStreamId ctx $ streamNumber strm + let ServerInfo{..} = toServerInfo roleInfo + launch ctx strm inpObj + ---------------------------------------------------------------- {- FOURMOLU_DISABLE -} @@ -267,7 +407,14 @@ csid <- getPeerStreamID ctx if streamId <= csid -- consider the stream closed then - if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] + -- RFC 9113 section 5.1: "An endpoint MUST ignore frames that + -- it receives on closed streams after it has sent a + -- RST_STREAM frame." DATA is in that list because resetting a + -- stream mid-body leaves whatever the peer already put on the + -- wire still to arrive. HEADERS is not: that would be reuse + -- of a stream identifier, which section 5.1.1 makes a + -- connection error. + if ftyp `elem` [FrameData, FrameWindowUpdate, FrameRSTStream, FramePriority] then return Nothing -- will be ignored else E.throwIO $ @@ -281,12 +428,24 @@ let errmsg = Short.toShort ( "this frame is not allowed in an idle stream: " - `BS.append` (C8.pack (show ftyp)) + `BS.append` C8.pack (show ftyp) ) E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg - when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId - -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit - Just <$> openOddStreamCheck ctx streamId ftyp + if ftyp == FramePriority + then + -- PRIORITY does not open a stream (RFC 9113, section + -- 5.1): it is checked and dropped like one for a + -- stream we do not have. It used to create the + -- stream, taking a concurrency slot that nothing ever + -- gave back, since no HEADERS need follow: a peer + -- could fill SETTINGS_MAX_CONCURRENT_STREAMS with + -- PRIORITY frames alone and have every request after + -- them refused. + return Nothing + else do + setPeerStreamID ctx streamId + -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit + Just <$> openOddStreamCheck ctx streamId ftyp | otherwise = -- We received a frame from the server on an unknown stream -- (likely a previously created and then subsequently reset stream). @@ -309,7 +468,7 @@ else do -- Settings Flood - CVE-2019-9515 rate <- getRate settingsRate - when (rate > settingsRateLimit) $ + when (rate > settingsRateLimit mySettings) $ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many settings" let ack = settingsFrame setAck [] @@ -325,18 +484,25 @@ setframe = CFrames (Just peerAlist) (frames ++ [ack]) writeIORef myFirstSettings True enqueueControl controlQ setframe -control FramePing FrameHeader{flags, streamId} bs Context{mySettings, controlQ, pingRate} = +control FramePing FrameHeader{flags, streamId} bs ctx@Context{mySettings, pingRate} = unless (testAck flags) $ do rate <- getRate pingRate if rate > pingRateLimit mySettings then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many ping" - else do - let frame = pingFrame bs - enqueueControl controlQ $ CFrames Nothing [frame] -control FrameGoAway header bs _ = do + else sendPing ctx True bs +control FrameGoAway header bs ctx = do GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs if err == NoError - then E.throwIO ConnectionIsClosed + then do + first <- goingAway ctx sid + -- The receiver goes on reading for the streams left, and stops + -- the way it does when the peer closes the connection, once + -- they are done. + when first $ do + receiver <- myThreadId + T.forkManaged (threadManager ctx) "H2 draining after GOAWAY" $ do + atomically $ drained ctx + E.throwTo receiver ConnectionIsClosed else E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg control FrameWindowUpdate header bs ctx = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs @@ -363,15 +529,17 @@ ProtocolError streamId "wrong header fragment for push promise" - (_, vt) <- hpackDecodeHeader frag streamId ctx + -- A malformed promised request is an error on the promised stream, + -- which 'resetPromised' resets. + (_, vt) <- hpackDecodeHeader frag streamId ctx `E.catch` onPromised sid let ClientInfo{..} = toClientInfo $ roleInfo ctx when - ( getHeaderValue tokenAuthority vt == Just (UTF8.fromString authority) - && getHeaderValue tokenScheme vt == Just scheme + ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority) + && getFieldValue tokenScheme vt == Just scheme ) $ do - let mmethod = getHeaderValue tokenMethod vt - mpath = getHeaderValue tokenPath vt + let mmethod = getFieldValue tokenMethod vt + mpath = getFieldValue tokenPath vt case (mmethod, mpath) of (Just method, Just path) -> -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit @@ -380,6 +548,10 @@ ---------------------------------------------------------------- +onPromised :: StreamId -> HTTP2Error -> IO a +onPromised sid (StreamErrorIsSent err _ msg) = E.throwIO $ StreamErrorIsSent err sid msg +onPromised _ e = E.throwIO e + {-# INLINE guardIt #-} guardIt :: Either FrameDecodeError a -> IO a guardIt x = case x of @@ -395,6 +567,27 @@ where dep = streamDependency p +-- | Handle a decoded response HEADERS section. On the client, a 1xx +-- informational response (e.g. 103 Early Hints) is delivered to the +-- informational callback and the stream keeps waiting for the final response; +-- otherwise the headers become the (final) response. +onResponseHeaders + :: Context + -> StreamId + -> Maybe ClosedCode + -> Bool + -> TokenHeaderTable + -> IO StreamState +onResponseHeaders ctx streamId hcl endOfStream tbl + | endOfStream = return $ Open hcl (NoBody tbl) + | role ctx == Client && isInformational = do + informationalCallback ctx streamId tbl + return $ Open hcl JustOpened + | otherwise = return $ Open hcl (HasBody tbl) + where + isInformational = + maybe False ("1" `BS.isPrefixOf`) $ getFieldValue tokenStatus (snd tbl) + stream :: FrameType -> FrameHeader @@ -412,7 +605,7 @@ then do -- Empty Frame Flooding - CVE-2019-9518 rate <- getRate $ emptyFrameRate ctx - if rate > emptyFrameRateLimit + if rate > emptyFrameRateLimit (mySettings ctx) then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty headers" @@ -424,41 +617,38 @@ if endOfHeader then do tbl <- hpackDecodeHeader frag streamId ctx - return $ - if endOfStream - then -- turned into HalfClosedRemote in processState - Open hcl (NoBody tbl) - else Open hcl (HasBody tbl) + onResponseHeaders ctx streamId hcl endOfStream tbl else do - let siz = BS.length frag - return $ Open hcl $ Continued [frag] siz 1 endOfStream + startHeaderBlock ctx streamId endOfStream frag + return s -- Transition (stream2) -stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx (Open _ (Body q _ _ tlr)) _ = do +stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx s@(Open _ (Body q _ _ tlr)) _ = do HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags -- checking frag == "" is not necessary if endOfStream then do - tbl <- hpackDecodeTrailer frag streamId ctx - writeIORef tlr (Just tbl) - atomically $ writeTQueue q $ Right "" - return HalfClosedRemote - else -- we don't support continuation here. + if testEndHeader flags + then onTrailers ctx streamId frag q tlr + else do + startHeaderBlock ctx streamId endOfStream frag + return s + else E.throwIO $ ConnectionErrorIsSent ProtocolError streamId - "continuation in trailer is not supported" + "trailers without END_STREAM" -- Transition (stream4) stream FrameData header@FrameHeader{flags, payloadLength, streamId} bs - Context{emptyFrameRate, rxFlow} + ctx@Context{emptyFrameRate, rxFlow, mySettings} s@(Open _ (Body q mcl bodyLength _)) - Stream{..} = do + strm@Stream{..} = do DataFrame body <- guardIt $ decodeDataFrame header bs -- FLOW CONTROL: WINDOW_UPDATE 0: recv: rejecting if over my limit okc <- atomicModifyIORef' rxFlow $ checkRxLimit payloadLength @@ -476,18 +666,47 @@ EnhanceYourCalm streamId "exceeds stream flow-control limit" + -- A push gives the connection window everything back now, padding + -- and all ('connectionCreditedOnArrival'); its stream window, and + -- any other stream's windows, as below. + when (connectionCreditedOnArrival streamId) $ + giveBackConnectionWindow ctx payloadLength + -- The padding is charged to both windows, as it must be, but it + -- never reaches the reader, whose reading is what gives octets + -- back ('readSource'). Left there, each padded frame shrank the + -- peer's windows for good, until the connection stalled. It is + -- done with as soon as it arrives, so it goes straight back. + informWindowUpdate ctx strm $ payloadLength - BS.length body len0 <- readIORef bodyLength - let len = len0 + payloadLength + -- The content itself: 'payloadLength', which flow control goes by, + -- also counts the padding, and so made a padded body look longer + -- than its content-length. + let len = len0 + BS.length body endOfStream = testEndStream flags -- Empty Frame Flooding - CVE-2019-9518 if body == "" then unless endOfStream $ do rate <- getRate emptyFrameRate - when (rate > emptyFrameRateLimit) $ do + when (rate > emptyFrameRateLimit mySettings) $ do E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty data" else do writeIORef bodyLength len - atomically $ writeTQueue q $ Right body + -- Not for a stream closed since its state was read, by + -- a reader that has done with it ('giveBackUnread') or a + -- reset of ours: nothing would ever read it, or give it + -- back to the connection window. Checked in the same + -- transaction, so that a closer that has emptied the + -- queue finds nothing put in after it. + queued <- atomically $ do + st <- readTVar streamState + if isClosed st + then return False + else do + writeTQueue q $ Right (body, endOfStream) + return True + unless (queued || connectionCreditedOnArrival streamId) $ + giveBackConnectionWindow ctx $ + BS.length body if endOfStream then do case mcl of @@ -500,43 +719,10 @@ streamId "actual body length is not the same as content-length" -- no trailers - atomically $ writeTQueue q $ Right "" + atomically $ writeTQueue q $ Right (mempty, True) return HalfClosedRemote else return s --- Transition (stream5) -stream FrameContinuation FrameHeader{flags, streamId} frag ctx s@(Open hcl (Continued rfrags siz n endOfStream)) _ = do - let endOfHeader = testEndHeader flags - if frag == "" && not endOfHeader - then do - -- Empty Frame Flooding - CVE-2019-9518 - rate <- getRate $ emptyFrameRate ctx - if rate > emptyFrameRateLimit - then - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation" - else return s - else do - let rfrags' = frag : rfrags - siz' = siz + BS.length frag - n' = n + 1 - when (siz' > headerFragmentLimit) $ - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big" - when (n' > continuationLimit) $ - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented" - if endOfHeader - then do - let hdrblk = BS.concat $ reverse rfrags' - tbl <- hpackDecodeHeader hdrblk streamId ctx - return $ - if endOfStream - then -- turned into HalfClosedRemote in processState - Open hcl (NoBody tbl) - else Open hcl (HasBody tbl) - else return $ Open hcl $ Continued rfrags' siz' n' endOfStream - -- (No state transition) stream FrameWindowUpdate header bs _ s strm = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs @@ -547,7 +733,7 @@ stream FrameRSTStream header@FrameHeader{streamId} bs ctx s strm = do -- Rapid Rest: CVE-2023-44487 rate <- getRate $ rstRate ctx - when (rate > rstRateLimit) $ + when (rate > rstRateLimit (mySettings ctx)) $ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many rst_stream" RSTStreamFrame err <- guardIt $ decodeRSTStreamFrame header bs @@ -569,18 +755,39 @@ -- > /Either endpoint/ can send a RST_STREAM frame from this state, causing -- > it to transition immediately to "closed". -- - -- (emphasis not in original). This justifies the two non-error cases, - -- below. (Section 8.1 of the spec is also relevant, but it is less explicit - -- about the /either endpoint/ part.) - case (s, err) of - (Open (Just _) _, NoError) -> - -- HalfClosedLocal - return (Closed cc) - (HalfClosedRemote, NoError) -> - return (Closed cc) - _otherwise -> do - E.throwIO $ StreamErrorIsReceived err streamId - + -- (emphasis not in original). + -- + -- In addition, the spec states (about the open state): + -- + -- > Either endpoint can send a RST_STREAM frame from this state, causing it + -- > to transition immediately to "closed". + -- + -- This justifies the non-error cases, below. (Section 8.1 of the spec + -- is also relevant, but it is less explicit about the /either endpoint/ + -- part.) + -- + -- The error code the peer sent does not enter into it. Receiving a + -- RST_STREAM closes that stream and nothing else, whatever the reason + -- given; the code is for whoever is reading the stream, and reaches them + -- as 'StreamResetIsReceived' by way of 'closed' above. Ending the whole + -- connection over it would punish every other stream on the connection + -- for a peer's complaint about one. + case s of + -- Open /or/ half-closed (local) + Open _ _ -> return (Closed cc) + HalfClosedRemote -> return (Closed cc) + Reserved -> return (Closed cc) + Closed _ -> return (Closed cc) + -- Only an idle stream is left, which a PRIORITY frame can have + -- created. Section 5.1 again, on "idle": "Receiving any frame other + -- than HEADERS or PRIORITY on a stream in this state MUST be treated + -- as a connection error (Section 5.4.1) of type PROTOCOL_ERROR." + Idle -> + E.throwIO $ + ConnectionErrorIsSent + ProtocolError + streamId + "rst_stream on an idle stream" -- (No state transition) stream FramePriority header bs _ s Stream{streamNumber} = do -- ignore @@ -593,15 +800,20 @@ stream FrameContinuation FrameHeader{streamId} _ _ _ _ = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continue frame cannot come here" -stream _ FrameHeader{streamId} _ _ (Open _ Continued{}) _ = - E.throwIO $ - ConnectionErrorIsSent - ProtocolError - streamId - "an illegal frame follows header/continuation frames" +-- DATA that is not taken in, below, is still paid for. RFC 9113 section +-- 6.9: "A receiver that receives a flow-controlled frame MUST always account +-- for its contribution against the connection flow-control window, unless +-- the receiver treats this as a connection error." The peer charged it to +-- the connection window before sending it, and unless it is charged and +-- given back here as well, the peer's view of that window shrinks for good. +-- -- Ignore frames to streams we have just reset, per section 5.1. +stream FrameData FrameHeader{payloadLength, streamId} _ ctx st@(Closed (ResetByMe _)) _ = do + informIgnoredData ctx streamId payloadLength + return st stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st -stream FrameData FrameHeader{streamId} _ _ _ _ = +stream FrameData FrameHeader{payloadLength, streamId} _ ctx _ _ = do + informIgnoredData ctx streamId payloadLength E.throwIO $ StreamErrorIsSent StreamClosed streamId $ fromString ("illegal data frame for " ++ show streamId) @@ -613,41 +825,148 @@ ---------------------------------------------------------------- -- | Type for input streaming. -data Source - = Source - (Int -> IO ()) - (TQueue (Either E.SomeException ByteString)) - (IORef ByteString) - (IORef Bool) +data Source = Source RxQ (Int -> IO ()) (IORef Bool) -mkSource - :: TQueue (Either E.SomeException ByteString) -> (Int -> IO ()) -> IO Source -mkSource q inform = Source inform q <$> newIORef "" <*> newIORef False +mkSource :: RxQ -> (Int -> IO ()) -> IO Source +mkSource q inform = Source q inform <$> newIORef False -readSource :: Source -> IO ByteString -readSource (Source inform q refBS refEOF) = do +readSource :: Source -> IO (ByteString, Bool) +readSource (Source q inform refEOF) = do eof <- readIORef refEOF if eof - then return "" + then return (mempty, True) else do - bs <- readBS - let len = BS.length bs - inform len - return bs + mBS <- atomically $ readTQueue q + case mBS of + Left err -> do + writeIORef refEOF True + E.throwIO err + Right (bs, isEOF) -> do + writeIORef refEOF isEOF + let len = BS.length bs + inform len + return (bs, isEOF) + +---------------------------------------------------------------- + +closureClient :: Config -> Context -> Either E.SomeException a -> IO a +closureClient conf ctx (Right x) = do + frame <- goaway ctx NoError "no error" + sendGoaway conf frame + return x +closureClient conf ctx (Left se) = closureServer conf ctx se + +closureServer :: Config -> Context -> E.SomeException -> IO a +closureServer conf ctx se + | isAsyncException se = do + frame <- goaway ctx NoError "maybe timeout by manager" + sendGoaway conf frame + E.throwIO se + | Just ConnectionIsClosed <- E.fromException se = do + frame <- goaway ctx NoError "no error" + sendGoaway conf frame + E.throwIO ConnectionIsClosed + | Just ConnectionIsTimeout <- E.fromException se = do + frame <- goaway ctx NoError "timeout" + sendGoaway conf frame + E.throwIO ConnectionIsTimeout + | Just e@(ConnectionErrorIsReceived _err _sid msg) <- E.fromException se = do + frame <- goaway ctx NoError $ Short.fromShort msg + sendGoaway conf frame + E.throwIO e + | Just e@(ConnectionErrorIsSent err _sid msg) <- E.fromException se = do + frame <- goaway ctx err $ Short.fromShort msg + sendGoaway conf frame + E.throwIO e + | Just e@(StreamErrorIsSent err _sid msg) <- E.fromException se = do + let frame = resetFrame err _sid + frame' <- goaway ctx err $ Short.fromShort msg + sendGoaway conf (frame <> frame') + E.throwIO e + | Just e@(StreamErrorIsReceived err _sid) <- E.fromException se = do + frame <- goaway ctx err "treat a stream error as a connection error" + sendGoaway conf frame + E.throwIO e + | Just (_ :: HTTP2Error) <- E.fromException se = E.throwIO se + | otherwise = E.throwIO $ BadThingHappen se + +goaway :: Context -> ErrorCode -> ByteString -> IO ByteString +goaway ctx err msg = do + sid <- getPeerLastStreamId ctx + return $ goawayFrame sid err msg + +sendGoaway :: Config -> ByteString -> IO () +sendGoaway Config{..} frame = confSendAll frame `E.catchIOError` \_ -> return () + +---------------------------------------------------------------- + +sendPing :: Context -> Bool -> ByteString -> IO () +sendPing Context{..} ack bs = enqueueControl controlQ $ CFrames Nothing [frame] where - readBS :: IO ByteString - readBS = do - bs0 <- readIORef refBS - if bs0 == "" - then do - mBS <- atomically $ readTQueue q - case mBS of - Left err -> do - writeIORef refEOF True - E.throwIO err - Right bs -> do - when (bs == "") $ writeIORef refEOF True - return bs - else do - writeIORef refBS "" - return bs0 + frame = pingFrame ack bs + +---------------------------------------------------------------- + +-- | Deliver a complete trailer block: the body ends with it. +onTrailers + :: Context + -> StreamId + -> HeaderBlockFragment + -> TQueue (Either E.SomeException (ByteString, Bool)) + -> IORef (Maybe TokenHeaderTable) + -> IO StreamState +onTrailers ctx streamId blk q tlr = do + tbl <- hpackDecodeTrailer blk streamId ctx + writeIORef tlr (Just tbl) + atomically $ writeTQueue q $ Right (mempty, True) + return HalfClosedRemote + +-- | Start accumulating a header block that does not fit in a single frame +startHeaderBlock + :: Context + -> StreamId + -> Bool + -- ^ END_STREAM, from the HEADERS frame + -> HeaderBlockFragment + -- ^ The fragment in the HEADERS frame + -> IO () +startHeaderBlock Context{continued} streamId endOfStream frag = + writeIORef continued . Just $ + HeaderContinuation + { hcStreamId = streamId + , hcBlock = newPartialHeaderBlock frag + , hcEndOfStream = endOfStream + } + +newPartialHeaderBlock :: HeaderBlockFragment -> PartialHeaderBlock +newPartialHeaderBlock frag = + PartialHeaderBlock + { phbFragments = [frag] + , phbTotalSize = BS.length frag + , phbNumFrames = 1 + } + +addFragment + :: StreamId + -- ^ Used for error messages only + -> HeaderBlockFragment + -> PartialHeaderBlock + -> IO PartialHeaderBlock +addFragment streamId frag phb = do + when (phbTotalSize phb' > headerFragmentLimit) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big" + when (phbNumFrames phb' > continuationLimit) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented" + return phb' + where + phb' = + PartialHeaderBlock + { phbFragments = frag : phbFragments phb + , phbTotalSize = phbTotalSize phb + BS.length frag + , phbNumFrames = phbNumFrames phb + 1 + } + +completeHeaderBlock :: PartialHeaderBlock -> HeaderBlockFragment +completeHeaderBlock = BS.concat . reverse . phbFragments diff --git a/Network/HTTP2/H2/Sender.hs b/Network/HTTP2/H2/Sender.hs --- a/Network/HTTP2/H2/Sender.hs +++ b/Network/HTTP2/H2/Sender.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -5,31 +6,25 @@ module Network.HTTP2.H2.Sender ( frameSender, - fillBuilderBodyGetNext, - fillFileBodyGetNext, - fillStreamBodyGetNext, - runTrailersMaker, ) where -import Control.Concurrent.MVar (putMVar) +import Control.Concurrent.STM +import qualified Control.Exception as E import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Lazy as BS.Lazy import Data.IORef (modifyIORef', readIORef, writeIORef) import Data.IntMap.Strict (IntMap) -import Foreign.Ptr (minusPtr, plusPtr) +import Foreign.Ptr (castPtr, minusPtr, plusPtr) import Network.ByteOrder -import qualified UnliftIO.Exception as E -import UnliftIO.STM +import Network.HTTP.Semantics.Client +import Network.HTTP.Semantics.IO import Imports -import Network.HPACK (TokenHeaderList, setLimitForEncoding, toHeaderTable) +import Network.HPACK (setLimitForEncoding, toTokenHeaderTable) import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame -import Network.HTTP2.H2.File import Network.HTTP2.H2.HPACK -import Network.HTTP2.H2.Manager hiding (start) import Network.HTTP2.H2.Queue import Network.HTTP2.H2.Settings import Network.HTTP2.H2.Stream @@ -39,29 +34,11 @@ ---------------------------------------------------------------- -data Leftover - = LZero - | LOne B.BufferWriter - | LTwo ByteString B.BufferWriter - ----------------------------------------------------------------- - -{-# INLINE waitStreaming #-} -waitStreaming :: TBQueue a -> IO () -waitStreaming tbq = atomically $ do - isEmpty <- isEmptyTBQueue tbq - checkSTM (not isEmpty) - data Switch = C Control - | O (Output Stream) + | O Output | Flush -wrapException :: E.SomeException -> IO () -wrapException se - | Just (e :: HTTP2Error) <- E.fromException se = E.throwIO e - | otherwise = E.throwIO $ BadThingHappen se - -- Peer SETTINGS_INITIAL_WINDOW_SIZE -- Adjusting initial window size for streams updatePeerSettings :: Context -> SettingsList -> IO () @@ -81,22 +58,60 @@ where updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO () updateAllStreamTxFlow siz strms = - forM_ strms $ \strm -> increaseStreamWindowSize strm siz + forM_ strms $ \strm -> increaseStreamWindowSize strm siz `E.catch` connectionError + -- RFC 9113, section 6.9.2: "An endpoint MUST treat a change to + -- SETTINGS_INITIAL_WINDOW_SIZE that causes any flow-control window to + -- exceed the maximum size as a connection error of type + -- FLOW_CONTROL_ERROR." The same overflow from a WINDOW_UPDATE is a stream + -- error, which is what 'increaseStreamWindowSize' raises. + connectionError (StreamErrorIsSent err sid msg) = + E.throwIO $ ConnectionErrorIsSent err sid msg + connectionError e = E.throwIO e -frameSender :: Context -> Config -> Manager -> IO () +checkDone :: Context -> Int -> IO (Maybe E.SomeException) +checkDone Context{..} 0 = atomically $ do + isEmptyC <- isEmptyTQueue controlQ + isEmptyO <- isEmptyTQueue outputQ + if not isEmptyC || not isEmptyO + then + return Nothing + else do + recv <- readTVar receiverDone + case recv of + Just done -> + return $ Just done + _otherwise -> + retry +checkDone _ _ = return Nothing + +frameSender :: Context -> Config -> IO E.SomeException frameSender ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit} - Config{..} - mgr = loop 0 `E.catch` wrapException + Config{..} = do + labelMe "H2 sender" + -- DATA that has to wait for the connection window, in the order it + -- came: see 'dequeue'. + parked <- newTVarIO [] + -- This catches an asynchronous exception. + -- It is re-thrown by "runH2" + loop parked 0 `E.catch` return where ---------------------------------------------------------------- - loop :: Offset -> IO () - loop off = do - x <- atomically $ dequeue off - case x of - C ctl -> flushN off >> control ctl >> loop 0 - O out -> outputOrEnqueueAgain out off >>= flushIfNecessary >>= loop - Flush -> flushN off >> loop 0 + loop :: TVar [Output] -> Offset -> IO E.SomeException + loop parked off = do + mDone <- checkDone ctx off + case mDone of + Just done -> + return done + Nothing -> do + x <- atomically $ dequeue parked off + case x of + C ctl -> flushN off >> control ctl >> loop parked 0 + O out -> + outputAndSync parked out off + >>= flushIfNecessary + >>= loop parked + Flush -> flushN off >> loop parked 0 -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled. @@ -113,17 +128,31 @@ flushN off return 0 - dequeue :: Offset -> STM Switch - dequeue off = do + -- Only DATA is flow-controlled (RFC 9113, section 6.9), so only DATA + -- waits for the connection window. The whole output queue used to: + -- with the window shut, no HEADERS, PUSH_PROMISE or RST_STREAM went + -- out either, on any stream -- not even the response to a request + -- that has no body, or the reset that would have freed some of the + -- window. Now outputs are taken as they come, and DATA there is no + -- connection window for is parked ('outputAndSync') and goes out, + -- first and in order, once there is. + dequeue :: TVar [Output] -> Offset -> STM Switch + dequeue parked off = do isEmptyC <- isEmptyTQueue controlQ if isEmptyC then do - -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit - waitConnectionWindowSize ctx - isEmptyO <- isEmptyTQueue outputQ - if isEmptyO - then if off /= 0 then return Flush else retrySTM - else O <$> readTQueue outputQ + ps <- readTVar parked + cws <- connectionWindowSizeSTM ctx + case ps of + -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit + p : rest | cws > 0 -> do + writeTVar parked rest + return $ O p + _ -> do + isEmptyO <- isEmptyTQueue outputQ + if isEmptyO + then if off /= 0 then return Flush else retry + else O <$> readTQueue outputQ else C <$> readTQueue controlQ ---------------------------------------------------------------- @@ -132,13 +161,6 @@ -- called with off == 0 control :: Control -> IO () - control (CFinish e) = E.throwIO e - control (CGoaway bs mvar) = do - buf <- copyAll [bs] confWriteBuffer - let off = buf `minusPtr` confWriteBuffer - flushN off - putMVar mvar () - E.throwIO GoAwayIsSent control (CFrames ms xs) = do buf <- copyAll xs confWriteBuffer let off = buf `minusPtr` confWriteBuffer @@ -158,119 +180,182 @@ | otherwise = confBufferSize writeIORef outputBufferLimit buflim -- Peer SETTINGS_HEADER_TABLE_SIZE - case lookup SettingsHeaderTableSize peerAlist of + case lookup SettingsTokenHeaderTableSize peerAlist of Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable ---------------------------------------------------------------- - output :: Output Stream -> Offset -> WindowSize -> IO Offset - output out@(Output strm OutObj{} (ONext curr tlrmkr) _ sentinel) off0 lim = do - -- Data frame payload - buflim <- readIORef outputBufferLimit - let payloadOff = off0 + frameHeaderLength - datBuf = confWriteBuffer `plusPtr` payloadOff - datBufSiz = buflim - payloadOff - Next datPayloadLen reqflush mnext <- curr datBuf datBufSiz lim -- checkme - NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen - fillDataHeaderEnqueueNext - strm - off0 - datPayloadLen - mnext - tlrmkr' - sentinel - out - reqflush - output out@(Output strm (OutObj hdr body tlrmkr) OObj mtbq _) off0 lim = do + -- INVARIANT + -- + -- Both the stream window and the connection window are open. + ---------------------------------------------------------------- + outputAndSync :: TVar [Output] -> Output -> Offset -> IO Offset + -- "handler" catches an asynchronous exception and + -- re-throws it. + outputAndSync parked out@(Output strm otyp sync) off = E.handle (handler strm off) $ do + state <- readStreamState strm + if isHalfClosedLocal state + then do + case otyp of + OReset mErr + | not (isClosed state) -> + -- RST_STREAM is the only frame we can still send + -- after half-closing + resetStreamWith strm mErr + _otherwise -> + return () + -- Nothing more can go out on this stream, but whoever + -- enqueued this output is waiting in 'syncWithSender'' to + -- be told so. Dropping the notification parked that + -- thread on an MVar nothing would ever fill, until the + -- timeout manager killed it -- one stranded worker per + -- stream the peer resets while a response is in flight. + sync Nothing + return off + else case otyp of + OHeader hdr mnext tlrmkr -> do + (off', mout') <- outputHeader strm hdr mnext tlrmkr sync off + sync mout' + return off' + OInformational hdr -> do + off' <- outputInformational strm hdr off + sync Nothing + return off' + OReset mErr -> do + resetStreamWith strm mErr + sync Nothing + return off + _ -> do + sws <- getStreamWindowSize strm + cws <- getConnectionWindowSize ctx + let lim = min cws sws + case otyp of + ONext{} + | cws <= 0 -> do + -- To wait for the connection window, + -- without holding up anything else. + atomically $ modifyTVar' parked (++ [out]) + return off + | lim <= 0 -> do + -- No room for any of the body: the + -- window was shut after this was queued + -- (a SETTINGS_INITIAL_WINDOW_SIZE + -- decrease, say). Filling a DATA frame + -- into no room reads 0 octets of a file, + -- which is taken for its end; handed back + -- instead, it is queued again once the + -- window opens. + sync $ Just out + return off + _ -> do + (off', mout') <- output out off lim + sync mout' + return off' + + ---------------------------------------------------------------- + handler strm off e = do + resetStream strm InternalError e + return off + + resetStream :: Stream -> ErrorCode -> E.SomeException -> IO () + resetStream strm err e + | isAsyncException e = E.throwIO e + | otherwise = do + closed ctx strm (ResetByMe e) + let rst = resetFrame err $ streamNumber strm + enqueueControl controlQ $ CFrames Nothing [rst] + + resetStreamWith :: Stream -> Maybe E.SomeException -> IO () + resetStreamWith strm (Just err) = + resetStream strm InternalError err + resetStreamWith strm Nothing = + resetStream strm Cancel (E.toException CancelledStream) + + ---------------------------------------------------------------- + outputHeader + :: Stream + -> [Header] + -> Maybe DynaNext + -> TrailersMaker + -> (Maybe Output -> IO ()) + -> Offset + -> IO (Offset, Maybe Output) + outputHeader strm hdr mnext tlrmkr sync off0 = do -- Header frame and Continuation frame let sid = streamNumber strm - endOfStream = case body of - OutBodyNone -> True - _ -> False - (ths, _) <- toHeaderTable $ fixHeaders hdr + endOfStream = isNothing mnext + (ths, _) <- toTokenHeaderTable $ fixHeaders hdr off' <- headerContinue sid ths endOfStream off0 -- halfClosedLocal calls closed which removes -- the stream from stream table. - when endOfStream $ halfClosedLocal ctx strm Finished off <- flushIfNecessary off' - case body of - OutBodyNone -> return off - OutBodyFile (FileSpec path fileoff bytecount) -> do - (pread, sentinel') <- confPositionReadMaker path - refresh <- case sentinel' of - Closer closer -> timeoutClose mgr closer - Refresher refresher -> return refresher - let next = fillFileBodyGetNext pread fileoff bytecount refresh - out' = out{outputType = ONext next tlrmkr} - output out' off lim - OutBodyBuilder builder -> do - let next = fillBuilderBodyGetNext builder - out' = out{outputType = ONext next tlrmkr} - output out' off lim - OutBodyStreaming _ -> - output (setNextForStreaming mtbq tlrmkr out) off lim - OutBodyStreamingUnmask _ -> - output (setNextForStreaming mtbq tlrmkr out) off lim - output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do + case mnext of + Nothing -> do + -- endOfStream + halfClosedLocal ctx strm Finished + return (off, Nothing) + Just next -> do + let out' = Output strm (ONext next tlrmkr) sync + return (off, Just out') + + ---------------------------------------------------------------- + -- Emit an informational (1xx) HEADERS section. Unlike 'outputHeader', + -- this never sets END_STREAM and never half-closes the stream, so the + -- final response can still be sent afterwards. + outputInformational + :: Stream + -> [Header] + -> Offset + -> IO Offset + outputInformational strm hdr off0 = do + let sid = streamNumber strm + (ths, _) <- toTokenHeaderTable $ fixHeaders hdr + off' <- headerContinue sid ths False {- not endOfStream -} off0 + flushIfNecessary off' + + ---------------------------------------------------------------- + output :: Output -> Offset -> WindowSize -> IO (Offset, Maybe Output) + output out@(Output strm (ONext curr tlrmkr) _) off0 lim = do + -- Data frame payload + buflim <- readIORef outputBufferLimit + let payloadOff = off0 + frameHeaderLength + datBuf = confWriteBuffer `plusPtr` payloadOff + datBufSiz = buflim - payloadOff + curr datBuf (min datBufSiz lim) >>= \case + Next datPayloadLen reqflush mnext -> do + tm <- runTrailersMaker tlrmkr datBuf datPayloadLen + let tlrmkr' = case tm of + NextTrailersMaker t -> t + _ -> defaultTrailersMaker + fillDataHeader + strm + off0 + datPayloadLen + mnext + tlrmkr' + out + reqflush + CancelNext mErr -> do + -- Stream cancelled + -- + -- At this point, the headers have already been sent. + -- Therefore, the stream cannot be in the 'Idle' state, so we + -- are justified in sending @RST_STREAM@. + -- + -- By the invariant on the 'outputQ', there are no other + -- outputs for this stream already enqueued. Therefore, we can + -- safely cancel it knowing that we won't try and send any + -- more data frames on this stream. + resetStreamWith strm mErr + return (off0, Nothing) + output (Output strm (OPush ths pid) _) off0 _lim = do -- Creating a push promise header -- Frame id should be associated stream id from the client. let sid = streamNumber strm len <- pushPromise pid sid ths off0 off <- flushIfNecessary $ off0 + frameHeaderLength + len - output out{outputType = OObj} off lim - output _ _ _ = undefined -- never reach - - ---------------------------------------------------------------- - setNextForStreaming - :: Maybe (TBQueue StreamingChunk) - -> TrailersMaker - -> Output Stream - -> Output Stream - setNextForStreaming mtbq tlrmkr out = - let tbq = fromJust mtbq - takeQ = atomically $ tryReadTBQueue tbq - next = fillStreamBodyGetNext takeQ - in out{outputType = ONext next tlrmkr} - - ---------------------------------------------------------------- - outputOrEnqueueAgain :: Output Stream -> Offset -> IO Offset - outputOrEnqueueAgain out@(Output strm _ otyp _ _) off = E.handle resetStream $ do - state <- readStreamState strm - if isHalfClosedLocal state - then return off - else case otyp of - OWait wait -> do - -- Checking if all push are done. - forkAndEnqueueWhenReady wait outputQ out{outputType = OObj} mgr - return off - _ -> case mtbq of - Just tbq -> checkStreaming tbq - _ -> checkStreamWindowSize - where - mtbq = outputStrmQ out - checkStreaming tbq = do - isEmpty <- atomically $ isEmptyTBQueue tbq - if isEmpty - then do - forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr - return off - else checkStreamWindowSize - -- FLOW CONTROL: WINDOW_UPDATE: send: respecting peer's limit - checkStreamWindowSize = do - sws <- getStreamWindowSize strm - if sws == 0 - then do - forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr - return off - else do - cws <- getConnectionWindowSize ctx -- not 0 - let lim = min cws sws - output out off lim - resetStream e = do - closed ctx strm (ResetByMe e) - let rst = resetFrame InternalError $ streamNumber strm - enqueueControl controlQ $ CFrames Nothing [rst] - return off + return (off, Nothing) + output _ _ _ = undefined -- never reached ---------------------------------------------------------------- headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset @@ -279,22 +364,31 @@ let offkv = off0 + frameHeaderLength bufkv = confWriteBuffer `plusPtr` offkv limkv = buflim - offkv - (ths, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0 - if kvlen == 0 - then continue off0 ths FrameHeaders + -- Most blocks fit where they are going: encode in place, which + -- is one HEADERS frame and no copying. + (rest, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0 + if null rest + then do + let buf = confWriteBuffer `plusPtr` off0 + fillFrameHeader FrameHeaders kvlen sid (getFlag FrameHeaders BS.Lazy.empty) buf + return $ offkv + kvlen else do - let flag = getFlag ths - buf = confWriteBuffer `plusPtr` off0 - off = offkv + kvlen - fillFrameHeader FrameHeaders kvlen sid flag buf - continue off ths FrameContinuation + -- It did not fit. What was written is the start of the + -- block, and the dynamic table has taken it into + -- account, so it is kept; the rest is encoded after it, + -- and the whole block then starts in a fresh buffer to + -- avoid emitting a tiny HEADERS frame. + start <- BS.packCStringLen (castPtr bufkv, kvlen) + ths1 <- hpackEncodeHeaderRest ctx (buflim - frameHeaderLength) rest + continue off0 (BS.Lazy.fromStrict start <> ths1) FrameHeaders where eos = if endOfStream then setEndStream else id - getFlag [] = eos $ setEndHeader defaultFlags - getFlag _ = eos $ defaultFlags + getFlag ft ths = + (if ft == FrameHeaders then eos else id) $ + if BS.Lazy.null ths then setEndHeader defaultFlags else defaultFlags - continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset - continue off [] _ = return off + continue :: Offset -> BS.Lazy.ByteString -> FrameType -> IO Offset + continue off ths _ | BS.Lazy.null ths = return off continue off ths ft = do flushN off -- Now off is 0 @@ -303,80 +397,89 @@ headerPayloadLim = buflim - frameHeaderLength (ths', kvlen') <- - hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths - when (ths == ths') $ - E.throwIO $ - ConnectionErrorIsSent CompressionError sid "cannot compress the header" - let flag = getFlag ths' + copyFragment bufHeaderPayload headerPayloadLim ths + let flag = getFlag ft ths' off' = frameHeaderLength + kvlen' fillFrameHeader ft kvlen' sid flag confWriteBuffer continue off' ths' FrameContinuation + -- Copy as much of the block as fits; return the rest and the number of bytes copied + copyFragment + :: Buffer -> Int -> BS.Lazy.ByteString -> IO (BS.Lazy.ByteString, Int) + copyFragment buf lim ths = do + let (frag, rest) = BS.Lazy.splitAt (fromIntegral (max 0 lim)) ths + _ <- foldM copy buf (BS.Lazy.toChunks frag) + return (rest, fromIntegral (BS.Lazy.length frag)) + ---------------------------------------------------------------- - fillDataHeaderEnqueueNext + fillDataHeader :: Stream -> Offset -> Int -> Maybe DynaNext -> (Maybe ByteString -> IO NextTrailersMaker) - -> IO () - -> Output Stream + -> Output -> Bool - -> IO Offset - fillDataHeaderEnqueueNext + -> IO (Offset, Maybe Output) + fillDataHeader strm@Stream{streamNumber} off datPayloadLen Nothing tlrmkr - tell _ reqflush = do let buf = confWriteBuffer `plusPtr` off - off' = off + frameHeaderLength + datPayloadLen (mtrailers, flag) <- do - Trailers trailers <- tlrmkr Nothing + tm <- tlrmkr Nothing + let trailers = case tm of + Trailers t -> t + _ -> [] if null trailers then return (Nothing, setEndStream defaultFlags) else return (Just trailers, defaultFlags) - fillFrameHeader FrameData datPayloadLen streamNumber flag buf + -- Avoid sending an empty data frame before trailers at the end + -- of a stream + off' <- + if datPayloadLen /= 0 || isNothing mtrailers + then do + decreaseWindowSize ctx strm datPayloadLen + fillFrameHeader FrameData datPayloadLen streamNumber flag buf + return $ off + frameHeaderLength + datPayloadLen + else + return off off'' <- handleTrailers mtrailers off' - void tell halfClosedLocal ctx strm Finished - decreaseWindowSize ctx strm datPayloadLen if reqflush then do flushN off'' - return 0 - else return off'' + return (0, Nothing) + else return (off'', Nothing) where handleTrailers Nothing off0 = return off0 handleTrailers (Just trailers) off0 = do - (ths, _) <- toHeaderTable trailers + (ths, _) <- toTokenHeaderTable trailers headerContinue streamNumber ths True {- endOfStream -} off0 - fillDataHeaderEnqueueNext + fillDataHeader _ off 0 (Just next) tlrmkr - _ out reqflush = do let out' = out{outputType = ONext next tlrmkr} - enqueueOutput outputQ out' if reqflush then do flushN off - return 0 - else return off - fillDataHeaderEnqueueNext + return (0, Just out') + else return (off, Just out') + fillDataHeader strm@Stream{streamNumber} off datPayloadLen (Just next) tlrmkr - _ out reqflush = do let buf = confWriteBuffer `plusPtr` off @@ -385,12 +488,11 @@ fillFrameHeader FrameData datPayloadLen streamNumber flag buf decreaseWindowSize ctx strm datPayloadLen let out' = out{outputType = ONext next tlrmkr} - enqueueOutput outputQ out' if reqflush then do flushN off' - return 0 - else return off' + return (0, Just out') + else return (off', Just out') ---------------------------------------------------------------- pushPromise :: StreamId -> StreamId -> TokenHeaderList -> Offset -> IO Int @@ -419,168 +521,3 @@ , flags = flag , streamId = sid } - --- | Running trailers-maker. --- --- > bufferIO buf siz $ \bs -> tlrmkr (Just bs) -runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker -runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs) - ----------------------------------------------------------------- - -fillBuilderBodyGetNext :: Builder -> DynaNext -fillBuilderBodyGetNext bb buf siz lim = do - let room = min siz lim - (len, signal) <- B.runBuilder bb buf room - return $ nextForBuilder len signal - -fillFileBodyGetNext - :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext -fillFileBodyGetNext pread start bytecount refresh buf siz lim = do - let room = min siz lim - len <- pread start (mini room bytecount) buf - let len' = fromIntegral len - return $ nextForFile len' pread (start + len) (bytecount - len) refresh - -fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext -fillStreamBodyGetNext takeQ buf siz lim = do - let room = min siz lim - (cont, len, reqflush, leftover) <- runStreamBuilder buf room takeQ - return $ nextForStream cont len reqflush leftover takeQ - ----------------------------------------------------------------- - -fillBufBuilder :: Leftover -> DynaNext -fillBufBuilder leftover buf0 siz0 lim = do - let room = min siz0 lim - case leftover of - LZero -> error "fillBufBuilder: LZero" - LOne writer -> do - (len, signal) <- writer buf0 room - getNext len signal - LTwo bs writer - | BS.length bs <= room -> do - buf1 <- copy buf0 bs - let len1 = BS.length bs - (len2, signal) <- writer buf1 (room - len1) - getNext (len1 + len2) signal - | otherwise -> do - let (bs1, bs2) = BS.splitAt room bs - void $ copy buf0 bs1 - getNext room (B.Chunk bs2 writer) - where - getNext l s = return $ nextForBuilder l s - -nextForBuilder :: BytesFilled -> B.Next -> Next -nextForBuilder len B.Done = - Next len True Nothing -- let's flush -nextForBuilder len (B.More _ writer) = - Next len False $ Just (fillBufBuilder (LOne writer)) -nextForBuilder len (B.Chunk bs writer) = - Next len False $ Just (fillBufBuilder (LTwo bs writer)) - ----------------------------------------------------------------- - -runStreamBuilder - :: Buffer - -> BufferSize - -> IO (Maybe StreamingChunk) - -> IO - ( Bool -- continue - , BytesFilled - , Bool -- require flusing - , Leftover - ) -runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0 - where - loop buf room total = do - mbuilder <- takeQ - case mbuilder of - Nothing -> return (True, total, False, LZero) - Just (StreamingBuilder builder) -> do - (len, signal) <- B.runBuilder builder buf room - let total' = total + len - case signal of - B.Done -> loop (buf `plusPtr` len) (room - len) total' - B.More _ writer -> return (True, total', False, LOne writer) - B.Chunk bs writer -> return (True, total', False, LTwo bs writer) - Just StreamingFlush -> return (True, total, True, LZero) - Just (StreamingFinished dec) -> do - dec - return (False, total, True, LZero) - -fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext -fillBufStream leftover0 takeQ buf0 siz0 lim0 = do - let room0 = min siz0 lim0 - case leftover0 of - LZero -> do - (cont, len, reqflush, leftover) <- runStreamBuilder buf0 room0 takeQ - getNext cont len reqflush leftover - LOne writer -> write writer buf0 room0 0 - LTwo bs writer - | BS.length bs <= room0 -> do - buf1 <- copy buf0 bs - let len = BS.length bs - write writer buf1 (room0 - len) len - | otherwise -> do - let (bs1, bs2) = BS.splitAt room0 bs - void $ copy buf0 bs1 - getNext True room0 False $ LTwo bs2 writer - where - getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next - getNext cont len reqflush l = return $ nextForStream cont len reqflush l takeQ - - write - :: (Buffer -> BufferSize -> IO (Int, B.Next)) - -> Buffer - -> BufferSize - -> Int - -> IO Next - write writer1 buf room sofar = do - (len, signal) <- writer1 buf room - case signal of - B.Done -> do - (cont, extra, reqflush, leftover) <- - runStreamBuilder (buf `plusPtr` len) (room - len) takeQ - let total = sofar + len + extra - getNext cont total reqflush leftover - B.More _ writer -> do - let total = sofar + len - getNext True total False $ LOne writer - B.Chunk bs writer -> do - let total = sofar + len - getNext True total False $ LTwo bs writer - -nextForStream - :: Bool - -> BytesFilled - -> Bool - -> Leftover - -> IO (Maybe StreamingChunk) - -> Next -nextForStream False len reqflush _ _ = Next len reqflush Nothing -nextForStream True len reqflush leftOrZero takeQ = - Next len reqflush $ Just (fillBufStream leftOrZero takeQ) - ----------------------------------------------------------------- - -fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext -fillBufFile pread start bytes refresh buf siz lim = do - let room = min siz lim - len <- pread start (mini room bytes) buf - refresh - let len' = fromIntegral len - return $ nextForFile len' pread (start + len) (bytes - len) refresh - -nextForFile - :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next -nextForFile 0 _ _ _ _ = Next 0 True Nothing -- let's flush -nextForFile len _ _ 0 _ = Next len False Nothing -nextForFile len pread start bytes refresh = - Next len False $ Just $ fillBufFile pread start bytes refresh - -{-# INLINE mini #-} -mini :: Int -> Int64 -> Int64 -mini i n - | fromIntegral i < n = fromIntegral i - | otherwise = n diff --git a/Network/HTTP2/H2/Settings.hs b/Network/HTTP2/H2/Settings.hs --- a/Network/HTTP2/H2/Settings.hs +++ b/Network/HTTP2/H2/Settings.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - module Network.HTTP2.H2.Settings where import Network.Control @@ -27,13 +24,21 @@ -- ^ SETTINGS_MAX_HEADER_LIST_SIZE , pingRateLimit :: Int -- ^ Maximum number of pings allowed per second (CVE-2019-9512) + , emptyFrameRateLimit :: Int + -- ^ Maximum number of empty data frames allowed per second (CVE-2019-9518) + , settingsRateLimit :: Int + -- ^ Maximum number of settings frames allowed per second (CVE-2019-9515) + , rstRateLimit :: Int + -- ^ Maximum number of streams reset per second, whether by the peer's + -- RST_STREAM (CVE-2023-44487) or by ours in answer to a stream error + -- the peer caused (CVE-2025-8671) } deriving (Eq, Show) -- | The default settings. -- -- >>> baseSettings --- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10} +-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} baseSettings :: Settings baseSettings = Settings @@ -44,12 +49,15 @@ , maxFrameSize = defaultPayloadLength -- 2^14 (16,384) , maxHeaderListSize = Nothing , pingRateLimit = 10 + , emptyFrameRateLimit = 4 + , settingsRateLimit = 4 + , rstRateLimit = 4 } -- | The default settings. -- -- >>> defaultSettings --- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10} +-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} defaultSettings :: Settings defaultSettings = baseSettings @@ -62,12 +70,12 @@ -- | Updating settings. -- -- >>> fromSettingsList defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderListSize,200)] --- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 200, pingRateLimit = 10} +-- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 200, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} {- FOURMOLU_DISABLE -} fromSettingsList :: Settings -> SettingsList -> Settings fromSettingsList settings kvs = foldl' update settings kvs where - update def (SettingsHeaderTableSize,x) = def { headerTableSize = x } + update def (SettingsTokenHeaderTableSize,x) = def { headerTableSize = x } -- fixme: x should be 0 or 1 update def (SettingsEnablePush,x) = def { enablePush = x > 0 } update def (SettingsMaxConcurrentStreams,x) = def { maxConcurrentStreams = Just x } @@ -101,7 +109,7 @@ s s0 headerTableSize - SettingsHeaderTableSize + SettingsTokenHeaderTableSize id , diff s diff --git a/Network/HTTP2/H2/Status.hs b/Network/HTTP2/H2/Status.hs deleted file mode 100644 --- a/Network/HTTP2/H2/Status.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.HTTP2.H2.Status ( - getStatus, - setStatus, -) where - -import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Internal (unsafeCreate) -import Foreign.Ptr (plusPtr) -import Foreign.Storable (poke) -import qualified Network.HTTP.Types as H - -import Imports -import Network.HPACK -import Network.HPACK.Token - ----------------------------------------------------------------- - -getStatus :: HeaderTable -> Maybe H.Status -getStatus (_, vt) = getHeaderValue tokenStatus vt >>= toStatus - -setStatus :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders -setStatus st hdr = (":status", fromStatus st) : hdr - ----------------------------------------------------------------- - -fromStatus :: H.Status -> ByteString -fromStatus status = unsafeCreate 3 $ \p -> do - poke p (toW8 r2) - poke (p `plusPtr` 1) (toW8 r1) - poke (p `plusPtr` 2) (toW8 r0) - where - toW8 :: Int -> Word8 - toW8 n = 48 + fromIntegral n - s = H.statusCode status - (q0, r0) = s `divMod` 10 - (q1, r1) = q0 `divMod` 10 - r2 = q1 `mod` 10 - -toStatus :: ByteString -> Maybe H.Status -toStatus bs = case C8.readInt bs of - Nothing -> Nothing - Just (code, _) -> Just $ toEnum code diff --git a/Network/HTTP2/H2/Stream.hs b/Network/HTTP2/H2/Stream.hs --- a/Network/HTTP2/H2/Stream.hs +++ b/Network/HTTP2/H2/Stream.hs @@ -1,15 +1,15 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Stream where -import Control.Exception +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception as E import Control.Monad import Data.IORef import Data.Maybe (fromMaybe) import Network.Control -import UnliftIO.Concurrent -import UnliftIO.STM +import Network.HTTP.Semantics.IO import Network.HTTP2.Frame import Network.HTTP2.H2.StreamTable @@ -48,50 +48,60 @@ newOddStream :: StreamId -> WindowSize -> WindowSize -> IO Stream newOddStream sid txwin rxwin = Stream sid - <$> newIORef Idle + <$> newTVarIO Idle <*> newEmptyMVar <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin) + <*> newIORef Nothing + <*> newIORef Nothing newEvenStream :: StreamId -> WindowSize -> WindowSize -> IO Stream newEvenStream sid txwin rxwin = Stream sid - <$> newIORef Reserved + <$> newTVarIO Reserved <*> newEmptyMVar <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin) + <*> newIORef Nothing + <*> newIORef Nothing ---------------------------------------------------------------- {-# INLINE readStreamState #-} readStreamState :: Stream -> IO StreamState -readStreamState Stream{streamState} = readIORef streamState +readStreamState Stream{streamState} = readTVarIO streamState ---------------------------------------------------------------- closeAllStreams - :: TVar OddStreamTable -> TVar EvenStreamTable -> Maybe SomeException -> IO () -closeAllStreams ovar evar mErr' = do + :: TVar OddStreamTable -> TVar EvenStreamTable -> Maybe E.SomeException -> IO () +closeAllStreams ovar evar mErr = do ostrms <- clearOddStreamTable ovar mapM_ finalize ostrms estrms <- clearEvenStreamTable evar mapM_ finalize estrms where + -- We treat /every/ exception, including 'ConectionIsClosed', as abnormal + -- termination: we should only report a clean termination when we receive an + -- explicit @END_STREAM@ frame. finalize strm = do st <- readStreamState strm - void . tryPutMVar (streamInput strm) $ - Left $ - fromMaybe (toException ConnectionIsClosed) $ - mErr + void $ tryPutMVar (streamInput strm) err case st of Open _ (Body q _ _ _) -> - atomically $ writeTQueue q $ maybe (Right mempty) Left mErr + atomically $ writeTQueue q $ maybe (Right (mempty, True)) Left mErr _otherwise -> return () - mErr :: Maybe SomeException - mErr = case mErr' of - Just err - | Just ConnectionIsClosed <- fromException err -> - Nothing - _otherwise -> - mErr' + + err :: Either E.SomeException a + err = Left $ fromMaybe (E.toException ConnectionIsClosed) mErr + +---------------------------------------------------------------- + +nextForStreaming + :: TBQueue StreamingChunk + -> DynaNext +nextForStreaming tbq = + let takeQ = atomically $ tryReadTBQueue tbq + next = fillStreamBodyGetNext takeQ + in next diff --git a/Network/HTTP2/H2/StreamTable.hs b/Network/HTTP2/H2/StreamTable.hs --- a/Network/HTTP2/H2/StreamTable.hs +++ b/Network/HTTP2/H2/StreamTable.hs @@ -33,12 +33,11 @@ import Control.Concurrent import Control.Concurrent.STM -import Control.Exception +import qualified Control.Exception as E import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Network.Control (LRUCache) import qualified Network.Control as LRUCache -import Network.HTTP.Types (Method) import Imports import Network.HTTP2.H2.Types (Stream (..)) @@ -59,6 +58,7 @@ , -- Cache must contain Stream instead of StreamId because -- a Stream is deleted when end-of-stream is received. -- After that, cache is looked up. + -- LRUCache is not used as LRU but as fixed-size map. evenCache :: LRUCache (Method, ByteString) Stream } @@ -78,7 +78,13 @@ let oddTable' = IntMap.insert k v oddTable in OddStreamTable oddConc oddTable' -deleteOdd :: TVar OddStreamTable -> IntMap.Key -> SomeException -> IO () +-- | Remove a stream and give its concurrency slot back. +-- +-- 'closed' can be called more than once for the same stream -- a RST_STREAM +-- carrying a non-critical error code goes through both 'stream' and +-- 'processState', each of which closes it -- so the count must follow an +-- entry that was really there, not the number of calls. +deleteOdd :: TVar OddStreamTable -> IntMap.Key -> E.SomeException -> IO () deleteOdd var k err = do mv <- atomically deleteStream case mv of @@ -88,10 +94,13 @@ deleteStream :: STM (Maybe Stream) deleteStream = do OddStreamTable{..} <- readTVar var - let oddConc' = oddConc - 1 - oddTable' = IntMap.delete k oddTable - writeTVar var $ OddStreamTable oddConc' oddTable' - return $ IntMap.lookup k oddTable + case IntMap.lookup k oddTable of + Nothing -> return Nothing + Just v -> do + let oddConc' = oddConc - 1 + oddTable' = IntMap.delete k oddTable + writeTVar var $ OddStreamTable oddConc' oddTable' + return $ Just v lookupOdd :: TVar OddStreamTable -> IntMap.Key -> IO (Maybe Stream) lookupOdd var k = IntMap.lookup k . oddTable <$> readTVarIO var @@ -128,7 +137,9 @@ let evenTable' = IntMap.insert k v evenTable in EvenStreamTable evenConc evenTable' evenCache -deleteEven :: TVar EvenStreamTable -> IntMap.Key -> SomeException -> IO () +-- | Remove a stream and give its concurrency slot back. +-- Idempotent, for the same reason as 'deleteOdd'. +deleteEven :: TVar EvenStreamTable -> IntMap.Key -> E.SomeException -> IO () deleteEven var k err = do mv <- atomically deleteStream case mv of @@ -138,10 +149,13 @@ deleteStream :: STM (Maybe Stream) deleteStream = do EvenStreamTable{..} <- readTVar var - let evenConc' = evenConc - 1 - evenTable' = IntMap.delete k evenTable - writeTVar var $ EvenStreamTable evenConc' evenTable' evenCache - return $ IntMap.lookup k evenTable + case IntMap.lookup k evenTable of + Nothing -> return Nothing + Just v -> do + let evenConc' = evenConc - 1 + evenTable' = IntMap.delete k evenTable + writeTVar var $ EvenStreamTable evenConc' evenTable' evenCache + return $ Just v lookupEven :: TVar EvenStreamTable -> IntMap.Key -> IO (Maybe Stream) lookupEven var k = IntMap.lookup k . evenTable <$> readTVarIO var diff --git a/Network/HTTP2/H2/Sync.hs b/Network/HTTP2/H2/Sync.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/H2/Sync.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.HTTP2.H2.Sync ( + LoopCheck (..), + newLoopCheck, + syncWithSender, + syncWithSender', + makeOutput, + makeOutputIO, + enqueueOutputSIO, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Network.Control +import Network.HTTP.Semantics.IO +import qualified System.ThreadManager as T + +import Network.HTTP2.H2.Context +import Network.HTTP2.H2.Queue +import Network.HTTP2.H2.Types + +syncWithSender + :: Context + -> Stream + -> OutputType + -> LoopCheck + -> IO () +syncWithSender ctx@Context{..} strm otyp lc = do + (pop, out) <- makeOutput strm otyp + enqueueOutput outputQ out + syncWithSender' ctx pop lc + +makeOutput :: Stream -> OutputType -> IO (IO Sync, Output) +makeOutput strm otyp = do + var <- newEmptyMVar + let push mout = case mout of + Nothing -> putMVar var Done + Just ot -> putMVar var $ Cont ot + pop = takeMVar var + out = + Output + { outputStream = strm + , outputType = otyp + , outputSync = push + } + return (pop, out) + +-- | An output for the 'runIO' interfaces, which have no thread waiting to +-- put the rest of a body back on the queue. +-- +-- The rest used to go back at once, whatever the stream's window. With +-- none left, the sender filled a DATA frame into no room; a file read into +-- no room reads 0 octets, which is the end of the file, so a body larger than +-- the window went out cut short with END_STREAM. A streaming body with +-- nothing queued made the sender spin instead. So the rest goes back once +-- it can go on, the way 'syncWithSender'' does it for the other interfaces; +-- only when it has to wait is a thread used for it. +makeOutputIO + :: Context -> Stream -> Maybe (TBQueue StreamingChunk) -> OutputType -> Output +makeOutputIO Context{..} strm mtbq otyp = out + where + push mout = case mout of + Nothing -> return () + Just ot -> do + now <- atomically $ (Just <$> ready) `orElse` return Nothing + case now of + Just True -> enqueueOutput outputQ ot + Just False -> return () + Nothing -> + T.forkManaged threadManager "H2 output waiting for its window" $ do + ok <- atomically ready + when ok $ enqueueOutput outputQ ot + ready = readyToContinue strm mtbq + out = + Output + { outputStream = strm + , outputType = otyp + , outputSync = push + } + +-- | Whether the rest of a stream's body can go on: waiting while the +-- stream's window is shut or a streaming body has nothing queued, and 'False' +-- once the stream is closed. +readyToContinue :: Stream -> Maybe (TBQueue StreamingChunk) -> STM Bool +readyToContinue Stream{streamState, streamTxFlow} mtbq = do + state <- readTVar streamState + case state of + Closed{} -> return False + _ -> do + waitStreaming' mtbq + waitStreamWindowSizeSTM streamTxFlow + return True + +enqueueOutputSIO :: Context -> Stream -> OutputType -> IO () +enqueueOutputSIO ctx@Context{..} strm otyp = do + let out = makeOutputIO ctx strm Nothing otyp + enqueueOutput outputQ out + +syncWithSender' :: Context -> IO Sync -> LoopCheck -> IO () +syncWithSender' Context{..} pop lc = loop + where + loop = do + s <- pop + case s of + Done -> return () + Cont newout -> do + cont <- checkLoop lc + when cont $ do + enqueueOutput outputQ newout + loop + +newLoopCheck :: Stream -> Maybe (TBQueue StreamingChunk) -> IO LoopCheck +newLoopCheck strm mtbq = do + tovar <- newTVarIO False + return $ + LoopCheck + { lcState = streamState strm + , lcTBQ = mtbq + , lcTimeout = tovar + , lcWindow = streamTxFlow strm + } + +data LoopCheck = LoopCheck + { lcState :: TVar StreamState + , lcTBQ :: Maybe (TBQueue StreamingChunk) + , lcTimeout :: TVar Bool + , lcWindow :: TVar TxFlow + } + +checkLoop :: LoopCheck -> IO Bool +checkLoop LoopCheck{..} = atomically $ do + tout <- readTVar lcTimeout + state <- readTVar lcState + if + | tout -> return False + | Closed{} <- state -> return False + | otherwise -> do + waitStreaming' lcTBQ + waitStreamWindowSizeSTM lcWindow + return True + +waitStreaming' :: Maybe (TBQueue a) -> STM () +waitStreaming' Nothing = return () +waitStreaming' (Just tbq) = do + isEmpty <- isEmptyTBQueue tbq + check (not isEmpty) + +waitStreamWindowSizeSTM :: TVar TxFlow -> STM () +waitStreamWindowSizeSTM txf = do + w <- txWindowSize <$> readTVar txf + check (w > 0) diff --git a/Network/HTTP2/H2/Types.hs b/Network/HTTP2/H2/Types.hs --- a/Network/HTTP2/H2/Types.hs +++ b/Network/HTTP2/H2/Types.hs @@ -1,138 +1,28 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Types where +import Control.Concurrent +import Control.Concurrent.STM import qualified Control.Exception as E -import Data.ByteString.Builder (Builder) import Data.IORef -import Data.Typeable +import Foreign.Ptr (nullPtr) import Network.Control -import qualified Network.HTTP.Types as H +import Network.HTTP.Semantics.Client +import Network.HTTP.Semantics.IO import Network.Socket hiding (Stream) import System.IO.Unsafe import qualified System.TimeManager as T -import UnliftIO.Concurrent -import UnliftIO.Exception (SomeException) -import UnliftIO.STM import Imports import Network.HPACK import Network.HTTP2.Frame -import Network.HTTP2.H2.File ---------------------------------------------------------------- --- | "http" or "https". -type Scheme = ByteString - --- | Authority. -type Authority = String - --- | Path. -type Path = ByteString - ----------------------------------------------------------------- - -type InpBody = IO ByteString - -data OutBody - = OutBodyNone - | -- | Streaming body takes a write action and a flush action. - OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ()) - | -- | Like 'OutBodyStreaming', but with a callback to unmask expections - -- - -- This is used in the client: we spawn the new thread for the request body - -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask' - -- with a callback to unmask them again (typically after installing an exception - -- handler). - -- - -- We do /NOT/ support this in the server, as here the scope of the thread - -- that is spawned for the server is the entire handler, not just the response - -- streaming body. - -- - -- TODO: The analogous change for the server-side would be to provide a similar - -- @unmask@ callback as the first argument in the 'Server' type alias. - OutBodyStreamingUnmask - ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) - | OutBodyBuilder Builder - | OutBodyFile FileSpec - --- | Input object -data InpObj = InpObj - { inpObjHeaders :: HeaderTable - -- ^ Accessor for headers. - , inpObjBodySize :: Maybe Int - -- ^ Accessor for body length specified in content-length:. - , inpObjBody :: InpBody - -- ^ Accessor for body. - , inpObjTrailers :: IORef (Maybe HeaderTable) - -- ^ Accessor for trailers. - } - -instance Show InpObj where - show (InpObj (thl, _) _ _body _tref) = show thl - --- | Output object -data OutObj = OutObj - { outObjHeaders :: [H.Header] - -- ^ Accessor for header. - , outObjBody :: OutBody - -- ^ Accessor for outObj body. - , outObjTrailers :: TrailersMaker - -- ^ Accessor for trailers maker. - } - -instance Show OutObj where - show (OutObj hdr _ _) = show hdr - --- | Trailers maker. A chunks of the response body is passed --- with 'Just'. The maker should update internal state --- with the 'ByteString' and return the next trailers maker. --- When response body reaches its end, --- 'Nothing' is passed and the maker should generate --- trailers. An example: --- --- > {-# LANGUAGE BangPatterns #-} --- > import Data.ByteString (ByteString) --- > import qualified Data.ByteString.Char8 as C8 --- > import Crypto.Hash (Context, SHA1) -- cryptonite --- > import qualified Crypto.Hash as CH --- > --- > -- Strictness is important for Context. --- > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker --- > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] --- > where --- > !sha1 = C8.pack $ show $ CH.hashFinalize ctx --- > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' --- > where --- > !ctx' = CH.hashUpdate ctx bs --- --- Usage example: --- --- > let h2rsp = responseFile ... --- > maker = trailersMaker (CH.hashInit :: Context SHA1) --- > h2rsp' = setResponseTrailersMaker h2rsp maker -type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker - --- | TrailersMake to create no trailers. -defaultTrailersMaker :: TrailersMaker -defaultTrailersMaker Nothing = return $ Trailers [] -defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker - --- | Either the next trailers maker or final trailers. -data NextTrailersMaker - = NextTrailersMaker TrailersMaker - | Trailers [H.Header] - ----------------------------------------------------------------- - --- | File specification. -data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show) - ----------------------------------------------------------------- - {- == Stream state @@ -155,30 +45,15 @@ is labelled with the relevant case in either the function 'stream' or the function 'processState'. -> [Open JustOpened] -> | -> | -> HEADERS -> | -> | (stream1) -> | -> END_HEADERS? -> | -> ______/ \______ -> / yes no \ -> | | -> | [Open Continued] <--\ -> | | | -> | CONTINUATION | -> | | | -> | | (stream5) | -> | | | -> | END_HEADERS? | -> | | | -> v yes / \ no | -> END_STREAM? <-------/ \-----------/ -> | (process3) +> [Open JustOpened] > | +> | +> HEADERS CONTINUATION* +> | +> | (stream1) +> | +> END_STREAM? +> | > _________/ \_________ > / yes no \ > | | @@ -190,7 +65,7 @@ > | | | | > | | +---------------\ | > RST_STREAM | | | | -> | | HEADERS DATA | +> | | HEADERS CONT* DATA | > | (stream6) | | | | > | | | (stream2) | (stream4) | > | (process5) | | | | @@ -211,33 +86,42 @@ data OpenState = JustOpened - | Continued - [HeaderBlockFragment] - Int -- Total size - Int -- The number of continuation frames - Bool -- End of stream - | NoBody HeaderTable - | HasBody HeaderTable + | NoBody TokenHeaderTable + | HasBody TokenHeaderTable | Body - (TQueue (Either SomeException ByteString)) + (TQueue (Either E.SomeException (ByteString, Bool))) (Maybe Int) -- received Content-Length -- compared the body length for error checking (IORef Int) -- actual body length - (IORef (Maybe HeaderTable)) -- trailers + (IORef (Maybe TokenHeaderTable)) -- trailers +-- | Header block fragments accumulated so far. +-- +-- Fragments are stored in reverse order (newest first). +data PartialHeaderBlock = PartialHeaderBlock + { phbFragments :: [HeaderBlockFragment] + , phbTotalSize :: Int + , phbNumFrames :: Int + } + data ClosedCode = Finished | Killed | Reset ErrorCode - | ResetByMe SomeException + | ResetByMe E.SomeException deriving (Show) +-- | Used for streams which are cancelled by calling +-- 'Network.HTTP.Semantics.outBodyCancel'. +data CancelledStream = CancelledStream + deriving (Show, E.Exception) + closedCodeToError :: StreamId -> ClosedCode -> HTTP2Error closedCodeToError sid cc = case cc of Finished -> ConnectionIsClosed Killed -> ConnectionIsTimeout - Reset err -> ConnectionErrorIsReceived err sid "Connection was reset" + Reset err -> StreamResetIsReceived err sid ResetByMe err -> BadThingHappen err ---------------------------------------------------------------- @@ -259,12 +143,18 @@ ---------------------------------------------------------------- +type RxQ = TQueue (Either E.SomeException (ByteString, Bool)) + data Stream = Stream { streamNumber :: StreamId - , streamState :: IORef StreamState - , streamInput :: MVar (Either SomeException InpObj) -- Client only + , streamState :: TVar StreamState + , streamInput :: MVar (Either E.SomeException InpObj) -- Client only , streamTxFlow :: TVar TxFlow , streamRxFlow :: IORef RxFlow + , streamRxQ :: IORef (Maybe RxQ) + , streamRequestMethod :: IORef (Maybe ByteString) + -- ^ Client only: the method of the request, which decides whether the + -- response may have content at all (RFC 9110, section 6.4.1) } instance Show Stream where @@ -272,60 +162,41 @@ "Stream{id=" ++ show streamNumber ++ ",state=" - ++ show (unsafePerformIO (readIORef streamState)) + ++ show (unsafePerformIO (readTVarIO streamState)) ++ "}" ---------------------------------------------------------------- -data Input a = Input a InpObj - -data Output a = Output - { outputStream :: a - , outputObject :: OutObj +data Output = Output + { outputStream :: Stream , outputType :: OutputType - , outputStrmQ :: Maybe (TBQueue StreamingChunk) - , outputSentinel :: IO () + , outputSync :: Maybe Output -> IO () } data OutputType - = OObj - | OWait (IO ()) + = OHeader [Header] (Maybe DynaNext) TrailersMaker | OPush TokenHeaderList StreamId -- associated stream id from client | ONext DynaNext TrailersMaker - ----------------------------------------------------------------- - -type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next - -type BytesFilled = Int - -data Next - = Next - BytesFilled -- payload length - Bool -- require flushing - (Maybe DynaNext) - ----------------------------------------------------------------- + | OInformational [Header] + | OReset (Maybe E.SomeException) -data Control - = CFinish HTTP2Error - | CFrames (Maybe SettingsList) [ByteString] - | CGoaway ByteString (MVar ()) +data Sync = Done | Cont Output ---------------------------------------------------------------- -data StreamingChunk - = StreamingFinished (IO ()) - | StreamingFlush - | StreamingBuilder Builder +data Control = CFrames (Maybe SettingsList) [ByteString] ---------------------------------------------------------------- type ReasonPhrase = ShortByteString -- | The connection error or the stream error. --- Stream errors are treated as connection errors since --- there are no good recovery ways. +-- A stream error resets that stream and the connection carries on, as +-- RFC 9113 section 5.4.2 asks. One kind of trouble is a connection error +-- even though the spec calls it a stream error, because this +-- implementation cannot carry on through it: a field block abandoned +-- part-way leaves the HPACK tables disagreeing with the peer's, and +-- nothing sent afterwards would decode. -- `ErrorCode` in connection errors should be the highest stream identifier -- but in this implementation it identifies the stream that -- caused this error. @@ -335,10 +206,10 @@ | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase | ConnectionErrorIsSent ErrorCode StreamId ReasonPhrase | StreamErrorIsReceived ErrorCode StreamId + | StreamResetIsReceived ErrorCode StreamId | StreamErrorIsSent ErrorCode StreamId ReasonPhrase | BadThingHappen E.SomeException - | GoAwayIsSent - deriving (Show, Typeable) + deriving (Show) instance E.Exception HTTP2Error @@ -393,4 +264,34 @@ -- ^ This is copied into 'Aux', if exist, on server. , confPeerSockAddr :: SockAddr -- ^ This is copied into 'Aux', if exist, on server. + , confReadNTimeout :: Bool + , confOnInformational :: StreamId -> TokenHeaderTable -> IO () + -- ^ Client only: called when a 1xx informational response (e.g. 103 Early + -- Hints) is received on the given stream, ahead of the final response. + -- No-op by default. + -- + -- @since 5.4.2 } + +-- | Default config. This is just a template to modify via +-- field names. Don't use this without modifications. +defaultConfig :: Config +defaultConfig = + Config + { confWriteBuffer = nullPtr + , confBufferSize = 0 + , confSendAll = \_ -> return () + , confReadN = \_ -> return "" + , confPositionReadMaker = defaultPositionReadMaker + , confTimeoutManager = T.defaultManager + , confMySockAddr = SockAddrInet 0 0 + , confPeerSockAddr = SockAddrInet 0 0 + , confReadNTimeout = False + , confOnInformational = \_ _ -> return () + } + +isAsyncException :: E.Exception e => e -> Bool +isAsyncException e = + case E.fromException (E.toException e) of + Just (E.SomeAsyncException _) -> True + Nothing -> False diff --git a/Network/HTTP2/H2/Window.hs b/Network/HTTP2/H2/Window.hs --- a/Network/HTTP2/H2/Window.hs +++ b/Network/HTTP2/H2/Window.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Network.HTTP2.H2.Window where +import Control.Concurrent.STM +import qualified Control.Exception as E +import qualified Data.ByteString as BS import Data.IORef import Network.Control -import qualified UnliftIO.Exception as E -import UnliftIO.STM import Imports import Network.HTTP2.Frame @@ -26,12 +28,15 @@ waitStreamWindowSize :: Stream -> IO () waitStreamWindowSize Stream{streamTxFlow} = atomically $ do w <- txWindowSize <$> readTVar streamTxFlow - checkSTM (w > 0) + check (w > 0) +connectionWindowSizeSTM :: Context -> STM WindowSize +connectionWindowSizeSTM Context{txFlow} = txWindowSize <$> readTVar txFlow + waitConnectionWindowSize :: Context -> STM () waitConnectionWindowSize Context{txFlow} = do w <- txWindowSize <$> readTVar txFlow - checkSTM (w > 0) + check (w > 0) ---------------------------------------------------------------- -- Receiving window update @@ -66,16 +71,92 @@ ---------------------------------------------------------------- -- Sending window update +-- | Whether a stream's DATA is given back to the connection window as it +-- arrives, rather than as it is read. +-- +-- So it is for pushes, the only streams of the server's we receive on. A +-- push is read only if a request for it comes along, and maybe never: held +-- against the connection window until then, pushes that nobody asked for +-- used it up, and the connection stalled, responses to requests and all. +-- Their stream windows still hold back what each can send unread. +connectionCreditedOnArrival :: StreamId -> Bool +connectionCreditedOnArrival = isServerInitiated + informWindowUpdate :: Context -> Stream -> Int -> IO () informWindowUpdate _ _ 0 = return () -informWindowUpdate Context{controlQ, rxFlow} Stream{streamNumber, streamRxFlow} len = do - mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate - forM_ mxc $ \ws -> do - let frame = windowUpdateFrame 0 ws - cframe = CFrames Nothing [frame] - enqueueControl controlQ cframe +informWindowUpdate ctx@Context{controlQ} Stream{streamNumber, streamRxFlow} len = do + unless (connectionCreditedOnArrival streamNumber) $ + giveBackConnectionWindow ctx len mxs <- atomicModifyIORef streamRxFlow $ maybeOpenRxWindow len FCTWindowUpdate forM_ mxs $ \ws -> do let frame = windowUpdateFrame streamNumber ws cframe = CFrames Nothing [frame] enqueueControl controlQ cframe + +-- | Account for a DATA frame that is being dropped. +-- +-- Its stream is gone -- reset, or closed and forgotten -- so there is no +-- stream window to adjust. The peer charged these octets against the +-- connection window before sending them, though, and if we say nothing its +-- view of that window shrinks for good; enough dropped frames and the +-- connection stalls with both sides believing the other is at fault. So +-- charge them and give them straight back. +informIgnoredData :: Context -> StreamId -> Int -> IO () +informIgnoredData _ _ 0 = return () +informIgnoredData ctx@Context{rxFlow} sid len = do + ok <- atomicModifyIORef' rxFlow $ checkRxLimit len + unless ok $ + E.throwIO $ + ConnectionErrorIsSent + EnhanceYourCalm + sid + "exceeds connection flow-control limit" + giveBackConnectionWindow ctx len + +-- | Give octets already charged to the connection window back to it, and to +-- it alone: for a stream that is closed, whose own window no longer +-- matters. +giveBackConnectionWindow :: Context -> Int -> IO () +giveBackConnectionWindow _ 0 = return () +giveBackConnectionWindow Context{controlQ, rxFlow} len = do + mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate + forM_ mxc $ \ws -> + enqueueControl controlQ $ CFrames Nothing [windowUpdateFrame 0 ws] + +-- This must be called after an application is finished +-- to adjust RX window. +adjustRxWindow :: Context -> Stream -> IO () +adjustRxWindow ctx stream = do + len <- takeUnread stream + informWindowUpdate ctx stream len + +-- | Like 'adjustRxWindow', for a stream that has been closed: what was +-- left unread goes back to the connection window only. +-- +-- Closed first, so that nothing is queued after this has looked: the +-- receiver does not queue DATA for a closed stream ('stream'), but gives +-- it back to the connection window itself. +giveBackUnread :: Context -> Stream -> IO () +giveBackUnread ctx stream = do + len <- takeUnread stream + unless (connectionCreditedOnArrival $ streamNumber stream) $ + giveBackConnectionWindow ctx len + +-- | Take what is left unread in a stream's queue, and say how many octets +-- of body it was. +takeUnread :: Stream -> IO Int +takeUnread Stream{streamRxQ} = do + mq <- readIORef streamRxQ + case mq of + Nothing -> return 0 + Just q -> atomically $ loop q 0 + where + loop q !total = do + meb <- tryReadTQueue q + case meb of + Just (Right (bs, _)) -> loop q (total + BS.length bs) + Just le@(Left _) -> do + -- reserving HTTP2Error + writeTQueue q le + return total + _ -> return total diff --git a/Network/HTTP2/Internal.hs b/Network/HTTP2/Internal.hs deleted file mode 100644 --- a/Network/HTTP2/Internal.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Network.HTTP2.Internal ( - -- * File - module Network.HTTP2.H2.File, - - -- * Types - Scheme, - Authority, - Path, - - -- * Request and response - InpObj (..), - InpBody, - OutObj (..), - OutBody (..), - FileSpec (..), - - -- * Sender - Next (..), - BytesFilled, - DynaNext, - StreamingChunk (..), - fillBuilderBodyGetNext, - fillFileBodyGetNext, - fillStreamBodyGetNext, - - -- * Trailer - TrailersMaker, - defaultTrailersMaker, - NextTrailersMaker (..), - runTrailersMaker, - - -- * Thread Manager - module Network.HTTP2.H2.Manager, -) where - -import Network.HTTP2.H2.File -import Network.HTTP2.H2.Manager -import Network.HTTP2.H2.Sender -import Network.HTTP2.H2.Types diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | HTTP\/2 server library. -- -- Example: @@ -46,181 +44,36 @@ maxFrameSize, maxHeaderListSize, + -- ** Rate limits + pingRateLimit, + settingsRateLimit, + emptyFrameRateLimit, + rstRateLimit, + -- * Common configuration - Config (..), + Config, + defaultConfig, + confWriteBuffer, + confBufferSize, + confSendAll, + confReadN, + confPositionReadMaker, + confTimeoutManager, + confMySockAddr, + confPeerSockAddr, + confReadNTimeout, + confOnInformational, allocSimpleConfig, + allocSimpleConfig', freeSimpleConfig, - - -- * HTTP\/2 server - Server, - - -- * Request - Request, - - -- ** Accessing request - requestMethod, - requestPath, - requestAuthority, - requestScheme, - requestHeaders, - requestBodySize, - getRequestBodyChunk, - getRequestTrailers, - - -- * Aux - Aux, - auxTimeHandle, - auxMySockAddr, - auxPeerSockAddr, - - -- * Response - Response, - - -- ** Creating response - responseNoBody, - responseFile, - responseStreaming, - responseBuilder, - - -- ** Accessing response - responseBodySize, - - -- ** Trailers maker - TrailersMaker, - NextTrailersMaker (..), - defaultTrailersMaker, - setResponseTrailersMaker, - - -- * Push promise - PushPromise, - pushPromise, - promiseRequestPath, - promiseResponse, - - -- * Types - Path, - Authority, - Scheme, - FileSpec (..), - FileOffset, - ByteCount, - - -- * RecvN - defaultReadN, - - -- * Position read for files - PositionReadMaker, - PositionRead, - Sentinel (..), - defaultPositionReadMaker, + module Network.HTTP.Semantics.Server, ) where -import Data.ByteString.Builder (Builder) -import Data.IORef (readIORef) -import qualified Network.HTTP.Types as H -import qualified Data.ByteString.UTF8 as UTF8 +import Network.HTTP.Semantics.Server -import Imports -import Network.HPACK -import Network.HPACK.Token -import Network.HTTP2.Frame.Types import Network.HTTP2.H2 import Network.HTTP2.Server.Run ( ServerConfig (..), defaultServerConfig, run, ) -import Network.HTTP2.Server.Types - ----------------------------------------------------------------- - --- | Getting the method from a request. -requestMethod :: Request -> Maybe H.Method -requestMethod (Request req) = getHeaderValue tokenMethod vt - where - (_, vt) = inpObjHeaders req - --- | Getting the path from a request. -requestPath :: Request -> Maybe Path -requestPath (Request req) = getHeaderValue tokenPath vt - where - (_, vt) = inpObjHeaders req - --- | Getting the authority from a request. -requestAuthority :: Request -> Maybe Authority -requestAuthority (Request req) = UTF8.toString <$> getHeaderValue tokenAuthority vt - where - (_, vt) = inpObjHeaders req - --- | Getting the scheme from a request. -requestScheme :: Request -> Maybe Scheme -requestScheme (Request req) = getHeaderValue tokenScheme vt - where - (_, vt) = inpObjHeaders req - --- | Getting the headers from a request. -requestHeaders :: Request -> HeaderTable -requestHeaders (Request req) = inpObjHeaders req - --- | Getting the body size from a request. -requestBodySize :: Request -> Maybe Int -requestBodySize (Request req) = inpObjBodySize req - --- | Reading a chunk of the request body. --- An empty 'ByteString' returned when finished. -getRequestBodyChunk :: Request -> IO ByteString -getRequestBodyChunk (Request req) = inpObjBody req - --- | Reading request trailers. --- This function must be called after 'getRequestBodyChunk' --- returns an empty. -getRequestTrailers :: Request -> IO (Maybe HeaderTable) -getRequestTrailers (Request req) = readIORef (inpObjTrailers req) - ----------------------------------------------------------------- - --- | Creating response without body. -responseNoBody :: H.Status -> H.ResponseHeaders -> Response -responseNoBody st hdr = Response $ OutObj hdr' OutBodyNone defaultTrailersMaker - where - hdr' = setStatus st hdr - --- | Creating response with file. -responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response -responseFile st hdr fileSpec = Response $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker - where - hdr' = setStatus st hdr - --- | Creating response with builder. -responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response -responseBuilder st hdr builder = Response $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker - where - hdr' = setStatus st hdr - --- | Creating response with streaming. -responseStreaming - :: H.Status - -> H.ResponseHeaders - -> ((Builder -> IO ()) -> IO () -> IO ()) - -> Response -responseStreaming st hdr strmbdy = Response $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker - where - hdr' = setStatus st hdr - ----------------------------------------------------------------- - --- | Getter for response body size. This value is available for file body. -responseBodySize :: Response -> Maybe Int -responseBodySize (Response (OutObj _ (OutBodyFile (FileSpec _ _ len)) _)) = Just (fromIntegral len) -responseBodySize _ = Nothing - --- | Setting 'TrailersMaker' to 'Response'. -setResponseTrailersMaker :: Response -> TrailersMaker -> Response -setResponseTrailersMaker (Response rsp) tm = Response rsp{outObjTrailers = tm} - ----------------------------------------------------------------- - --- | Creating push promise. --- The third argument is traditional, not used. -pushPromise :: ByteString -> Response -> Weight -> PushPromise -pushPromise path rsp _ = PushPromise path rsp diff --git a/Network/HTTP2/Server/Internal.hs b/Network/HTTP2/Server/Internal.hs --- a/Network/HTTP2/Server/Internal.hs +++ b/Network/HTTP2/Server/Internal.hs @@ -1,6 +1,8 @@ module Network.HTTP2.Server.Internal ( Request (..), Response (..), + Config (..), + ServerConfig (..), Aux (..), -- * Low level @@ -9,6 +11,8 @@ runIO, ) where +import Network.HTTP.Semantics.Server +import Network.HTTP.Semantics.Server.Internal + import Network.HTTP2.H2 import Network.HTTP2.Server.Run -import Network.HTTP2.Server.Types diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -1,25 +1,26 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Server.Run where +import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Exception import Imports import Network.Control (defaultMaxData) +import Network.HTTP.Semantics.IO +import Network.HTTP.Semantics.Server +import Network.HTTP.Semantics.Server.Internal import Network.Socket (SockAddr) -import UnliftIO.Async (concurrently_) +import qualified System.ThreadManager as T import Network.HTTP2.Frame import Network.HTTP2.H2 -import Network.HTTP2.Server.Types import Network.HTTP2.Server.Worker -- | Server configuration data ServerConfig = ServerConfig { numberOfWorkers :: Int - -- ^ The number of workers + -- ^ Deprecated field. , connectionWindowSize :: WindowSize -- ^ The window size of incoming streams , settings :: Settings @@ -27,10 +28,12 @@ } deriving (Eq, Show) +{-# DEPRECATED numberOfWorkers "No effect anymore" #-} + -- | The default server config. -- -- >>> defaultServerConfig --- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}} +-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig @@ -43,23 +46,23 @@ -- | Running HTTP/2 server. run :: ServerConfig -> Config -> Server -> IO () -run sconf@ServerConfig{numberOfWorkers} conf server = do +run sconf conf server = do ok <- checkPreface conf when ok $ do - (ctx, mgr) <- setup sconf conf - let wc = fromContext ctx - setAction mgr $ worker wc mgr server - replicateM_ numberOfWorkers $ spawnAction mgr - runH2 conf ctx mgr + let lnch = runServer conf server + ctx <- setup sconf conf lnch Nothing + runH2 conf ctx ---------------------------------------------------------------- -data ServerIO = ServerIO +data ServerIO a = ServerIO { sioMySockAddr :: SockAddr , sioPeerSockAddr :: SockAddr - , sioReadRequest :: IO (StreamId, Stream, Request) - , sioWriteResponse :: Stream -> Response -> IO () - , sioWriteBytes :: ByteString -> IO () + , sioReadRequest :: IO (a, Request) + , sioWriteResponse :: a -> Response -> IO () + -- ^ 'Response' MUST be created with 'responseBuilder'. + -- Others are not supported. + , sioDone :: IO () } -- | Launching a receiver and a sender without workers. @@ -67,22 +70,35 @@ runIO :: ServerConfig -> Config - -> (ServerIO -> IO (IO ())) + -> (ServerIO Stream -> IO (IO ())) -> IO () runIO sconf conf@Config{..} action = do ok <- checkPreface conf when ok $ do - (ctx@Context{..}, mgr) <- setup sconf conf - let ServerInfo{..} = toServerInfo roleInfo - get = do - Input strm inObj <- atomically $ readTQueue inputQ - return (streamNumber strm, strm, Request inObj) - putR strm (Response outObj) = do - let out = Output strm outObj OObj Nothing (return ()) - enqueueOutput outputQ out - putB bs = enqueueControl controlQ $ CFrames Nothing [bs] - io <- action $ ServerIO confMySockAddr confPeerSockAddr get putR putB - concurrently_ io $ runH2 conf ctx mgr + inpQ <- newTQueueIO + let lnch _ strm inpObj = atomically $ writeTQueue inpQ (strm, inpObj) + done <- newTVarIO False + ctx <- setup sconf conf lnch $ Just $ readTVar done + let get = do + (strm, inpObj) <- atomically $ readTQueue inpQ + return (strm, Request inpObj) + putR strm (Response OutObj{..}) = do + case outObjBody of + OutBodyBuilder builder -> do + let next = fillBuilderBodyGetNext builder + otyp = OHeader outObjHeaders (Just next) outObjTrailers + enqueueOutputSIO ctx strm otyp + _ -> error "Response other than OutBodyBuilder is not supported" + serverIO = + ServerIO + { sioMySockAddr = confMySockAddr + , sioPeerSockAddr = confPeerSockAddr + , sioReadRequest = get + , sioWriteResponse = putR + , sioDone = atomically $ writeTVar done True + } + io <- action serverIO + concurrently_ io $ runH2 conf ctx checkPreface :: Config -> IO Bool checkPreface conf@Config{..} = do @@ -93,33 +109,41 @@ return False else return True -setup :: ServerConfig -> Config -> IO (Context, Manager) -setup ServerConfig{..} conf@Config{..} = do - serverInfo <- newServerInfo - ctx <- - newContext - serverInfo - conf - 0 - connectionWindowSize - settings - -- Workers, worker manager and timer manager - mgr <- start confTimeoutManager - return (ctx, mgr) +setup :: ServerConfig -> Config -> Launch -> Maybe (STM Bool) -> IO Context +setup ServerConfig{..} conf@Config{..} lnch mIsDone = do + let serverInfo = newServerInfo lnch + newContext + serverInfo + conf + 0 + connectionWindowSize + settings + confTimeoutManager + mIsDone -runH2 :: Config -> Context -> Manager -> IO () -runH2 conf ctx mgr = do - let runReceiver = frameReceiver ctx conf - runSender = frameSender ctx conf mgr - runBackgroundThreads = concurrently_ runReceiver runSender - stopAfter mgr runBackgroundThreads $ \res -> do - closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $ - either Just (const Nothing) res - case res of - Left err -> - throwIO err - Right x -> - return x +runH2 :: Config -> Context -> IO () +runH2 conf ctx = do + let mgr = threadManager ctx + runReceiver = frameReceiver ctx conf + runSender = frameSender ctx conf + runBackgroundThreads = + withAsync runReceiver $ \ar -> + withAsync runSender $ \as -> do + r <- waitEither ar as + e <- case r of + -- The receiver is done; the sender finishes once it + -- has flushed what is queued. + Left _ -> wait as + -- The sender finished first. Either the receiver is + -- done too and not yet seen to be, and this is its + -- error, or the sender failed: nothing more would go + -- out, and leaving the receiver to run on left the + -- connection open and silent, with no GOAWAY. Both + -- are closed with it. + Right e -> return e + closureServer conf ctx e + T.stopAfter mgr runBackgroundThreads $ \res -> + closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res -- connClose must not be called here since Run:fork calls it goaway :: Config -> ErrorCode -> ByteString -> IO () diff --git a/Network/HTTP2/Server/Types.hs b/Network/HTTP2/Server/Types.hs deleted file mode 100644 --- a/Network/HTTP2/Server/Types.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Network.HTTP2.Server.Types where - -import Network.Socket (SockAddr) -import qualified System.TimeManager as T - -import Imports -import Network.HTTP2.H2 - ----------------------------------------------------------------- - --- | Server type. Server takes a HTTP request, should --- generate a HTTP response and push promises, then --- should give them to the sending function. --- The sending function would throw exceptions so that --- they can be logged. -type Server = Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO () - --- | Request from client. -newtype Request = Request InpObj deriving (Show) - --- | Response from server. -newtype Response = Response OutObj deriving (Show) - --- | HTTP/2 push promise or sever push. --- Pseudo REQUEST headers in push promise is automatically generated. --- Then, a server push is sent according to 'promiseResponse'. -data PushPromise = PushPromise - { promiseRequestPath :: ByteString - -- ^ Accessor for a URL path in a push promise (a virtual request from a server). - -- E.g. \"\/style\/default.css\". - , promiseResponse :: Response - -- ^ Accessor for response actually pushed from a server. - } - --- | Additional information. -data Aux = Aux - { auxTimeHandle :: T.Handle - -- ^ Time handle for the worker processing this request and response. - , auxMySockAddr :: SockAddr - -- ^ Local socket address copied from 'Config'. - , auxPeerSockAddr :: SockAddr - -- ^ Remove socket address copied from 'Config'. - } diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -1,249 +1,239 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Server.Worker ( - worker, - WorkerConf (..), - fromContext, + runServer, ) where +import Control.Concurrent.STM +import qualified Control.Exception as E import Data.IORef -import qualified Network.HTTP.Types as H -import Network.Socket (SockAddr) -import qualified System.TimeManager as T -import UnliftIO.Exception (SomeException (..)) -import qualified UnliftIO.Exception as E -import UnliftIO.STM +import Network.HTTP.Semantics +import Network.HTTP.Semantics.IO +import Network.HTTP.Semantics.Server +import Network.HTTP.Semantics.Server.Internal +import Network.HTTP.Types +import qualified System.ThreadManager as T import Imports hiding (insert) -import Network.HPACK -import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2 -import Network.HTTP2.Server.Types +import Network.HTTP2.H2.OutBodyIface +#if MIN_VERSION_http_semantics(0,4,1) +import qualified Data.ByteString.Char8 as C8 +#endif + ---------------------------------------------------------------- -data WorkerConf a = WorkerConf - { readInputQ :: IO (Input a) - , writeOutputQ :: Output a -> IO () - , workerCleanup :: a -> IO () - , isPushable :: IO Bool - , makePushStream :: a -> PushPromise -> IO (StreamId, a) - , mySockAddr :: SockAddr - , peerSockAddr :: SockAddr - } +runServer :: Config -> Server -> Launch +runServer conf server ctx@Context{..} strm req = + T.forkManagedTimeout threadManager label $ \th -> do + let req' = pauseRequestBody th + aux = + defaultAux + { auxTimeHandle = th + , auxMySockAddr = mySockAddr + , auxPeerSockAddr = peerSockAddr +#if MIN_VERSION_http_semantics(0,4,1) + , auxSendInformational = sendInformational ctx strm +#endif + } + request = Request req' + lc <- newLoopCheck strm Nothing + server request aux $ sendResponse conf ctx lc strm request + adjustRxWindow ctx strm + where + label = "H2 response sender for stream " ++ show (streamNumber strm) + pauseRequestBody th = req{inpObjBody = readBody'} + where + readBody = inpObjBody req + readBody' = do + T.pause th + bs <- readBody + T.resume th -- this is the same as 'tickle' + return bs -fromContext :: Context -> WorkerConf Stream -fromContext ctx@Context{..} = - WorkerConf - { readInputQ = atomically $ readTQueue $ inputQ $ toServerInfo roleInfo - , writeOutputQ = enqueueOutput outputQ - , workerCleanup = \strm -> do - closed ctx strm Killed - let frame = resetFrame InternalError $ streamNumber strm - enqueueControl controlQ $ CFrames Nothing [frame] - , -- Peer SETTINGS_ENABLE_PUSH - isPushable = enablePush <$> readIORef peerSettings - , -- Peer SETTINGS_INITIAL_WINDOW_SIZE - makePushStream = \pstrm _ -> do - -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit - (_, newstrm) <- openEvenStreamWait ctx - let pid = streamNumber pstrm - return (pid, newstrm) - , mySockAddr = mySockAddr - , peerSockAddr = peerSockAddr - } +---------------------------------------------------------------- +#if MIN_VERSION_http_semantics(0,4,1) +-- | Send an informational (1xx) response, e.g. 103 Early Hints, on the given +-- stream ahead of the final response. This is wired into 'auxSendInformational' +-- so that a server (or WAI handler via Warp) can emit early hints. It blocks +-- until the informational HEADERS have been handed to the sender, preserving +-- ordering with respect to the final response. +sendInformational :: Context -> Stream -> Status -> ResponseHeaders -> IO () +sendInformational ctx strm st hdrs = do + lc <- newLoopCheck strm Nothing + let hdr = (":status", C8.pack (show (statusCode st))) : hdrs + syncWithSender ctx strm (OInformational hdr) lc +#endif + ---------------------------------------------------------------- +-- | This function is passed to workers. +-- They also pass 'Response's from a server to this function. +-- This function enqueues commands for the HTTP/2 sender. +sendResponse + :: Config + -> Context + -> LoopCheck + -> Stream + -> Request + -> Response + -> [PushPromise] + -> IO () +sendResponse conf ctx lc strm (Request req) (Response rsp) pps = do + mwait <- pushStream conf ctx strm reqvt pps + case mwait of + Nothing -> return () + Just wait -> wait -- all pushes are sent + sendHeaderBody conf ctx lc strm rsp + where + (_, reqvt) = inpObjHeaders req + +---------------------------------------------------------------- + pushStream - :: WorkerConf a - -> a -- parent stream + :: Config + -> Context + -> Stream -- parent stream -> ValueTable -- request -> [PushPromise] - -> IO OutputType -pushStream _ _ _ [] = return OObj -pushStream WorkerConf{..} pstrm reqvt pps0 - | len == 0 = return OObj + -> IO (Maybe (IO ())) +pushStream _ _ _ _ [] = return Nothing +pushStream conf ctx@Context{..} pstrm reqvt pps0 + | len == 0 = return Nothing | otherwise = do - pushable <- isPushable + pushable <- enablePush <$> readIORef peerSettings if pushable then do tvar <- newTVarIO 0 lim <- push tvar pps0 0 if lim == 0 - then return OObj - else return $ OWait (waiter lim tvar) - else return OObj + then return Nothing + else return $ Just $ waiter lim tvar + else return Nothing where len = length pps0 increment tvar = atomically $ modifyTVar' tvar (+ 1) + -- Checking if all push are done. waiter lim tvar = atomically $ do n <- readTVar tvar - checkSTM (n >= lim) + check (n >= lim) push _ [] n = return (n :: Int) push tvar (pp : pps) n = do - (pid, newstrm) <- makePushStream pstrm pp - let scheme = fromJust $ getHeaderValue tokenScheme reqvt + T.forkManaged threadManager "H2 server push" $ do + mpushed <- promise pp `E.finally` increment tvar + forM_ mpushed $ \(newstrm, lc) -> do + let Response rsp = promiseResponse pp + sendHeaderBody conf ctx lc newstrm rsp + push tvar pps (n + 1) + -- Sending the PUSH_PROMISE, and only then counting the push as done: + -- 'waiter' holds the parent's response back until every push is + -- counted. The PUSH_PROMISE has to go out before the parent's frames + -- (RFC 9113, section 8.4.1) -- before its END_STREAM above all, after + -- which a PUSH_PROMISE on it is a connection error. Counted before it + -- was queued, the parent's response could overtake it, and a client + -- asked for the pushed resource itself before hearing of the promise. + -- 'syncWithSender' returns once the sender has written the frame. + -- Counted however it ends, or the parent would wait for ever. A push + -- the peer has no room for is not made ('openEvenStreamTry'). + promise pp = do + mstrm <- makePushStream ctx pstrm + forM mstrm $ \(pid, newstrm) -> promiseOn pp pid newstrm + promiseOn pp pid newstrm = do + let scheme = fromJust $ getFieldValue tokenScheme reqvt -- fixme: this value can be Nothing auth = fromJust - ( getHeaderValue tokenAuthority reqvt - <|> getHeaderValue tokenHost reqvt + ( getFieldValue tokenAuthority reqvt + <|> getFieldValue tokenHost reqvt ) path = promiseRequestPath pp promiseRequest = - [ (tokenMethod, H.methodGet) + [ (tokenMethod, methodGet) , (tokenScheme, scheme) , (tokenAuthority, auth) , (tokenPath, path) ] ot = OPush promiseRequest pid - Response rsp = promiseResponse pp - out = Output newstrm rsp ot Nothing $ increment tvar - writeOutputQ out - push tvar pps (n + 1) - --- | This function is passed to workers. --- They also pass 'Response's from a server to this function. --- This function enqueues commands for the HTTP/2 sender. -response - :: WorkerConf a - -> Manager - -> T.Handle - -> ThreadContinue - -> a - -> Request - -> Response - -> [PushPromise] - -> IO () -response wc@WorkerConf{..} mgr th tconf strm (Request req) (Response rsp) pps = case outObjBody rsp of - OutBodyNone -> do - setThreadContinue tconf True - writeOutputQ $ Output strm rsp OObj Nothing (return ()) - OutBodyBuilder _ -> do - otyp <- pushStream wc strm reqvt pps - setThreadContinue tconf True - writeOutputQ $ Output strm rsp otyp Nothing (return ()) - OutBodyFile _ -> do - otyp <- pushStream wc strm reqvt pps - setThreadContinue tconf True - writeOutputQ $ Output strm rsp otyp Nothing (return ()) - OutBodyStreaming strmbdy -> do - otyp <- pushStream wc strm reqvt pps - -- We must not exit this server application. - -- If the application exits, streaming would be also closed. - -- So, this work occupies this thread. - -- - -- We need to increase the number of workers. - spawnAction mgr - -- After this work, this thread stops to decease - -- the number of workers. - setThreadContinue tconf False - -- Since streaming body is loop, we cannot control it. - -- So, let's serialize 'Builder' with a designated queue. - tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 - writeOutputQ $ Output strm rsp otyp (Just tbq) (return ()) - let push b = do - T.pause th - atomically $ writeTBQueue tbq (StreamingBuilder b) - T.resume th - flush = atomically $ writeTBQueue tbq StreamingFlush - finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr) - incCounter mgr - strmbdy push flush `E.finally` finished - OutBodyStreamingUnmask _ -> - error "response: server does not support OutBodyStreamingUnmask" - where - (_, reqvt) = inpObjHeaders req - --- | Worker for server applications. -worker :: WorkerConf a -> Manager -> Server -> Action -worker wc@WorkerConf{..} mgr server = do - sinfo <- newStreamInfo - tcont <- newThreadContinue - timeoutKillThread mgr $ go sinfo tcont - where - go sinfo tcont th = do - setThreadContinue tcont True - ex <- E.trySyncOrAsync $ do - T.pause th - Input strm req <- readInputQ - let req' = pauseRequestBody req th - setStreamInfo sinfo strm - T.resume th - T.tickle th - let aux = Aux th mySockAddr peerSockAddr - server (Request req') aux $ response wc mgr th tcont strm (Request req') - cont1 <- case ex of - Right () -> return True - Left e@(SomeException _) - -- killed by the local worker manager - | Just KilledByHttp2ThreadManager{} <- E.fromException e -> return False - -- killed by the local timeout manager - | Just T.TimeoutThread <- E.fromException e -> do - cleanup sinfo - return True - | otherwise -> do - cleanup sinfo - return True - cont2 <- getThreadContinue tcont - clearStreamInfo sinfo - when (cont1 && cont2) $ go sinfo tcont th - pauseRequestBody req th = req{inpObjBody = readBody'} - where - readBody = inpObjBody req - readBody' = do - T.pause th - bs <- readBody - T.resume th - return bs - cleanup sinfo = do - minp <- getStreamInfo sinfo - case minp of - Nothing -> return () - Just strm -> workerCleanup strm + lc <- newLoopCheck newstrm Nothing + syncWithSender ctx newstrm ot lc + -- Reserved (local) until now. The peer sends nothing on a pushed + -- stream, so its side is closed from here (RFC 9113, section 5.1: + -- "half-closed (remote)" once the HEADERS go out), and the END_STREAM + -- of the pushed response closes the stream. Left reserved, that + -- END_STREAM only half-closed it: the stream stayed in the table + -- holding a slot of the peer's SETTINGS_MAX_CONCURRENT_STREAMS, and + -- once that many pushes had been made, the next waited for a slot + -- for ever, and so did the response it belonged to. + halfClosedRemote ctx newstrm + return (newstrm, lc) ---------------------------------------------------------------- --- A reference is shared by a responder and its worker. --- The reference refers a value of this type as a return value. --- If 'True', the worker continue to serve requests. --- Otherwise, the worker get finished. -newtype ThreadContinue = ThreadContinue (IORef Bool) - -{-# INLINE newThreadContinue #-} -newThreadContinue :: IO ThreadContinue -newThreadContinue = ThreadContinue <$> newIORef True - -{-# INLINE setThreadContinue #-} -setThreadContinue :: ThreadContinue -> Bool -> IO () -setThreadContinue (ThreadContinue ref) x = writeIORef ref x - -{-# INLINE getThreadContinue #-} -getThreadContinue :: ThreadContinue -> IO Bool -getThreadContinue (ThreadContinue ref) = readIORef ref +makePushStream :: Context -> Stream -> IO (Maybe (StreamId, Stream)) +makePushStream ctx pstrm = do + -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit + mstrm <- openEvenStreamTry ctx + let pid = streamNumber pstrm + return $ (\(_, newstrm) -> (pid, newstrm)) <$> mstrm ---------------------------------------------------------------- --- | The type for cleaning up. -newtype StreamInfo a = StreamInfo (IORef (Maybe a)) - -{-# INLINE newStreamInfo #-} -newStreamInfo :: IO (StreamInfo a) -newStreamInfo = StreamInfo <$> newIORef Nothing - -{-# INLINE clearStreamInfo #-} -clearStreamInfo :: StreamInfo a -> IO () -clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing +sendHeaderBody + :: Config + -> Context + -> LoopCheck + -> Stream + -> OutObj + -> IO () +sendHeaderBody Config{..} ctx lc strm OutObj{..} = do + (mnext, mtbq) <- case outObjBody of + OutBodyNone -> return (Nothing, Nothing) + OutBodyFile (FileSpec path fileoff bytecount) -> do + (pread, sentinel) <- confPositionReadMaker path + let next = fillFileBodyGetNext pread fileoff bytecount sentinel + return (Just next, Nothing) + OutBodyBuilder builder -> do + let next = fillBuilderBodyGetNext builder + return (Just next, Nothing) + OutBodyStreaming strmbdy -> do + q <- sendStreaming ctx strm $ \OutBodyIface{..} -> strmbdy outBodyPush outBodyFlush + let next = nextForStreaming q + return (Just next, Just q) + OutBodyStreamingIface strmbdy -> do + q <- sendStreaming ctx strm strmbdy + let next = nextForStreaming q + return (Just next, Just q) + let lc' = lc{lcTBQ = mtbq} + syncWithSender ctx strm (OHeader outObjHeaders mnext outObjTrailers) lc' -{-# INLINE setStreamInfo #-} -setStreamInfo :: StreamInfo a -> a -> IO () -setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp +---------------------------------------------------------------- -{-# INLINE getStreamInfo #-} -getStreamInfo :: StreamInfo a -> IO (Maybe a) -getStreamInfo (StreamInfo ref) = readIORef ref +sendStreaming + :: Context + -> Stream + -> (OutBodyIface -> IO ()) + -> IO (TBQueue StreamingChunk) +sendStreaming ctx@Context{..} strm strmbdy = do + tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 + T.forkManagedTimeout threadManager label $ \th -> + withOutBodyIface ctx strm tbq id $ \iface -> do + let iface' = + iface + { outBodyPush = \b -> do + T.pause th + outBodyPush iface b + T.resume th -- this is the same as 'tickle' + , outBodyPushFinal = \b -> do + T.pause th + outBodyPushFinal iface b + T.resume th -- this is the same as 'tickle' + } + strmbdy iface' + return tbq + where + label = "H2 response streaming sender for " ++ show (streamNumber strm) diff --git a/bench-hpack/Main.hs b/bench-hpack/Main.hs --- a/bench-hpack/Main.hs +++ b/bench-hpack/Main.hs @@ -2,9 +2,9 @@ module Main where -import Control.Exception +import qualified Control.Exception as E +import Criterion.Main import Data.ByteString (ByteString) -import Gauge.Main import Network.HPACK ---------------------------------------------------------------- @@ -39,7 +39,7 @@ ] ---------------------------------------------------------------- -prepare :: [HeaderList] -> IO [ByteString] +prepare :: [[Header]] -> IO [ByteString] prepare hdrs = do tbl <- newDynamicTableForEncoding defaultDynamicTableSize go tbl hdrs id @@ -59,7 +59,7 @@ !_ <- decodeHeader tbl f go tbl fs -enc :: EncodeStrategy -> [HeaderList] -> IO () +enc :: EncodeStrategy -> [[Header]] -> IO () enc stgy hdrs = do tbl <- newDynamicTableForEncoding defaultDynamicTableSize go tbl hdrs diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,6 +1,6 @@ -cabal-version: >=1.10 +cabal-version: 2.0 name: http2 -version: 5.1.4 +version: 5.4.7 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -8,7 +8,7 @@ homepage: https://github.com/kazu-yamamoto/http2 synopsis: HTTP/2 library description: - HTTP/2 library including frames, priority queues, HPACK, client and server. + HTTP/2 library including frames, HPACK, client and server. category: Network build-type: Simple @@ -60,14 +60,12 @@ Network.HTTP2.Client Network.HTTP2.Client.Internal Network.HTTP2.Frame - Network.HTTP2.Internal Network.HTTP2.Server Network.HTTP2.Server.Internal other-modules: Imports Network.HPACK.Builder - Network.HTTP2.Client.Types Network.HTTP2.Client.Run Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode @@ -90,24 +88,21 @@ Network.HTTP2.H2.Config Network.HTTP2.H2.Context Network.HTTP2.H2.EncodeFrame - Network.HTTP2.H2.File Network.HTTP2.H2.HPACK - Network.HTTP2.H2.Manager + Network.HTTP2.H2.OutBodyIface Network.HTTP2.H2.Queue - Network.HTTP2.H2.ReadN Network.HTTP2.H2.Receiver Network.HTTP2.H2.Sender Network.HTTP2.H2.Settings - Network.HTTP2.H2.Status Network.HTTP2.H2.Stream Network.HTTP2.H2.StreamTable + Network.HTTP2.H2.Sync Network.HTTP2.H2.Types Network.HTTP2.H2.Window Network.HTTP2.Frame.Decode Network.HTTP2.Frame.Encode Network.HTTP2.Frame.Types Network.HTTP2.Server.Run - Network.HTTP2.Server.Types Network.HTTP2.Server.Worker default-language: Haskell2010 @@ -115,25 +110,27 @@ ghc-options: -Wall build-depends: base >=4.9 && <5, - array >= 0.5 && < 0.6, - async >= 2.2 && < 2.3, - bytestring >= 0.10, - containers >= 0.6 && < 0.7, - stm >= 2.5 && < 2.6, - case-insensitive >= 1.2 && < 1.3, - http-types >= 0.12 && < 0.13, - network >= 3.1, - network-byte-order >= 0.1.7 && < 0.2, - network-control >= 0.1 && < 0.2, - unix-time >= 0.4.11 && < 0.5, - time-manager >= 0.0.1 && < 0.1, - unliftio >= 0.2 && < 0.3, - utf8-string >= 1.0 && < 1.1 + array >=0.5 && <0.6, + async >=2.2 && <2.3, + bytestring >=0.10, + case-insensitive >=1.2 && <1.3, + containers >=0.6, + http-semantics >= 0.4 && <0.5, + http-types >=0.12 && <0.13, + iproute >= 1.7 && < 1.8, + network >=3.1, + network-byte-order >=0.1.7 && <0.2, + network-control >=0.1 && <0.2, + stm >=2.5 && <2.6, + time-manager >=0.3.0 && <0.4, + unix-time >=0.4.11 && <0.6, + utf8-string >=1.0 && <1.1 -executable client - main-is: client.hs +executable h2c-client + main-is: h2c-client.hs hs-source-dirs: util default-language: Haskell2010 + other-modules: Client Monitor default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts build-depends: @@ -142,16 +139,19 @@ bytestring, http-types, http2, - network-run + network, + network-run >= 0.6 && <0.7, + unix-time if flag(devel) else buildable: False -executable server - main-is: server.hs +executable h2c-server + main-is: h2c-server.hs hs-source-dirs: util + other-modules: Server Monitor default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded @@ -185,7 +185,6 @@ array, base16-bytestring >=1.0, bytestring, - case-insensitive, containers, http2, network-byte-order, @@ -215,7 +214,6 @@ array, base16-bytestring >=1.0, bytestring, - case-insensitive, containers, http2, network-byte-order, @@ -242,7 +240,6 @@ aeson-pretty, array, bytestring, - case-insensitive, containers, directory, filepath, @@ -308,10 +305,12 @@ bytestring, crypton, hspec >=1.3, + http-semantics, http-types, http2, network, - network-run >=0.1.0, + network-byte-order, + network-run >= 0.6 && <0.7, random, typed-process @@ -330,7 +329,7 @@ hspec >=1.3, http-types, http2, - network-run >=0.1.0, + network-run >= 0.6 && <0.7, typed-process if flag(h2spec) @@ -405,7 +404,7 @@ bytestring, case-insensitive, containers, - gauge, + criterion, + http2, network-byte-order, - stm, - http2 + stm diff --git a/test-frame/FrameSpec.hs b/test-frame/FrameSpec.hs --- a/test-frame/FrameSpec.hs +++ b/test-frame/FrameSpec.hs @@ -10,7 +10,7 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL import Network.HTTP2.Frame -import System.FilePath.Glob (compile, globDir) +import System.FilePath.Glob (compile, globDir1) import Test.Hspec import JSON @@ -19,7 +19,7 @@ testDir = "test-frame/http2-frame-test-case" getTestFiles :: FilePath -> IO [FilePath] -getTestFiles dir = head <$> globDir [compile "*/*.json"] dir +getTestFiles dir = globDir1 (compile "*/*.json") dir check :: FilePath -> IO () check file = do diff --git a/test-frame/frame-encode.hs b/test-frame/frame-encode.hs --- a/test-frame/frame-encode.hs +++ b/test-frame/frame-encode.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Main where import Data.Aeson diff --git a/test-hpack/HPACKDecode.hs b/test-hpack/HPACKDecode.hs --- a/test-hpack/HPACKDecode.hs +++ b/test-hpack/HPACKDecode.hs @@ -12,7 +12,7 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif -import Control.Exception +import qualified Control.Exception as E import Control.Monad (when) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B8 @@ -66,7 +66,7 @@ case size c of Nothing -> return () Just siz -> renewDynamicTable siz dyntbl - x <- try $ decodeHeader dyntbl inp + x <- E.try $ decodeHeader dyntbl inp case x of Left e -> return $ Just $ show (e :: DecodeError) Right hs' -> do @@ -87,12 +87,12 @@ inp = B16.decodeLenient wirehex hs = headers c --- | Printing 'HeaderList'. -printHeaderList :: HeaderList -> IO () +-- | Printing '[Header]'. +printHeaderList :: [Header] -> IO () printHeaderList hs = mapM_ printHeader hs where printHeader (k, v) = do - B8.putStr k + B8.putStr $ original k putStr ": " B8.putStr v putStr "\n" diff --git a/test-hpack/HPACKEncode.hs b/test-hpack/HPACKEncode.hs --- a/test-hpack/HPACKEncode.hs +++ b/test-hpack/HPACKEncode.hs @@ -20,7 +20,7 @@ data Conf = Conf { debug :: Bool - , enc :: DynamicTable -> HeaderList -> IO ByteString + , enc :: DynamicTable -> [Header] -> IO ByteString } run :: Bool -> EncodeStrategy -> Test -> IO [ByteString] diff --git a/test-hpack/JSON.hs b/test-hpack/JSON.hs --- a/test-hpack/JSON.hs +++ b/test-hpack/JSON.hs @@ -6,7 +6,7 @@ module JSON ( Test (..), Case (..), - HeaderList, + Header, ) where #if __GLASGOW_HASKELL__ < 709 @@ -44,7 +44,7 @@ data Case = Case { size :: Maybe Int , wire :: ByteString - , headers :: HeaderList + , headers :: [Header] , seqno :: Maybe Int } deriving (Show) @@ -87,24 +87,27 @@ , "seqno" .= no ] -instance {-# OVERLAPPING #-} FromJSON HeaderList where +instance {-# OVERLAPPING #-} FromJSON [Header] where parseJSON (Array a) = mapM parseJSON $ V.toList a parseJSON _ = mzero -instance {-# OVERLAPPING #-} ToJSON HeaderList where +instance {-# OVERLAPPING #-} ToJSON [Header] where toJSON hs = toJSON $ map toJSON hs instance {-# OVERLAPPING #-} FromJSON Header where - parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old + parseJSON (Array a) = pure (mk $ toKey (a ! 0), toValue (a ! 1)) -- old where toKey = toValue - parseJSON (Object o) = pure (textToByteString (Key.toText k), toValue v) -- new + parseJSON (Object o) = pure (mk $ textToByteString $ Key.toText k, toValue v) -- new where - (k, v) = head $ H.toList o + (k, v) = case H.toList o of + [] -> error "parseJSON" + x : _ -> x parseJSON _ = mzero instance {-# OVERLAPPING #-} ToJSON Header where - toJSON (k, v) = object [Key.fromText (byteStringToText k) .= byteStringToText v] + toJSON (k, v) = + object [Key.fromText (byteStringToText $ foldedCase k) .= byteStringToText v] textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack diff --git a/test-hpack/hpack-stat.hs b/test-hpack/hpack-stat.hs --- a/test-hpack/hpack-stat.hs +++ b/test-hpack/hpack-stat.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.List import Data.Maybe (fromJust) +import Network.HPACK import System.Directory import System.FilePath @@ -81,7 +82,7 @@ let len = sum $ map toT $ cases tc return len where - toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length x + BS.length y) hs + toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length (foldedCase x) + BS.length y) hs getHeaderLen :: FilePath -> IO Int getHeaderLen file = do diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -2,8 +2,14 @@ module HPACK.DecodeSpec where +import Control.Monad (forM_) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.String (fromString) +import Data.Word (Word8) import Network.HPACK import Network.HPACK.Table +import Network.HPACK.Token (tokenKey) import Test.Hspec import HPACK.HeaderBlock @@ -11,7 +17,7 @@ spec :: Spec spec = do describe "fromHeaderBlock" $ do - it "decodes HeaderList in request" $ do + it "decodes [Header] in request" $ do withDynamicTableForDecoding 4096 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d41b h1 `shouldBe` d41h @@ -19,7 +25,7 @@ h2 `shouldBe` d42h h3 <- decodeHeader dyntabl d43b h3 `shouldBe` d43h - it "decodes HeaderList in response" $ do + it "decodes [Header] in response" $ do withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d61b h1 `shouldBe` d61h @@ -27,11 +33,11 @@ h2 `shouldBe` d62h h3 <- decodeHeader dyntabl d63b h3 `shouldBe` d63h - it "decodes HeaderList in response (deny max table size update to 0)" $ + it "decodes [Header] in response (deny max table size update to 0)" $ withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d81b h1 `shouldBe` d81h - it "decodes HeaderList even if an entry is larger than DynamicTable" $ + it "decodes [Header] even if an entry is larger than DynamicTable" $ withDynamicTableForEncoding 64 $ \etbl -> withDynamicTableForDecoding 64 4096 $ \dtbl -> do hs <- encodeHeader defaultEncodeStrategy 4096 etbl hl1 @@ -39,8 +45,119 @@ h1 `shouldBe` hl1 isDynamicTableEmpty etbl `shouldReturn` True isDynamicTableEmpty dtbl `shouldReturn` True + it "keeps the newest entry when a full table evicts" $ + -- A size update to 40 leaves room for one entry. Two literals + -- with incremental indexing, then index 62: the newest entry, + -- "b". Inserting before evicting used to write "b" over "a", + -- then evict the slot it had just written, so 62 came back as + -- a dummy entry. + withDynamicTableForDecoding 4096 4096 $ \dtbl -> do + let blk = + BS.pack + [ 0x3f + , 0x09 -- size update: 31 + 9 + , 0x40 + , 0x01 + , 0x61 + , 0x00 -- a: (incremental) + , 0x40 + , 0x01 + , 0x62 + , 0x00 -- b: (incremental) + , 0xbe -- indexed 62 + ] + decodeHeader dtbl blk `shouldReturn` [("a", ""), ("b", ""), ("b", "")] + it "decodes a Huffman-coded value longer than the Huffman buffer" $ + -- The value decodes to more than the 4096 octets of the + -- decoder's Huffman buffer. It used to be reported as a + -- truncated block, although the same value as a plain literal + -- was accepted. + withDynamicTableForEncoding 4096 $ \etbl -> + withDynamicTableForDecoding 4096 4096 $ \dtbl -> + forM_ [False, True] $ \huff -> do + let hs = [("x-long", BS8.replicate 5000 'a')] + stgy = defaultEncodeStrategy{useHuffman = huff} + blk <- encodeHeader stgy 8192 etbl hs + decodeHeader dtbl blk `shouldReturn` hs + (tvs, _) <- decodeTokenHeader dtbl blk + map (\(t, v) -> (tokenKey t, v)) tvs `shouldBe` hs + it "decodes a block with no fields" $ + -- Empty, or only dynamic table size updates: both are valid + -- blocks of no fields, and both used to be taken for truncated. + withDynamicTableForDecoding 4096 4096 $ \dtbl -> + forM_ ["", "\x20", "\x3f\xe1\x1f"] $ \blk -> do + decodeHeader dtbl blk `shouldReturn` [] + (tvs, _) <- decodeTokenHeader dtbl blk + tvs `shouldBe` [] + it "decodes the rest of a block with a malformed field" $ + -- The field after the malformed ones goes into the dynamic + -- table, and the next block refers to it: index 62, the newest + -- entry. The decoder used to stop at the malformed field, so + -- that reference went astray. + forM_ [illegalName, tooMany] $ \(fields, err) -> + withDynamicTableForDecoding 4096 4096 $ \dtbl -> do + let blk1 = fields <> incremental "x-after" "2" + blk2 = BS.pack [0xbe] + decodeTokenHeader dtbl blk1 `shouldThrow` (== err) + (tvs, _) <- decodeTokenHeader dtbl blk2 + map (\(t, v) -> (tokenKey t, v)) tvs `shouldBe` [("x-after", "2")] + it "round-trips through tables small enough to fill up" $ + -- Entries near the 32-octet minimum fill a table of these sizes + -- to its last slot. The encoder follows the peer's + -- SETTINGS_HEADER_TABLE_SIZE, so any of them can be asked for; + -- the encoder used to send index 61 of the static table + -- (www-authenticate) for an entry it had lost. + forM_ [33, 40, 63, 64, 100, 127, 1023] $ \siz -> + forM_ [False, True] $ \huff -> + withDynamicTableForEncoding siz $ \etbl -> + withDynamicTableForDecoding siz 4096 $ \dtbl -> + forM_ smallBlocks $ \hs -> do + let stgy = defaultEncodeStrategy{useHuffman = huff} + blk <- encodeHeader stgy 4096 etbl hs + decodeHeader dtbl blk `shouldReturn` hs -hl1 :: HeaderList +-- | A field name the encoder would have made lower-case. +illegalName :: (BS.ByteString, DecodeError) +illegalName = (literal "X-Upper" "1", IllegalHeaderName) + +-- | One field more than the decoder takes. +tooMany :: (BS.ByteString, DecodeError) +tooMany = + ( mconcat [literal (BS8.pack ('f' : show i)) "v" | i <- [1 .. 202 :: Int]] + , TooLargeHeader + ) + +-- | A literal field with a new name, without indexing (RFC 7541, 6.2.2). +literal :: BS.ByteString -> BS.ByteString -> BS.ByteString +literal = field 0x00 + +-- | A literal field with a new name, with incremental indexing (6.2.1). +incremental :: BS.ByteString -> BS.ByteString -> BS.ByteString +incremental = field 0x40 + +-- | Names and values shorter than 127 octets. +field :: Word8 -> BS.ByteString -> BS.ByteString -> BS.ByteString +field w k v = + BS.pack [w, fromIntegral (BS.length k)] + <> k + <> BS.pack [fromIntegral (BS.length v)] + <> v + +-- | Blocks of fields close to the 32-octet minimum entry size, coming back +-- to earlier ones so that the encoder refers to what it inserted. +smallBlocks :: [[Header]] +smallBlocks = + concat $ + replicate 3 $ + [ [("aa", "x")] + , [("bb", "y")] + , [("aa", "x")] + , [("cc", ""), ("aa", "x")] + , [("dd", "z"), ("bb", "y"), ("cc", "")] + ] + ++ [[(fromString ('k' : show i), "v")] | i <- [0 .. 40 :: Int]] + +hl1 :: [Header] hl1 = [ ("custom-key", "custom-value") , diff --git a/test/HPACK/EncodeSpec.hs b/test/HPACK/EncodeSpec.hs --- a/test/HPACK/EncodeSpec.hs +++ b/test/HPACK/EncodeSpec.hs @@ -8,8 +8,12 @@ import qualified Control.Exception as E import Data.Bits import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import Data.Maybe (fromMaybe) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Network.ByteOrder (withReadBuffer, withWriteBuffer) import Network.HPACK +import Network.HPACK.Internal (decodeH, decodeS, encodeS) import Test.Hspec spec :: Spec @@ -32,6 +36,17 @@ run (Just 0) EncodeStrategy{compressionAlgo = Linear, useHuffman = False} [] it "does not use indexed fields" $ do runNotIndexed EncodeStrategy{compressionAlgo = Linear, useHuffman = False} + describe "encodeS" $ do + it "round-trips a Huffman-coded string whose length needs four octets" $ do + -- 'a' is a five-bit code, so these come to 5/8 of their length + -- when Huffman-coded: 26416 is the first to need a four-octet + -- length with a 7-bit prefix. The fourth octet used to overwrite + -- the first octet of the code. + sequence_ + [ roundTripS n len + | n <- [3, 5, 7] + , len <- [100, 20000, 26415, 26416, 30000, 100000] + ] run :: Maybe Int -> EncodeStrategy -> [Int] -> Expectation run msz stgy lens0 = do @@ -41,7 +56,7 @@ withDynamicTableForDecoding sz 4096 $ \dtbl -> go etbl dtbl hdrs lens0 `shouldReturn` True where - go :: DynamicTable -> DynamicTable -> [HeaderList] -> [Int] -> IO Bool + go :: DynamicTable -> DynamicTable -> [[Header]] -> [Int] -> IO Bool go _ _ [] _ = return True go etbl dtbl (h : hs) lens = do bs <- @@ -74,7 +89,7 @@ hdrs <- read <$> readFile "bench-hpack/headers.hs" withDynamicTableForEncoding 0 $ \etbl -> withDynamicTableForDecoding 0 4096 $ \dtbl -> - mapM_ (go etbl dtbl) (hdrs :: [HeaderList]) + mapM_ (go etbl dtbl) (hdrs :: [[Header]]) where go etbl _dtbl h = do print h @@ -101,3 +116,16 @@ linearLens :: [Int] linearLens = [250,312,26,390,288,204,224,204,200,202,204,204,206,206,228,100,204,204,218,208,228,434,208,608,232,208,208,208,98,202,208,256,168,208,208,224,208,208,382,84,242,208,208,232,208,208,208,210,210,210,210,208,210,222,208,210,400,224,238,206,206,230,252,222,202,202,198,138,250,204,216,204,204,108,96,306,250,242,208,94,226,206,264,222,40,224,810,204,38,266,144,158,254,100,206,110,132,38,254,144,102,132,102,102,102,102,102,210,230,208,204,464,224,142,198,198,410,156,250,218,130,18,26,338,284,238,222,36,142,208,92,34,552,152,206,1020,288,42,490,98,40,1884,434,300,240,206,278,278,268,252,460,632,178,220,298,144,430,746,724,202,330,144,204,206,782,146,206,206,146,240,228,204,206,208,300,144,160,146,146,38,280,220,144,146,100,144,418,206,204,294,144,300,228,204,204,146,144,240,204,244,218,230,286,102,256,202,208,206,144,146,206,836,204,842,300,220,326,182,300,148,150,204,144,144,98,146,204,206,146,100,204,222,202,202,166,268,146,40,38,142,38,206,418,318,226,174,256,246,274,208,208,208,208,208,544,254,146,146,144,268,160,572,362,178,224,590,362,3150,1034,316,402,204,228,206,206,40,146,142,266,158,142,354,380,264,702,74,424,674,410,688,322,250,300,204,188,60,298,204,206,468,230,200,232,222,208,210,272,282,252,218,724,144,238,206,208,210,100,254,146,144,124,38,112,204,204,216,168,208,276,100,206,116,100,326,892,194,102,210,102,210,206,40,126,102,100,208,98,242,206,218,278,282,292,234,144,40,144,202,288,206,98,40,146,148,40,116,850,242,38,40,40,148,204,110,290,162,662,212,218,230,100,100,134,100,1026,100,2442,100,100,100,208,100,100,112,100,164,144,100,100,100,110,100,518,202,232,342,728,46,384,204,230,100,398,100,208,114,102,290,208,246,324,782,296,280,796,636,268,84,74,246,34,38,284,612,1090,332,602,378,84,24,256,204,234,26,226,654,60,206,28,160,220,238,38,204,484,206,440,308,206,246,392,314,814,714,200,244,290,258,50,94,252,572,38,284,1050,286,24,252,24,728,46,400,390,330,214,740,368,244,38,252,32,244,252,246,36,94,22,638,296,206,304,32,34,246,240,20,306,340,28,276,226,814,638,278,40,226,50,38,34,42,630,552,252,84,244,252,240,20,198,346,284,290,202,240,300,206,102,214,204,210,430,210,208,144,252,210,240,208,304,224,208,100,354,102,210,764,102,240,210,208,208,102,208,102,208,208,100,102,208,210,100,100,154,268,222,286,256,260,92,642,232,208,262,204,146,100,260,226,146,72,206,38,98,394,1090,348,2602,112,102,490,526,312,486,366,368,368,368,368,674,46,462,202,220,210,516,906,154,384,300,280,206,102,102,102,102,102,102,102,626,102,160,88,226,50,248,34,36,632,308,1124,684,450,254,252,714,60] -} + +roundTripS :: Int -> Int -> Expectation +roundTripS n len = do + let bs = C8.replicate len 'a' + bufsiz = len * 4 + 64 + enc <- withWriteBuffer bufsiz $ \wbuf -> encodeS wbuf True id (`setBit` n) n bs + gcbuf <- mallocPlainForeignPtrBytes bufsiz + dec <- + withReadBuffer enc $ + decodeS (.&. mask) (`testBit` n) n (decodeH gcbuf bufsiz) + dec `shouldBe` bs + where + mask = (1 `shiftL` n) - 1 diff --git a/test/HPACK/HeaderBlock.hs b/test/HPACK/HeaderBlock.hs --- a/test/HPACK/HeaderBlock.hs +++ b/test/HPACK/HeaderBlock.hs @@ -4,14 +4,14 @@ import Data.ByteString (ByteString) import Data.ByteString.Base16 -import Network.HPACK +import Network.HTTP.Types fromHexString :: ByteString -> ByteString fromHexString = decodeLenient ---------------------------------------------------------------- -d41h :: HeaderList +d41h :: [Header] d41h = [ (":method", "GET") , (":scheme", "http") @@ -22,7 +22,7 @@ d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" -d42h :: HeaderList +d42h :: [Header] d42h = [ (":method", "GET") , (":scheme", "http") @@ -34,7 +34,7 @@ d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" -d43h :: HeaderList +d43h :: [Header] d43h = [ (":method", "GET") , (":scheme", "https") @@ -48,7 +48,7 @@ ---------------------------------------------------------------- -d61h :: HeaderList +d61h :: [Header] d61h = [ (":status", "302") , ("cache-control", "private") @@ -61,7 +61,7 @@ fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" -d62h :: HeaderList +d62h :: [Header] d62h = [ (":status", "307") , ("cache-control", "private") @@ -72,7 +72,7 @@ d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" -d63h :: HeaderList +d63h :: [Header] d63h = [ (":status", "200") , ("cache-control", "private") @@ -89,7 +89,7 @@ ---------------------------------------------------------------- -d81h :: HeaderList +d81h :: [Header] d81h = [ (":status", "403") , ("server", "nginx/1.14.0") diff --git a/test/HPACK/HuffmanSpec.hs b/test/HPACK/HuffmanSpec.hs --- a/test/HPACK/HuffmanSpec.hs +++ b/test/HPACK/HuffmanSpec.hs @@ -60,6 +60,10 @@ es <- encodeHuffman bs ds <- decodeHuffman es ds `shouldBe` bs + it "decodes a string longer than 4096 octets" $ do + let bs = BS.replicate 6000 'a' -- 3750 octets encoded + es <- encodeHuffman bs + decodeHuffman es `shouldReturn` bs describe "encode" $ do it "encodes" $ do mapM_ (\(x, y) -> x `shouldBeEncoded` y) testData diff --git a/test/HPACK/IntegerSpec.hs b/test/HPACK/IntegerSpec.hs --- a/test/HPACK/IntegerSpec.hs +++ b/test/HPACK/IntegerSpec.hs @@ -2,6 +2,8 @@ import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) +import Data.Word (Word8) +import Network.HPACK (DecodeError (..)) import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck @@ -14,8 +16,38 @@ x' <- decodeInteger n w ws x `shouldBe` x' +roundtrip7 :: BS.ByteString -> IO Int +roundtrip7 bs = do + let (w, ws) = fromMaybe (error "roundtrip7") $ BS.uncons bs + decodeInteger 7 w ws + +-- | Decode with a 7-bit prefix that is all ones, so that the continuation +-- octets in 'ws' are what decides the value. +decode7 :: [Word8] -> IO Int +decode7 ws = decodeInteger 7 127 (BS.pack ws) + spec :: Spec spec = do + describe "decodeInteger" $ do + it "rejects an encoding that runs past the limit" $ do + r <- encodeInteger 7 integerLimit >>= roundtrip7 + r `shouldBe` integerLimit + ws <- BS.unpack . BS.tail <$> encodeInteger 7 (integerLimit + 1) + decode7 ws `shouldThrow` (== TooLargeInteger) + + it "rejects an encoding in more octets than the limit can take" $ + -- Continuation octets that each add nothing, so only their number + -- is objectionable. + decode7 (replicate 8 0x80 ++ [0x00]) `shouldThrow` (== TooLargeInteger) + + it "rejects an encoding that would wrap around" $ + -- This used to come back as 2, by overflowing 'Int' until it + -- landed there: the same as the single octet 0x82, ":method: GET". + -- Two byte strings decoding alike is exactly what RFC 7541 + -- section 5.1 asks a decoder to refuse. + decode7 [0x83, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01] + `shouldThrow` (== TooLargeInteger) + describe "encode and decode" $ do prop "duality" $ dual 1 prop "duality" $ dual 2 diff --git a/test/HTTP2/ClientSpec.hs b/test/HTTP2/ClientSpec.hs --- a/test/HTTP2/ClientSpec.hs +++ b/test/HTTP2/ClientSpec.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -module HTTP2.ClientSpec where +module HTTP2.ClientSpec (spec) where import Control.Concurrent import qualified Control.Exception as E @@ -12,8 +11,9 @@ import Data.Foldable (for_) import Data.Maybe import Data.Traversable (for) +import Network.HTTP.Semantics import Network.HTTP.Types -import Network.Run.TCP +import Network.Run.TCP hiding (defaultSettings) import System.IO.Unsafe (unsafePerformIO) import System.Random import System.Timeout (timeout) @@ -36,18 +36,18 @@ it "receives an error if scheme is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 - runClient "" host (defaultClient []) `shouldThrow` connectionError + runClient "" host (defaultClient []) `shouldThrow` streamError it "receives an error if authority is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 - runClient "http" "" (defaultClient []) `shouldThrow` connectionError + runClient "http" "" (defaultClient []) `shouldThrow` streamError it "receives an error if authority and host are different" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 runClient "http" host (defaultClient [("Host", "foo")]) - `shouldThrow` connectionError + `shouldThrow` streamError it "does not deadlock (in concurrent setting)" $ E.bracket (forkIO $ runServer irresponsiveServer) killThread $ \_ -> do @@ -67,7 +67,7 @@ let maxConc = fromJust $ maxConcurrentStreams defaultSettings resultVars <- runClient "http" "localhost" $ \sendReq aux -> do - for [1 .. (maxConc + 1) :: Int] $ \_ -> do + replicateM ((maxConc + 1) :: Int) $ do resultVar <- newEmptyMVar concurrentClient resultVar sendReq aux pure resultVar @@ -110,7 +110,7 @@ body = byteString "Hello, world!\n" runClient :: Scheme -> Authority -> Client a -> IO a -runClient sc au client = runTCPClient host port $ runHTTP2Client +runClient sc au client = runTCPClient host port runHTTP2Client where cliconf = defaultClientConfig{scheme = sc, authority = au} runHTTP2Client s = @@ -136,6 +136,13 @@ putMVar resultVar result threadDelay 10000 -connectionError :: Selector HTTP2Error -connectionError ConnectionErrorIsReceived{} = True -connectionError _ = False +-- | A malformed request is a stream error (RFC 9113 section 8.1.1), so the +-- server resets that stream and the connection carries on. The client learns +-- of it through the stream it was waiting on, as 'StreamResetIsReceived'. +-- +-- This used to also admit 'ConnectionErrorIsReceived', from back when the +-- server escalated every stream error to the connection and answered one bad +-- request by hanging up on all of them. +streamError :: Selector HTTP2Error +streamError StreamResetIsReceived{} = True +streamError _ = False diff --git a/test/HTTP2/FrameSpec.hs b/test/HTTP2/FrameSpec.hs --- a/test/HTTP2/FrameSpec.hs +++ b/test/HTTP2/FrameSpec.hs @@ -4,12 +4,67 @@ import Test.Hspec +import qualified Data.ByteString as BS import Data.ByteString.Char8 () import Data.Either import Network.HTTP2.Frame +-- | The error a decoder reports, or Nothing when it accepted the payload. +decodeError :: FrameType -> FrameHeader -> BS.ByteString -> Maybe ErrorCode +decodeError typ header body = case decodeFramePayload typ header body of + Left (FrameDecodeError ec _ _) -> Just ec + Right _ -> Nothing + spec :: Spec spec = do + describe "decodeFramePayload" $ do + -- Each of these used to reach a peek at a fixed offset that never + -- consulted the length of the ByteString it was reading from. An + -- empty one is the shared empty ByteString, whose pointer is null, so + -- the result was a segfault rather than an exception -- which is why + -- none of this could be written as a failing assertion before. + it "rejects a padded frame with no room for Pad Length" $ do + let padded = FrameHeader 0 (setPadded defaultFlags) 1 + decodeError FrameData padded "" `shouldBe` Just FrameSizeError + decodeError FramePushPromise padded "" `shouldBe` Just FrameSizeError + + it "rejects a padded HEADERS whose padding covers the priority fields" $ do + -- Six octets is the smallest payload the header check accepts for + -- PADDED and PRIORITY together, and a Pad Length of five leaves + -- none of the five priority octets behind. + let flags = setPadded $ setPriority defaultFlags + header = FrameHeader 6 flags 1 + decodeError FrameHeaders header (BS.pack [5, 0, 0, 0, 0, 0]) + `shouldBe` Just FrameSizeError + + it "rejects a padded PUSH_PROMISE whose padding covers the promised id" $ do + let flags = setPadded defaultFlags + header = FrameHeader 5 flags 1 + decodeError FramePushPromise header (BS.pack [4, 0, 0, 0, 0]) + `shouldBe` Just FrameSizeError + + it "rejects a payload shorter than the frame header promised" $ do + -- What a peer that hangs up mid-frame leaves behind. + decodeError FramePriority (FrameHeader 5 defaultFlags 1) "" + `shouldBe` Just FrameSizeError + decodeError FrameRSTStream (FrameHeader 4 defaultFlags 1) "" + `shouldBe` Just FrameSizeError + decodeError FrameWindowUpdate (FrameHeader 4 defaultFlags 1) "" + `shouldBe` Just FrameSizeError + decodeError FrameSettings (FrameHeader 6 defaultFlags 0) "" + `shouldBe` Just FrameSizeError + + it "rejects a payload too short for the fields it holds" $ do + -- A payloadLength of zero satisfies checkFrameSize against an + -- empty payload, but each of these still has a fixed-size field + -- to read. GOAWAY was a segfault; the other three quietly + -- returned whatever lay past the end of the buffer. + let lying = FrameHeader 0 defaultFlags 1 + decodeError FrameRSTStream lying "" `shouldBe` Just FrameSizeError + decodeError FrameWindowUpdate lying "" `shouldBe` Just FrameSizeError + decodeError FramePriority lying "" `shouldBe` Just FrameSizeError + decodeError FrameGoAway lying "" `shouldBe` Just FrameSizeError + describe "encodeFrameHeader & decodeFrameHeader" $ do it "encode/decodes frames properly" $ do let header = diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -1,420 +1,1700 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module HTTP2.ServerSpec where - -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Exception as E -import Control.Monad -import Crypto.Hash (Context, SHA1) -- cryptonite -import qualified Crypto.Hash as CH -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Builder (Builder, byteString) -import qualified Data.ByteString.Char8 as C8 -import Data.IORef -import Network.HTTP.Types -import Network.Run.TCP -import Network.Socket -import Network.Socket.ByteString -import System.IO -import System.IO.Unsafe -import System.Random -import Test.Hspec - -import Network.HPACK -import Network.HPACK.Internal -import Network.HPACK.Token -import qualified Network.HTTP2.Client as C -import qualified Network.HTTP2.Client.Internal as C -import Network.HTTP2.Frame -import Network.HTTP2.Server - -port :: String -port = show $ unsafePerformIO (randomPort <$> getStdGen) - where - randomPort = fst . randomR (43124 :: Int, 44320) - -host :: String -host = "127.0.0.1" - -spec :: Spec -spec = do - describe "server" $ do - it "handles normal cases" $ - E.bracket (forkIO runServer) killThread $ \_ -> do - threadDelay 10000 - (runClient allocSimpleConfig) - - it "should always send the connection preface first" $ do - prefaceVar <- newEmptyMVar - E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do - threadDelay 10000 - E.catch (runClient allocSlowPrefaceConfig) ignoreHTTP2Error - - preface <- takeMVar prefaceVar - preface `shouldBe` connectionPreface - - it "prevents attacks" $ - E.bracket (forkIO runServer) killThread $ \_ -> do - threadDelay 10000 - runAttack rapidSettings `shouldThrow` connectionError "too many settings" - runAttack rapidPing `shouldThrow` connectionError "too many ping" - runAttack rapidEmptyHeader - `shouldThrow` connectionError "too many empty headers" - runAttack rapidEmptyData `shouldThrow` connectionError "too many empty data" - runAttack rapidRst `shouldThrow` connectionError "too many rst_stream" - -ignoreHTTP2Error :: C.HTTP2Error -> IO () -ignoreHTTP2Error _ = pure () - -runServer :: IO () -runServer = runTCPServer (Just host) port runHTTP2Server - where - runHTTP2Server s = - E.bracket - (allocSimpleConfig s 32768) - freeSimpleConfig - (\conf -> run defaultServerConfig conf server) - -runFakeServer :: MVar ByteString -> IO () -runFakeServer prefaceVar = do - runTCPServer (Just host) port $ \s -> do - ref <- newIORef Nothing - - -- send settings - sendAll s $ - "\x00\x00\x12\x04\x00\x00\x00\x00\x00" - `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00" - `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff" - - -- receive preface - value <- defaultReadN s ref (B.length connectionPreface) - putMVar prefaceVar value - - -- send goaway frame - sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01" - - -- wait for a few ms to make sure the client has a chance to close the - -- socket on its end - threadDelay 10000 - -server :: Server -server req _aux sendResponse = case requestMethod req of - Just "GET" -> case requestPath req of - Just "/" -> sendResponse responseHello [] - Just "/stream" -> sendResponse responseInfinite [] - Just "/push" -> do - let pp = pushPromise "/push-pp" responsePP 0 - sendResponse responseHello [pp] - _ -> sendResponse response404 [] - Just "POST" -> case requestPath req of - Just "/echo" -> sendResponse (responseEcho req) [] - _ -> sendResponse responseHello [] - _ -> sendResponse response405 [] - -responseHello :: Response -responseHello = responseBuilder ok200 header body - where - header = [("Content-Type", "text/plain")] - body = byteString "Hello, world!\n" - -responsePP :: Response -responsePP = responseBuilder ok200 header body - where - header = - [ ("Content-Type", "text/plain") - , ("x-push", "True") - ] - body = byteString "Push\n" - -responseInfinite :: Response -responseInfinite = responseStreaming ok200 header body - where - header = [("Content-Type", "text/plain")] - body :: (Builder -> IO ()) -> IO () -> IO () - body write flush = do - let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n) - go (0 :: Int) - -response404 :: Response -response404 = responseNoBody notFound404 [] - -response405 :: Response -response405 = responseNoBody methodNotAllowed405 [] - -responseEcho :: Request -> Response -responseEcho req = setResponseTrailersMaker h2rsp maker - where - h2rsp = responseStreaming ok200 header streamingBody - header = [("Content-Type", "text/plain")] - mhx = getHeaderValue (toToken "X-Tag") (snd (requestHeaders req)) - streamingBody write _flush = do - loop - mt <- getRequestTrailers req - firstTrailerValue <$> mt `shouldBe` mhx - where - loop = do - bs <- getRequestBodyChunk req - when (bs /= "") $ do - void $ write $ byteString bs - loop - maker = trailersMaker (CH.hashInit :: Context SHA1) - --- Strictness is important for Context. -trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker -trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] - where - !sha1 = C8.pack $ show $ CH.hashFinalize ctx -trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' - where - !ctx' = CH.hashUpdate ctx bs - -runClient :: (Socket -> BufferSize -> IO Config) -> IO () -runClient allocConfig = - runTCPClient host port $ runHTTP2Client - where - auth = host - cliconf = C.defaultClientConfig{C.authority = auth} - runHTTP2Client s = - E.bracket - (allocConfig s 4096) - freeSimpleConfig - (\conf -> C.run cliconf conf client) - - client :: C.Client () - client sendRequest aux = - foldr1 concurrently_ $ - [ client0 sendRequest aux - , client1 sendRequest aux - , client2 sendRequest aux - , client3 sendRequest aux - , client3' sendRequest aux - , client3'' sendRequest aux - , client4 sendRequest aux - , client5 sendRequest aux - ] - --- delay sending preface to be able to test if it is always sent first -allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config -allocSlowPrefaceConfig s size = do - config <- allocSimpleConfig s size - pure config{confSendAll = slowPrefaceSend (confSendAll config)} - where - slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO () - slowPrefaceSend orig chunk = do - when (C8.pack "PRI" `C8.isPrefixOf` chunk) $ do - threadDelay 10000 - orig chunk - -client0 :: C.Client () -client0 sendRequest _aux = do - let req = C.requestNoBody methodGet "/" [] - sendRequest req $ \rsp -> do - C.responseStatus rsp `shouldBe` Just ok200 - fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK" - -client1 :: C.Client () -client1 sendRequest _aux = do - let req = C.requestNoBody methodGet "/push-pp" [] - sendRequest req $ \rsp -> do - C.responseStatus rsp `shouldBe` Just notFound404 - -client2 :: C.Client () -client2 sendRequest _aux = do - let req = C.requestNoBody methodPut "/" [] - sendRequest req $ \rsp -> do - C.responseStatus rsp `shouldBe` Just methodNotAllowed405 - -client3 :: C.Client () -client3 sendRequest _aux = do - let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a" - req0 = - C.requestFile methodPost "/echo" [("X-Tag", hx)] $ - FileSpec "test/inputFile" 0 1012731 - req = C.setRequestTrailersMaker req0 maker - sendRequest req $ \rsp -> do - let comsumeBody = do - bs <- C.getResponseBodyChunk rsp - when (bs /= "") comsumeBody - comsumeBody - mt <- C.getResponseTrailers rsp - firstTrailerValue <$> mt `shouldBe` Just hx - where - !maker = trailersMaker (CH.hashInit :: Context SHA1) - -client3' :: C.Client () -client3' sendRequest _aux = do - let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a" - req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do - let sendFile h = do - bs <- B.hGet h 1024 - when (bs /= "") $ do - write $ byteString bs - sendFile h - withFile "test/inputFile" ReadMode sendFile - req = C.setRequestTrailersMaker req0 maker - sendRequest req $ \rsp -> do - let comsumeBody = do - bs <- C.getResponseBodyChunk rsp - when (bs /= "") comsumeBody - comsumeBody - mt <- C.getResponseTrailers rsp - firstTrailerValue <$> mt `shouldBe` Just hx - where - !maker = trailersMaker (CH.hashInit :: Context SHA1) - -client3'' :: C.Client () -client3'' sendRequest _axu = do - let hx = "59f82dfddc0adf5bdf7494b8704f203a67e25d4a" - req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do - let chunk = C8.replicate (16384 * 2) 'c' - tag = C8.replicate 16 't' - -- I don't think 9 is important here, this is just what I have, the client hangs on receiving the last one - replicateM_ 9 $ write $ byteString chunk - write $ byteString tag - req = C.setRequestTrailersMaker req0 maker - sendRequest req $ \rsp -> do - let comsumeBody = do - bs <- C.getResponseBodyChunk rsp - when (bs /= "") comsumeBody - comsumeBody - mt <- C.getResponseTrailers rsp - firstTrailerValue <$> mt `shouldBe` Just hx - where - !maker = trailersMaker (CH.hashInit :: Context SHA1) - -client4 :: C.Client () -client4 sendRequest _aux = do - let req0 = C.requestNoBody methodGet "/push" [] - sendRequest req0 $ \rsp -> do - C.responseStatus rsp `shouldBe` Just ok200 - let req1 = C.requestNoBody methodGet "/push-pp" [] - sendRequest req1 $ \rsp -> do - C.responseStatus rsp `shouldBe` Just ok200 - -client5 :: C.Client () -client5 sendRequest _aux = do - let req0 = C.requestNoBody methodGet "/stream" [] - sendRequest req0 $ \rsp -> do - C.responseStatus rsp `shouldBe` Just ok200 - let go n - | n > 0 = do - _ <- C.getResponseBodyChunk rsp - go (pred n) - | otherwise = pure () - go (100 :: Int) - -firstTrailerValue :: HeaderTable -> HeaderValue -firstTrailerValue = snd . Prelude.head . fst - -runAttack :: (C.ClientIO -> IO ()) -> IO () -runAttack attack = - runTCPClient host port $ runHTTP2Client - where - auth = host - cliconf = C.defaultClientConfig{C.authority = auth} - runHTTP2Client s = - E.bracket - (allocSimpleConfig s 4096) - freeSimpleConfig - (\conf -> C.runIO cliconf conf client) - client cconf = return $ do - attack cconf - threadDelay 1000000 - -rapidSettings :: C.ClientIO -> IO () -rapidSettings C.ClientIO{..} = do - let einfo = EncodeInfo defaultFlags 0 Nothing - bs = encodeFrame einfo $ SettingsFrame [(SettingsEnablePush, 0)] - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - -rapidPing :: C.ClientIO -> IO () -rapidPing C.ClientIO{..} = do - let einfo = EncodeInfo defaultFlags 0 Nothing - opaque64 = "01234567" - bs = encodeFrame einfo $ PingFrame opaque64 - replicateM_ 20 $ cioWriteBytes bs - -rapidEmptyHeader :: C.ClientIO -> IO () -rapidEmptyHeader C.ClientIO{..} = do - (sid, _) <- cioCreateStream - let einfo = EncodeInfo defaultFlags sid Nothing - bs = encodeFrame einfo $ HeadersFrame Nothing "" - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - cioWriteBytes bs - -rapidEmptyData :: C.ClientIO -> IO () -rapidEmptyData C.ClientIO{..} = do - (sid, _) <- cioCreateStream - let einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing - hdr = - hpackEncode - [ (":scheme", "http") - , (":authority", "127.0.0.1") - , (":path", "/") - , (":method", "GET") - ] - bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr - cioWriteBytes bsH - let einfoD = EncodeInfo defaultFlags sid Nothing - bsD = encodeFrame einfoD $ DataFrame "" - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - cioWriteBytes bsD - -rapidRst :: C.ClientIO -> IO () -rapidRst C.ClientIO{..} = do - reset - reset - reset - reset - reset - reset - reset - reset - where - reset = do - (sid, _) <- cioCreateStream - -- setEndStream for HalfClosedRemote - let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing - hdr = - hpackEncode - [ (":scheme", "http") - , (":authority", "127.0.0.1") - , (":path", "/") - , (":method", "GET") - ] - bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr - cioWriteBytes bsH - let einfoR = EncodeInfo defaultFlags sid Nothing - -- Only (HalfClosedRemote, NoError) is accepted. - -- Otherwise, a stream error terminates the connection. - bsR = encodeFrame einfoR $ RSTStreamFrame NoError - cioWriteBytes bsR +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +-- GHC 9.12 and later (still on master), with -O, compile 'responseInfinite' +-- to a response with no body: 'OutBodyNone' instead of 'OutBodyStreaming'. +-- Full laziness floats the constructor application to a top-level thunk, +-- and that thunk reaches code that switches on the pointer tag without +-- evaluating it: https://gitlab.haskell.org/ghc/ghc/-/work_items/27857 +-- The "infinite" stream then ends with its HEADERS, and the MadeYouReset +-- test sometimes sees a stream closed before its PRIORITY arrives (#191). +-- 9.10 and earlier are not affected. +{-# OPTIONS_GHC -fno-full-laziness #-} + +module HTTP2.ServerSpec (spec) where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad +import Crypto.Hash (Context, SHA1) +import qualified Crypto.Hash as CH +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (Builder, byteString) +import qualified Data.ByteString.Char8 as C8 +import Data.IORef +import Data.Maybe (isJust, isNothing) +import Network.HTTP.Semantics +import Network.HTTP.Types +import Network.Run.TCP +import Network.Socket +import Network.Socket.ByteString +import System.IO +import System.IO.Unsafe +import System.Random +import System.Timeout (timeout) +import Test.Hspec + +import Network.HPACK +import Network.HPACK.Internal +import qualified Network.HTTP2.Client as C +import qualified Network.HTTP2.Client.Internal as C +import Network.HTTP2.Frame +import Network.HTTP2.Server + +port :: String +port = show $ unsafePerformIO (randomPort <$> getStdGen) + where + randomPort = fst . randomR (43124 :: Int, 44320) + +host :: String +host = "127.0.0.1" + +spec :: Spec +spec = do + describe "server" $ do + it "sends a header block and trailers larger than a frame" $ + -- Both have to go out as HEADERS and CONTINUATION frames and be + -- put back together on receipt; the requests after them check + -- that the two ends' HPACK tables still agree. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + r <- timeout 5000000 $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do + sendRequest (C.requestNoBody methodGet "/big" []) $ \rsp -> do + getFieldValue (toToken "x-big") (snd (C.responseHeaders rsp)) + `shouldBe` Just bigVal + let drain = do + bs <- C.getResponseBodyChunk rsp + unless (B.null bs) drain + drain + mt <- C.getResponseTrailers rsp + (mt >>= getFieldValue (toToken "x-big-trailer") . snd) + `shouldBe` Just bigVal + -- Same connection: the HPACK state must still agree. + forM_ [1 :: Int, 2] $ \_ -> + sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> + C.responseStatus rsp `shouldBe` Just ok200 + r `shouldBe` Just () + + it "handles normal cases" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + runClient allocSimpleConfig + + it "delivers 103 Early Hints to the client's informational handler" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + hintsRef <- newIORef [] + runClientEarly hintsRef >>= (`shouldBe` Just ok200) + hints <- readIORef hintsRef + map (getFieldValue (toToken "link") . snd) hints + `shouldBe` [ Just "; rel=preload; as=style" + , Just "; rel=preload; as=script" + ] + + it "should always send the connection preface first" $ do + prefaceVar <- newEmptyMVar + E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do + threadDelay 10000 + E.catch (runClient allocSlowPrefaceConfig) ignoreHTTP2Error + + preface <- takeMVar prefaceVar + preface `shouldBe` connectionPreface + + it "refuses one stream over the limit and keeps the connection" $ + E.bracket (forkIO runServerMaxConc1) killThread $ \_ -> do + threadDelay 10000 + -- The server announced room for one concurrent stream. Open + -- one, reset it, then open two more: the second of those is + -- the one over the limit. + -- + -- Two things are on trial. That the reset gives the slot back + -- exactly once -- decrementing the count twice, as it used to, + -- would leave room for both. And that being over the limit + -- costs you that stream and not the connection: no GOAWAY. + frames <- + rawExchange + [ openStreamFrame 1 + , encodeFrame (EncodeInfo defaultFlags 1 Nothing) $ + RSTStreamFrame Cancel + , openStreamFrame 3 + , openStreamFrame 5 + ] + [(sid, ec) | (FrameRSTStream, sid, ec) <- resets frames] + `shouldBe` [(5, RefusedStream)] + [() | (FrameGoAway, _, _) <- resets frames] `shouldBe` [] + + it "releases a worker whose stream the peer reset" $ do + doneVar <- newEmptyMVar + E.bracket (forkIO (runServerCancel doneVar)) killThread $ \_ -> do + threadDelay 10000 + runAttack cancelInFlight + timeout 1000000 (takeMVar doneVar) `shouldReturn` Just () + + it "survives a padded HEADERS whose padding covers the priority fields" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + runAttack paddingOverPriority + `shouldThrow` connectionError "no room for priority fields" + + it "resets one stream and goes on serving the connection" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + runStreamErrorClient + + it "limits the resets a peer can make us send (MadeYouReset)" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + -- Not through the client library: it would take the + -- server's first RST_STREAM, on a stream it never opened + -- itself, for a protocol error of its own. + timeout 5000000 rapidStreamError + `shouldReturn` Just (Just (EnhanceYourCalm, "too many stream errors")) + + it "gives back the slot of a stream both sides streamed on" $ + -- Room for four concurrent streams, so a few slots that are + -- never given back stop the connection within a few thousand + -- requests one after another. Both sides stream with flushes: the receiver used to write back a stream state + -- it had read before the sender half-closed the stream, undoing + -- the half-close, so the peer's END_STREAM then left the stream + -- half-closed instead of closed and in the table for good. + -- + -- It is a race between the receiver and the sender, so it needs + -- them running in parallel: on one capability it hardly ever + -- shows. + withCapabilities 4 $ + E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do + threadDelay 10000 + done <- newIORef (0 :: Int) + r <- timeout 60000000 $ runTCPClient host port $ \s -> do + -- Fifty small writes each way per request: without + -- this, Nagle and delayed ACKs can hold each one up. + setSocketOption s NoDelay 1 + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> + forM_ [1 .. 2000 :: Int] $ \_ -> do + let req = C.requestStreaming methodPost "/both" [] $ \write flush -> + replicateM_ 50 $ write (byteString (C8.replicate 50 'a')) >> flush + sendRequest req $ \rsp -> do + let drain n = do + bs <- C.getResponseBodyChunk rsp + if B.null bs then return n else drain (n + B.length bs) + drain 0 `shouldReturn` 2500 + modifyIORef' done (+ 1) + -- How far it got tells a hang from a slow run. + n <- readIORef done + when (isNothing r) $ + expectationFailure $ + "timed out after " ++ show n ++ " of 2000 requests" + + it "accepts a content-length on a response with no content" $ + -- RFC 9113, section 8.1.1: the response to HEAD, 204 and 304 can + -- carry a non-zero content-length without content. The client + -- used to take each of these for a malformed response. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do + let noContent method path = + sendRequest (C.requestNoBody method path []) $ \rsp -> do + C.responseStatus rsp `shouldSatisfy` isJust + C.getResponseBodyChunk rsp `shouldReturn` "" + noContent methodHead "/" + noContent methodHead "/data" + noContent methodGet "/not-modified" + -- A response that is meant to have content still + -- has to match its content-length. + sendRequest (C.requestNoBody methodGet "/no-content" []) (const $ return ()) + `shouldThrow` malformedResponse + + it "does not open a stream for a PRIORITY frame" $ + -- Over a raw socket, as the client library does not send + -- PRIORITY. The server allows 64 concurrent streams; each of + -- these PRIORITY frames used to open one and hold its slot, + -- so the request after them was refused. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 idlePriority `shouldReturn` Just (Just "HEADERS") + + it "closes the connection when SETTINGS overflow a stream's window" $ + -- RFC 9113, section 6.9.2: a connection error of type + -- FLOW_CONTROL_ERROR. The overflow is found in the sender, + -- which used to stop on it without a word, leaving the + -- connection open and silent. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + -- A connection error: GOAWAY, with no RST_STREAM before it. + timeout 5000000 settingsOverflow + `shouldReturn` Just (False, Just FlowControlError) + + it "accepts empty trailers" $ + -- A HEADERS frame with END_STREAM and an empty field block ends + -- the body with no trailer fields. The empty block used to be + -- taken for a truncated one: COMPRESSION_ERROR, and the + -- connection closed. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 emptyTrailers `shouldReturn` Just (Just "HEADERS") + + it "checks a padded body against its content-length" $ + -- Padding is not content (RFC 9113, section 6.1). It used to + -- be counted into the body's length, so a padded body that + -- matched its content-length was reset as one that did not. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 paddedBody `shouldReturn` Just (Just "DATA 4") + + it "gives the padding of a body back to the windows" $ + -- 2000 DATA frames of one octet of content and 255 of padding: + -- about twice the stream's window. The padding used to be + -- charged and never given back, so a peer keeping to the + -- windows stalled, and one that did not, like this one, broke + -- the stream's limit and had the connection closed. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 paddingWindow `shouldReturn` Just (Just "DATA 2000") + + it "gives DATA it refuses back to the connection window" $ + -- DATA on a stream the peer has half-closed is a stream error + -- (RFC 9113, section 5.1), but it still counts against the + -- connection window (section 6.9). It used to be left out, so + -- the peer's view of that window shrank for good. With a + -- window of 65535, the refused 16384 octets and the 16384 of + -- the next request make up the half that is given back. + E.bracket (forkIO runServerSmallConnWindow) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 refusedData `shouldReturn` Just (Just (32768, "16384")) + + it "goes on sending requests after one fails before it is queued" $ + -- The file of this requestFile does not exist, so the request + -- fails after its stream id is taken and before it is queued. + -- Requests are queued in stream id order, so every one after it + -- used to wait for its turn for ever. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + r <- timeout 5000000 $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do + let missing = + C.requestFile methodPost "/echo" [] $ + FileSpec "test/no-such-file" 0 10 + failed <- E.try $ sendRequest missing (const $ return ()) + either (const True) (const False) (failed :: Either E.SomeException ()) + `shouldBe` True + replicateM_ 3 $ + sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> + C.responseStatus rsp `shouldBe` Just ok200 + r `shouldBe` Just () + + it "answers without a push when the peer has no room for one" $ + -- SETTINGS_MAX_CONCURRENT_STREAMS of 0 is how a peer can refuse + -- pushes (RFC 9113, section 8.4). The push of /push-pp used to + -- wait for room for ever, and the response to /push with it. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 pushNoRoom `shouldReturn` Just (Just "HEADERS") + + it "frees the stream of a response the client did not read to the end" $ + -- /endless never ends. Each request here reads one chunk of it + -- and is done, by returning or by throwing. Its stream used to + -- stay open, holding one of the server's 64 slots, with what the + -- server sent never given back to the connection window: the + -- 65th request waited for a slot for ever. Now each is reset, + -- 70 in a burst, which takes a server allowing more resets a + -- second than the default. + E.bracket (forkIO runServerManyResets) killThread $ \_ -> do + threadDelay 10000 + r <- timeout 10000000 $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do + forM_ [1 .. 70 :: Int] $ \i -> do + let abandon rsp = do + _ <- C.getResponseBodyChunk rsp + when (even i) $ E.throwIO $ userError "done with it" + r <- E.try $ sendRequest (C.requestNoBody methodGet "/endless" []) abandon + either (\e -> const (return ()) (e :: E.IOException)) return r + sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> + C.responseStatus rsp `shouldBe` Just ok200 + r `shouldBe` Just () + + it "goes on when pushes nobody asks for fill the connection window" $ + -- Each /push-big comes with a push of 20000 octets that is never + -- asked for. With a connection window of 65535, the fourth push + -- used to find it used up by the first three, unread, and the + -- connection stalled, the responses to /push-big with it. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + let cconf = + C.defaultClientConfig + { C.authority = host + , C.connectionWindowSize = defaultWindowSize + } + r <- timeout 5000000 $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run cconf conf $ \sendRequest _ -> + replicateM_ 10 $ + sendRequest (C.requestNoBody methodGet "/push-big" []) $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + let body = do + bs <- C.getResponseBodyChunk rsp + unless (B.null bs) body + body + r `shouldBe` Just () + + it "counts streams whose handlers are running in its GOAWAY" $ + -- RFC 9113, section 6.8: the last stream identifier is the + -- highest one that "might have been processed". Streams 1 and + -- 3 are being answered when the connection is closed, and used + -- to be left out until their handlers had returned, so the + -- GOAWAY said 0: as if the client could send them again. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 goAwayLastStream `shouldReturn` Just (Just (3, ProtocolError)) + + it "finishes what the server will still answer after its GOAWAY" $ + -- RFC 9113, section 6.8: a GOAWAY with NO_ERROR and last stream 1 + -- says stream 1 will still be answered, stream 3 will not. The + -- client used to close the connection as soon as it came, + -- failing both, and the client function with them. + E.bracket (forkIO runGoAwayServer) killThread $ \_ -> do + threadDelay 10000 + r <- timeout 5000000 $ E.try $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do + let get = E.try . flip sendRequest readAll . C.requestNoBody methodGet "/" $ [] + readAll rsp = do + bs <- C.getResponseBodyChunk rsp + if B.null bs then return "" else (bs <>) <$> readAll rsp + (r1, r3) <- concurrently get (threadDelay 50000 >> get) + -- By now the connection has run its course, + -- and the client function goes on: nothing new + -- goes out, and it is not killed either. + threadDelay 100000 + r5 <- get + return (status r1, status r3, status r5) + case r of + Just (Right rs) -> rs `shouldBe` ("hello", "closed", "closed") + Just (Left e) -> expectationFailure $ show (e :: C.HTTP2Error) + Nothing -> expectationFailure "timed out" + + it "answers the requests it has after the client's GOAWAY" $ + -- A client's GOAWAY speaks of the server's own streams, and + -- the requests it has already sent are still to be answered. + -- The server used to close the connection on it at once. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 goAwayFromClient + `shouldReturn` Just ["HEADERS 1", "DATA 1 END_STREAM", "GOAWAY NoError"] + + it "resets a malformed request and goes on serving the connection" $ + -- An upper-case field name makes the request malformed: a + -- stream error (RFC 9113, section 8.1.1). It used to close the + -- connection, and the next request on it went unanswered. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 malformedRequest + `shouldReturn` Just ["RST_STREAM 1 ProtocolError", "HEADERS 3"] + + it "answers without a body while the connection window is shut" $ + -- HEADERS are not flow-controlled (RFC 9113, section 6.9). The + -- sender used to wait for the connection window before taking + -- anything off its queue, so once /endless had used it up, the + -- response to a request with no body never went out. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 shutWindow `shouldReturn` Just (Just "HEADERS 3, then DATA 1") + + it "sends a PUSH_PROMISE before the response that carries it" $ + -- /push answers with a push of /push-pp, so a request for + -- /push-pp after it is served from the push. The server used to + -- let the response to /push overtake the PUSH_PROMISE now and + -- then; the client then asked the server for /push-pp itself, + -- and got 404. One round in a few dozen did, so 200 of them -- + -- which also takes more pushes than the peer allows concurrent + -- streams, so pushed streams that are never closed show too. + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + done <- newIORef (0 :: Int) + r <- timeout 30000000 $ runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> + replicateM_ 200 $ do + -- Bodies are read to the end, so that the + -- streams close and give their slots back. + let drain rsp = do + bs <- C.getResponseBodyChunk rsp + unless (B.null bs) $ drain rsp + sendRequest (C.requestNoBody methodGet "/push" []) $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + drain rsp + sendRequest (C.requestNoBody methodGet "/push-pp" []) $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + drain rsp + modifyIORef' done (+ 1) + -- How far it got tells a hang (at 64, the peer's concurrency + -- limit, if pushed streams leak) from a slow run. + n <- readIORef done + when (isNothing r) $ + expectationFailure $ + "timed out after " ++ show n ++ " of 200 rounds" + + it "uploads a file through runIO past the stream's window" $ + -- The server announces an 8192-octet window. runIO put the rest + -- of a body back on the queue without waiting for the window to + -- open; with none left, the file was read into no room, and a + -- read of 0 octets is the end of the file, so the request ended + -- with END_STREAM after the first window's worth. + E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do + threadDelay 10000 + timeout 10000000 uploadIO `shouldReturn` Just 100000 + + it "prevents attacks" $ + E.bracket (forkIO runServer) killThread $ \_ -> do + threadDelay 10000 + runAttack rapidSettings `shouldThrow` connectionError "too many settings" + runAttack rapidPing `shouldThrow` connectionError "too many ping" + runAttack rapidEmptyHeader + `shouldThrow` connectionError "too many empty headers" + runAttack rapidEmptyData `shouldThrow` connectionError "too many empty data" + runAttack rapidRst `shouldThrow` connectionError "too many rst_stream" + +ignoreHTTP2Error :: C.HTTP2Error -> IO () +ignoreHTTP2Error _ = pure () + +runServer :: IO () +runServer = runTCPServer (Just host) port runHTTP2Server + where + runHTTP2Server s = + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run defaultServerConfig conf server) + +-- | Like 'runServer', but announcing room for a single concurrent stream. +-- | Uploading 100000 octets of a file through 'C.runIO', and what the server +-- says it received. +uploadIO :: IO Int +uploadIO = runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.runIO C.defaultClientConfig{C.authority = host} conf $ \C.ClientIO{..} -> + return $ do + let body rsp acc = do + bs <- C.getResponseBodyChunk rsp + if B.null bs then return acc else body rsp (acc <> bs) + exchange req = cioWriteRequest req >>= cioReadResponse . snd + -- A request first, so that the server's SETTINGS -- and its + -- small window -- are known before the upload starts. + _ <- exchange (C.requestNoBody methodGet "/" []) >>= (`body` "") + rsp <- + exchange $ + C.requestFile methodPost "/count" [] $ + FileSpec "test/inputFile" 0 100000 + read . C8.unpack <$> body rsp "" + +-- | Running with at least this many capabilities. +withCapabilities :: Int -> IO a -> IO a +withCapabilities n act = + E.bracket getNumCapabilities setNumCapabilities $ \old -> do + setNumCapabilities (max n old) + act + +-- | Room for four concurrent streams and a small window, so that WINDOW_UPDATE +-- frames go back and forth all the time. +runServerSmallWindow :: IO () +runServerSmallWindow = runTCPServer (Just host) port runHTTP2Server + where + sconf = + defaultServerConfig + { settings = + (settings defaultServerConfig) + { maxConcurrentStreams = Just 4 + , initialWindowSize = 8192 + } + } + runHTTP2Server s = do + setSocketOption s NoDelay 1 + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run sconf conf server) + +-- | Like 'runServer', but with the connection window left at its initial +-- 65535 octets. +runServerSmallConnWindow :: IO () +runServerSmallConnWindow = runTCPServer (Just host) port runHTTP2Server + where + sconf = defaultServerConfig{connectionWindowSize = defaultWindowSize} + runHTTP2Server s = + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run sconf conf server) + +-- | Like 'runServer', but allowing a client to reset 1000 streams a second. +runServerManyResets :: IO () +runServerManyResets = runTCPServer (Just host) port runHTTP2Server + where + sconf = + defaultServerConfig + { settings = (settings defaultServerConfig){rstRateLimit = 1000} + } + runHTTP2Server s = + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run sconf conf server) + +runServerMaxConc1 :: IO () +runServerMaxConc1 = runTCPServer (Just host) port runHTTP2Server + where + sconf = + defaultServerConfig + { settings = (settings defaultServerConfig){maxConcurrentStreams = Just 1} + } + runHTTP2Server s = + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run sconf conf server) + +-- | A server whose handler waits long enough for a RST_STREAM to arrive +-- before it responds, and then signals that 'sendResponse' returned. +runServerCancel :: MVar () -> IO () +runServerCancel doneVar = runTCPServer (Just host) port runHTTP2Server + where + runHTTP2Server s = + E.bracket + (allocSimpleConfig s 32768) + freeSimpleConfig + (\conf -> run defaultServerConfig conf cancelServer) + cancelServer _req _aux sendResponse = do + threadDelay 200000 + sendResponse responseHello [] + putMVar doneVar () + +runFakeServer :: MVar ByteString -> IO () +runFakeServer prefaceVar = do + runTCPServer (Just host) port $ \s -> do + ref <- newIORef Nothing + + -- send settings + sendAll s $ + "\x00\x00\x12\x04\x00\x00\x00\x00\x00" + `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00" + `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff" + + -- receive preface + value <- defaultReadN s ref (B.length connectionPreface) + putMVar prefaceVar value + + -- send goaway frame + sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01" + + -- wait for a few ms to make sure the client has a chance to close the + -- socket on its end + threadDelay 10000 + +-- | Answering two requests with a GOAWAY that leaves out the second: the +-- headers of the first response, GOAWAY(NO_ERROR) with last stream 1, and +-- the rest of the first response a little later. +runGoAwayServer :: IO () +runGoAwayServer = runTCPServer (Just host) port $ \s -> do + _ <- recvAll s (B.length connectionPreface) + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let awaitRequests :: Int -> IO () + awaitRequests 2 = return () + awaitRequests n = do + mf <- recvFrame s + case mf of + Nothing -> return () + Just (FrameSettings, fh, _) + | not (testAck (flags fh)) -> do + sendAll s $ + encodeFrame (EncodeInfo (setAck defaultFlags) 0 Nothing) $ + SettingsFrame [] + awaitRequests n + Just (FrameHeaders, _, _) -> awaitRequests (n + 1) + Just _ -> awaitRequests n + awaitRequests 0 + sendAll s $ + encodeFrame (EncodeInfo (setEndHeader defaultFlags) 1 Nothing) $ + HeadersFrame Nothing $ + hpackEncode [(":status", "200")] + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + GoAwayFrame 1 NoError "going" + threadDelay 200000 + sendAll s $ + encodeFrame (EncodeInfo (setEndStream defaultFlags) 1 Nothing) $ + DataFrame "hello" + -- Until the client closes it. + let drain = recvFrame s >>= maybe (return ()) (const drain) + drain + +-- | How a request through the client ended: the body, or "closed" for +-- 'ConnectionIsClosed'. +status :: Either C.HTTP2Error ByteString -> ByteString +status (Right bs) = bs +status (Left C.ConnectionIsClosed) = "closed" +status (Left e) = C8.pack $ show e + +-- | A request for /slow, then GOAWAY(NO_ERROR) at once. What the server +-- sends from then on until it closes the connection. +goAwayFromClient :: IO [String] +goAwayFromClient = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + sendAll s $ + encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing) $ + HeadersFrame Nothing $ + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/slow") + , (":method", "GET") + ] + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + GoAwayFrame 0 NoError "going" + collect s + where + collect s = do + mf <- recvFrame s + case mf of + Nothing -> return [] + Just (FrameHeaders, fh, _) -> (("HEADERS " ++ show (streamId fh)) :) <$> collect s + Just (FrameData, fh, _) + | testEndStream (flags fh) -> + (("DATA " ++ show (streamId fh) ++ " END_STREAM") :) <$> collect s + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + (("GOAWAY " ++ show err) :) <$> collect s + Just _ -> collect s + +server :: Server +server req aux sendResponse = case requestMethod req of + Just "GET" -> case requestPath req of + Just "/" -> sendResponse responseHello [] + -- A moment before the answer. + Just "/slow" -> threadDelay 200000 >> sendResponse responseHello [] + Just "/early" -> do + auxSendInformational + aux + earlyHints103 + [("link", "; rel=preload; as=style")] + auxSendInformational + aux + earlyHints103 + [("link", "; rel=preload; as=script")] + sendResponse responseHello [] + Just "/stream" -> sendResponse responseInfinite [] + -- Like /stream, but going quietly once the client resets it. + Just "/endless" -> sendResponse responseEndless [] + Just "/not-modified" -> sendResponse (responseNoBody notModified304 bigLength) [] + -- Says it has content, and has none: malformed. + Just "/no-content" -> sendResponse (responseNoBody ok200 bigLength) [] + Just "/big" -> sendResponse responseBig [] + Just "/push" -> do + let pp = pushPromise "/push-pp" responsePP 0 + sendResponse responseHello [pp] + -- A push of 20000 octets. + Just "/push-big" -> do + let pp = pushPromise "/push-big-pp" responsePushBig 0 + sendResponse responseHello [pp] + _ -> sendResponse response404 [] + Just "POST" -> case requestPath req of + Just "/echo" -> sendResponse (responseEcho req) [] + -- How many octets of body arrived. + Just "/count" -> do + let count n = do + bs <- getRequestBodyChunk req + if B.null bs then return n else count (n + B.length bs) + n <- count (0 :: Int) + sendResponse (responseBuilder ok200 [] (byteString (C8.pack (show n)))) [] + Just "/both" -> do + -- Read the body on the side, so that the response does not + -- wait for it. + _ <- + forkIO $ + let d = getRequestBodyChunk req >>= \bs -> unless (B.null bs) d + in d + sendResponse responseBoth [] + _ -> sendResponse responseHello [] + Just "HEAD" -> case requestPath req of + -- HEADERS, then an empty DATA frame with END_STREAM. + Just "/data" -> sendResponse (responseBuilder ok200 bigLength mempty) [] + -- HEADERS with END_STREAM. + _ -> sendResponse (responseNoBody ok200 bigLength) [] + _ -> sendResponse response405 [] + +-- | Larger than the default frame size and than the server's 32K buffer. +bigVal :: ByteString +bigVal = C8.replicate 40000 'x' + +responseBig :: Response +responseBig = setResponseTrailersMaker rsp maker + where + rsp = responseBuilder ok200 [("x-big", bigVal)] "hello" + maker Nothing = return $ Trailers [("x-big-trailer", bigVal)] + maker (Just _) = return $ NextTrailersMaker maker + +-- | The stream error a client raises for a malformed response, as +-- 'sendRequest' hands it on. +malformedResponse :: C.HTTP2Error -> Bool +malformedResponse (C.StreamErrorIsSent C.ProtocolError _ _) = True +malformedResponse (C.BadThingHappen se) = + maybe False malformedResponse $ E.fromException se +malformedResponse _ = False + +-- | The content-length of content that is not there. +bigLength :: ResponseHeaders +bigLength = [("content-length", "1234")] + +responseHello :: Response +responseHello = responseBuilder ok200 header body + where + header = [("Content-Type", "text/plain")] + body = byteString "Hello, world!\n" + +earlyHints103 :: Status +earlyHints103 = mkStatus 103 "Early Hints" + +responsePushBig :: Response +responsePushBig = responseBuilder ok200 [] $ byteString $ C8.replicate 20000 'p' + +responsePP :: Response +responsePP = responseBuilder ok200 header body + where + header = + [ ("Content-Type", "text/plain") + , ("x-push", "True") + ] + body = byteString "Push\n" + +-- | A streaming response that does not wait for the request body, so that +-- both ends are sending at once and either can finish first. +responseBoth :: Response +responseBoth = responseStreaming ok200 [] $ \write flush -> + replicateM_ 50 $ write (byteString (C8.replicate 50 'b')) >> flush + +responseEndless :: Response +responseEndless = responseStreaming ok200 [] body + where + body :: (Builder -> IO ()) -> IO () -> IO () + body write flush = forever (write (byteString chunk) *> flush) `E.catch` quiet + chunk = C8.replicate 1024 'x' + quiet :: E.SomeException -> IO () + quiet _ = return () + +responseInfinite :: Response +responseInfinite = responseStreaming ok200 header body + where + header = [("Content-Type", "text/plain")] + body :: (Builder -> IO ()) -> IO () -> IO () + body write flush = do + let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n) + go (0 :: Int) + +response404 :: Response +response404 = responseNoBody notFound404 [] + +response405 :: Response +response405 = responseNoBody methodNotAllowed405 [] + +responseEcho :: Request -> Response +responseEcho req = setResponseTrailersMaker h2rsp maker + where + h2rsp = responseStreaming ok200 header streamingBody + header = [("Content-Type", "text/plain")] + mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req)) + streamingBody write _flush = do + loop + mt <- getRequestTrailers req + firstTrailerValue <$> mt `shouldBe` mhx + where + loop = do + bs <- getRequestBodyChunk req + when (bs /= "") $ do + void $ write $ byteString bs + loop + maker = trailersMaker (CH.hashInit :: Context SHA1) + +-- Strictness is important for Context. +trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker +trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] + where + !sha1 = C8.pack $ show $ CH.hashFinalize ctx +trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' + where + !ctx' = CH.hashUpdate ctx bs + +-- | Request @/early@ with an informational handler installed, recording each +-- 103 Early Hints section and returning the final response status. +runClientEarly :: IORef [TokenHeaderTable] -> IO (Maybe Status) +runClientEarly hintsRef = runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf0 -> + C.run cliconf (conf0{confOnInformational = onInformational}) $ \sendRequest _aux -> + sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus) + where + cliconf = C.defaultClientConfig{C.authority = host} + onInformational _sid tbl = modifyIORef' hintsRef (++ [tbl]) + +runClient :: (Socket -> BufferSize -> IO Config) -> IO () +runClient allocConfig = + runTCPClient host port runHTTP2Client + where + auth = host + cliconf = C.defaultClientConfig{C.authority = auth} + runHTTP2Client s = + E.bracket + (allocConfig s 4096) + freeSimpleConfig + (\conf -> C.run cliconf conf client) + + client :: C.Client () + client sendRequest aux = + foldr1 + concurrently_ + [ client0 sendRequest aux + , client1 sendRequest aux + , client2 sendRequest aux + , client3 sendRequest aux + , client3' sendRequest aux + , client3'' sendRequest aux + , client4 sendRequest aux + , client5 sendRequest aux + ] + +-- delay sending preface to be able to test if it is always sent first +allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config +allocSlowPrefaceConfig s size = do + config <- allocSimpleConfig s size + pure config{confSendAll = slowPrefaceSend (confSendAll config)} + where + slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO () + slowPrefaceSend orig chunk = do + when (C8.pack "PRI" `C8.isPrefixOf` chunk) $ do + threadDelay 10000 + orig chunk + +client0 :: C.Client () +client0 sendRequest _aux = do + let req = C.requestNoBody methodGet "/" [] + sendRequest req $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK" + +client1 :: C.Client () +client1 sendRequest _aux = do + let req = C.requestNoBody methodGet "/push-pp" [] + sendRequest req $ \rsp -> do + C.responseStatus rsp `shouldBe` Just notFound404 + +client2 :: C.Client () +client2 sendRequest _aux = do + let req = C.requestNoBody methodPut "/" [] + sendRequest req $ \rsp -> do + C.responseStatus rsp `shouldBe` Just methodNotAllowed405 + +client3 :: C.Client () +client3 sendRequest _aux = do + let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a" + req0 = + C.requestFile methodPost "/echo" [("X-Tag", hx)] $ + FileSpec "test/inputFile" 0 1012731 + req = C.setRequestTrailersMaker req0 maker + sendRequest req $ \rsp -> do + let consumeBody = do + bs <- C.getResponseBodyChunk rsp + when (bs /= "") consumeBody + consumeBody + mt <- C.getResponseTrailers rsp + firstTrailerValue <$> mt `shouldBe` Just hx + where + !maker = trailersMaker (CH.hashInit :: Context SHA1) + +client3' :: C.Client () +client3' sendRequest _aux = do + let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a" + req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do + let sendFile h = do + bs <- B.hGet h 1024 + when (bs /= "") $ do + write $ byteString bs + sendFile h + withFile "test/inputFile" ReadMode sendFile + req = C.setRequestTrailersMaker req0 maker + sendRequest req $ \rsp -> do + let consumeBody = do + bs <- C.getResponseBodyChunk rsp + when (bs /= "") consumeBody + consumeBody + mt <- C.getResponseTrailers rsp + firstTrailerValue <$> mt `shouldBe` Just hx + where + !maker = trailersMaker (CH.hashInit :: Context SHA1) + +client3'' :: C.Client () +client3'' sendRequest _axu = do + let hx = "59f82dfddc0adf5bdf7494b8704f203a67e25d4a" + req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do + let chunk = C8.replicate (16384 * 2) 'c' + tag = C8.replicate 16 't' + -- I don't think 9 is important here, this is just what I have, the client hangs on receiving the last one + replicateM_ 9 $ write $ byteString chunk + write $ byteString tag + req = C.setRequestTrailersMaker req0 maker + sendRequest req $ \rsp -> do + let consumeBody = do + bs <- C.getResponseBodyChunk rsp + when (bs /= "") consumeBody + consumeBody + mt <- C.getResponseTrailers rsp + firstTrailerValue <$> mt `shouldBe` Just hx + where + !maker = trailersMaker (CH.hashInit :: Context SHA1) + +client4 :: C.Client () +client4 sendRequest _aux = do + let req0 = C.requestNoBody methodGet "/push" [] + sendRequest req0 $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + let req1 = C.requestNoBody methodGet "/push-pp" [] + sendRequest req1 $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + +client5 :: C.Client () +client5 sendRequest _aux = do + let req0 = C.requestNoBody methodGet "/stream" [] + sendRequest req0 $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + let go n + | n > 0 = do + _ <- C.getResponseBodyChunk rsp + go (pred n) + | otherwise = pure () + go (100 :: Int) + +firstTrailerValue :: TokenHeaderTable -> FieldValue +firstTrailerValue tbl = case fst tbl of + [] -> error "firstTrailerValue" + x : _ -> snd x + +runAttack :: (C.ClientIO -> IO ()) -> IO () +runAttack attack = + runTCPClient host port runHTTP2Client + where + auth = host + cliconf = C.defaultClientConfig{C.authority = auth} + runHTTP2Client s = + E.bracket + (allocSimpleConfig s 4096) + freeSimpleConfig + (\conf -> C.runIO cliconf conf client) + client cconf = return $ do + attack cconf + threadDelay 1000000 + +rapidSettings :: C.ClientIO -> IO () +rapidSettings C.ClientIO{..} = do + let einfo = EncodeInfo defaultFlags 0 Nothing + bs = encodeFrame einfo $ SettingsFrame [(SettingsEnablePush, 0)] + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + +rapidPing :: C.ClientIO -> IO () +rapidPing C.ClientIO{..} = do + let einfo = EncodeInfo defaultFlags 0 Nothing + opaque64 = "01234567" + bs = encodeFrame einfo $ PingFrame opaque64 + replicateM_ 20 $ cioWriteBytes bs + +rapidEmptyHeader :: C.ClientIO -> IO () +rapidEmptyHeader C.ClientIO{..} = do + (sid, _) <- cioCreateStream + let einfo = EncodeInfo defaultFlags sid Nothing + bs = encodeFrame einfo $ HeadersFrame Nothing "" + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + cioWriteBytes bs + +rapidEmptyData :: C.ClientIO -> IO () +rapidEmptyData C.ClientIO{..} = do + (sid, _) <- cioCreateStream + let einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr + cioWriteBytes bsH + let einfoD = EncodeInfo defaultFlags sid Nothing + bsD = encodeFrame einfoD $ DataFrame "" + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + cioWriteBytes bsD + +rapidRst :: C.ClientIO -> IO () +rapidRst C.ClientIO{..} = do + reset + reset + reset + reset + reset + reset + reset + reset + where + reset = do + (sid, _) <- cioCreateStream + -- setEndStream for HalfClosedRemote + let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr + cioWriteBytes bsH + let einfoR = EncodeInfo defaultFlags sid Nothing + -- Only (HalfClosedRemote, NoError) is accepted. + -- Otherwise, a stream error terminates the connection. + bsR = encodeFrame einfoR $ RSTStreamFrame NoError + cioWriteBytes bsR + +-- | MadeYouReset (CVE-2025-8671): the same churn as 'rapidRst' without a +-- single RST_STREAM from us. Each stream gets a handler that goes on +-- running, then a PRIORITY making it depend on itself, which the server +-- answers by resetting the stream -- giving its concurrency slot back while +-- the handler runs on. Those resets did not count against the limit on +-- resets, so this could be kept up for as long as the peer liked. +rapidStreamError :: IO (Maybe (ErrorCode, ByteString)) +rapidStreamError = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + forM_ [1, 3 .. 15] $ \sid -> do + let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/stream") + , (":method", "GET") + ] + einfoP = EncodeInfo defaultFlags sid Nothing + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + sendAll s $ encodeFrame einfoP $ PriorityFrame $ Priority False sid 16 + awaitGoAway s + +-- | What the server says in its GOAWAY, if it sends one before closing. +awaitGoAway :: Socket -> IO (Maybe (ErrorCode, ByteString)) +awaitGoAway s = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err msg) <- decodeGoAwayFrame fh p -> + return $ Just (err, msg) + Just _ -> awaitGoAway s + +-- | A SETTINGS_INITIAL_WINDOW_SIZE that takes an open stream's window past +-- 2^31-1. What the server answers with: whether it reset the stream, and +-- the error in its GOAWAY. +settingsOverflow :: IO (Bool, Maybe ErrorCode) +settingsOverflow = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let sid = 1 + -- No END_STREAM: the stream stays open, waiting for the body. + einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/echo") + , (":method", "POST") + ] + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + -- The stream's window is now the largest there is ... + sendAll s $ + encodeFrame (EncodeInfo defaultFlags sid Nothing) $ + WindowUpdateFrame (maxWindowSize - defaultWindowSize) + -- ... and one more octet of initial window takes it over. + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + SettingsFrame [(SettingsInitialWindowSize, defaultWindowSize + 1)] + answer s False + where + answer s reset = do + mf <- recvFrame s + case mf of + Nothing -> return (reset, Nothing) + Just (FrameRSTStream, _, _) -> answer s True + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return (reset, Just err) + Just _ -> answer s reset + +-- | A request whose body ends with an empty trailer block. What the +-- server answers it with. +emptyTrailers :: IO (Maybe String) +emptyTrailers = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let sid = 1 + einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/count") + , (":method", "POST") + ] + einfoT = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + sendAll s $ encodeFrame (EncodeInfo defaultFlags sid Nothing) $ DataFrame "body" + sendAll s $ encodeFrame einfoT $ HeadersFrame Nothing "" + answer s sid + where + answer s sid = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameHeaders, fh, _) + | streamId fh == sid -> return $ Just "HEADERS" + Just (FrameRSTStream, fh, p) + | streamId fh == sid + , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> + return $ Just $ "RST_STREAM " ++ show err + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err + Just _ -> answer s sid + +-- | A request with a content-length of 4, whose body comes in padded DATA +-- frames: "bo", "dy", and an empty one with END_STREAM. What the server +-- answers it with: the body of its response, which is the number of octets +-- of body that arrived. +paddedBody :: IO (Maybe String) +paddedBody = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let sid = 1 + einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/count") + , (":method", "POST") + , ("content-length", "4") + ] + padding = C8.replicate 10 '\0' + einfoD = EncodeInfo defaultFlags sid (Just padding) + einfoE = EncodeInfo (setEndStream defaultFlags) sid (Just padding) + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + sendAll s $ encodeFrame einfoD $ DataFrame "bo" + sendAll s $ encodeFrame einfoD $ DataFrame "dy" + sendAll s $ encodeFrame einfoE $ DataFrame "" + answer s sid + where + answer s sid = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameData, fh, p) + | streamId fh == sid -> return $ Just $ "DATA " ++ C8.unpack p + Just (FrameRSTStream, fh, p) + | streamId fh == sid + , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> + return $ Just $ "RST_STREAM " ++ show err + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err + Just _ -> answer s sid + +-- | A request whose body is 2000 DATA frames of one octet each, padded to +-- 257 octets of payload, more than the stream's window in all. Sent +-- without waiting for WINDOW_UPDATE: every octet of padding has to have +-- been given back by the time the next frame is checked. What the server +-- answers it with: the number of octets of body that arrived. +paddingWindow :: IO (Maybe String) +paddingWindow = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let sid = 1 + einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/count") + , (":method", "POST") + ] + padding = C8.replicate 255 '\0' + einfoD = EncodeInfo defaultFlags sid (Just padding) + einfoE = EncodeInfo (setEndStream defaultFlags) sid Nothing + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + replicateM_ 2000 $ sendAll s $ encodeFrame einfoD $ DataFrame "x" + sendAll s $ encodeFrame einfoE $ DataFrame "" + answer s sid + where + answer s sid = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameData, fh, p) + | streamId fh == sid -> return $ Just $ "DATA " ++ C8.unpack p + Just (FrameRSTStream, fh, p) + | streamId fh == sid + , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> + return $ Just $ "RST_STREAM " ++ show err + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err msg) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err ++ " " ++ C8.unpack msg + Just _ -> answer s sid + +-- | 16384 octets of DATA on a stream we have half-closed, then a request +-- with a body of 16384 octets. What the server gives back to the +-- connection window before answering the request, and the answer: the +-- number of octets of body that arrived. +refusedData :: IO (Maybe (Int, String)) +refusedData = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let request sid method path flags = + encodeFrame (EncodeInfo (flags $ setEndHeader defaultFlags) sid Nothing) $ + HeadersFrame Nothing $ + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", path) + , (":method", method) + ] + chunk = C8.replicate 16384 'x' + -- A response that goes on for ever keeps stream 1 in the table. + sendAll s $ request 1 "GET" "/stream" setEndStream + sendAll s $ encodeFrame (EncodeInfo defaultFlags 1 Nothing) $ DataFrame chunk + sendAll s $ request 3 "POST" "/count" id + sendAll s $ + encodeFrame (EncodeInfo (setEndStream defaultFlags) 3 Nothing) $ + DataFrame chunk + answer s 0 + where + answer s n = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameWindowUpdate, fh, p) + | streamId fh == 0 + , Right (WindowUpdateFrame w) <- decodeWindowUpdateFrame fh p -> + answer s (n + w) + Just (FrameData, fh, p) + | streamId fh == 3 -> return $ Just (n, C8.unpack p) + Just (FrameGoAway, _, _) -> return Nothing + Just _ -> answer s n + +-- | A request for /push, which comes with a push, from a peer that has +-- announced room for no streams of the server's. What the server answers +-- it with first. +pushNoRoom :: IO (Maybe String) +pushNoRoom = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + SettingsFrame [(SettingsMaxConcurrentStreams, 0)] + -- The server takes our SETTINGS on board once it has acknowledged them, + -- and before it goes on to what comes next: the answer to a PING sent + -- after them. + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + PingFrame "12345678" + awaitPingAck s + let sid = 1 + einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/push") + , (":method", "GET") + ] + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + answer s sid + where + awaitPingAck s = do + mf <- recvFrame s + case mf of + Just (FramePing, fh, _) | testAck (flags fh) -> return () + Just _ -> awaitPingAck s + Nothing -> return () + answer s sid = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameHeaders, fh, _) + | streamId fh == sid -> return $ Just "HEADERS" + Just (FramePushPromise, _, _) -> return $ Just "PUSH_PROMISE" + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err + Just _ -> answer s sid + +-- | Two requests that are answered for ever, then SETTINGS that are a +-- connection error. The last stream identifier and the error of the +-- server's GOAWAY. +goAwayLastStream :: IO (Maybe (StreamId, ErrorCode)) +goAwayLastStream = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + forM_ [1, 3] $ \sid -> + sendAll s $ + encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $ + HeadersFrame Nothing $ + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/endless") + , (":method", "GET") + ] + -- SETTINGS_ENABLE_PUSH can only be 0 or 1. + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + SettingsFrame [(SettingsEnablePush, 2)] + answer s + where + answer s = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame sid err _) <- decodeGoAwayFrame fh p -> + return $ Just (sid, err) + Just _ -> answer s + +-- | A request with an upper-case field name on stream 1, then a good one +-- on stream 3. What the server sends on them, up to the answer on 3. +malformedRequest :: IO [String] +malformedRequest = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let request sid extra = + encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $ + HeadersFrame Nothing $ + hpackEncode $ + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + ++ extra + sendAll s $ request 1 [("X-Upper", "1")] + sendAll s $ request 3 [] + collect s + where + collect s = do + mf <- recvFrame s + case mf of + Nothing -> return [] + Just (FrameHeaders, fh, _) + | streamId fh == 3 -> return ["HEADERS 3"] + Just (FrameRSTStream, fh, p) + | Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> + (("RST_STREAM " ++ show (streamId fh) ++ " " ++ show err) :) <$> collect s + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return ["GOAWAY " ++ show err] + Just _ -> collect s + +-- | /endless until the server has used up the connection window, which we +-- do not open, then a request whose answer has no body: what the server +-- sends for it. Then the windows opened a little: whether the body held +-- back goes on. +shutWindow :: IO (Maybe String) +shutWindow = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + let request sid path = + encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $ + HeadersFrame Nothing $ + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", path) + , (":method", "GET") + ] + sendAll s $ request 1 "/endless" + used <- untilShut s 0 + if not used + then return Nothing + else do + sendAll s $ request 3 "/not-modified" + ma <- answer s + case ma of + Just "HEADERS 3" -> do + forM_ [0, 1] $ \sid -> + sendAll s $ + encodeFrame (EncodeInfo defaultFlags sid Nothing) $ + WindowUpdateFrame 1000 + fmap ("HEADERS 3, then " ++) <$> resumed s + _ -> return ma + where + resumed s = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameData, fh, _) + | streamId fh == 1 -> return $ Just "DATA 1" + Just _ -> resumed s + untilShut s n + | n >= defaultWindowSize = return True + | otherwise = do + mf <- recvFrame s + case mf of + Nothing -> return False + Just (FrameData, fh, _) -> untilShut s (n + payloadLength fh) + Just _ -> untilShut s n + answer s = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameHeaders, fh, _) + | streamId fh == 3 -> return $ Just "HEADERS 3" + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err + Just _ -> answer s + +-- | PRIORITY frames for 100 streams that are never opened, then a request. +-- What the server answers the request with. +idlePriority :: IO (Maybe String) +idlePriority = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + forM_ [3, 5 .. 201] $ \sid -> + sendAll s $ + encodeFrame (EncodeInfo defaultFlags sid Nothing) $ + PriorityFrame $ + Priority False 0 16 + let sid = 203 + einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr + answer s sid + where + answer s sid = do + mf <- recvFrame s + case mf of + Nothing -> return Nothing + Just (FrameHeaders, fh, _) + | streamId fh == sid -> return $ Just "HEADERS" + Just (FrameRSTStream, fh, p) + | streamId fh == sid + , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> + return $ Just $ "RST_STREAM " ++ show err + Just (FrameGoAway, fh, p) + | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p -> + return $ Just $ "GOAWAY " ++ show err + Just _ -> answer s sid + +-- | Exactly so many octets off a raw connection, or fewer once it is closed. +recvAll :: Socket -> Int -> IO ByteString +recvAll s n0 = go n0 [] + where + go 0 acc = return $ B.concat $ reverse acc + go k acc = do + bs <- recv s k + if B.null bs + then return $ B.concat $ reverse acc + else go (k - B.length bs) (bs : acc) + +-- | One frame off a raw connection, or 'Nothing' once it is closed. +recvFrame :: Socket -> IO (Maybe (FrameType, FrameHeader, ByteString)) +recvFrame s = do + mh <- recvExactly frameHeaderLength + case mh of + Nothing -> return Nothing + Just h -> do + let (ftyp, fh) = decodeFrameHeader h + fmap (\p -> (ftyp, fh, p)) <$> recvExactly (payloadLength fh) + where + recvExactly n = go n [] + where + go 0 acc = return $ Just $ B.concat $ reverse acc + go k acc = do + bs <- recv s k + if B.null bs + then return Nothing + else go (k - B.length bs) (bs : acc) + +-- | Open a stream, reset it, then open two more. The server announced room +-- for one concurrent stream, so the third one here must be refused. +-- +-- Closing a stream used to give its slot back twice -- a RST_STREAM carrying a +-- non-critical error code is closed by both 'stream' and 'processState' -- so +-- the count drifted down by one on every reset and this sequence went through +-- unchallenged. +-- | A HEADERS frame opening a stream and leaving it open, so that it goes on +-- holding a concurrency slot. +-- +-- Stream identifiers are written out rather than taken from +-- 'C.cioCreateStream': the limit being overrun is the one the server +-- announced, and asking for a stream the proper way would block on that same +-- limit on this side. +openStreamFrame :: StreamId -> ByteString +openStreamFrame sid = encodeFrame einfo $ HeadersFrame Nothing hdr + where + einfo = EncodeInfo (setEndHeader defaultFlags) sid Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + +-- | Speak raw frames to the server and collect what it says back. +rawExchange :: [ByteString] -> IO [(FrameType, StreamId, ByteString)] +rawExchange out = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame [] + mapM_ (sendAll s) out + splitFrames <$> collect mempty s + where + collect acc s = do + mbs <- timeout 300000 $ recv s 4096 + case mbs of + Just bs | not (B.null bs) -> collect (acc `B.append` bs) s + _ -> return acc + +splitFrames :: ByteString -> [(FrameType, StreamId, ByteString)] +splitFrames bs + | B.length bs < frameHeaderLength = [] + | otherwise = + let (h, rest) = B.splitAt frameHeaderLength bs + (typ, FrameHeader{payloadLength, streamId}) = decodeFrameHeader h + (body, rest') = B.splitAt payloadLength rest + in (typ, streamId, body) : splitFrames rest' + +-- | The RST_STREAM and GOAWAY frames among them, with their error codes. +resets + :: [(FrameType, StreamId, ByteString)] -> [(FrameType, StreamId, ErrorCode)] +resets frames = + [ (typ, sid, ec) + | (typ, sid, body) <- frames + , typ == FrameRSTStream || typ == FrameGoAway + , Just ec <- [errorCodeOf typ sid body] + ] + where + errorCodeOf FrameRSTStream sid body = + case decodeRSTStreamFrame (FrameHeader (B.length body) defaultFlags sid) body of + Right (RSTStreamFrame ec) -> Just ec + _ -> Nothing + errorCodeOf FrameGoAway sid body = + case decodeGoAwayFrame (FrameHeader (B.length body) defaultFlags sid) body of + Right (GoAwayFrame _ ec _) -> Just ec + _ -> Nothing + errorCodeOf _ _ _ = Nothing + +-- | Open a stream and cancel it straight away, while the server is still +-- working on the response. +-- +-- The sender skips a stream that is already half-closed, and used to return +-- without telling the thread that enqueued the output. That thread sat in +-- 'syncWithSender'' on an MVar nothing would fill, so 'sendResponse' never +-- returned and the worker was only reclaimed when the timeout manager killed +-- it, seconds later. +cancelInFlight :: C.ClientIO -> IO () +cancelInFlight C.ClientIO{..} = do + -- setEndStream for HalfClosedRemote, so that CANCEL is accepted as a + -- stream error rather than taken down the connection. + let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing + hdr = + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + cioWriteBytes $ encodeFrame einfoH $ HeadersFrame Nothing hdr + cioWriteBytes $ + encodeFrame (EncodeInfo defaultFlags 1 Nothing) $ + RSTStreamFrame Cancel + +-- | Send a malformed request, then a good one down the same connection. +-- +-- RFC 9113 section 8.1.1 makes a malformed request a stream error, so the +-- server must reset that one stream and keep serving: the second request is +-- the point of the test. The whole connection used to come down with the +-- first, taking every other stream on it along. +runStreamErrorClient :: IO () +runStreamErrorClient = runTCPClient host port $ \s -> + E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf -> + C.run cliconf conf $ \sendRequest _aux -> do + -- "te" may only ever be "trailers" (section 8.2.2), and unlike + -- "connection" it is not one of the headers the sender strips. + let bad = C.requestNoBody methodGet "/" [("te", "gzip")] + sendRequest bad (\_ -> return ()) `shouldThrow` streamWasReset + let good = C.requestNoBody methodGet "/" [] + sendRequest good $ \rsp -> + C.responseStatus rsp `shouldBe` Just ok200 + where + cliconf = C.defaultClientConfig{C.authority = host} + +streamWasReset :: Selector C.HTTP2Error +streamWasReset C.StreamResetIsReceived{} = True +streamWasReset _ = False + +-- | A HEADERS frame with PADDED and PRIORITY set, six octets of payload and a +-- Pad Length of five, so that the padding covers the whole of the priority +-- fields the flag promises. +-- +-- Six octets is the smallest payload the frame header check accepts for those +-- two flags together, so this gets through it; the decoder then took the five +-- priority octets out of what padding had left empty, reading off the end of +-- the buffer. The empty ByteString is the shared one, whose pointer is null, +-- so what died was the process rather than the connection. +paddingOverPriority :: C.ClientIO -> IO () +paddingOverPriority C.ClientIO{..} = do + let flags = setPadded $ setPriority $ setEndHeader defaultFlags + header = encodeFrameHeader FrameHeaders $ FrameHeader 6 flags 1 + payload = B.pack [5, 0, 0, 0, 0, 0] -- Pad Length 5, then the padding + cioWriteBytes $ header `B.append` payload connectionError :: C.ReasonPhrase -> C.HTTP2Error -> Bool connectionError phrase (C.ConnectionErrorIsReceived _ _ p) diff --git a/test2/ServerSpec.hs b/test2/ServerSpec.hs --- a/test2/ServerSpec.hs +++ b/test2/ServerSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module ServerSpec (spec) where @@ -34,7 +33,7 @@ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig - (`run` server) + (\conf -> run defaultServerConfig conf server) server :: Server server req _aux sendResponse = case requestMethod req of diff --git a/util/Client.hs b/util/Client.hs new file mode 100644 --- /dev/null +++ b/util/Client.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Client where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.UnixTime +import Foreign.C.Types +import Network.HTTP.Types +import System.IO +import Text.Printf + +import Network.HTTP2.Client + +import Monitor + +data Options = Options + { optPerformance :: Int + , optNumOfReqs :: Int + , optMonitor :: Bool + , optInteractive :: Bool + } + deriving (Show) + +client :: Options -> [Path] -> Client () +client Options{..} paths sendRequest _aux = do + labelMe "h2c client" + let cli + | optPerformance /= 0 = clientPF optPerformance sendRequest + | otherwise = clientNReqs optNumOfReqs sendRequest + ex <- E.try $ mapConcurrently_ cli paths + case ex of + Right () -> return () + Left e -> print (e :: HTTP2Error) + +clientNReqs :: Int -> SendRequest -> Path -> IO () +clientNReqs n0 sendRequest path = do + labelMe "h2c clinet N requests" + loop n0 + where + req = requestNoBody methodGet path [] + loop 0 = return () + loop n = do + sendRequest req $ \rsp -> do + print $ responseStatus rsp + getResponseBodyChunk rsp >>= C8.putStrLn + loop (n - 1) + +-- Path is dummy +clientPF :: Int -> SendRequest -> Path -> IO () +clientPF n sendRequest _ = do + labelMe "h2c clinet performance" + t1 <- getUnixTime + sendRequest req loop + t2 <- getUnixTime + printThroughput t1 t2 n + where + req = requestNoBody methodGet path [] + path = "/perf/" <> C8.pack (show n) + loop rsp = do + bs <- getResponseBodyChunk rsp + when (bs /= "") $ loop rsp + +printThroughput :: UnixTime -> UnixTime -> Int -> IO () +printThroughput t1 t2 n = + printf + "Throughput %.2f Mbps (%d bytes in %d msecs)\n" + bytesPerSeconds + n + millisecs + where + UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1 + millisecs :: Int + millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000 + bytesPerSeconds :: Double + bytesPerSeconds = + fromIntegral n + * (1000 :: Double) + * 8 + / fromIntegral millisecs + / 1024 + / 1024 + +console + :: Options -> [ByteString] -> IO () -> Aux -> IO () +console _opt paths cli aux = do + putStrLn "q -- quit" + putStrLn "g -- get" + putStrLn "p -- ping" + mvar <- newEmptyMVar + loop mvar `E.catch` \(E.SomeException _) -> return () + where + loop mvar = do + hSetBuffering stdout NoBuffering + putStr "> " + hSetBuffering stdout LineBuffering + l <- getLine + case l of + "q" -> putStrLn "bye" + "g" -> do + mapM_ (\p -> putStrLn $ "GET " ++ C8.unpack p) paths + _ <- forkIO $ cli >> putMVar mvar () + takeMVar mvar + loop mvar + "p" -> do + putStrLn "Ping" + auxSendPing aux + loop mvar + _ -> do + putStrLn "No such command" + loop mvar diff --git a/util/Monitor.hs b/util/Monitor.hs new file mode 100644 --- /dev/null +++ b/util/Monitor.hs @@ -0,0 +1,30 @@ +module Monitor (monitor, labelMe) where + +import Control.Monad +import Data.List +import Data.Maybe +import GHC.Conc.Sync + +monitor :: IO () -> IO () +monitor action = do + labelMe "monitor" + forever $ do + action + threadSummary >>= mapM_ (putStrLn . showT) + putStr "\n" + where + showT (i, l, s) = i ++ " " ++ l ++ ": " ++ show s + +threadSummary :: IO [(String, String, ThreadStatus)] +threadSummary = listThreads >>= mapM summary . sort + where + summary t = do + let idstr = drop 9 $ show t + l <- fromMaybe "(no name)" <$> threadLabel t + s <- threadStatus t + return (idstr, l, s) + +labelMe :: String -> IO () +labelMe lbl = do + tid <- myThreadId + labelThread tid lbl diff --git a/util/Server.hs b/util/Server.hs new file mode 100644 --- /dev/null +++ b/util/Server.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Server where + +import Control.Monad +import Crypto.Hash (Context, SHA1) -- crypton +import qualified Crypto.Hash as CH +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Types +import Network.HTTP2.Server + +server :: Server +server req _aux sendResponse = case requestMethod req of + Just "GET" -> case requestPath req of + Nothing -> sendResponse response404 [] + Just path + | path == "/" -> sendResponse responseHello [] + | "/perf/" `B.isPrefixOf` path -> do + case C8.readInt (B.drop 6 path) of + Nothing -> sendResponse responseHello [] + Just (n, _) -> sendResponse (responsePerf n) [] + | otherwise -> sendResponse response404 [] + Just "POST" -> sendResponse (responseEcho req) [] + _ -> sendResponse response404 [] + +responseHello :: Response +responseHello = responseBuilder ok200 header body + where + header = [("Content-Type", "text/plain")] + body = byteString "Hello, world!\n" + +responsePerf :: Int -> Response +responsePerf n0 = responseStreaming ok200 header streaming + where + header = [("Content-Type", "text/plain")] + bs1024 = BB.byteString $ B.replicate 1024 65 + streaming write _flush = loop n0 + where + loop 0 = return () + loop n + | n < 1024 = write $ BB.byteString $ B.replicate (fromIntegral n) 65 + | otherwise = do + write bs1024 + loop (n - 1024) + +response404 :: Response +response404 = responseBuilder notFound404 header body + where + header = [("Content-Type", "text/plain")] + body = byteString "Not found\n" + +responseEcho :: Request -> Response +responseEcho req = setResponseTrailersMaker h2rsp maker + where + h2rsp = responseStreaming ok200 header streamingBody + header = [("Content-Type", "text/plain")] + streamingBody write _flush = loop + where + loop = do + bs <- getRequestBodyChunk req + unless (B.null bs) $ do + void $ write $ byteString bs + loop + maker = trailersMaker (CH.hashInit :: Context SHA1) + +-- Strictness is important for Context. +trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker +trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] + where + sha1 = C8.pack $ show $ CH.hashFinalize ctx +trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' + where + ctx' = CH.hashUpdate ctx bs diff --git a/util/client.hs b/util/client.hs deleted file mode 100644 --- a/util/client.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Main where - -import Control.Concurrent.Async -import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as C8 -import Network.HTTP.Types -import Network.Run.TCP (runTCPClient) -- network-run -import System.Environment -import System.Exit - -import Network.HTTP2.Client - -serverName :: String -serverName = "127.0.0.1" - -main :: IO () -main = do - args <- getArgs - (host, port) <- case args of - [h, p] -> return (h, p) - _ -> do - putStrLn "client " - exitFailure - runTCPClient serverName port $ runHTTP2Client host - where - cliconf host = defaultClientConfig{authority = C8.pack host} - runHTTP2Client host s = - E.bracket - (allocSimpleConfig s 4096) - freeSimpleConfig - (\conf -> run (cliconf host) conf client) - client :: Client () - client sendRequest _aux = do - let req0 = requestNoBody methodGet "/" [] - client0 = sendRequest req0 $ \rsp -> do - print rsp - getResponseBodyChunk rsp >>= C8.putStrLn - req1 = requestNoBody methodGet "/foo" [] - client1 = sendRequest req1 $ \rsp -> do - print rsp - getResponseBodyChunk rsp >>= C8.putStrLn - ex <- E.try $ concurrently_ client0 client1 - case ex of - Left e -> print (e :: HTTP2Error) - Right () -> putStrLn "OK" diff --git a/util/h2c-client.hs b/util/h2c-client.hs new file mode 100644 --- /dev/null +++ b/util/h2c-client.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Main where + +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP2.Client +import Network.Run.TCP (runTCPClient) +import Network.Socket +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Client +import Monitor + +defaultOptions :: Options +defaultOptions = + Options + { optPerformance = 0 + , optNumOfReqs = 1 + , optMonitor = False + , optInteractive = False + } + +usage :: String +usage = "Usage: h2c-client [OPTION] addr port [path]" + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['t'] + ["performance"] + (ReqArg (\n o -> o{optPerformance = read n}) "") + "measure performance" + , Option + ['n'] + ["number-of-requests"] + (ReqArg (\n o -> o{optNumOfReqs = read n}) "") + "specify the number of requests" + , Option + ['m'] + ["monitor"] + (NoArg (\opts -> opts{optMonitor = True})) + "run thread monitor" + , Option + ['i'] + ["interactive"] + (NoArg (\o -> o{optInteractive = True})) + "enter interactive mode" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + exitFailure + +clientOpts :: [String] -> IO (Options, [String]) +clientOpts argv = + case getOpt Permute options argv of + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs + +main :: IO () +main = do + labelMe "h2c-client main" + args <- getArgs + (opts, ips) <- clientOpts args + (host, port, paths) <- case ips of + [] -> showUsageAndExit usage + _ : [] -> showUsageAndExit usage + h : p : [] -> return (h, p, ["/"]) + h : p : ps -> return (h, p, C8.pack <$> ps) + when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000 + let cliconf = defaultClientConfig{authority = host} + run' cliconf host port $ client' opts paths + +run' :: ClientConfig -> HostName -> ServiceName -> Client a -> IO a +run' cliconf host port f = runTCPClient host port $ \s -> + E.bracket + (allocSimpleConfig' s 4096 10000000) + freeSimpleConfig + (\conf -> run cliconf conf f) + +client' :: Options -> [Path] -> Client () +client' opts paths sendRequest _aux + | optInteractive opts = do + let action = client opts paths sendRequest _aux + console opts paths action _aux + return () + | otherwise = client opts paths sendRequest _aux diff --git a/util/h2c-server.hs b/util/h2c-server.hs new file mode 100644 --- /dev/null +++ b/util/h2c-server.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +import Network.HTTP2.Server +import Network.Run.TCP +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Monitor +import Server + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['m'] + ["monitor"] + (NoArg (\opts -> opts{optMonitor = True})) + "run thread monitor" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + exitFailure + +serverOpts :: [String] -> IO (Options, [String]) +serverOpts argv = + case getOpt Permute options argv of + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs + +newtype Options = Options + { optMonitor :: Bool + } + deriving (Show) + +defaultOptions :: Options +defaultOptions = + Options + { optMonitor = False + } + +usage :: String +usage = "Usage: h2c-server [OPTION] " + +main :: IO () +main = do + labelMe "h2c-server main" + args <- getArgs + (opts, ips) <- serverOpts args + (host, port) <- case ips of + [h, p] -> return (h, p) + _ -> showUsageAndExit usage + when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000 + runTCPServer (Just host) port $ \s -> do + E.bracket + (allocSimpleConfig' s 4096 5000000) + freeSimpleConfig + (\conf -> run defaultServerConfig conf server) diff --git a/util/server.hs b/util/server.hs deleted file mode 100644 --- a/util/server.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main (main) where - -import qualified Control.Exception as E -import Control.Monad -import Crypto.Hash (Context, SHA1) -- cryptonite -import qualified Crypto.Hash as CH -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Builder (byteString) -import qualified Data.ByteString.Char8 as C8 -import Network.HPACK -import Network.HPACK.Token -import Network.HTTP.Types -import Network.Run.TCP -- network-run -import System.Environment -import System.Exit - -import Network.HTTP2.Server - -main :: IO () -main = do - args <- getArgs - (host, port) <- case args of - [h, p] -> return (h, p) - _ -> do - putStrLn "server " - exitFailure - runTCPServer (Just host) port runHTTP2Server - where - runHTTP2Server s = - E.bracket - (allocSimpleConfig s 4096) - freeSimpleConfig - (\conf -> run defaultServerConfig conf server) - server req _aux sendResponse = case getHeaderValue tokenMethod vt of - Just "GET" -> sendResponse responseHello [] - Just "POST" -> sendResponse (responseEcho req) [] - _ -> sendResponse response404 [] - where - (_, vt) = requestHeaders req - -responseHello :: Response -responseHello = responseBuilder ok200 header body - where - header = [("Content-Type", "text/plain")] - body = byteString "Hello, world!\n" - -response404 :: Response -response404 = responseNoBody notFound404 [] - -responseEcho :: Request -> Response -responseEcho req = setResponseTrailersMaker h2rsp maker - where - h2rsp = responseStreaming ok200 header streamingBody - header = [("Content-Type", "text/plain")] - streamingBody write _flush = loop - where - loop = do - bs <- getRequestBodyChunk req - unless (B.null bs) $ do - void $ write $ byteString bs - loop - maker = trailersMaker (CH.hashInit :: Context SHA1) - --- Strictness is important for Context. -trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker -trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] - where - !sha1 = C8.pack $ show $ CH.hashFinalize ctx -trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' - where - !ctx' = CH.hashUpdate ctx bs