http3-0.1.8: test/QPACK/HeaderBlockSpec.hs
{-# LANGUAGE OverloadedStrings #-}
module QPACK.HeaderBlockSpec where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.IORef
import Data.Maybe (isNothing)
import Network.HPACK.Token (toToken)
import Network.QPACK
import Network.QPACK.Internal (
DecoderInstruction (..),
EncoderInstruction (..),
EncoderInstructionError (..),
encodeDecoderInstructions,
encodeEncoderInstructions,
)
import System.Timeout (timeout)
import Test.Hspec
spec :: Spec
spec = do
describe "field section round trip" $ do
it "decodes a header value larger than the decoder's scratch buffer" $ do
-- The scratch buffer for Huffman decoding used to be a fixed 2048
-- octets, so a value above that failed to decode however small the
-- section carrying it was: 2100 octets here comes to well under
-- 1.4K encoded, far inside the SETTINGS_MAX_FIELD_SECTION_SIZE we
-- advertise.
mapM_ roundTrip [1000, 2100, 8000, 20000]
it "encodes a field larger than the encoder's buffers" $ do
-- With the default 4096-octet buffers. 1011 is the value that
-- makes the field come to exactly the buffer by the encoder's
-- estimate ('tokenHeaderSize': four times the octets, plus 32);
-- one like it used to loop forever, and anything larger was
-- refused with BufferOverrun. 4083 was that value when the
-- estimate was the raw length plus 8. 100000 is also long
-- enough for its Huffman code to need a four-octet length.
forM_ [1011, 1012, 4083, 4084, 10000, 100000] $ \n -> do
r <- timeout 5000000 $ roundTripWith defaultQEncoderConfig n
void r `shouldBe` Just ()
it "keeps the tables in step when Huffman makes a value longer" $ do
-- The encoder sized its chunks by the raw length of the fields,
-- but Huffman coding, tried in place, makes octets above 0x7f
-- three to four times longer. A value of 1500 of them overran
-- the 4096-octet buffers after an entry earlier in the chunk had
-- gone into the encoder's table, its insertion still unsent: the
-- next section referred to an entry the decoder never got, and
-- waited for it for ever.
r <- timeout 5000000 $ withConnectedPair $ \enc dec -> do
let small = [(toToken "x-a", "foo")]
big n = small ++ [(toToken "x-b", BS.replicate n 0xff)]
sections = [small, big 1500, small] ++ map big [500, 1000 .. 6000] ++ [small]
forM_ (zip [0, 4 ..] sections) $ \(sid, hdr) -> do
blk <- enc sid hdr
(ths, _) <- dec sid blk
ths `shouldBe` hdr
r `shouldBe` Just ()
it "refuses at once an encoder instruction too long to be valid" $ do
-- Its length says it inserts an entry larger than any capacity
-- the decoder allows. It used to be decoded again from its
-- beginning with each piece of it that arrived, and kept for as
-- long as the peer went on.
-- Insert with literal name "x", not in Huffman, its value
-- declared to be 1000000 octets: 127 and the rest in 7-bit
-- groups.
let ei =
BS.pack ([0x41, 0x78, 0x7f] ++ varint (1000000 - 127 :: Int))
<> BS.replicate 10000 0x61
varint n
| n < 128 = [fromIntegral n]
| otherwise = fromIntegral (n `mod` 128 + 128) : varint (n `div` 128)
ref <- newIORef $ BS.take 10000 ei
let recv n = atomicModifyIORef' ref $ \bs -> let (a, b) = BS.splitAt n bs in (b, a)
(_, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())
r <- timeout 1000000 $ E.try $ handleEI recv
r `shouldBe` Just (Left EncoderInstructionError)
it "takes encoder instructions arriving an octet at a time" $ do
-- Each is decoded once it is all there. A value of 4000 octets is
-- near what the default capacity of 4096 takes.
r <- timeout 5000000 $ withConnectedPairBy 1 $ \enc dec ->
forM_ (zip [0, 4 ..] [100, 100, 4000, 4000]) $ \(sid, n) -> do
let hdr = [(toToken "x-big", C8.replicate n 'a')]
blk <- enc sid hdr
(ths, _) <- dec sid blk
ths `shouldBe` hdr
r `shouldBe` Just ()
it "agrees with the decoder on MaxEntries when the encoder uses less" $ do
-- The decoder offers 64K, the encoder settles for 4K. Required
-- Insert Count is encoded against the 64K both ends know about;
-- encoding it against the 4K made the two ends disagree once
-- 2*128 entries had been inserted.
roundTripMany 4096 65536 600
it "does not refer to an unacknowledged entry when blocking is not allowed" $ do
-- SETTINGS_QPACK_BLOCKED_STREAMS is 0, and no acknowledgement
-- ever arrives: every section has to be decodable with what the
-- decoder is known to hold, i.e. Required Insert Count 0. The
-- third one used to refer to the entry the second one inserted.
(enc, _, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())
setCapacity tblop 4096
setBlockedStreams tblop 0
forM_ [0 .. 4] $ \i -> do
blk <- enc (i * 4) [(toToken "x-foo", "bar")]
encodedInsertCount blk `shouldBe` 0
it "keeps the number of blocked streams within the decoder's limit" $ do
-- One blocked stream allowed, and nothing is ever acknowledged, so
-- every section that refers to the dynamic table is blocked: at
-- most one of them may do so.
(enc, _, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())
setCapacity tblop 4096
setBlockedStreams tblop 1
blks <- forM [0 .. 29] $ \i -> do
let hdr = [(toToken "x-foo", C8.pack (show (i `div` 3 :: Int)))]
enc (i * 4) hdr
length (filter ((/= 0) . encodedInsertCount) blks) `shouldSatisfy` (<= 1)
it "takes two outstanding sections on one stream one at a time" $ do
-- Headers and trailers on the same stream, both referring to the
-- dynamic table and so both acknowledged. The second used to
-- replace the first, and the second acknowledgement then found
-- nothing and was taken for a decoder stream error.
eiRef <- newIORef []
diRef <- newIORef []
let save ref bs = modifyIORef' ref (++ [bs])
(enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig (save eiRef)
(dec, handleEI) <- newQDecoder defaultQDecoderConfig (save diRef)
setCapacity tblop 4096
setBlockedStreams tblop 100
let hdr = [(toToken "x-foo", "bar")]
exchange sid = do
blk <- enc sid hdr
drain eiRef handleEI
(ths, _) <- dec sid blk
ths `shouldBe` hdr
return blk
-- Get the field into the table and acknowledged.
forM_ [0, 4, 8] $ \sid -> exchange sid >> drain diRef handleDI
blk1 <- exchange 12
blk2 <- exchange 12
map encodedInsertCount [blk1, blk2] `shouldSatisfy` all (/= 0)
drain diRef handleDI
it "keeps the decoder's entries across a change of capacity" $ do
-- The encoder may change the capacity at any time. The decoder
-- used to reallocate its table when told, so the entry inserted
-- before the change was gone when referred to after it.
eiRef <- newIORef []
(dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())
ins <-
encodeEncoderInstructions
[ SetDynamicTableCapacity 4096
, InsertWithLiteralName (toToken "x-foo") "bar"
, SetDynamicTableCapacity 2048
]
False
writeIORef eiRef [ins]
drain eiRef handleEI
-- Required Insert Count 1 (encoded as 2 against 128 entries),
-- Delta Base 0, then an indexed field line for relative index 0.
(ths, _) <- dec 0 $ BS.pack [0x02, 0x00, 0x80]
ths `shouldBe` [(toToken "x-foo", "bar")]
it "stops counting a blocked stream whose wait is given up" $ do
-- One blocked stream allowed. A section waiting for an entry
-- that has not arrived is abandoned, as when its stream is reset.
-- The stream it was counted as used to stay counted, and the next
-- section that had to wait was refused as one too many.
eiRef <- newIORef []
(dec, handleEI) <-
newQDecoder defaultQDecoderConfig{dcBlockedSterams = 1} (\_ -> return ())
-- Required Insert Count 1, Delta Base 0, then an indexed field
-- line for relative index 0: the first entry, not inserted yet.
let blk = BS.pack [0x02, 0x00, 0x80]
withAsync (dec 0 blk) $ \a -> do
threadDelay 100000
poll a >>= (`shouldSatisfy` isNothing)
withAsync (dec 4 blk) $ \a -> do
threadDelay 100000
poll a >>= (`shouldSatisfy` isNothing)
ins <-
encodeEncoderInstructions
[ SetDynamicTableCapacity 4096
, InsertWithLiteralName (toToken "x-foo") "bar"
]
False
writeIORef eiRef [ins]
drain eiRef handleEI
(ths, _) <- wait a
ths `shouldBe` [(toToken "x-foo", "bar")]
it "evicts an entry nothing refers to once its insertion is acknowledged" $ do
-- No stream may block, and nothing is acknowledged at first, so
-- every entry is inserted without being referred to. Such an
-- entry used to be kept for good, and once the table was full
-- nothing new went in.
eiRef <- newIORef []
diRef <- newIORef []
(enc, handleDI, tblop) <-
newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))
setCapacity tblop 256
setBlockedStreams tblop 0
let inserts i = do
writeIORef eiRef []
-- Twice, since a field is only inserted the second time
-- it is seen.
forM_ [0, 1] $ \j ->
enc ((i * 2 + j) * 4) [(toToken (C8.pack ("x-foo-" ++ show i)), "a")]
any (not . BS.null) <$> readIORef eiRef
-- 40 octets each: six fit in 256.
mapM inserts [0 .. 5] `shouldReturn` replicate 6 True
-- Full, and none of them acknowledged, so none is evictable.
inserts 6 `shouldReturn` False
di <- encodeDecoderInstructions [InsertCountIncrement 6]
writeIORef diRef [di]
drain diRef handleDI
inserts 7 `shouldReturn` True
it "releases the sections of a stream the decoder cancels" $ do
-- One blocked stream allowed, and nothing acknowledged. Stream 4
-- takes it, so stream 8 may not refer to the entry. Once the
-- decoder cancels stream 4, stream 12 may. The cancellation used
-- to be ignored, and stream 4 stayed blocked for good.
diRef <- newIORef []
(enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())
setCapacity tblop 4096
setBlockedStreams tblop 1
let hdr = [(toToken "x-foo", "bar")]
-- Inserted the second time it is seen.
_ <- enc 0 hdr
enc 4 hdr >>= (`shouldSatisfy` (/= 0)) . encodedInsertCount
enc 8 hdr >>= (`shouldBe` 0) . encodedInsertCount
di <- encodeDecoderInstructions [StreamCancellation 4]
writeIORef diRef [di]
drain diRef handleDI
enc 12 hdr >>= (`shouldSatisfy` (/= 0)) . encodedInsertCount
it "refuses a section that decodes to more than the announced limit" $ do
-- A field line of one octet refers to a 1037-octet entry, so a
-- section of a few octets decodes to far more than its length.
-- Only the length of the frame used to be capped.
eiRef <- newIORef []
(dec, handleEI) <-
newQDecoder
defaultQDecoderConfig{dcMaxFieldSectionSize = 2000}
(\_ -> return ())
ins <-
encodeEncoderInstructions
[ SetDynamicTableCapacity 4096
, InsertWithLiteralName (toToken "x-foo") (C8.replicate 1000 'a')
]
False
writeIORef eiRef [ins]
drain eiRef handleEI
-- Required Insert Count 1, Delta Base 0, then indexed field
-- lines for relative index 0: once, and then twice.
(ths, _) <- dec 0 $ BS.pack [0x02, 0x00, 0x80]
map fst ths `shouldBe` [toToken "x-foo"]
dec 4 (BS.pack [0x02, 0x00, 0x80, 0x80])
`shouldThrow` (== FieldSectionTooLarge)
it "inserts with a reference to a name not yet acknowledged" $ do
-- No stream may block, and nothing is acknowledged. x-foo is in
-- the table, unacknowledged, so a field line may not refer to it;
-- but an insertion may, on the encoder stream, and x-foo: b is
-- inserted so. The encoder used to give that up and insert
-- nothing, since it guarded the insertion as though it were a
-- field line.
eiRef <- newIORef []
(enc, _, tblop) <-
newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))
(dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())
setCapacity tblop 4096
setBlockedStreams tblop 0
let hdr v = [(toToken "x-foo", v)]
-- Twice each, since a field is only inserted the second time it
-- is seen.
blks1 <- forM [0, 4] $ \sid -> enc sid (hdr "a")
eis1 <- readIORef eiRef
writeIORef eiRef []
blks2 <- forM [8, 12] $ \sid -> enc sid (hdr "b")
eis2 <- readIORef eiRef
BS.concat eis2 `shouldSatisfy` (not . BS.null)
-- And what went out still decodes.
eiQ <- newIORef [BS.concat (eis1 ++ eis2)]
drain eiQ handleEI
forM_ (zip [0, 4, 8, 12] (blks1 ++ blks2)) $ \(sid, blk) -> do
encodedInsertCount blk `shouldBe` 0
(ths, _) <- dec sid blk
ths `shouldSatisfy` (`elem` [hdr "a", hdr "b"])
it "refuses a section more than the peer will take" $ do
-- RFC 9114, section 4.2.2: "SHOULD NOT send". The peer's limit
-- used to be kept and never looked at. Refused before anything
-- is inserted, so the encoder stream carries nothing.
eiRef <- newIORef []
(enc, _, tblop) <-
newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))
setCapacity tblop 4096
setHeaderSize tblop 100
writeIORef eiRef []
-- 5 + 100 + 32 octets as the limit counts them.
enc 0 [(toToken "x-foo", C8.replicate 100 'a')]
`shouldThrow` (== FieldSectionTooLargeForPeer 137 100)
BS.concat <$> readIORef eiRef `shouldReturn` ""
void $ enc 4 [(toToken "x-foo", "bar")]
-- | Feeding an instruction handler what has been queued for it, then an end
-- of stream, so that it returns -- or throws -- here.
drain :: IORef [BS.ByteString] -> ((Int -> IO BS.ByteString) -> IO ()) -> IO ()
drain ref handler = do
bss <- readIORef ref
writeIORef ref []
queue <- newIORef [BS.concat bss]
handler $ \_ -> atomicModifyIORef' queue $ \xs -> case xs of
[] -> ([], "")
y : ys -> (ys, y)
roundTrip :: Int -> IO ()
roundTrip n = do
blk <- roundTripWith defaultQEncoderConfig{ecHeaderBlockBufferSize = 262144} n
-- The encoded section stays well under the announced limit; it is only
-- the decoded value that is large.
BS.length blk `shouldSatisfy` (< dcMaxFieldSectionSize defaultQDecoderConfig)
-- | Encoding and decoding a field with an n-octet value; the encoded field
-- section is returned.
roundTripWith :: QEncoderConfig -> Int -> IO BS.ByteString
roundTripWith conf n = do
(enc, _, _) <- newQEncoder conf (\_ -> return ())
-- Room for the largest field here, which the default limit on a field
-- section is not.
(dec, _) <-
newQDecoder
defaultQDecoderConfig{dcMaxFieldSectionSize = 1000000}
(\_ -> return ())
let val = C8.replicate n 'a'
blk <- enc 0 [(toToken ":status", "200"), (toToken "x-big", val)]
(ths, _) <- dec 0 blk
lookup (toToken "x-big") ths `shouldBe` Just val
return blk
-- | An encoder and a decoder with the default configurations, each one's
-- instructions carried to the other.
withConnectedPair :: (QEncoder -> QDecoder -> IO a) -> IO a
withConnectedPair = withConnectedPairBy maxBound
-- | Like 'withConnectedPair', the encoder's instructions reaching the
-- decoder no more than the given number of octets at a time.
withConnectedPairBy :: Int -> (QEncoder -> QDecoder -> IO a) -> IO a
withConnectedPairBy chunk body = do
eiQ <- newTQueueIO
diQ <- newTQueueIO
(enc, handleDI, tblop) <-
newQEncoder defaultQEncoderConfig (atomically . writeTQueue eiQ)
(dec, handleEI) <-
newQDecoder defaultQDecoderConfig (atomically . writeTQueue diQ)
-- What the decoder's SETTINGS would carry.
setCapacity tblop $ dcMaxTableCapacity defaultQDecoderConfig
setBlockedStreams tblop 100
pendingEI <- newIORef ""
let recvFrom q _ = atomically $ readTQueue q
recvEI n = do
bs0 <- readIORef pendingEI
bs <- if BS.null bs0 then atomically (readTQueue eiQ) else return bs0
let (a, b) = BS.splitAt (min n chunk) bs
writeIORef pendingEI b
return a
withAsync (handleEI recvEI) $ \_ ->
withAsync (handleDI $ recvFrom diQ) $ \_ ->
body enc dec
roundTripMany :: Int -> Int -> Int -> IO ()
roundTripMany encCap decCap n = do
eiQ <- newTQueueIO
diQ <- newTQueueIO
(enc, handleDI, tblop) <-
newQEncoder
defaultQEncoderConfig{ecMaxTableCapacity = encCap}
(atomically . writeTQueue eiQ)
(dec, handleEI) <-
newQDecoder
defaultQDecoderConfig{dcMaxTableCapacity = decCap}
(atomically . writeTQueue diQ)
-- What the decoder's SETTINGS would carry.
setCapacity tblop decCap
setBlockedStreams tblop 100
let recvFrom q _ = atomically $ readTQueue q
ricMax <- newIORef 0
withAsync (handleEI $ recvFrom eiQ) $ \_ ->
withAsync (handleDI $ recvFrom diQ) $ \_ ->
forM_ [0 .. n - 1] $ \i -> do
-- Twice each, since a field is only inserted the second
-- time it is seen.
forM_ [0, 1] $ \j -> do
let sid = (i * 2 + j) * 4
hdr = [(toToken "x-count", C8.pack (show i))]
blk <- enc sid hdr
modifyIORef' ricMax (max (encodedInsertCount blk))
(ths, _) <- dec sid blk
ths `shouldBe` hdr
-- Let acknowledgements reach the encoder, so that
-- entries can be evicted and inserting goes on.
atomically $ isEmptyTQueue diQ >>= check
-- Our own decoder would accept either reading of MaxEntries as long as
-- the encoder used the same one, so look at the prefix itself: against
-- the decoder's 2048 entries nothing here wraps, and the encoded count
-- goes past what 2*128 would have allowed.
readIORef ricMax >>= (`shouldSatisfy` (> 2 * (encCap `div` 32)))
-- | The encoded Required Insert Count: an integer with an 8-bit prefix.
encodedInsertCount :: BS.ByteString -> Int
encodedInsertCount blk = case BS.unpack blk of
w : ws
| w < 255 -> fromIntegral w
| otherwise -> 255 + go 0 0 ws
[] -> 0
where
go acc sh (x : xs)
| x < 128 = acc + fromIntegral x * 2 ^ (sh :: Int)
| otherwise = go (acc + fromIntegral (x - 128) * 2 ^ sh) (sh + 7) xs
go acc _ [] = acc