http2 5.1.4 → 5.4.7
raw patch · 73 files changed
Files
- ChangeLog.md +314/−1
- Imports.hs +13/−0
- Network/HPACK.hs +11/−14
- Network/HPACK/HeaderBlock.hs +3/−3
- Network/HPACK/HeaderBlock/Decode.hs +68/−56
- Network/HPACK/HeaderBlock/Encode.hs +38/−63
- Network/HPACK/HeaderBlock/Integer.hs +36/−8
- Network/HPACK/Huffman/Decode.hs +25/−10
- Network/HPACK/Huffman/Encode.hs +2/−2
- Network/HPACK/Huffman/Tree.hs +7/−3
- Network/HPACK/Internal.hs +5/−0
- Network/HPACK/Table/Dynamic.hs +55/−27
- Network/HPACK/Table/Entry.hs +14/−14
- Network/HPACK/Table/RevIndex.hs +28/−27
- Network/HPACK/Table/Static.hs +1/−0
- Network/HPACK/Token.hs +2/−482
- Network/HPACK/Types.hs +7/−31
- Network/HTTP2/Client.hs +25/−137
- Network/HTTP2/Client/Internal.hs +4/−1
- Network/HTTP2/Client/Run.hs +197/−92
- Network/HTTP2/Client/Types.hs +0/−25
- Network/HTTP2/Frame.hs +1/−1
- Network/HTTP2/Frame/Decode.hs +107/−36
- Network/HTTP2/Frame/Types.hs +8/−9
- Network/HTTP2/H2.hs +2/−8
- Network/HTTP2/H2/Config.hs +23/−20
- Network/HTTP2/H2/Context.hs +326/−119
- Network/HTTP2/H2/EncodeFrame.hs +3/−3
- Network/HTTP2/H2/File.hs +0/−38
- Network/HTTP2/H2/HPACK.hs +91/−21
- Network/HTTP2/H2/Manager.hs +0/−182
- Network/HTTP2/H2/OutBodyIface.hs +130/−0
- Network/HTTP2/H2/Queue.hs +6/−13
- Network/HTTP2/H2/ReadN.hs +0/−40
- Network/HTTP2/H2/Receiver.hs +541/−222
- Network/HTTP2/H2/Sender.hs +299/−362
- Network/HTTP2/H2/Settings.hs +16/−8
- Network/HTTP2/H2/Status.hs +0/−44
- Network/HTTP2/H2/Stream.hs +31/−21
- Network/HTTP2/H2/StreamTable.hs +26/−12
- Network/HTTP2/H2/Sync.hs +155/−0
- Network/HTTP2/H2/Types.hs +90/−189
- Network/HTTP2/H2/Window.hs +92/−11
- Network/HTTP2/Internal.hs +0/−39
- Network/HTTP2/Server.hs +21/−168
- Network/HTTP2/Server/Internal.hs +5/−1
- Network/HTTP2/Server/Run.hs +78/−54
- Network/HTTP2/Server/Types.hs +0/−43
- Network/HTTP2/Server/Worker.hs +186/−196
- bench-hpack/Main.hs +4/−4
- http2.cabal +36/−37
- test-frame/FrameSpec.hs +2/−2
- test-frame/frame-encode.hs +0/−2
- test-hpack/HPACKDecode.hs +5/−5
- test-hpack/HPACKEncode.hs +1/−1
- test-hpack/JSON.hs +11/−8
- test-hpack/hpack-stat.hs +2/−1
- test/HPACK/DecodeSpec.hs +122/−5
- test/HPACK/EncodeSpec.hs +30/−2
- test/HPACK/HeaderBlock.hs +8/−8
- test/HPACK/HuffmanSpec.hs +4/−0
- test/HPACK/IntegerSpec.hs +32/−0
- test/HTTP2/ClientSpec.hs +18/−11
- test/HTTP2/FrameSpec.hs +55/−0
- test/HTTP2/ServerSpec.hs +1696/−416
- test2/ServerSpec.hs +1/−2
- util/Client.hs +117/−0
- util/Monitor.hs +30/−0
- util/Server.hs +77/−0
- util/client.hs +0/−48
- util/h2c-client.hs +95/−0
- util/h2c-server.hs +65/−0
- util/server.hs +0/−75
ChangeLog.md view
@@ -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)
Imports.hs view
@@ -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
Network/HPACK.hs view
@@ -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
Network/HPACK/HeaderBlock.hs view
@@ -2,9 +2,9 @@ decodeHeader, decodeTokenHeader, ValueTable,- HeaderTable,- toHeaderTable,- getHeaderValue,+ TokenHeaderTable,+ toTokenHeaderTable,+ getFieldValue, encodeHeader, encodeTokenHeader, ) where
Network/HPACK/HeaderBlock/Decode.hs view
@@ -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)
Network/HPACK/HeaderBlock/Encode.hs view
@@ -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)
Network/HPACK/HeaderBlock/Integer.hs view
@@ -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
Network/HPACK/Huffman/Decode.hs view
@@ -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 ----------------------------------------------------------------
Network/HPACK/Huffman/Encode.hs view
@@ -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
Network/HPACK/Huffman/Tree.hs view
@@ -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
Network/HPACK/Internal.hs view
@@ -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 (..))
Network/HPACK/Table/Dynamic.hs view
@@ -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
Network/HPACK/Table/Entry.hs view
@@ -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 ----------------------------------------------------------------
Network/HPACK/Table/RevIndex.hs view
@@ -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'
Network/HPACK/Table/Static.hs view
@@ -9,6 +9,7 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry+import Network.HTTP.Types (Header) ----------------------------------------------------------------
Network/HPACK/Token.hs view
@@ -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
Network/HPACK/Types.hs view
@@ -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
Network/HTTP2/Client.hs view
@@ -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
Network/HTTP2/Client/Internal.hs view
@@ -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
Network/HTTP2/Client/Run.hs view
@@ -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
− Network/HTTP2/Client/Types.hs
@@ -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.- }
Network/HTTP2/Frame.hs view
@@ -73,7 +73,7 @@ SettingsList, SettingsKey ( SettingsKey,- SettingsHeaderTableSize,+ SettingsTokenHeaderTableSize, SettingsEnablePush, SettingsMaxConcurrentStreams, SettingsInitialWindowSize,
Network/HTTP2/Frame/Decode.hs view
@@ -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
Network/HTTP2/Frame/Types.hs view
@@ -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" #-}
Network/HTTP2/H2.hs view
@@ -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
Network/HTTP2/H2/Config.hs view
@@ -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 ()
Network/HTTP2/H2/Context.hs view
@@ -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
Network/HTTP2/H2/EncodeFrame.hs view
@@ -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
− Network/HTTP2/H2/File.hs
@@ -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)
Network/HTTP2/H2/HPACK.hs view
@@ -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
− Network/HTTP2/H2/Manager.hs
@@ -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)
+ Network/HTTP2/H2/OutBodyIface.hs view
@@ -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
Network/HTTP2/H2/Queue.hs view
@@ -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 ()
− Network/HTTP2/H2/ReadN.hs
@@ -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
Network/HTTP2/H2/Receiver.hs view
@@ -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
Network/HTTP2/H2/Sender.hs view
@@ -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
Network/HTTP2/H2/Settings.hs view
@@ -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
− Network/HTTP2/H2/Status.hs
@@ -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
Network/HTTP2/H2/Stream.hs view
@@ -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
Network/HTTP2/H2/StreamTable.hs view
@@ -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
+ Network/HTTP2/H2/Sync.hs view
@@ -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)
Network/HTTP2/H2/Types.hs view
@@ -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
Network/HTTP2/H2/Window.hs view
@@ -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
− Network/HTTP2/Internal.hs
@@ -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
Network/HTTP2/Server.hs view
@@ -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
Network/HTTP2/Server/Internal.hs view
@@ -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
Network/HTTP2/Server/Run.hs view
@@ -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 ()
− Network/HTTP2/Server/Types.hs
@@ -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'.- }
Network/HTTP2/Server/Worker.hs view
@@ -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)
bench-hpack/Main.hs view
@@ -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
http2.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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
test-frame/FrameSpec.hs view
@@ -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
test-frame/frame-encode.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Main where import Data.Aeson
test-hpack/HPACKDecode.hs view
@@ -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"
test-hpack/HPACKEncode.hs view
@@ -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]
test-hpack/JSON.hs view
@@ -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
test-hpack/hpack-stat.hs view
@@ -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
test/HPACK/DecodeSpec.hs view
@@ -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") ,
test/HPACK/EncodeSpec.hs view
@@ -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
test/HPACK/HeaderBlock.hs view
@@ -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")
test/HPACK/HuffmanSpec.hs view
@@ -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
test/HPACK/IntegerSpec.hs view
@@ -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
test/HTTP2/ClientSpec.hs view
@@ -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
test/HTTP2/FrameSpec.hs view
@@ -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 =
test/HTTP2/ServerSpec.hs view
@@ -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 "</style.css>; rel=preload; as=style"+ , Just "</app.js>; 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", "</style.css>; rel=preload; as=style")]+ auxSendInformational+ aux+ earlyHints103+ [("link", "</app.js>; 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)
test2/ServerSpec.hs view
@@ -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
+ util/Client.hs view
@@ -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
+ util/Monitor.hs view
@@ -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
+ util/Server.hs view
@@ -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
− util/client.hs
@@ -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 <addr> <port>"- 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"
+ util/h2c-client.hs view
@@ -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}) "<size>")+ "measure performance"+ , Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<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
+ util/h2c-server.hs view
@@ -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] <addr> <port>"++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)
− util/server.hs
@@ -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 <addr> <port>"- 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