http3 0.0.24 → 0.1.0

raw patch · 39 files changed

+2320/−880 lines, 39 filesdep +cerealdep +network-controldep +psqueuesdep ~quicdep ~time-managernew-component:exe:qif-decnew-component:exe:qif-encPVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, network-control, psqueues

Dependency ranges changed: quic, time-manager

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Imports.hs +16/−1
• Network/HQ/Client.hs +7/−4
• Network/HQ/Server.hs +1/−1
• Network/HTTP3/Client.hs +29/−3
• Network/HTTP3/Config.hs +20/−1
• Network/HTTP3/Context.hs +13/−22
• Network/HTTP3/Control.hs +33/−16
• Network/HTTP3/Frame.hs +17/−17
• Network/HTTP3/Send.hs +1/−1
• Network/HTTP3/Server.hs +12/−1
• Network/HTTP3/Settings.hs +3/−3
• Network/QPACK.hs +290/−102
• Network/QPACK/Error.hs +2/−1
• Network/QPACK/HeaderBlock.hs +0/−2
• Network/QPACK/HeaderBlock/Decode.hs +105/−60
• Network/QPACK/HeaderBlock/Encode.hs +321/−96
• Network/QPACK/HeaderBlock/Prefix.hs +24/−15
• Network/QPACK/Instruction.hs +10/−4
• Network/QPACK/Table.hs +2/−31
• Network/QPACK/Table/Dynamic.hs +661/−138
• Network/QPACK/Table/RevIndex.hs +107/−60
• Network/QPACK/Table/Static.hs +1/−1
• Network/QPACK/Types.hs +34/−21
• http3.cabal +38/−6
• qifs/encoded/qpack-05/examples/examples.out.220.100.1 binary
• qifs/qifs/draft-examples.qif +0/−9
• test/HTTP3/Config.hs +1/−1
• test/HTTP3/ErrorSpec.hs +1/−1
• test/HTTP3/Server.hs +11/−3
• test/HTTP3/ServerSpec.hs +1/−1
• test/QPACK/QIF2Spec.hs +135/−0
• test/QPACK/QIFSpec.hs +61/−90
• test/QPACK/TableSpec.hs +4/−4
• util/ClientX.hs +2/−3
• util/QIF.hs +84/−0
• util/qif-dec.hs +182/−0
• util/qif-enc.hs +85/−0
• util/qif.hs +0/−161

@@ -1,5 +1,11 @@ # Revision history for http3 +## 0.1.0++* QPACK encoder now supports the dynamic table.+* Breaking change: `Config` takes 'confQEncoderConfig' and+  `confQDecoderConfig`.+ ## 0.0.24  * Supporting SSLKEYLOGFILE in h3-server and h3-client.

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Imports (     ByteString (..),     module Control.Applicative,@@ -16,11 +18,14 @@     module Data.CaseInsensitive,     withForeignPtr,     mallocPlainForeignPtrBytes,+#if !MIN_VERSION_base(4,17,0)+    (!<<.), (!>>.),+#endif ) where  import Control.Applicative import Control.Monad-import Data.Bits hiding (Bits)+import Data.Bits import Data.ByteString.Internal (ByteString (..)) import Data.CaseInsensitive (foldedCase, mk, original) import Data.Foldable@@ -35,3 +40,13 @@ import Network.HTTP.Semantics import Network.HTTP.Types import Numeric++#if !MIN_VERSION_base(4,17,0)+infixl 8 !<<.+(!<<.) :: Bits a => a -> Int -> a+(!<<.) = unsafeShiftL++infixl 8 !>>.+(!>>.) :: Bits a => a -> Int -> a+(!>>.) = unsafeShiftR+#endif

@@ -6,13 +6,16 @@     -- * Runner     run, -    -- * Runner arguments-    H3.ClientConfig (..),+    -- * Client configration+    H3.ClientConfig,+    H3.defaultClientConfig,+    H3.scheme,+    Scheme,++    -- * Common configration     H3.Config (..),     H3.allocSimpleConfig,     H3.freeSimpleConfig,-    Scheme,-    Authority,      -- * HQ client     Client,

@@ -5,7 +5,7 @@     -- * Runner     run, -    -- * Runner arguments+    -- * Common configration     Config (..),     allocSimpleConfig,     freeSimpleConfig,

@@ -7,13 +7,28 @@     -- * Runner     run, -    -- * Runner arguments-    ClientConfig (..),+    -- * Client configration+    ClientConfig,+    defaultClientConfig,+    scheme,+    authority,++    -- * Common configuration     Config (..),+    defaultConfig,     allocSimpleConfig,     freeSimpleConfig,+    defaultQEncoderConfig,+    ecMaxTableCapacity,+    ecHeaderBlockBufferSize,+    ecInstructionBufferSize,+    defaultQDecoderConfig,+    dcMaxTableCapacity,+    dcHuffmanBufferSize,     Hooks (..),     defaultHooks,++    -- * HTTP semantics     module Network.HTTP.Semantics.Client, ) where @@ -36,6 +51,7 @@ import Network.HTTP3.Frame import Network.HTTP3.Recv import Network.HTTP3.Send+import Network.QPACK  -- | Configuration for HTTP\/3 or HQ client. For HQ, 'authority' is --   not used and an server's IP address is used in 'Request'.@@ -44,6 +60,13 @@     , authority :: Authority     } +defaultClientConfig :: ClientConfig+defaultClientConfig =+    ClientConfig+        { scheme = "https"+        , authority = "localhost"+        }+ -- | Running an HTTP\/3 client. run :: Connection -> ClientConfig -> Config -> Client a -> IO a run conn ClientConfig{..} conf client = withContext conn conf $ \ctx -> do@@ -100,4 +123,7 @@     auth'         | isIPv6 = "[" <> UTF8.fromString auth <> "]"         | otherwise = UTF8.fromString auth-    hdr' = (":scheme", scm) : (":authority", auth') : hdr+    hdr' = addIfNotExist (":scheme", scm) $ addIfNotExist (":authority", auth') hdr+    addIfNotExist keyVal@(key, _) hs = case find (\(k, _) -> k == key) hs of+        Nothing -> keyVal : hs+        Just _ -> hs

@@ -2,6 +2,7 @@  import Network.HTTP.Semantics.Client import Network.HTTP3.Frame+import Network.QPACK import Network.QUIC (Stream) import qualified System.TimeManager as T @@ -28,14 +29,32 @@ -- | Configuration for HTTP\/3 or HQ. data Config = Config     { confHooks :: Hooks+    , confQEncoderConfig :: QEncoderConfig+    , confQDecoderConfig :: QDecoderConfig     , confPositionReadMaker :: PositionReadMaker     , confTimeoutManager :: T.Manager     } +defaultConfig :: Config+defaultConfig =+    Config+        { confHooks = defaultHooks+        , confQEncoderConfig = defaultQEncoderConfig+        , confQDecoderConfig = defaultQDecoderConfig+        , confPositionReadMaker = defaultPositionReadMaker+        , confTimeoutManager = T.defaultManager+        }+ -- | Allocating a simple configuration with a handle-based position --   reader and a locally allocated timeout manager. allocSimpleConfig :: IO Config-allocSimpleConfig = Config defaultHooks defaultPositionReadMaker <$> T.initialize (30 * 1000000)+allocSimpleConfig =+    Config+        defaultHooks+        defaultQEncoderConfig+        defaultQDecoderConfig+        defaultPositionReadMaker+        <$> T.initialize (30 * 1000000)  -- | Freeing a simple configration. freeSimpleConfig :: Config -> IO ()

@@ -60,31 +60,22 @@  newContext :: Connection -> Config -> IO Context newContext conn conf = do-    sendDI <- setupUnidirectional conn conf-    ctl <- controlStream conn <$> newIORef IInit-    (enc, handleDI) <- newQEncoder defaultQEncoderConfig-    (dec, handleEI) <- newQDecoder defaultQDecoderConfig sendDI+    (sendEI, sendDI) <- setupUnidirectional conn conf+    (ctxQEncoder, handleDI, dyntblE) <- newQEncoder (confQEncoderConfig conf) sendEI+    -- newQDecoder passes dyntbl for decoder to handleEI internally+    (ctxQDecoder, handleEI) <- newQDecoder (confQDecoderConfig conf) sendDI+    ctl <- controlStream conn dyntblE <$> newIORef IInit     info <- getConnectionInfo conn     let handleDI' recv = handleDI recv `E.catch` abortWith QpackDecoderStreamError         handleEI' recv = handleEI recv `E.catch` abortWith QpackEncoderStreamError-        sw = switch conn ctl handleEI' handleDI'-        preadM = confPositionReadMaker conf-        hooks = confHooks conf-        mysa = localSockAddr info-        peersa = remoteSockAddr info-    mgr <- T.newThreadManager $ confTimeoutManager conf-    return $-        Context-            { ctxConnection = conn-            , ctxQEncoder = enc-            , ctxQDecoder = dec-            , ctxUniSwitch = sw-            , ctxPReadMaker = preadM-            , ctxThreadManager = mgr-            , ctxHooks = hooks-            , ctxMySockAddr = mysa-            , ctxPeerSockAddr = peersa-            }+        ctxUniSwitch = switch conn ctl handleEI' handleDI'+        ctxPReadMaker = confPositionReadMaker conf+        ctxHooks = confHooks conf+        ctxMySockAddr = localSockAddr info+        ctxPeerSockAddr = remoteSockAddr info+    ctxThreadManager <- T.newThreadManager $ confTimeoutManager conf+    let ctxConnection = conn+    return Context{..}   where     abortWith :: ApplicationProtocolError -> E.SomeException -> IO ()     abortWith aerr se

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Network.HTTP3.Control (     setupUnidirectional,@@ -21,14 +22,17 @@ mkType = BS.singleton . fromIntegral . fromH3StreamType  setupUnidirectional-    :: Connection -> H3.Config -> IO (EncodedDecoderInstruction -> IO ())-setupUnidirectional conn conf = do+    :: Connection+    -> H3.Config+    -> IO (EncodedEncoderInstruction -> IO (), EncodedDecoderInstruction -> IO ())+setupUnidirectional conn conf@H3.Config{..} = do+    let QDecoderConfig{..} = confQDecoderConfig     settings <-         encodeH3Settings-            [ (SettingsQpackBlockedStreams, 100)-            , (SettingsQpackMaxTableCapacity, 4096)-            , (SettingsMaxFieldSectionSize, 32768)-            ] -- fixme+            [ (SettingsQpackBlockedStreams, dcBlockedSterams)+            , (SettingsQpackMaxTableCapacity, dcMaxTableCapacity)+            , (SettingsMaxFieldSectionSize, dcMaxFieldSectionSize)+            ]     let framesC = H3.onControlFrameCreated hooks [H3Frame H3FrameSettings settings]     let bssC = encodeH3Frames framesC     sC <- unidirectionalStream conn@@ -41,15 +45,17 @@     H3.onControlStreamCreated hooks sC     H3.onEncoderStreamCreated hooks sE     H3.onDecoderStreamCreated hooks sD-    return $ sendStream sD+    return (sendStream sE, sendStream sD)   where     stC = mkType H3ControlStreams     stE = mkType QPACKEncoderStream     stD = mkType QPACKDecoderStream     hooks = H3.confHooks conf -controlStream :: Connection -> IORef IFrame -> InstructionHandler-controlStream conn ref recv = loop0+-- DynamicTable for Encoder+controlStream+    :: Connection -> TableOperation -> IORef IFrame -> InstructionHandler+controlStream conn tblop ref recv = loop0   where     loop0 = do         bs <- recv 1024@@ -70,7 +76,7 @@         case parseH3Frame st0 bs of             IDone typ payload leftover -> do                 case typ of-                    H3FrameSettings -> checkSettings conn payload+                    H3FrameSettings -> checkSettings conn tblop payload                     _ -> abortConnection conn H3MissingSettings ""                 st1 <- parse leftover IInit                 return (True, st1)@@ -90,20 +96,31 @@                 parse leftover IInit             st1 -> return st1 -checkSettings :: Connection -> ByteString -> IO ()-checkSettings conn payload = do+checkSettings :: Connection -> TableOperation -> ByteString -> IO ()+checkSettings conn tblop payload = do     h3settings <- decodeH3Settings payload     loop (0 :: Int) h3settings   where     loop _ [] = return ()-    loop flags ((k@(H3SettingsKey i), _v) : ss)+    loop flags ((k@(H3SettingsKey i), v) : ss)         | flags `testBit` i = abortConnection conn H3SettingsError ""         | otherwise = do             let flags' = flags `setBit` i             case k of-                SettingsQpackMaxTableCapacity -> loop flags' ss-                SettingsMaxFieldSectionSize -> loop flags' ss-                SettingsQpackBlockedStreams -> loop flags' ss+                SettingsQpackMaxTableCapacity -> do+                    setCapacity tblop v+                    loop flags' ss+                -- This value is not used yet.+                -- RFC 9114: "A server that receives a larger field+                -- section than it is willing to handle can send an+                -- HTTP 431 (Request Header Fields Too Large) status+                -- code ([RFC6585])."+                SettingsMaxFieldSectionSize -> do+                    setHeaderSize tblop v+                    loop flags' ss+                SettingsQpackBlockedStreams -> do+                    setBlockedStreams tblop v+                    loop flags' ss                 _                     -- HTTP/2 settings                     | i <= 0x6 -> abortConnection conn H3SettingsError ""

@@ -39,23 +39,23 @@  {- FOURMOLU_DISABLE -} fromH3FrameType :: H3FrameType -> Int64-fromH3FrameType H3FrameData        = 0x0-fromH3FrameType H3FrameHeaders     = 0x1-fromH3FrameType H3FrameCancelPush  = 0x3-fromH3FrameType H3FrameSettings    = 0x4-fromH3FrameType H3FramePushPromise = 0x5-fromH3FrameType H3FrameGoaway      = 0x7-fromH3FrameType H3FrameMaxPushId   = 0xD+fromH3FrameType H3FrameData        = 0x00+fromH3FrameType H3FrameHeaders     = 0x01+fromH3FrameType H3FrameCancelPush  = 0x03+fromH3FrameType H3FrameSettings    = 0x04+fromH3FrameType H3FramePushPromise = 0x05+fromH3FrameType H3FrameGoaway      = 0x07+fromH3FrameType H3FrameMaxPushId   = 0x0d fromH3FrameType (H3FrameUnknown i) = i  toH3FrameType :: Int64 -> H3FrameType-toH3FrameType 0x0 = H3FrameData-toH3FrameType 0x1 = H3FrameHeaders-toH3FrameType 0x3 = H3FrameCancelPush-toH3FrameType 0x4 = H3FrameSettings-toH3FrameType 0x5 = H3FramePushPromise-toH3FrameType 0x7 = H3FrameGoaway-toH3FrameType 0xD = H3FrameMaxPushId+toH3FrameType 0x00 = H3FrameData+toH3FrameType 0x01 = H3FrameHeaders+toH3FrameType 0x03 = H3FrameCancelPush+toH3FrameType 0x04 = H3FrameSettings+toH3FrameType 0x05 = H3FramePushPromise+toH3FrameType 0x07 = H3FrameGoaway+toH3FrameType 0x0d = H3FrameMaxPushId toH3FrameType i   = H3FrameUnknown i  permittedInControlStream :: H3FrameType -> Bool@@ -67,7 +67,7 @@ permittedInControlStream H3FrameGoaway      = True permittedInControlStream H3FrameMaxPushId   = True permittedInControlStream (H3FrameUnknown i)-    | i <= 0x9 = False+    | i <= 0x09 = False     | otherwise = True  permittedInRequestStream :: H3FrameType -> Bool@@ -79,7 +79,7 @@ permittedInRequestStream H3FrameGoaway      = False permittedInRequestStream H3FrameMaxPushId   = False permittedInRequestStream (H3FrameUnknown i)-    | i <= 0x9  = False+    | i <= 0x09 = False     | otherwise = True  permittedInPushStream :: H3FrameType -> Bool@@ -91,7 +91,7 @@ permittedInPushStream H3FrameGoaway      = False permittedInPushStream H3FrameMaxPushId   = False permittedInPushStream (H3FrameUnknown i)-    | i <= 0x9  = False+    | i <= 0x09 = False     | otherwise = True {- FOURMOLU_ENABLE -} 

@@ -26,7 +26,7 @@ sendHeader ctx strm th hdrs = do     -- fixme: fixHeaders     (ths, _) <- toTokenHeaderTable hdrs-    (hdr, "") <- qpackEncode ctx ths -- FIXME: send 2nd ret value as EI+    hdr <- qpackEncode ctx (streamId strm) ths     let frames = [H3Frame H3FrameHeaders hdr]         frames' = onHeadersFrameCreated (getHooks ctx) frames         bss = encodeH3Frames frames'

@@ -6,12 +6,22 @@     -- * Runner     run, -    -- * Runner arguments+    -- * Common configration     Config (..),+    defaultConfig,     allocSimpleConfig,     freeSimpleConfig,+    defaultQEncoderConfig,+    ecMaxTableCapacity,+    ecHeaderBlockBufferSize,+    ecInstructionBufferSize,+    defaultQDecoderConfig,+    dcMaxTableCapacity,+    dcHuffmanBufferSize,     Hooks (..),     defaultHooks,++    -- * HTTP semantics     module Network.HTTP.Semantics.Server,      -- * Internal@@ -40,6 +50,7 @@ import Network.HTTP3.Frame import Network.HTTP3.Recv import Network.HTTP3.Send+import Network.QPACK import Network.QPACK.Internal  -- | Running an HTTP\/3 server.

@@ -11,13 +11,13 @@  {- FOURMOLU_DISABLE -} pattern SettingsQpackMaxTableCapacity :: H3SettingsKey-pattern SettingsQpackMaxTableCapacity  = H3SettingsKey 0x1+pattern SettingsQpackMaxTableCapacity  = H3SettingsKey 0x01  pattern SettingsMaxFieldSectionSize   :: H3SettingsKey-pattern SettingsMaxFieldSectionSize    = H3SettingsKey 0x6+pattern SettingsMaxFieldSectionSize    = H3SettingsKey 0x06  pattern SettingsQpackBlockedStreams   :: H3SettingsKey-pattern SettingsQpackBlockedStreams    = H3SettingsKey 0x7+pattern SettingsQpackBlockedStreams    = H3SettingsKey 0x07 {- FOURMOLU_ENABLE -}  {- FOURMOLU_DISABLE -}

@@ -8,7 +8,12 @@     defaultQEncoderConfig,     QEncoder,     newQEncoder,+    TableOperation (..), +    -- ** Encoder for debugging+    QEncoderS,+    newQEncoderS,+     -- * Decoder     QDecoderConfig (..),     defaultQDecoderConfig,@@ -28,10 +33,6 @@     InstructionHandler,     Size, -    -- * Strategy-    EncodeStrategy (..),-    CompressionAlgo (..),-     -- * Re-exports     TokenHeaderTable,     TokenHeaderList,@@ -47,8 +48,9 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception as E-import qualified Data.ByteString as B-import Data.CaseInsensitive+import qualified Data.ByteString as BS+import Data.CaseInsensitive hiding (map)+import qualified Data.CaseInsensitive as CI import Network.ByteOrder import Network.HPACK.Internal (     GCBuffer,@@ -58,7 +60,7 @@     toTokenHeaderTable,  ) import Network.HTTP.Types-import Network.QUIC.Internal (StreamId, stdoutLogger)+import Network.QUIC.Internal (StreamId)  import Imports import Network.QPACK.Error@@ -70,20 +72,24 @@ ----------------------------------------------------------------  -- | QPACK encoder.-type QEncoder =-    TokenHeaderList -> IO (EncodedFieldSection, EncodedEncoderInstruction)+type QEncoder = StreamId -> TokenHeaderList -> IO EncodedFieldSection +-- | QPACK simple encoder.+type QEncoderS = StreamId -> [Header] -> IO EncodedFieldSection+ -- | QPACK decoder. type QDecoder = StreamId -> EncodedFieldSection -> IO TokenHeaderTable  -- | QPACK simple decoder.-type QDecoderS = StreamId -> EncodedFieldSection -> IO [Header]+type QDecoderS = StreamId -> EncodedFieldSection -> IO (Maybe [Header])  -- | Encoder instruction handler. type EncoderInstructionHandler = (Int -> IO EncodedEncoderInstruction) -> IO ()  -- | Simple encoder instruction handler.-type EncoderInstructionHandlerS = EncodedEncoderInstruction -> IO ()+--   Leftover is returned.+type EncoderInstructionHandlerS =+    EncodedEncoderInstruction -> IO EncodedEncoderInstruction  -- | Encoded decoder instruction. type EncodedDecoderInstruction = ByteString@@ -94,122 +100,275 @@ -- | A type to integrating handlers. type InstructionHandler = (Int -> IO ByteString) -> IO () +data TableOperation = TableOperation+    { setCapacity :: Int -> IO ()+    , setBlockedStreams :: Int -> IO ()+    , setHeaderSize :: Int -> IO ()+    }+ ----------------------------------------------------------------  -- | Configuration for QPACK encoder. data QEncoderConfig = QEncoderConfig-    { ecDynamicTableSize :: Size+    { ecMaxTableCapacity :: Size     , ecHeaderBlockBufferSize :: Size-    , ecPrefixBufferSize :: Size     , ecInstructionBufferSize :: Size-    , encStrategy :: EncodeStrategy     }     deriving (Show)  -- | Default configuration for QPACK encoder. -- -- >>> defaultQEncoderConfig--- QEncoderConfig {ecDynamicTableSize = 4096, ecHeaderBlockBufferSize = 4096, ecPrefixBufferSize = 128, ecInstructionBufferSize = 4096, encStrategy = EncodeStrategy {compressionAlgo = Static, useHuffman = True}}+-- QEncoderConfig {ecMaxTableCapacity = 4096, ecHeaderBlockBufferSize = 4096, ecInstructionBufferSize = 4096} defaultQEncoderConfig :: QEncoderConfig defaultQEncoderConfig =     QEncoderConfig-        { ecDynamicTableSize = 4096+        { ecMaxTableCapacity = 4096         , ecHeaderBlockBufferSize = 4096-        , ecPrefixBufferSize = 128         , ecInstructionBufferSize = 4096-        , encStrategy = EncodeStrategy Static True         }  -- | Creating a new QPACK encoder.-newQEncoder :: QEncoderConfig -> IO (QEncoder, DecoderInstructionHandler)-newQEncoder QEncoderConfig{..} = do+newQEncoder+    :: QEncoderConfig+    -> (EncodedEncoderInstruction -> IO ())+    -> IO (QEncoder, DecoderInstructionHandler, TableOperation)+newQEncoder QEncoderConfig{..} sendEI = do     let bufsiz1 = ecHeaderBlockBufferSize-        bufsiz2 = ecPrefixBufferSize-        bufsiz3 = ecInstructionBufferSize+        bufsiz2 = ecInstructionBufferSize     gcbuf1 <- mallocPlainForeignPtrBytes bufsiz1     gcbuf2 <- mallocPlainForeignPtrBytes bufsiz2-    gcbuf3 <- mallocPlainForeignPtrBytes bufsiz3-    dyntbl <- newDynamicTableForEncoding ecDynamicTableSize+    dyntbl <- newDynamicTableForEncoding sendEI     lock <- newMVar ()     let enc =             qpackEncoder-                encStrategy                 gcbuf1                 bufsiz1                 gcbuf2                 bufsiz2-                gcbuf3-                bufsiz3                 dyntbl                 lock         handler = decoderInstructionHandler dyntbl-    return (enc, handler)+        ctl =+            TableOperation+                { setCapacity = \n -> do+                    -- "n" is decoder-proposed size via settings.+                    let tableSize = min ecMaxTableCapacity n+                    setTableCapacity dyntbl tableSize+                    ins <- encodeEncoderInstructions [SetDynamicTableCapacity tableSize] False+                    sendIns dyntbl ins+                , setBlockedStreams = setMaxBlockedStreams dyntbl+                , setHeaderSize = setMaxHeaderSize dyntbl+                }+    return (enc, handler, ctl) +tokenHeaderSize :: TokenHeader -> Int+tokenHeaderSize (t, v) = BS.length (CI.original (tokenKey t)) + BS.length v + 8 -- adhoc overhead++split :: Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)+split lim ts = split' 0 ts+  where+    split' _ [] = ([], [])+    split' s xxs@(x : xs)+        | siz > lim = E.throw BufferOverrun+        | s' < lim =+            let (ys, zs) = split' s' xs+             in (x : ys, zs)+        | otherwise = ([], xxs)+      where+        siz = tokenHeaderSize x+        s' = s + siz++splitThrough :: Int -> TokenHeaderList -> [TokenHeaderList]+splitThrough lim ts0 = loop ts0 id+  where+    loop [] builder = builder []+    loop ts builder = loop ts2 (builder . (ts1 :))+      where+        (ts1, ts2) = split lim ts+ qpackEncoder-    :: EncodeStrategy-    -> GCBuffer+    :: GCBuffer     -> Int     -> GCBuffer     -> Int+    -> DynamicTable+    -> MVar ()+    -> QEncoder+qpackEncoder gcbuf1 bufsiz1 gcbuf2 bufsiz2 dyntbl lock sid ts =+    withMVar lock $ \_ ->+        withForeignPtr gcbuf1 $ \buf1 ->+            withForeignPtr gcbuf2 $ \buf2 -> do+                siz <- getTableCapacity dyntbl+                qpackDebug dyntbl $+                    putStrLn $+                        "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz+                setBasePointToInsersionPoint dyntbl+                clearRequiredInsertCount dyntbl+                let tss = splitThrough bufsiz1 ts+                his <- mapM (qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 dyntbl) tss+                let (hbs, daiss) = unzip his+                prefix <- qpackEncodePrefix buf1 bufsiz1 dyntbl+                let section = BS.concat (prefix : hbs)+                reqInsCnt <- getRequiredInsertCount dyntbl+                -- To count only blocked sections,+                -- dont' register this section if reqInsCnt == 0.+                when (reqInsCnt /= 0) $+                    insertSection dyntbl sid $+                        Section reqInsCnt $+                            concat daiss+                return section++qpackEncoderS+    :: GCBuffer+    -> Int     -> GCBuffer     -> Int     -> DynamicTable     -> MVar ()-    -> TokenHeaderList-    -> IO (EncodedFieldSection, EncodedEncoderInstruction)-qpackEncoder stgy gcbuf1 bufsiz1 gcbuf2 bufsiz2 gcbuf3 bufsiz3 dyntbl lock ts =+    -> QEncoderS+qpackEncoderS gcbuf1 bufsiz1 gcbuf2 bufsiz2 dyntbl lock sid hs =     withMVar lock $ \_ ->         withForeignPtr gcbuf1 $ \buf1 ->-            withForeignPtr gcbuf2 $ \buf2 ->-                withForeignPtr gcbuf3 $ \buf3 -> do-                    wbuf1 <- newWriteBuffer buf1 bufsiz1-                    wbuf2 <- newWriteBuffer buf2 bufsiz2-                    wbuf3 <- newWriteBuffer buf3 bufsiz3-                    thl <- encodeTokenHeader wbuf1 wbuf3 stgy dyntbl ts -- fixme: leftover-                    when (thl /= []) $ stdoutLogger "qpackEncoder: leftover"-                    hb0 <- toByteString wbuf1-                    ins <- toByteString wbuf3-                    encodePrefix wbuf2 dyntbl-                    prefix <- toByteString wbuf2-                    let hb = prefix `B.append` hb0-                    return (hb, ins)+            withForeignPtr gcbuf2 $ \buf2 -> do+                siz <- getTableCapacity dyntbl+                qpackDebug dyntbl $+                    putStrLn $+                        "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz+                setBasePointToInsersionPoint dyntbl+                clearRequiredInsertCount dyntbl+                let tss = splitThrough bufsiz1 ts+                his <- mapM (qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 dyntbl) tss+                let (hbs, daiss) = unzip his+                prefix <- qpackEncodePrefix buf1 bufsiz1 dyntbl+                let section = BS.concat (prefix : hbs)+                reqInsCnt <- getRequiredInsertCount dyntbl+                -- To count only blocked sections,+                -- dont' register this section if reqInsCnt == 0.+                immAck <- getImmediateAck dyntbl+                when (reqInsCnt /= 0) $ do+                    blocked <- wouldSectionBeBlocked dyntbl reqInsCnt+                    when blocked $ insertBlockedStreamE dyntbl sid+                    let dais = concat daiss+                    insertSection dyntbl sid $ Section reqInsCnt dais+                    when immAck $ do+                        -- The same logic of SectionAcknowledgement.+                        updateKnownReceivedCount dyntbl reqInsCnt+                        mapM_ (decreaseReference dyntbl) dais+                        deleteBlockedStreamE dyntbl sid+                -- Need to emulate InsertCountIncrement since+                -- SectionAcknowledgement is not returned if+                -- RequiredInsertCount is 0.+                when immAck $ setInsersionPointToKnownReceivedCount dyntbl+                return section+  where+    mk' (k, v) = (t, v)+      where+        t = toToken $ foldedCase k+    ts = map mk' hs +qpackEncodeHeader+    :: Buffer+    -> BufferSize+    -> Buffer+    -> BufferSize+    -> DynamicTable+    -> TokenHeaderList+    -> IO (ByteString, [AbsoluteIndex])+qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 dyntbl ts = do+    wbuf1 <- newWriteBuffer buf1 bufsiz1+    wbuf2 <- newWriteBuffer buf2 bufsiz2+    dais <- encodeTokenHeader wbuf1 wbuf2 dyntbl ts+    hb <- toByteString wbuf1+    ins <- toByteString wbuf2+    when (ins /= "") $ sendIns dyntbl ins+    return (hb, dais)++qpackEncodePrefix :: Buffer -> BufferSize -> DynamicTable -> IO ByteString+qpackEncodePrefix buf1 bufsiz1 dyntbl = do+    wbuf1 <- newWriteBuffer buf1 bufsiz1+    encodePrefix wbuf1 dyntbl+    toByteString wbuf1++-- Note: dyntbl for encoder decoderInstructionHandler :: DynamicTable -> DecoderInstructionHandler-decoderInstructionHandler dyntbl recv = loop+decoderInstructionHandler dyntbl recv = loop ""   where-    loop = do-        _ <- getInsertionPoint dyntbl -- fixme-        bs <- recv 1024+    loop bs0 = do+        bs1 <- recv 1024+        let bs+                | bs0 == "" = bs1+                | otherwise = bs0 <> bs1         when (bs /= "") $ do-            (ins, leftover) <- decodeDecoderInstructions bs -- fixme: saving leftover-            when (leftover /= "") $ stdoutLogger "decoderInstructionHandler: leftover"+            (ins, leftover) <- decodeDecoderInstructions bs             qpackDebug dyntbl $ mapM_ print ins             mapM_ handle ins-            loop-    handle (SectionAcknowledgement _n) = return ()-    handle (StreamCancellation _n) = return ()+            loop leftover+    handle (SectionAcknowledgement sid) = do+        msec <- getAndDelSection dyntbl sid+        case msec of+            Nothing -> E.throwIO DecoderInstructionError+            Just (Section reqInsCnt ais) -> do+                updateKnownReceivedCount dyntbl reqInsCnt+                mapM_ (decreaseReference dyntbl) ais+                deleteBlockedStreamE dyntbl sid+    handle (StreamCancellation _n) = return () -- fixme     handle (InsertCountIncrement n)         | n == 0 = E.throwIO DecoderInstructionError-        | otherwise = return () -- FIXME: Known Received Count+        | otherwise = incrementKnownReceivedCount dyntbl n  ---------------------------------------------------------------- +newQEncoderS+    :: QEncoderConfig -- capacity+    -> (EncodedEncoderInstruction -> IO ())+    -> Int -- blocked stream+    -> Bool -- immediate Acks+    -> Bool -- debug+    -> IO QEncoderS+newQEncoderS QEncoderConfig{..} saveEI blocked immediateAck debug = do+    let bufsiz1 = ecHeaderBlockBufferSize+        bufsiz2 = ecInstructionBufferSize+    gcbuf1 <- mallocPlainForeignPtrBytes bufsiz1+    gcbuf2 <- mallocPlainForeignPtrBytes bufsiz2+    dyntbl <- newDynamicTableForEncoding saveEI+    setTableCapacity dyntbl ecMaxTableCapacity+    setMaxBlockedStreams dyntbl blocked+    setImmediateAck dyntbl immediateAck+    setDebugQPACK dyntbl debug+    lock <- newMVar ()+    let enc =+            qpackEncoderS+                gcbuf1+                bufsiz1+                gcbuf2+                bufsiz2+                dyntbl+                lock+    return enc++----------------------------------------------------------------+ -- | Configuration for QPACK decoder. data QDecoderConfig = QDecoderConfig-    { dcDynamicTableSize :: Size-    , dcHuffmanBufferSize :: Size+    { dcMaxTableCapacity :: Size+    , dcHuffmanBufferSize :: Size -- for encoder insteruction handler+    , dcBlockedSterams :: Int+    , dcMaxFieldSectionSize :: Int     }     deriving (Show)  -- | Default configuration for QPACK decoder. -- -- >>> defaultQDecoderConfig--- QDecoderConfig {dcDynamicTableSize = 4096, dcHuffmanBufferSize = 4096}+-- QDecoderConfig {dcMaxTableCapacity = 4096, dcHuffmanBufferSize = 2048, dcBlockedSterams = 100, dcMaxFieldSectionSize = 32768} defaultQDecoderConfig :: QDecoderConfig defaultQDecoderConfig =     QDecoderConfig-        { dcDynamicTableSize = 4096-        , dcHuffmanBufferSize = 4096+        { dcMaxTableCapacity = 4096+        , dcHuffmanBufferSize = 2048 -- no global locking+        , dcBlockedSterams = 100+        , dcMaxFieldSectionSize = 32768         }  -- | Creating a new QPACK decoder.@@ -219,9 +378,10 @@     -> IO (QDecoder, EncoderInstructionHandler) newQDecoder QDecoderConfig{..} sendDI = do     dyntbl <--        newDynamicTableForDecoding dcDynamicTableSize dcHuffmanBufferSize sendDI+        newDynamicTableForDecoding dcHuffmanBufferSize sendDI+    setMaxBlockedStreams dyntbl dcBlockedSterams     let dec = qpackDecoder dyntbl-        handler = encoderInstructionHandler dyntbl+        handler = encoderInstructionHandler dcMaxTableCapacity dyntbl     return (dec, handler)  -- | Creating a new simple QPACK decoder.@@ -232,10 +392,11 @@     -> IO (QDecoderS, EncoderInstructionHandlerS) newQDecoderS QDecoderConfig{..} sendDI debug = do     dyntbl <--        newDynamicTableForDecoding dcDynamicTableSize dcHuffmanBufferSize sendDI-    when debug $ setDebugQPACK dyntbl+        newDynamicTableForDecoding dcHuffmanBufferSize sendDI+    setMaxBlockedStreams dyntbl dcBlockedSterams+    setDebugQPACK dyntbl debug     let dec = qpackDecoderS dyntbl-        handler = encoderInstructionHandlerS dyntbl+        handler = encoderInstructionHandlerS dcMaxTableCapacity dyntbl     return (dec, handler)  qpackDecoder@@ -243,40 +404,55 @@ qpackDecoder dyntbl sid bs = do     (tbl, needAck) <- withReadBuffer bs $ \rbuf -> decodeTokenHeader dyntbl rbuf     when needAck $-        encodeDecoderInstructions [SectionAcknowledgement sid] >>= getSendDI dyntbl+        encodeDecoderInstructions [SectionAcknowledgement sid] >>= sendIns dyntbl     return tbl -qpackDecoderS :: DynamicTable -> StreamId -> EncodedFieldSection -> IO [Header]+qpackDecoderS+    :: DynamicTable -> StreamId -> EncodedFieldSection -> IO (Maybe [Header]) qpackDecoderS dyntbl sid bs = do-    (hs, needAck) <- withReadBuffer bs $ \rbuf -> decodeTokenHeaderS dyntbl rbuf-    when needAck $-        encodeDecoderInstructions [SectionAcknowledgement sid] >>= getSendDI dyntbl-    return hs+    qpackDebug dyntbl $ putStrLn $ "---- Stream " ++ show sid+    mhs <- withReadBuffer bs $ \rbuf -> decodeTokenHeaderS dyntbl rbuf+    case mhs of+        Nothing -> return Nothing+        Just (hs, needAck) -> do+            when needAck $+                encodeDecoderInstructions [SectionAcknowledgement sid] >>= sendIns dyntbl+            return $ Just hs -encoderInstructionHandler :: DynamicTable -> EncoderInstructionHandler-encoderInstructionHandler dyntbl recv = loop+-- Note: dyntbl for decoder+encoderInstructionHandler :: Int -> DynamicTable -> EncoderInstructionHandler+encoderInstructionHandler decCapLim dyntbl recv = loop ""   where-    loop = do-        bs <- recv 1024+    loop bs0 = do+        bs1 <- recv 1024+        let bs+                | bs0 == "" = bs1+                | otherwise = bs0 <> bs1         when (bs /= "") $ do-            encoderInstructionHandlerS dyntbl bs-            loop--encoderInstructionHandlerS :: DynamicTable -> EncoderInstructionHandlerS-encoderInstructionHandlerS _dyntbl "" = return ()-encoderInstructionHandlerS dyntbl bs = do-    (ins, leftover) <- decodeEncoderInstructions hufdec bs -- fixme: saving leftover-    when (leftover /= "") $ stdoutLogger "encoderInstructionHandler: leftover"+            leftover <- encoderInstructionHandlerS decCapLim dyntbl bs+            loop leftover -    qpackDebug dyntbl $ mapM_ print ins-    mapM_ handle ins+-- Note: dyntbl for decoder+encoderInstructionHandlerS :: Int -> DynamicTable -> EncoderInstructionHandlerS+encoderInstructionHandlerS _ _dyntbl "" = return ""+encoderInstructionHandlerS decCapLim dyntbl bs = do+    (ins, leftover) <- decodeEncoderInstructions hufdec bs+    cnt <- sum <$> mapM handle ins+    when (cnt /= 0) $+        encodeDecoderInstructions [InsertCountIncrement cnt] >>= sendIns dyntbl+    return leftover   where-    hufdec = getHuffmanDecoder dyntbl-    handle (SetDynamicTableCapacity n)-        | n > 4096 = E.throwIO EncoderInstructionError-        | otherwise = return () -- FIXME: set cap-    handle (InsertWithNameReference ii val) = do-        atomically $ do+    hufdec = getHuffmanDecoder dyntbl -- only for encoder instruction handler+    handle ins@(SetDynamicTableCapacity n)+        | n > decCapLim = E.throwIO EncoderInstructionError+        | otherwise = do+            setTableCapacity dyntbl n+            qpackDebug dyntbl $ print ins+            return 0+    handle ins@(InsertWithNameReference ii val) = do+        ready <- isTableReady dyntbl+        unless ready $ E.throwIO EncoderInstructionError+        dai <- atomically $ do             idx <- case ii of                 Left ai -> return $ SIndex ai                 Right ri -> do@@ -284,17 +460,29 @@                     return $ DIndex $ fromInsRelativeIndex ri ip             ent0 <- toIndexedEntry dyntbl idx             let ent = toEntryToken (entryToken ent0) val-            insertEntryToDecoder ent dyntbl-        encodeDecoderInstructions [InsertCountIncrement 1] >>= getSendDI dyntbl-    handle (InsertWithLiteralName t val) = do-        atomically $ do+            _ <- insertEntryToDecoder ent dyntbl+            return idx+        qpackDebug dyntbl $ putStrLn $ show ins ++ ": " ++ show dai+        return 1+    handle ins@(InsertWithLiteralName t val) = do+        ready <- isTableReady dyntbl+        unless ready $ E.throwIO EncoderInstructionError+        dai <- atomically $ do             let ent = toEntryToken t val             insertEntryToDecoder ent dyntbl-        encodeDecoderInstructions [InsertCountIncrement 1] >>= getSendDI dyntbl-    handle (Duplicate ri) = do-        atomically $ do+        qpackDebug dyntbl $ putStrLn $ show ins ++ ": " ++ show dai+        return 1+    handle ins@(Duplicate ri) = do+        ready <- isTableReady dyntbl+        unless ready $ E.throwIO EncoderInstructionError+        (dai, dai') <- atomically $ do             ip <- getInsertionPointSTM dyntbl-            let idx = DIndex $ fromInsRelativeIndex ri ip+            let ai = fromInsRelativeIndex ri ip+                idx = DIndex ai             ent <- toIndexedEntry dyntbl idx-            insertEntryToDecoder ent dyntbl-        encodeDecoderInstructions [InsertCountIncrement 1] >>= getSendDI dyntbl+            ai' <- insertEntryToDecoder ent dyntbl+            return (ai, ai')+        qpackDebug dyntbl $+            putStrLn $+                show ins ++ ": " ++ show dai ++ " -> " ++ show dai'+        return 1

@@ -28,8 +28,9 @@ {- FOURMOLU_ENABLE -}  data DecodeError-    = IllegalStaticIndex+    = IllegalStaticIndex Int     | IllegalInsertCount+    | BlockedStreamsOverflow     deriving (Eq, Show)  data EncoderInstructionError = EncoderInstructionError

@@ -4,8 +4,6 @@     encodeTokenHeader,     EncodedFieldSection,     EncodedEncoderInstruction,-    EncodeStrategy (..),-    CompressionAlgo (..),     encodePrefix,      -- * Decoder

@@ -3,10 +3,13 @@ module Network.QPACK.HeaderBlock.Decode where  import Control.Concurrent.STM+import qualified Control.Exception as E import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive import Network.ByteOrder import Network.HPACK.Internal (+    HuffmanDecoder,+    decodeH,     decodeI,     decodeS,     decodeSimple,@@ -17,6 +20,7 @@ import Network.HTTP.Types  import Imports+import Network.QPACK.Error import Network.QPACK.HeaderBlock.Prefix import Network.QPACK.Table import Network.QPACK.Types@@ -26,31 +30,56 @@     -> ReadBuffer     -> IO (TokenHeaderTable, Bool) decodeTokenHeader dyntbl rbuf = do-    (reqip, bp, needAck) <- decodePrefix rbuf dyntbl-    checkInsertionPoint dyntbl reqip-    tbl <- decodeSophisticated (toTokenHeader dyntbl bp) rbuf+    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl+    ready <- checkRequiredInsertCountNB dyntbl reqInsertCount+    unless ready $ do+        ok <- tryIncreaseStreams dyntbl+        unless ok $ E.throwIO BlockedStreamsOverflow+        checkRequiredInsertCount dyntbl reqInsertCount+        decreaseStreams dyntbl+    checkRequiredInsertCount dyntbl reqInsertCount+    let bufsiz = 2048+    gcbuf <- mallocPlainForeignPtrBytes 2048+    let hufdec = decodeH gcbuf bufsiz+    tbl <- decodeSophisticated (toTokenHeader dyntbl bp hufdec) rbuf     return (tbl, needAck)  decodeTokenHeaderS     :: DynamicTable     -> ReadBuffer-    -> IO ([Header], Bool)+    -> IO (Maybe ([Header], Bool)) decodeTokenHeaderS dyntbl rbuf = do-    (reqip, bp, needAck) <- decodePrefix rbuf dyntbl-    debug <- getDebugQPACK dyntbl-    unless debug $ checkInsertionPoint dyntbl reqip-    hs <- decodeSimple (toTokenHeader dyntbl bp) rbuf-    return (hs, needAck)+    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl+    ok <- checkRequiredInsertCountNB dyntbl reqInsertCount+    if ok+        then do+            let bufsiz = 2048+            gcbuf <- mallocPlainForeignPtrBytes 2048+            let hufdec = decodeH gcbuf bufsiz+            hs <- decodeSimple (toTokenHeader dyntbl bp hufdec) rbuf+            return $ Just (hs, needAck)+        else return Nothing +{- FOURMOLU_DISABLE -} toTokenHeader-    :: DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader-toTokenHeader dyntbl bp w8 rbuf-    | w8 `testBit` 7 = decodeIndexedFieldLine rbuf dyntbl bp w8-    | w8 `testBit` 6 = decodeLiteralFieldLineWithNameReference rbuf dyntbl bp w8-    | w8 `testBit` 5 = decodeLiteralFieldLineWithoutNameReference rbuf dyntbl bp w8-    | w8 `testBit` 4 = decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8+    :: DynamicTable+    -> BasePoint+    -> HuffmanDecoder+    -> Word8+    -> ReadBuffer+    -> IO TokenHeader+toTokenHeader dyntbl bp hufdec w8 rbuf+    | w8 `testBit` 7 =+        decodeIndexedFieldLine                  rbuf dyntbl        bp w8+    | w8 `testBit` 6 =+        decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8+    | w8 `testBit` 5 =+        decodeLiteralFieldLineWithLiteralName   rbuf dyntbl hufdec bp w8+    | w8 `testBit` 4 =+        decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl        bp w8     | otherwise =-        decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl bp w8+        decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8+{- FOURMOLU_ENABLE -}  -- 4.5.2.  Indexed Field Line decodeIndexedFieldLine@@ -60,48 +89,14 @@     let static = w8 `testBit` 6         hidx             | static = SIndex $ AbsoluteIndex i-            | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp+            | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp     ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)-    qpackDebug dyntbl $+    qpackDebug dyntbl $ do+        checkHIndex dyntbl hidx         putStrLn $             "IndexedFieldLine (" ++ show hidx ++ ") " ++ showTokenHeader ret     return ret --- 4.5.4.  Literal Field Line With Name Reference-decodeLiteralFieldLineWithNameReference-    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader-decodeLiteralFieldLineWithNameReference rbuf dyntbl bp w8 = do-    i <- decodeI 4 (w8 .&. 0b00001111) rbuf-    let static = w8 `testBit` 4-        hidx-            | static = SIndex $ AbsoluteIndex i-            | otherwise = DIndex $ fromHBRelativeIndex (HBRelativeIndex i) bp-    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)-    let hufdec = getHuffmanDecoder dyntbl-    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf-    let ret = (key, val)-    qpackDebug dyntbl $-        putStrLn $-            "LiteralFieldLineWithNameReference ("-                ++ show hidx-                ++ ") "-                ++ showTokenHeader ret-    return ret---- 4.5.6.  Literal Field Line Without Name Reference-decodeLiteralFieldLineWithoutNameReference-    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader-decodeLiteralFieldLineWithoutNameReference rbuf dyntbl _bp _w8 = do-    ff rbuf (-1)-    let hufdec = getHuffmanDecoder dyntbl-    key <- toToken <$> decodeS (.&. 0b00000111) (`testBit` 3) 3 hufdec rbuf-    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf-    let ret = (key, val)-    qpackDebug dyntbl $-        putStrLn $-            "LiteralFieldLineWithoutNameReference " ++ showTokenHeader ret-    return ret- -- 4.5.3.  Indexed Field Line With Post-Base Index decodeIndexedFieldLineWithPostBaseIndex     :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader@@ -109,34 +104,84 @@     i <- decodeI 4 (w8 .&. 0b00001111) rbuf     let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp     ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)-    qpackDebug dyntbl $+    qpackDebug dyntbl $ do+        checkHIndex dyntbl hidx         putStrLn $             "IndexedFieldLineWithPostBaseIndex ("                 ++ show hidx                 ++ " "-                ++ show i-                ++ "/"                 ++ show bp+                ++ " after "+                ++ show i                 ++ ") "                 ++ showTokenHeader ret     return ret +-- 4.5.4.  Literal Field Line With Name Reference+decodeLiteralFieldLineWithNameReference+    :: ReadBuffer+    -> DynamicTable+    -> HuffmanDecoder+    -> BasePoint+    -> Word8+    -> IO TokenHeader+decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8 = do+    i <- decodeI 4 (w8 .&. 0b00001111) rbuf+    let static = w8 `testBit` 4+        hidx+            | static = SIndex $ AbsoluteIndex i+            | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp+    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)+    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf+    let ret = (key, val)+    qpackDebug dyntbl $ do+        checkHIndex dyntbl hidx+        putStrLn $+            "LiteralFieldLineWithNameReference ("+                ++ show hidx+                ++ ") "+                ++ showTokenHeader ret+    return ret+ -- 4.5.5.  Literal Field Line With Post-Base Name Reference decodeLiteralFieldLineWithPostBaseNameReference-    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader-decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl bp w8 = do+    :: ReadBuffer+    -> DynamicTable+    -> HuffmanDecoder+    -> BasePoint+    -> Word8+    -> IO TokenHeader+decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8 = do     i <- decodeI 3 (w8 .&. 0b00000111) rbuf     let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp     key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)-    let hufdec = getHuffmanDecoder dyntbl     val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf     let ret = (key, val)-    qpackDebug dyntbl $+    qpackDebug dyntbl $ do+        checkHIndex dyntbl hidx         putStrLn $             "LiteralFieldLineWithPostBaseNameReference ("                 ++ show hidx                 ++ ") "                 ++ showTokenHeader ret+    return ret++-- 4.5.6.  Literal Field Line With Literal Name+decodeLiteralFieldLineWithLiteralName+    :: ReadBuffer+    -> DynamicTable+    -> HuffmanDecoder+    -> BasePoint+    -> Word8+    -> IO TokenHeader+decodeLiteralFieldLineWithLiteralName rbuf dyntbl hufdec _bp _w8 = do+    ff rbuf (-1)+    key <- toToken <$> decodeS (.&. 0b00000111) (`testBit` 3) 3 hufdec rbuf+    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf+    let ret = (key, val)+    qpackDebug dyntbl $+        putStrLn $+            "LiteralFieldLineWithLiteralName " ++ showTokenHeader ret     return ret  showTokenHeader :: TokenHeader -> String

@@ -1,22 +1,19 @@ {-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.QPACK.HeaderBlock.Encode (     encodeHeader,     encodeTokenHeader,     EncodedFieldSection,     EncodedEncoderInstruction,-    EncodeStrategy (..),-    CompressionAlgo (..), ) where  import qualified Control.Exception as E import qualified Data.ByteString as B-import Data.IORef+import qualified Data.ByteString.Char8 as C8 import Network.ByteOrder+import Network.Control import Network.HPACK.Internal (-    CompressionAlgo (..),-    EncodeStrategy (..),     encodeI,     encodeS,     toEntryToken,@@ -40,15 +37,17 @@ --   Header block with prefix and instructions are returned. --   2048, 32, and 2048 bytes-buffers are --   temporally allocated for header block, prefix and encoder instructions.+--   If headers are too large, 'BufferOverrun' is thrown. encodeHeader-    :: EncodeStrategy-    -> DynamicTable+    :: DynamicTable     -> [Header]     -> IO (EncodedFieldSection, EncodedEncoderInstruction)-encodeHeader stgy dyntbl hs = do+encodeHeader dyntbl hs = do+    setBasePointToInsersionPoint dyntbl+    clearRequiredInsertCount dyntbl     (hb0, insb) <- withWriteBuffer' 2048 $ \wbuf1 ->         withWriteBuffer 2048 $ \wbuf2 -> do-            hs1 <- encodeTokenHeader wbuf1 wbuf2 stgy dyntbl ts+            hs1 <- encodeTokenHeader wbuf1 wbuf2 dyntbl ts             unless (null hs1) $ E.throwIO BufferOverrun     prefix <- withWriteBuffer 32 $ \wbuf -> encodePrefix wbuf dyntbl     let hb = prefix `B.append` hb0@@ -57,32 +56,24 @@     ts = map (\(k, v) -> let t = toToken (foldedCase k) in (t, v)) hs  -- | Converting 'TokenHeaderList' to the QPACK format.+--  'TokenHeaderList' must be smaller than or equal to workspaces.+--  Otherwise, 'BufferOverrun' is thrown. encodeTokenHeader     :: WriteBuffer     -- ^ Workspace for the body of header block     -> WriteBuffer     -- ^ Workspace for encoder instructions-    -> EncodeStrategy     -> DynamicTable     -> TokenHeaderList-    -> IO TokenHeaderList-    -- ^ Leftover-encodeTokenHeader wbuf1 wbuf2 EncodeStrategy{..} dyntbl ts0 = do+    -> IO [AbsoluteIndex]+encodeTokenHeader wbuf1 wbuf2 dyntbl ts0 = do     clearWriteBuffer wbuf1     clearWriteBuffer wbuf2-    setBasePointToInsersionPoint dyntbl     let revidx = getRevIndex dyntbl-    ref <- newIORef ts0-    case compressionAlgo of-        Static ->-            encodeStatic wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return ()-        _ ->-            encodeLinear wbuf1 wbuf2 dyntbl revidx useHuffman ref ts0 `E.catch` \BufferOverrun -> return ()-    ts <- readIORef ref-    unless (null ts) $ do-        goBack wbuf1-        goBack wbuf2-    return ts+    ready <- isTableReady dyntbl+    if ready+        then encodeLinear wbuf1 wbuf2 dyntbl revidx True ts0+        else encodeStatic wbuf1 wbuf2 dyntbl revidx True ts0  encodeStatic     :: WriteBuffer@@ -90,87 +81,259 @@     -> DynamicTable     -> RevIndex     -> Bool-    -> IORef TokenHeaderList     -> TokenHeaderList-    -> IO ()-encodeStatic wbuf1 _wbuf2 dyntbl revidx huff ref ts0 = loop ts0-  where-    loop [] = return ()-    loop ((t, val) : ts) = do-        rr <- lookupRevIndex t val revidx-        case rr of-            KV hi -> do-                -- 4.5.2.  Indexed Field Line-                encodeIndexedFieldLine wbuf1 dyntbl hi-            K hi -> do-                -- 4.5.4.  Literal Field Line With Name Reference-                encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff-            N -> do-                -- 4.5.6.  Literal Field Line Without Name Reference-                encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff-        save wbuf1-        writeIORef ref ts-        loop ts+    -> IO [AbsoluteIndex]+encodeStatic wbuf1 _wbuf2 dyntbl revidx huff ts0 = do+    mapM_ (encStatic wbuf1 dyntbl revidx huff) ts0+    return [] +encStatic+    :: WriteBuffer -> DynamicTable -> RevIndex -> Bool -> (Token, FieldValue) -> IO ()+encStatic wbuf1 dyntbl revidx huff (t, val) = do+    rr <- lookupRevIndex t val revidx+    case rr of+        KV hi -> do+            -- 4.5.2.  Indexed Field Line+            encodeIndexedFieldLine wbuf1 dyntbl hi+        K i -> do+            -- 4.5.4.  Literal Field Line With Name Reference+            encodeLiteralFieldLineWithNameReference wbuf1 dyntbl i val huff+        N -> do+            -- 4.5.6.  Literal Field Line with Literal Name+            encodeLiteralFieldLineWithLiteralName wbuf1 dyntbl t val huff+ encodeLinear     :: WriteBuffer     -> WriteBuffer     -> DynamicTable     -> RevIndex     -> Bool-    -> IORef TokenHeaderList     -> TokenHeaderList-    -> IO ()-encodeLinear wbuf1 wbuf2 dyntbl revidx huff ref ts0 = loop ts0+    -> IO [AbsoluteIndex]+encodeLinear wbuf1 wbuf2 dyntbl revidx huff ts0 =+    catMaybes <$> mapM (encLinear wbuf1 wbuf2 dyntbl revidx huff) ts0++encLinear+    :: WriteBuffer+    -> WriteBuffer+    -> DynamicTable+    -> RevIndex+    -> Bool+    -> (Token, FieldValue)+    -> IO (Maybe AbsoluteIndex)+encLinear wbuf1 wbuf2 dyntbl revidx huff (t, val) = do+    rr <- lookupRevIndex t val revidx+    qpackDebug dyntbl $ do+        tblsiz <- getTableCapacity dyntbl+        base <- getBasePoint dyntbl+        insPnt <- getInsertionPoint dyntbl+        putStrLn $+            "    Table size: "+                ++ show tblsiz+                ++ " "+                ++ show base+                ++ " "+                ++ show insPnt+        putStr "    "+        printReferences dyntbl+        putStrLn $ show rr ++ ": " ++ show (tokenKey t) ++ " " ++ show val ++ ""+    case rr of+        KV hi@(SIndex _) -> do+            -- 4.5.2/4.5.3+            encodeIndexed wbuf1 dyntbl hi+            return Nothing+        KV hi@(DIndex ai) -> do+            qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "KV (1)"+            withDIndex ai $ do+                -- 4.5.2/4.5.3+                encodeIndexed wbuf1 dyntbl hi+                increaseReference dyntbl ai+                return $ Just ai+        K hi@(SIndex i) -> tryInsertVal hi $ do+            insertWithNameReference val ent Nothing $ Left i+        K hi@(DIndex ai) -> do+            qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "K (1)"+            withDIndex ai $ tryInsertVal hi $ do+                ridx <- toInsRelativeIndex ai <$> getInsertionPoint dyntbl+                insertWithNameReference val ent (Just ai) $ Right ridx+        N -> tryInsertKeyVal $ insertWithLiteralName val ent   where-    loop [] = return ()-    loop ((t, val) : ts) = do-        rr <- lookupRevIndex t val revidx-        case rr of-            KV hi -> do-                -- 4.5.2.  Indexed Field Line-                encodeIndexedFieldLine wbuf1 dyntbl hi-            K hi-                | shouldBeIndexed t -> do-                    insidx <- case hi of-                        SIndex i -> return $ Left i-                        DIndex i -> do-                            ip <- getInsertionPoint dyntbl-                            return $ Right $ toInsRelativeIndex i ip-                    let ins = InsertWithNameReference insidx val-                    encodeEI wbuf2 True ins-                    dai <- insertEntryToEncoder (toEntryToken t val) dyntbl-                    -- 4.5.3.  Indexed Field Line With Post-Base Index-                    encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai-                | otherwise -> do-                    -- 4.5.4.  Literal Field Line With Name Reference-                    encodeLiteralFieldLineWithNameReference wbuf1 dyntbl hi val huff-            N-                | shouldBeIndexed t -> do-                    let ins = InsertWithLiteralName t val-                    encodeEI wbuf2 True ins-                    dai <- insertEntryToEncoder (toEntryToken t val) dyntbl-                    encodeIndexedFieldLineWithPostBaseIndex wbuf1 dyntbl dai-                | otherwise -> do-                    -- 4.5.6.  Literal Field Line Without Name Reference-                    encodeLiteralFieldLineWithoutNameReference wbuf1 t val huff-        save wbuf1-        save wbuf2-        writeIORef ref ts-        loop ts+    ent = toEntryToken t val+    key = tokenFoldedKey t+    lru = getLruCache dyntbl +    withDIndex ai action = do+        blocked <- wouldInstructionBeBlocked dyntbl ai+        canUseDynamicTable <- checkBlockedStreams dyntbl+        if canUseDynamicTable || not blocked+            then action+            else encodeLiteralFieldLineStatic++    insertWithNameReference v e mai insidx =+        insertWith mai e $ InsertWithNameReference insidx v++    insertWithLiteralName v e =+        insertWith Nothing e $ InsertWithLiteralName t v++    insertWith maiForKey e ins = do+        encodeEI wbuf2 True ins+        ai <- insertEntryToEncoder e dyntbl+        qpackDebug dyntbl $ putStrLn $ show ins ++ ": " ++ show ai+        canUseDynamicTable <- checkBlockedStreams dyntbl+        if canUseDynamicTable+            then do+                -- 4.5.4/4.5.5+                encodeWithNameReference wbuf1 dyntbl (DIndex ai) val huff+                increaseReference dyntbl ai+                return $ Just ai+            else encodeLiteralValue maiForKey++    encodeLiteralValue Nothing = encodeLiteralFieldLineStatic+    encodeLiteralValue (Just ai) = do+        blocked <- wouldInstructionBeBlocked dyntbl ai+        canUseDynamicTable <- checkBlockedStreams dyntbl+        if canUseDynamicTable || not blocked+            then do+                -- 4.5.4/4.5.5+                encodeWithNameReference wbuf1 dyntbl (DIndex ai) val huff+                increaseReference dyntbl ai+                return $ Just ai+            else encodeLiteralFieldLineStatic++    tryInsertVal hi action = do+        -- Field representation MUST not refer to a dropped entry+        -- on insertion.+        let possiblelyDropMySelf = case hi of+                SIndex _ -> Nothing+                DIndex ai -> Just ai+        ok <- checkExistenceAndSpace ent key val possiblelyDropMySelf "Val"+        if ok+            then action+            else do+                -- 4.5.4/4.5.5+                encodeWithNameReference wbuf1 dyntbl hi val huff+                case hi of+                    SIndex _ -> return Nothing+                    DIndex dai -> do+                        increaseReference dyntbl dai+                        return $ Just dai++    tryInsertKeyVal action = do+        ok <- checkExistenceAndSpace ent key val Nothing "KeyVal"+        case ok of+            True -> action+            False -> tryInsertKey++    tryInsertKey+        | isJust (tokenToStaticIndex t) = encodeLiteralFieldLineStatic+        | otherwise = do+            mdai <- isKeyRegistered key revidx+            case mdai of+                Nothing -> do+                    let val' = ""+                        ent' = toEntryToken t val'+                    okK <- checkExistenceAndSpace ent' key val' Nothing "Key"+                    if okK+                        then insertWithLiteralName val' ent'+                        else encodeLiteralFieldLineStatic+                Just dai -> encodeLiteralFieldLineDynamic dai++    encodeLiteralFieldLineDynamic dai = do+        canUseDynamicTable <- checkBlockedStreams dyntbl+        if canUseDynamicTable+            then do+                -- 4.5.4/4.5.5+                encodeWithNameReference wbuf1 dyntbl (DIndex dai) val huff++                increaseReference dyntbl dai+                return $ Just dai+            else do+                -- 4.5.6.  Literal Field Line with Literal Name+                encodeLiteralFieldLineWithLiteralName wbuf1 dyntbl t val huff+                tryTailDuplication+                return Nothing++    encodeLiteralFieldLineStatic = do+        case tokenToStaticIndex t of+            Just i -> do+                -- 4.5.4/4.5.5+                encodeWithNameReference wbuf1 dyntbl (SIndex i) val huff+            Nothing -> do+                -- 4.5.6.  Literal Field Line with Literal Name+                encodeLiteralFieldLineWithLiteralName wbuf1 dyntbl t val huff+                tryTailDuplication+        return Nothing++    checkExistence k v tag = do+        (_, exist) <- cached lru (k, v) (return ())+        qpackDebug dyntbl $+            putStrLn $+                (if exist then "    HIT for " ++ tag else "    not HIT for " ++ tag)+                    ++ " "+                    ++ show k+                    ++ " "+                    ++ show v+        return exist++    checkSpace e possiblelyDropMySelf tag = do+        spaceOK <- canInsertEntry dyntbl e possiblelyDropMySelf+        unless spaceOK $ do+            adjustDrainingPoint dyntbl+            qpackDebug dyntbl $ putStrLn $ "    NO SPACE for " ++ tag+        return spaceOK++    checkExistenceAndSpace e k v possiblelyDropMySelf tag = do+        exist <- checkExistence k v tag+        if exist+            then checkSpace e possiblelyDropMySelf tag+            else return False++    tryTailDuplication = do+        mx <- checkTailDuplication dyntbl+        case mx of+            Nothing -> return ()+            Just ai -> do+                ridx <- toInsRelativeIndex ai <$> getInsertionPoint dyntbl+                let ins = Duplicate ridx+                encodeEI wbuf2 True ins+                qpackDebug dyntbl $ putStrLn $ (show ins) ++ " = " ++ show ai+                nai <- tailDuplication dyntbl+                qpackDebug dyntbl $ putStrLn $ "Duplicate: " ++ show ai ++ " -> " ++ show nai++-- 4.5.2/4.5.3+encodeIndexed :: WriteBuffer -> DynamicTable -> HIndex -> IO ()+encodeIndexed wbuf dyntbl hi@(SIndex (AbsoluteIndex idx)) = do+    encodeI wbuf set11 6 idx+    qpackDebug dyntbl $ putStrLn $ "IndexedFieldLine (" ++ show hi ++ ")"+encodeIndexed wbuf dyntbl hi@(DIndex ai) = do+    qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "encodeIndexed"+    updateRequiredInsertCount dyntbl ai+    bp <- getBasePoint dyntbl+    case toBaseIndex ai bp of+        Left (PreBaseIndex idx) -> do+            encodeI wbuf set10 6 idx+            qpackDebug dyntbl $ putStrLn $ "IndexedFieldLine (" ++ show hi ++ ")"+        Right (PostBaseIndex idx) -> do+            encodeI wbuf set0001 4 idx+            qpackDebug dyntbl $+                putStrLn $+                    "IndexedFieldLineWithPostBaseIndex (" ++ show hi ++ ")"+ -- 4.5.2.  Indexed Field Line encodeIndexedFieldLine :: WriteBuffer -> DynamicTable -> HIndex -> IO () encodeIndexedFieldLine wbuf dyntbl hi = do     (idx, set) <- case hi of         SIndex (AbsoluteIndex i) -> return (i, set11)         DIndex ai -> do-            updateLargestReference dyntbl ai+            qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "encodeIndexedFieldLine"+            updateRequiredInsertCount dyntbl ai             bp <- getBasePoint dyntbl-            let HBRelativeIndex i = toHBRelativeIndex ai bp+            let PreBaseIndex i = toPreBaseIndex ai bp             return (i, set10)     encodeI wbuf set 6 idx+    qpackDebug dyntbl $ putStrLn $ "IndexedFieldLine (" ++ show hi ++ ")" +{- -- 4.5.3.  Indexed Field Line With Post-Base Index encodeIndexedFieldLineWithPostBaseIndex     :: WriteBuffer@@ -178,31 +341,93 @@     -> AbsoluteIndex -- in Dynamic table     -> IO () encodeIndexedFieldLineWithPostBaseIndex wbuf dyntbl ai = do+    updateRequiredInsertCount dyntbl ai     bp <- getBasePoint dyntbl-    let HBRelativeIndex idx = toHBRelativeIndex ai bp+    let PostBaseIndex idx = toPostBaseIndex ai bp     encodeI wbuf set0001 4 idx+    qpackDebug dyntbl $ putStrLn "IndexedFieldLineWithPostBaseIndex "+-} +---------------------------------------------------------------++-- 4.5.4/4.5.5+encodeWithNameReference+    :: WriteBuffer -> DynamicTable -> HIndex -> ByteString -> Bool -> IO ()+encodeWithNameReference wbuf dyntbl hidx@(SIndex (AbsoluteIndex idx)) val huff = do+    encodeI wbuf set0101 4 idx+    encodeS wbuf huff id set1 7 val+    qpackDebug dyntbl $+        putStrLn $+            "LiteralFieldLineWithNameReference (" ++ show hidx ++ ")"+encodeWithNameReference wbuf dyntbl hidx@(DIndex ai) val huff = do+    qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "encodeWithNameReference"+    updateRequiredInsertCount dyntbl ai+    bp <- getBasePoint dyntbl+    case toBaseIndex ai bp of+        Left (PreBaseIndex idx) -> do+            encodeI wbuf set0100 4 idx+            encodeS wbuf huff id set1 7 val+            qpackDebug dyntbl $+                putStrLn $+                    "LiteralFieldLineWithNameReference (" ++ show hidx ++ ")"+        Right (PostBaseIndex idx) -> do+            encodeI wbuf set00000 3 idx+            encodeS wbuf huff id set1 7 val+            qpackDebug dyntbl $+                putStrLn $+                    "LiteralFieldLineWithPostBaseNameReference (DIndex " ++ show ai ++ ")"+ -- 4.5.4.  Literal Field Line With Name Reference encodeLiteralFieldLineWithNameReference     :: WriteBuffer -> DynamicTable -> HIndex -> ByteString -> Bool -> IO ()-encodeLiteralFieldLineWithNameReference wbuf dyntbl hi val huff = do-    (idx, set) <- case hi of+encodeLiteralFieldLineWithNameReference wbuf dyntbl hidx val huff = do+    (idx, set) <- case hidx of         SIndex (AbsoluteIndex i) -> return (i, set0101)         DIndex ai -> do-            updateLargestReference dyntbl ai+            updateRequiredInsertCount dyntbl ai             bp <- getBasePoint dyntbl-            let HBRelativeIndex i = toHBRelativeIndex ai bp+            let PreBaseIndex i = toPreBaseIndex ai bp             return (i, set0100)     encodeI wbuf set 4 idx     encodeS wbuf huff id set1 7 val+    qpackDebug dyntbl $+        putStrLn $+            "LiteralFieldLineWithNameReference (" ++ show hidx ++ ")" +{- -- 4.5.5.  Literal Field Line With Post-Base Name Reference--- not implemented+encodeLiteralFieldLineWithPostBaseNameReference+    :: WriteBuffer+    -> DynamicTable+    -> AbsoluteIndex -- in Dynamic table+    -> ByteString+    -> Bool+    -> IO ()+encodeLiteralFieldLineWithPostBaseNameReference wbuf dyntbl ai val huff = do+    updateRequiredInsertCount dyntbl ai+    bp <- getBasePoint dyntbl+    let PostBaseIndex idx = toPostBaseIndex ai bp+    encodeI wbuf set00000 3 idx+    encodeS wbuf huff id set1 7 val+    qpackDebug dyntbl $+        putStrLn $+            "LiteralFieldLineWithPostBaseNameReference (DIndex " ++ show ai ++ ")"+-} --- 4.5.6.  Literal Field Line Without Name Reference-encodeLiteralFieldLineWithoutNameReference-    :: WriteBuffer -> Token -> ByteString -> Bool -> IO ()-encodeLiteralFieldLineWithoutNameReference wbuf token val huff = do+---------------------------------------------------------------++-- 4.5.6.  Literal Field Line with Literal Name+encodeLiteralFieldLineWithLiteralName+    :: WriteBuffer -> DynamicTable -> Token -> ByteString -> Bool -> IO ()+encodeLiteralFieldLineWithLiteralName wbuf dyntbl token val huff = do     let key = tokenFoldedKey token     encodeS wbuf huff set0010 set00001 3 key     encodeS wbuf huff id set1 7 val+    qpackDebug dyntbl $+        putStrLn $+            "LiteralFieldLineWithLiteralName " ++ showHeader key val++---------------------------------------------------------------++showHeader :: ByteString -> ByteString -> String+showHeader key val = "\"" ++ C8.unpack key ++ "\" \"" ++ C8.unpack val ++ "\""

@@ -26,25 +26,27 @@ -- 4 -- >>> encodeRequiredInsertCount 128 1000 -- 233-encodeRequiredInsertCount :: Int -> InsertionPoint -> Int+encodeRequiredInsertCount :: Int -> RequiredInsertCount -> Int encodeRequiredInsertCount _ 0 = 0-encodeRequiredInsertCount maxEntries (InsertionPoint reqInsertCount) =+encodeRequiredInsertCount maxEntries (RequiredInsertCount reqInsertCount) =     (reqInsertCount `mod` (2 * maxEntries)) + 1  -- | for decoder -- -- >>> decodeRequiredInsertCount 3 10 4--- InsertionPoint 9+-- RequiredInsertCount 9 -- >>> decodeRequiredInsertCount 128 990 233--- InsertionPoint 1000-decodeRequiredInsertCount :: Int -> InsertionPoint -> Int -> InsertionPoint+-- RequiredInsertCount 1000+decodeRequiredInsertCount+    :: Int -> InsertionPoint -> Int -> RequiredInsertCount decodeRequiredInsertCount _ _ 0 = 0+decodeRequiredInsertCount 0 _ n = RequiredInsertCount (n - 1) decodeRequiredInsertCount maxEntries (InsertionPoint totalNumberOfInserts) encodedInsertCount     | encodedInsertCount > fullRange = E.throw IllegalInsertCount     | reqInsertCount > maxValue && reqInsertCount <= fullRange =         E.throw IllegalInsertCount-    | reqInsertCount > maxValue = InsertionPoint (reqInsertCount - fullRange)-    | otherwise = InsertionPoint reqInsertCount+    | reqInsertCount > maxValue = RequiredInsertCount (reqInsertCount - fullRange)+    | otherwise = RequiredInsertCount reqInsertCount   where     fullRange = 2 * maxEntries     maxValue = totalNumberOfInserts + maxEntries@@ -58,8 +60,8 @@ -- (False,3) -- >>> encodeBase 9 6 -- (True,2)-encodeBase :: InsertionPoint -> BasePoint -> (Bool, Int)-encodeBase (InsertionPoint reqInsCnt) (BasePoint base)+encodeBase :: RequiredInsertCount -> BasePoint -> (Bool, Int)+encodeBase (RequiredInsertCount reqInsCnt) (BasePoint base)     | diff >= 0 = (False, diff) -- base - reqInsCnt     | otherwise = (True, negate diff - 1) -- reqInsCnt - base - 1   where@@ -70,9 +72,9 @@ -- BasePoint 9 -- >>> decodeBase 9 True 2 -- BasePoint 6-decodeBase :: InsertionPoint -> Bool -> Int -> BasePoint-decodeBase (InsertionPoint reqInsCnt) False deltaBase = BasePoint (reqInsCnt + deltaBase)-decodeBase (InsertionPoint reqInsCnt) True deltaBase = BasePoint (reqInsCnt - deltaBase - 1)+decodeBase :: RequiredInsertCount -> Bool -> Int -> BasePoint+decodeBase (RequiredInsertCount reqInsCnt) False deltaBase = BasePoint (reqInsCnt + deltaBase)+decodeBase (RequiredInsertCount reqInsCnt) True deltaBase = BasePoint (reqInsCnt - deltaBase - 1)  ---------------------------------------------------------------- @@ -83,7 +85,8 @@     clearWriteBuffer wbuf     maxEntries <- getMaxNumOfEntries dyntbl     baseIndex <- getBasePoint dyntbl-    reqInsCnt <- getLargestReference dyntbl+    reqInsCnt <- getRequiredInsertCount dyntbl+    qpackDebug dyntbl $ print reqInsCnt     -- Required Insert Count     let ric = encodeRequiredInsertCount maxEntries reqInsCnt     encodeI wbuf set0 8 ric@@ -96,7 +99,7 @@  -- | Decoding the prefix part of header block. decodePrefix-    :: ReadBuffer -> DynamicTable -> IO (InsertionPoint, BasePoint, Bool)+    :: ReadBuffer -> DynamicTable -> IO (RequiredInsertCount, BasePoint, Bool) decodePrefix rbuf dyntbl = do     maxEntries <- getMaxNumOfEntries dyntbl     totalNumberOfInserts <- getInsertionPoint dyntbl@@ -110,6 +113,12 @@     let baseIndex = decodeBase reqInsCnt s delta     qpackDebug dyntbl $         putStrLn $-            "Required" ++ show reqInsCnt ++ ", " ++ show baseIndex+            show reqInsCnt+                ++ ", "+                ++ show baseIndex+                ++ ", "+                ++ show totalNumberOfInserts+                ++ ", maxN "+                ++ show maxEntries     let needAck = reqInsCnt /= 0     return (reqInsCnt, baseIndex, needAck)

@@ -59,14 +59,18 @@             ++ BS8.unpack v             ++ "\""     show (InsertWithNameReference (Right (InsRelativeIndex idx)) v) =-        "InsertWithNameReference (DynRel " ++ show idx ++ ") \"" ++ BS8.unpack v ++ "\""+        "InsertWithNameReference (InsRelative "+            ++ show idx+            ++ ") \""+            ++ BS8.unpack v+            ++ "\""     show (InsertWithLiteralName t v) =         "InsertWithLiteralName \""             ++ BS8.unpack (foldedCase (tokenKey t))             ++ "\" \""             ++ BS8.unpack v             ++ "\""-    show (Duplicate (InsRelativeIndex idx)) = "Duplicate (DynRel " ++ show idx ++ ")"+    show (Duplicate (InsRelativeIndex idx)) = "Duplicate (InsRelative " ++ show idx ++ ")"  ---------------------------------------------------------------- @@ -92,10 +96,12 @@ decodeEncoderInstructions'     :: ByteString -> IO ([EncoderInstruction], ByteString) decodeEncoderInstructions' bs = do-    let bufsiz = 4096-    gcbuf <- mallocPlainForeignPtrBytes 4096+    let bufsiz = 2048+    gcbuf <- mallocPlainForeignPtrBytes 2048     decodeEncoderInstructions (decodeH gcbuf bufsiz) bs +-- HuffmanDecoder is occupied.+-- No other threads MUST NOT use it. decodeEncoderInstructions     :: HuffmanDecoder -> ByteString -> IO ([EncoderInstruction], ByteString) decodeEncoderInstructions hufdec bs = withReadBuffer bs $ loop id

@@ -1,36 +1,7 @@ module Network.QPACK.Table (-    -- * Dynamic table-    DynamicTable,-    newDynamicTableForEncoding,-    newDynamicTableForDecoding,--    -- * Getter and setter-    getMaxNumOfEntries,-    setBasePointToInsersionPoint,-    getBasePoint,-    getInsertionPoint,-    getInsertionPointSTM,-    checkInsertionPoint,-    getLargestReference,-    updateLargestReference,--    -- * Entry-    insertEntryToEncoder,-    insertEntryToDecoder,+    module Network.QPACK.Table.Dynamic,+    module Network.QPACK.Table.RevIndex,     toIndexedEntry,--    -- * Reverse index-    RevIndex,-    RevResult (..),-    getRevIndex,-    lookupRevIndex,--    -- * Misc-    getHuffmanDecoder,-    getSendDI,-    setDebugQPACK,-    getDebugQPACK,-    qpackDebug, ) where  import Control.Concurrent.STM

@@ -1,190 +1,254 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Network.QPACK.Table.Dynamic where+module Network.QPACK.Table.Dynamic (+    -- * Dynamic table+    DynamicTable,+    newDynamicTableForEncoding,+    newDynamicTableForDecoding, +    -- * Capacity+    isTableReady,+    getTableCapacity,+    setTableCapacity,+    getMaxNumOfEntries,++    -- * Entry+    insertEntryToDecoder,+    insertEntryToEncoder,+    toDynamicEntry,++    -- * Section+    Section (..),+    insertSection,+    getAndDelSection,+    increaseReference,+    decreaseReference,++    -- * Streams+    getMaxBlockedStreams,+    setMaxBlockedStreams,+    tryIncreaseStreams,+    decreaseStreams,++    -- * Blocked streams+    insertBlockedStreamE,+    deleteBlockedStreamE,+    checkBlockedStreams,++    -- * Required insert count+    getRequiredInsertCount,+    clearRequiredInsertCount,+    checkRequiredInsertCount,+    checkRequiredInsertCountNB,+    updateRequiredInsertCount,++    -- * Known received count+    incrementKnownReceivedCount,+    updateKnownReceivedCount,+    wouldSectionBeBlocked,+    wouldInstructionBeBlocked,+    setInsersionPointToKnownReceivedCount,++    -- * Points+    getBasePoint,+    setBasePointToInsersionPoint,+    getInsertionPoint,+    getInsertionPointSTM,++    -- * Draining+    isDraining,+    adjustDrainingPoint,+    checkTailDuplication,+    tailDuplication,+    duplicate,+    tryDrop,++    -- * Dropping+    canInsertEntry,++    -- * Accessing+    getLruCache,+    getRevIndex,+    getHuffmanDecoder,+    sendIns,++    -- * Max header size+    getMaxHeaderSize,+    setMaxHeaderSize,++    -- * Debug+    qpackDebug,+    getDebugQPACK,+    setDebugQPACK,+    printReferences,+    checkHIndex,+    checkAbsoluteIndex,++    -- * QIF+    getImmediateAck,+    setImmediateAck,+) where++import Control.Concurrent import Control.Concurrent.STM-import qualified Control.Exception as E import Data.Array.Base (unsafeRead, unsafeWrite)-import Data.Array.MArray (newArray)+import Data.Array.IO (IOArray, newArray) import Data.IORef-import Network.ByteOrder+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Set (Set)+import qualified Data.Set as Set -- Set.size is O(1), IntSet.size is O(n)+import Imports+import Network.Control import Network.HPACK.Internal (     Entry,-    GCBuffer,     HuffmanDecoder,     Index,     Size,-    decH,+    decodeH,     dummyEntry,+    entryFieldValue,+    entryHeaderName,+    entrySize,     maxNumbers,  )+import System.IO.Unsafe (unsafePerformIO) -import Imports import Network.QPACK.Table.RevIndex import Network.QPACK.Types+import Network.QUIC (StreamId) +----------------------------------------------------------------++type Table = TArray Index Entry+data Section = Section RequiredInsertCount [AbsoluteIndex]+data Reference = Reference Int Int deriving (Show)++{- FOURMOLU_DISABLE -} data CodeInfo     = EncodeInfo-        RevIndex -- Reverse index-        (IORef InsertionPoint)-    | DecodeInfo HuffmanDecoder (ByteString -> IO ())+        { revIndex            :: RevIndex -- Reverse index+        , requiredInsertCount :: IORef RequiredInsertCount+        , droppingPoint       :: IORef AbsoluteIndex+        , drainingPoint       :: IORef AbsoluteIndex+        , knownReceivedCount  :: TVar Int+        , referenceCounters   :: IORef (IOArray Index Reference)+        , sections            :: IORef (IntMap Section)+        , lruCache            :: LRUCacheRef (FieldName, FieldValue) ()+        , immediateAck        :: IORef Bool -- for QIF+        , blockedStreamsE     :: IORef (Set Int)+        }+    | DecodeInfo+        { huffmanDecoder  :: HuffmanDecoder  -- only for encoder instruction handler+        , blockedStreamsD :: IORef Int+        }+{- FOURMOLU_ENABLE -}  -- | Dynamic table for QPACK.+{- FOURMOLU_DISABLE -} data DynamicTable = DynamicTable-    { codeInfo :: CodeInfo-    , droppingPoint :: IORef AbsoluteIndex-    , drainingPoint :: IORef AbsoluteIndex-    , insertionPoint :: TVar InsertionPoint-    , basePoint :: IORef BasePoint-    , maxNumOfEntries :: TVar Int-    , circularTable :: TVar Table-    , debugQPACK :: IORef Bool+    { codeInfo          :: CodeInfo+    , insertionPoint    :: TVar InsertionPoint+    , maxNumOfEntries   :: TVar Int+    , circularTable     :: TVar Table+    , basePoint         :: IORef BasePoint+    , debugQPACK        :: IORef Bool+    , capaReady         :: IORef Bool+    , tableSize         :: TVar Size+    , maxTableSize      :: IORef Size+    , sendIns           :: ByteString -> IO ()+    , maxHeaderSize     :: IORef Int+    , maxBlockedStreams :: IORef Int     }---- knownReceivedCount :: TVar Int--type Table = TArray Index Entry--------------------------------------------------------------------getBasePoint :: DynamicTable -> IO BasePoint-getBasePoint DynamicTable{..} = readIORef basePoint--setBasePointToInsersionPoint :: DynamicTable -> IO ()-setBasePointToInsersionPoint DynamicTable{..} = do-    InsertionPoint ip <- readTVarIO insertionPoint-    writeIORef basePoint $ BasePoint ip--getInsertionPoint :: DynamicTable -> IO InsertionPoint-getInsertionPoint DynamicTable{..} = readTVarIO insertionPoint--getInsertionPointSTM :: DynamicTable -> STM InsertionPoint-getInsertionPointSTM DynamicTable{..} = readTVar insertionPoint--checkInsertionPoint :: DynamicTable -> InsertionPoint -> IO ()-checkInsertionPoint DynamicTable{..} reqip = atomically $ do-    ip <- readTVar insertionPoint-    check (reqip <= ip)+{- FOURMOLU_ENABLE -}  ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} -- | Creating 'DynamicTable' for encoding. newDynamicTableForEncoding-    :: Size-    -- ^ The dynamic table size+    :: (ByteString -> IO ())     -> IO DynamicTable-newDynamicTableForEncoding maxsiz = do-    rev <- newRevIndex-    ref <- newIORef 0-    let info = EncodeInfo rev ref-    newDynamicTable maxsiz info+newDynamicTableForEncoding sendEI = do+    arr <- newArray (0, 0) $ Reference 0 0+    info <- do+        revIndex            <- newRevIndex+        requiredInsertCount <- newIORef 0+        droppingPoint       <- newIORef 0+        drainingPoint       <- newIORef 0+        knownReceivedCount  <- newTVarIO 0+        referenceCounters   <- newIORef arr+        sections            <- newIORef IntMap.empty+        lruCache            <- newLRUCacheRef 0+        immediateAck        <- newIORef False+        blockedStreamsE     <- newIORef Set.empty+        return EncodeInfo{..}+    newDynamicTable info sendEI+{- FOURMOLU_ENABLE -}  -- | Creating 'DynamicTable' for decoding. newDynamicTableForDecoding     :: Size-    -- ^ The dynamic table size-    -> Size     -- ^ The size of temporary buffer for Huffman decoding     -> (ByteString -> IO ())     -> IO DynamicTable-newDynamicTableForDecoding maxsiz huftmpsiz sendDI = do+newDynamicTableForDecoding huftmpsiz sendDI = do     gcbuf <- mallocPlainForeignPtrBytes huftmpsiz-    tvar <- newTVarIO $ Just (gcbuf, huftmpsiz)-    let decoder = decodeHLock tvar-        info = DecodeInfo decoder sendDI-    newDynamicTable maxsiz info--decodeHLock-    :: TVar (Maybe (GCBuffer, Int)) -> ReadBuffer -> Int -> IO ByteString-decodeHLock tvar rbuf len = E.bracket lock unlock $ \(gcbuf, bufsiz) ->-    withForeignPtr gcbuf $ \buf -> do-        wbuf <- newWriteBuffer buf bufsiz-        decH wbuf rbuf len-        toByteString wbuf-  where-    lock = atomically $ do-        mx <- readTVar tvar-        case mx of-            Nothing -> retry-            Just x -> do-                writeTVar tvar Nothing-                return x-    unlock x = atomically $ writeTVar tvar $ Just x+    let huffmanDecoder = decodeH gcbuf huftmpsiz+    blockedStreamsD <- newIORef 0+    newDynamicTable DecodeInfo{..} sendDI -newDynamicTable :: Size -> CodeInfo -> IO DynamicTable-newDynamicTable maxsiz info = do-    tbl <- atomically $ newArray (0, end) dummyEntry-    DynamicTable info-        <$> newIORef 0 -- droppingPoint-        <*> newIORef 0 -- drainingPoint-        <*> newTVarIO 0 -- insertionPoint-        <*> newIORef 0 -- basePoint-        <*> newTVarIO maxN -- maxNumOfEntries-        <*> newTVarIO tbl -- maxDynamicTableSize-        <*> newIORef False -- debugQPACK-  where-    maxN = maxNumbers maxsiz-    end = maxN - 1+newDynamicTable :: CodeInfo -> (ByteString -> IO ()) -> IO DynamicTable+newDynamicTable info send = do+    tbl <- atomically $ newArray (0, 0) dummyEntry+    let codeInfo = info+    insertionPoint <- newTVarIO 0+    maxNumOfEntries <- newTVarIO 0+    circularTable <- newTVarIO tbl+    basePoint <- newIORef 0+    debugQPACK <- newIORef False+    capaReady <- newIORef False+    tableSize <- newTVarIO 0+    maxTableSize <- newIORef 0+    let sendIns = send+    maxHeaderSize <- newIORef maxBound+    maxBlockedStreams <- newIORef 0+    return DynamicTable{..}  ---------------------------------------------------------------- -setDebugQPACK :: DynamicTable -> IO ()-setDebugQPACK DynamicTable{..} = writeIORef debugQPACK True--getDebugQPACK :: DynamicTable -> IO Bool-getDebugQPACK DynamicTable{..} = readIORef debugQPACK+isTableReady :: DynamicTable -> IO Bool+isTableReady DynamicTable{..} = readIORef capaReady -qpackDebug :: DynamicTable -> IO () -> IO ()-qpackDebug DynamicTable{..} action = do-    debug <- readIORef debugQPACK-    when debug action+getTableCapacity :: DynamicTable -> IO Int+getTableCapacity DynamicTable{..} = readTVarIO tableSize -----------------------------------------------------------------+setTableCapacity :: DynamicTable -> Int -> IO ()+setTableCapacity dyntbl@DynamicTable{..} maxsiz = do+    qpackDebug dyntbl $ putStrLn $ "setTableCapacity " ++ show maxsiz+    when (maxN >= 1) $ do+        writeIORef maxTableSize maxsiz+        tbl <- atomically $ newArray (0, end) dummyEntry+        atomically $ do+            writeTVar maxNumOfEntries maxN+            writeTVar circularTable tbl+        case codeInfo of+            EncodeInfo{..} -> do+                arr <- newArray (0, end) $ Reference 0 0+                writeIORef referenceCounters arr+                setLRUCapacity lruCache (maxN * 4)+            _ -> return ()+        writeIORef capaReady True+  where+    maxN = maxNumbers maxsiz+    end = maxN - 1  getMaxNumOfEntries :: DynamicTable -> IO Int getMaxNumOfEntries DynamicTable{..} = readTVarIO maxNumOfEntries  ---------------------------------------------------------------- -{-# INLINE getRevIndex #-}-getRevIndex :: DynamicTable -> RevIndex-getRevIndex DynamicTable{..} = rev-  where-    EncodeInfo rev _ = codeInfo--getHuffmanDecoder :: DynamicTable -> HuffmanDecoder-getHuffmanDecoder DynamicTable{..} = huf-  where-    DecodeInfo huf _ = codeInfo--getSendDI :: DynamicTable -> (ByteString -> IO ())-getSendDI DynamicTable{..} = sendDI-  where-    DecodeInfo _ sendDI = codeInfo--------------------------------------------------------------------clearLargestReference :: DynamicTable -> IO ()-clearLargestReference DynamicTable{..} = writeIORef ref 0-  where-    EncodeInfo _ ref = codeInfo--getLargestReference :: DynamicTable -> IO InsertionPoint-getLargestReference DynamicTable{..} = readIORef ref-  where-    EncodeInfo _ ref = codeInfo--updateLargestReference :: DynamicTable -> AbsoluteIndex -> IO ()-updateLargestReference DynamicTable{..} (AbsoluteIndex idx) = do-    let nidx = InsertionPoint idx-    oidx <- readIORef ref-    when (nidx > oidx) $ writeIORef ref nidx-  where-    EncodeInfo _ ref = codeInfo------------------------------------------------------------------- insertEntryToEncoder :: Entry -> DynamicTable -> IO AbsoluteIndex insertEntryToEncoder ent dyntbl@DynamicTable{..} = do     InsertionPoint insp <- atomically $ do@@ -197,10 +261,13 @@     atomically $ unsafeWrite table i ent     let revtbl = getRevIndex dyntbl     let ai = AbsoluteIndex insp-    insertRevIndex ent (DIndex ai) revtbl+    insertRevIndex ent ai revtbl+    atomically $ modifyTVar' tableSize (+ entrySize ent)+    dropIfNecessary dyntbl+    resetReference dyntbl ai     return ai -insertEntryToDecoder :: Entry -> DynamicTable -> STM ()+insertEntryToDecoder :: Entry -> DynamicTable -> STM AbsoluteIndex insertEntryToDecoder ent DynamicTable{..} = do     x@(InsertionPoint insp) <- readTVar insertionPoint     writeTVar insertionPoint (x + 1)@@ -208,6 +275,8 @@     let i = insp `mod` maxN     table <- readTVar circularTable     unsafeWrite table i ent+    modifyTVar' tableSize (+ entrySize ent)+    return $ AbsoluteIndex insp  toDynamicEntry :: DynamicTable -> AbsoluteIndex -> STM Entry toDynamicEntry DynamicTable{..} (AbsoluteIndex idx) = do@@ -215,3 +284,457 @@     let i = idx `mod` maxN     table <- readTVar circularTable     unsafeRead table i++----------------------------------------------------------------++insertSection :: DynamicTable -> StreamId -> Section -> IO ()+insertSection DynamicTable{..} sid section = atomicModifyIORef' sections ins+  where+    ins m =+        let m' = IntMap.insert sid section m+         in (m', ())+    EncodeInfo{..} = codeInfo++getAndDelSection :: DynamicTable -> StreamId -> IO (Maybe Section)+getAndDelSection DynamicTable{..} sid = atomicModifyIORef' sections getAndDel+  where+    getAndDel m =+        let (msec, m') = IntMap.updateLookupWithKey f sid m+         in (m', msec)+    f _ _ = Nothing -- delete the entry if found+    EncodeInfo{..} = codeInfo++increaseReference :: DynamicTable -> AbsoluteIndex -> IO ()+increaseReference = modifyReference $ \(Reference c t) -> Reference (c + 1) (t + 1)++decreaseReference :: DynamicTable -> AbsoluteIndex -> IO ()+decreaseReference = modifyReference $ \(Reference c t) -> Reference (c - 1) t++modifyReference+    :: (Reference -> Reference) -> DynamicTable -> AbsoluteIndex -> IO ()+modifyReference func DynamicTable{..} (AbsoluteIndex idx) = do+    maxN <- readTVarIO maxNumOfEntries+    let i = idx `mod` maxN+    arr <- readIORef referenceCounters+    -- modifyArray' is not provided by GHC 9.4 or earlier, sigh.+    x <- unsafeRead arr i+    let x' = func x+    unsafeWrite arr i x'+  where+    EncodeInfo{..} = codeInfo++resetReference :: DynamicTable -> AbsoluteIndex -> IO ()+resetReference DynamicTable{..} (AbsoluteIndex idx) = do+    maxN <- readTVarIO maxNumOfEntries+    let i = idx `mod` maxN+    arr <- readIORef referenceCounters+    unsafeWrite arr i $ Reference 0 0+  where+    EncodeInfo{..} = codeInfo++----------------------------------------------------------------++getMaxBlockedStreams :: DynamicTable -> IO Int+getMaxBlockedStreams DynamicTable{..} = readIORef maxBlockedStreams++setMaxBlockedStreams :: DynamicTable -> Int -> IO ()+setMaxBlockedStreams DynamicTable{..} n = writeIORef maxBlockedStreams n++-- Decoder++tryIncreaseStreams :: DynamicTable -> IO Bool+tryIncreaseStreams DynamicTable{..} = do+    lim <- readIORef maxBlockedStreams+    curr <- atomicModifyIORef' blockedStreamsD (\n -> (n + 1, n + 1))+    return (curr <= lim)+  where+    DecodeInfo{..} = codeInfo++decreaseStreams :: DynamicTable -> IO ()+decreaseStreams DynamicTable{..} = atomicModifyIORef' blockedStreamsD (\n -> (n - 1, ()))+  where+    DecodeInfo{..} = codeInfo++----------------------------------------------------------------++getBlockedStreamsE :: DynamicTable -> IO Int+getBlockedStreamsE DynamicTable{..} =+    Set.size <$> readIORef blockedStreamsE+  where+    EncodeInfo{..} = codeInfo++insertBlockedStreamE :: DynamicTable -> StreamId -> IO ()+insertBlockedStreamE DynamicTable{..} sid =+    modifyIORef' blockedStreamsE (Set.insert sid)+  where+    EncodeInfo{..} = codeInfo++deleteBlockedStreamE :: DynamicTable -> StreamId -> IO ()+deleteBlockedStreamE DynamicTable{..} sid =+    modifyIORef' blockedStreamsE (Set.delete sid)+  where+    EncodeInfo{..} = codeInfo++checkBlockedStreams :: DynamicTable -> IO Bool+checkBlockedStreams dyntbl = do+    maxBlocked <- getMaxBlockedStreams dyntbl+    blocked <- getBlockedStreamsE dyntbl+    -- The next one would be blocked, so <, not <=+    return $ blocked < maxBlocked++----------------------------------------------------------------++getRequiredInsertCount :: DynamicTable -> IO RequiredInsertCount+getRequiredInsertCount DynamicTable{..} = readIORef requiredInsertCount+  where+    EncodeInfo{..} = codeInfo++clearRequiredInsertCount :: DynamicTable -> IO ()+clearRequiredInsertCount DynamicTable{..} = writeIORef requiredInsertCount 0+  where+    EncodeInfo{..} = codeInfo++checkRequiredInsertCount :: DynamicTable -> RequiredInsertCount -> IO ()+checkRequiredInsertCount DynamicTable{..} (RequiredInsertCount reqip) = atomically $ do+    InsertionPoint ip <- readTVar insertionPoint+    -- RequiredInsertCount is index + 1+    -- InsertionPoin is index + 1+    -- So, equal is necessary.+    check (reqip <= ip)++checkRequiredInsertCountNB :: DynamicTable -> RequiredInsertCount -> IO Bool+checkRequiredInsertCountNB DynamicTable{..} (RequiredInsertCount reqip) = atomically $ do+    InsertionPoint ip <- readTVar insertionPoint+    return (reqip <= ip)++absoluteIndexToRequiredInsertCount :: AbsoluteIndex -> RequiredInsertCount+absoluteIndexToRequiredInsertCount (AbsoluteIndex idx) =+    RequiredInsertCount (idx + 1)++updateRequiredInsertCount :: DynamicTable -> AbsoluteIndex -> IO ()+updateRequiredInsertCount DynamicTable{..} aidx = do+    let newric = absoluteIndexToRequiredInsertCount aidx+    oldric <- readIORef requiredInsertCount+    when (newric > oldric) $ writeIORef requiredInsertCount newric+  where+    EncodeInfo{..} = codeInfo++----------------------------------------------------------------++incrementKnownReceivedCount :: DynamicTable -> Int -> IO ()+incrementKnownReceivedCount DynamicTable{..} n =+    atomically $ modifyTVar' knownReceivedCount (+ n)+  where+    EncodeInfo{..} = codeInfo++updateKnownReceivedCount :: DynamicTable -> RequiredInsertCount -> IO ()+updateKnownReceivedCount DynamicTable{..} (RequiredInsertCount reqInsCnt) =+    atomically $ modifyTVar' knownReceivedCount $ \krc -> max reqInsCnt krc+  where+    EncodeInfo{..} = codeInfo++wouldSectionBeBlocked :: DynamicTable -> RequiredInsertCount -> IO Bool+wouldSectionBeBlocked DynamicTable{..} (RequiredInsertCount reqip) = atomically $ do+    krc <- readTVar knownReceivedCount+    return (reqip > krc)+  where+    EncodeInfo{..} = codeInfo++wouldInstructionBeBlocked :: DynamicTable -> AbsoluteIndex -> IO Bool+wouldInstructionBeBlocked DynamicTable{..} (AbsoluteIndex ai) = atomically $ do+    krc <- readTVar knownReceivedCount+    return (ai > krc)+  where+    EncodeInfo{..} = codeInfo++setInsersionPointToKnownReceivedCount :: DynamicTable -> IO ()+setInsersionPointToKnownReceivedCount dyntbl@DynamicTable{..} = do+    InsertionPoint ai <- getInsertionPoint dyntbl+    atomically $ writeTVar knownReceivedCount ai+  where+    EncodeInfo{..} = codeInfo++----------------------------------------------------------------++getBasePoint :: DynamicTable -> IO BasePoint+getBasePoint DynamicTable{..} = readIORef basePoint++setBasePointToInsersionPoint :: DynamicTable -> IO ()+setBasePointToInsersionPoint DynamicTable{..} = do+    InsertionPoint ip <- readTVarIO insertionPoint+    writeIORef basePoint $ BasePoint ip++getInsertionPoint :: DynamicTable -> IO InsertionPoint+getInsertionPoint DynamicTable{..} = readTVarIO insertionPoint++getInsertionPointSTM :: DynamicTable -> STM InsertionPoint+getInsertionPointSTM DynamicTable{..} = readTVar insertionPoint++----------------------------------------------------------------++isDraining :: DynamicTable -> AbsoluteIndex -> IO Bool+isDraining DynamicTable{..} ai = do+    di <- readIORef drainingPoint+    return (ai <= di)+  where+    EncodeInfo{..} = codeInfo++adjustDrainingPoint :: DynamicTable -> IO ()+adjustDrainingPoint DynamicTable{..} = do+    InsertionPoint beg <- readTVarIO insertionPoint+    AbsoluteIndex end <- readIORef droppingPoint+    let num = beg - end+        space = max 1 (num !>>. 4)+        end' = beg - num + space+    writeIORef drainingPoint $ AbsoluteIndex end'+    table <- readTVarIO circularTable+    maxN <- readTVarIO maxNumOfEntries+    loop end end' table maxN+  where+    EncodeInfo{..} = codeInfo+    loop :: Int -> Int -> Table -> Int -> IO ()+    loop ai lim table maxN+        | ai == lim = return ()+        | otherwise = do+            let i = ai `mod` maxN+            ent <- atomically $ unsafeRead table i+            deleteRevIndex revIndex ent $ AbsoluteIndex ai+            loop (ai + 1) lim table maxN++tailDuplicationThreshold :: Int+tailDuplicationThreshold = 10++checkTailDuplication :: DynamicTable -> IO (Maybe AbsoluteIndex)+checkTailDuplication DynamicTable{..} = do+    dai@(AbsoluteIndex ai) <- readIORef droppingPoint+    arr <- readIORef referenceCounters+    maxN <- readTVarIO maxNumOfEntries+    let i = ai `mod` maxN+    -- modifyArray' is not provided by GHC 9.4 or earlier, sigh.+    Reference current total <- unsafeRead arr i+    if current == 0 && total >= tailDuplicationThreshold+        then return $ Just dai+        else return Nothing+  where+    EncodeInfo{..} = codeInfo++tailDuplication :: DynamicTable -> IO AbsoluteIndex+tailDuplication dyntbl@DynamicTable{..} = do+    dai <- readIORef droppingPoint+    ndai <- duplicate dyntbl dai+    dropIfNecessary dyntbl+    return ndai+  where+    EncodeInfo{..} = codeInfo++duplicate :: DynamicTable -> AbsoluteIndex -> IO AbsoluteIndex+duplicate dyntbl@DynamicTable{..} (AbsoluteIndex ai) = do+    maxN <- readTVarIO maxNumOfEntries+    let i = ai `mod` maxN+    table <- readTVarIO circularTable+    ent <- atomically $ unsafeRead table i+    insertEntryToEncoder ent dyntbl++----------------------------------------------------------------++canInsertEntry :: DynamicTable -> Entry -> Maybe (AbsoluteIndex) -> IO Bool+canInsertEntry DynamicTable{..} ent mai = do+    let siz = entrySize ent+    tblsiz <- readTVarIO tableSize+    maxtblsiz <- readIORef maxTableSize+    if tblsiz + siz <= maxtblsiz+        then+            return True+        else do+            AbsoluteIndex ai <- readIORef droppingPoint+            InsertionPoint lim <- readTVarIO insertionPoint+            loop ai lim (tblsiz + siz - maxtblsiz)+  where+    myself = case mai of+        Nothing -> -1 -- trick: this index does not exist+        Just (AbsoluteIndex i) -> i+    EncodeInfo{..} = codeInfo+    loop ai lim requiredSize+        | requiredSize <= 0 = return True+        | otherwise = do+            if ai < lim && ai /= myself -- don't drop the referred entry+                then do+                    maxN <- readTVarIO maxNumOfEntries+                    let i = ai `mod` maxN+                    refs <- readIORef referenceCounters+                    Reference current total <- unsafeRead refs i+                    if current == 0 && total >= 1+                        then do+                            table <- readTVarIO circularTable+                            dent <- atomically $ unsafeRead table i+                            let siz = entrySize dent++                            loop (ai + 1) lim (requiredSize - siz)+                        else return False+                else return False++dropIfNecessary :: DynamicTable -> IO ()+dropIfNecessary dyntbl@DynamicTable{..} = loop+  where+    loop = do+        tblsize <- readTVarIO tableSize+        maxtblsize <- readIORef maxTableSize+        unless (tblsize <= maxtblsize) $ do+            dropped <- tryDrop dyntbl+            if dropped then loop else error "dropIfNecessary"++tryDrop :: DynamicTable -> IO Bool+tryDrop dyntbl@DynamicTable{..} = do+    maxN <- readTVarIO maxNumOfEntries+    dai@(AbsoluteIndex ai) <- readIORef droppingPoint+    InsertionPoint lim <- readTVarIO insertionPoint+    if ai < lim+        then do+            let i = ai `mod` maxN+            refs <- readIORef referenceCounters+            Reference current total <- unsafeRead refs i+            if current == 0 && total >= 1+                then do+                    table <- readTVarIO circularTable+                    ent <- atomically $ do+                        e <- unsafeRead table i+                        unsafeWrite table i dummyEntry+                        return e+                    let siz = entrySize ent+                    atomically $ modifyTVar' tableSize $ subtract siz+                    modifyIORef' droppingPoint (+ 1)+                    qpackDebug dyntbl $ do+                        putStrLn $+                            "DROPPED (AbsoluteIndex "+                                ++ show ai+                                ++ ") "+                                ++ show (entryHeaderName ent)+                                ++ " "+                                ++ show (entryFieldValue ent)+                        tblsiz <- readTVarIO tableSize+                        putStrLn $ "    tblsiz: " ++ show tblsiz+                    deleteRevIndex revIndex ent dai+                    return True+                else return False+        else return False+  where+    EncodeInfo{..} = codeInfo++----------------------------------------------------------------++getLruCache :: DynamicTable -> LRUCacheRef (FieldName, FieldValue) ()+getLruCache DynamicTable{..} = lruCache+  where+    EncodeInfo{..} = codeInfo++{-# INLINE getRevIndex #-}+getRevIndex :: DynamicTable -> RevIndex+getRevIndex DynamicTable{..} = revIndex+  where+    EncodeInfo{..} = codeInfo++-- only for encoder instruction handler+getHuffmanDecoder :: DynamicTable -> HuffmanDecoder+getHuffmanDecoder DynamicTable{..} = huffmanDecoder+  where+    DecodeInfo{..} = codeInfo++----------------------------------------------------------------++getMaxHeaderSize :: DynamicTable -> IO Int+getMaxHeaderSize DynamicTable{..} = readIORef maxHeaderSize++setMaxHeaderSize :: DynamicTable -> Int -> IO ()+setMaxHeaderSize DynamicTable{..} n = writeIORef maxHeaderSize n++----------------------------------------------------------------++qpackDebug :: DynamicTable -> IO () -> IO ()+qpackDebug DynamicTable{..} action = do+    debug <- readIORef debugQPACK+    when debug $ withMVar stdoutLock $ \_ -> action++getDebugQPACK :: DynamicTable -> IO Bool+getDebugQPACK DynamicTable{..} = readIORef debugQPACK++setDebugQPACK :: DynamicTable -> Bool -> IO ()+setDebugQPACK DynamicTable{..} b = writeIORef debugQPACK b++{-# NOINLINE stdoutLock #-}+stdoutLock :: MVar ()+stdoutLock = unsafePerformIO $ newMVar ()++printReferences :: DynamicTable -> IO ()+printReferences DynamicTable{..} = do+    AbsoluteIndex start <- readIORef droppingPoint+    InsertionPoint end <- readTVarIO insertionPoint+    maxN <- readTVarIO maxNumOfEntries+    arr <- readIORef referenceCounters+    putStr "Refs: "+    loop start end arr maxN+    putStr "\n"+  where+    loop :: Int -> Int -> IOArray Index Reference -> Int -> IO ()+    loop start end arr maxN+        | start < end = do+            r <- unsafeRead arr (start `mod` maxN)+            putStr $ show start ++ ": " ++ showReference r ++ ", "+            loop (start + 1) end arr maxN+        | otherwise = return ()+    EncodeInfo{..} = codeInfo+    showReference (Reference c t) = show c ++ "(" ++ show t ++ ")"++-- For decoder+checkHIndex :: DynamicTable -> HIndex -> IO ()+checkHIndex _ (SIndex _) = return ()+checkHIndex DynamicTable{..} (DIndex (AbsoluteIndex ai)) = do+    InsertionPoint ip <- readTVarIO insertionPoint+    maxN <- readTVarIO maxNumOfEntries+    if ip - maxN <= ai && ai < ip+        then return ()+        else error "checkHIndex"++-- For encoder+checkAbsoluteIndex :: DynamicTable -> AbsoluteIndex -> String -> IO ()+checkAbsoluteIndex DynamicTable{..} (AbsoluteIndex ai) tag = do+    InsertionPoint beg <- readTVarIO insertionPoint+    AbsoluteIndex end <- readIORef droppingPoint+    maxN <- readTVarIO maxNumOfEntries+    table <- readTVarIO circularTable+    let calcSize i acc+            | i == beg = return acc+            | otherwise = do+                siz <- entrySize <$> atomically (unsafeRead table (i `mod` maxN))+                calcSize (i + 1) (acc + siz)+    if end <= ai && ai < beg+        then do+            size <- calcSize end 0+            size0 <- readTVarIO tableSize+            when (size /= size0) $ error $ "checkAbsoluteIndex: size /= size0) " ++ tag+            lim <- readIORef maxTableSize+            when (size > lim) $ error $ "checkAbsoluteIndex: size > lim " ++ tag+            putStrLn $ "    check: tblsiz: " ++ show size ++ " " ++ show ai ++ " " ++ tag+        else+            error $+                "checkAbsoluteIndex (3) "+                    ++ tag+                    ++ " <= "+                    ++ show end+                    ++ " "+                    ++ show ai+                    ++ " < "+                    ++ show beg+  where+    EncodeInfo{..} = codeInfo++----------------------------------------------------------------++getImmediateAck :: DynamicTable -> IO Bool+getImmediateAck DynamicTable{..} = readIORef immediateAck+  where+    EncodeInfo{..} = codeInfo++setImmediateAck :: DynamicTable -> Bool -> IO ()+setImmediateAck DynamicTable{..} b = writeIORef immediateAck b+  where+    EncodeInfo{..} = codeInfo

@@ -9,7 +9,10 @@     lookupRevIndex,     lookupRevIndex',     insertRevIndex,-    deleteRevIndexList,+    deleteRevIndex,+    tokenToStaticIndex,+    isKeyRegistered,+    lookupRevIndexS, ) where  import Data.Array (Array)@@ -17,8 +20,12 @@ import Data.Array.Base (unsafeAt) 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 Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ import Network.HPACK.Internal (Entry (..)) import Network.HTTP.Semantics @@ -29,37 +36,36 @@  ---------------------------------------------------------------- -data RevResult = N | K HIndex | KV HIndex deriving (Eq, Show)+data RevResult+    = N+    | K HIndex+    | KV HIndex+    deriving (Eq, Show)  ---------------------------------------------------------------- -data RevIndex = RevIndex DynamicRevIndex OtherRevIdex+data RevIndex = RevIndex DynamicRevIndex OtherRevIndex -type DynamicRevIndex = Array Int (IORef ValueMap)+---------------------------------------------------------------- -data KeyValue = KeyValue FieldName FieldValue deriving (Eq, Ord)+type DynamicRevIndex = Array Int (IORef DynamicValueMap) --- We always create an index for a pair of an unknown header and its value--- in Linear{H}.-type OtherRevIdex = IORef (Map KeyValue HIndex)+type DynamicValueMap = Map FieldValue AbsoluteIndex -{-# SPECIALIZE INLINE M.lookup ::-    KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex-    #-}-{-# SPECIALIZE INLINE M.delete ::-    KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex-    #-}-{-# SPECIALIZE INLINE M.insert ::-    KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex-    #-}+---------------------------------------------------------------- +type OtherRevIndex = IORef (Map FieldName OtherValueMap) -- dynamic table only++type OtherValueMap = OrdPSQ FieldValue Int AbsoluteIndex+ ----------------------------------------------------------------  type StaticRevIndex = Array Int StaticEntry -data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show)+data StaticEntry = StaticEntry AbsoluteIndex (Maybe StaticValueMap)+    deriving (Show) -type ValueMap = Map FieldValue HIndex+type StaticValueMap = Map FieldValue AbsoluteIndex  ---------------------------------------------------------------- @@ -69,26 +75,33 @@     toEnt (k, xs) = (quicIx $ tokenIx $ toToken $ foldedCase k, m)       where         m = case xs of-            [] -> error "staticRevIndex"-            [("", i)] -> StaticEntry i Nothing-            (_, i) : _ -> StaticEntry i $ Just $ M.fromList xs-    zs = map extract $ groupBy ((==) `on` fst) $ sort lst+            ("", i) :| [] -> StaticEntry i Nothing+            (_, i) :| _ -> StaticEntry i $ Just $ M.fromList $ NE.toList xs+    zs = map extract $ NE.groupBy ((==) `on` fst) $ sort lst       where         lst =             zipWith (\(k, v) i -> (k, (v, i))) staticTableList $-                map (SIndex . AbsoluteIndex) [0 ..]-        extract xs = (headFst xs, map snd xs)-        headFst [] = error "headFst"-        headFst (x : _) = fst x+                map AbsoluteIndex [0 ..]+        extract xs = (fst (NE.head xs), NE.map snd xs)  {-# INLINE lookupStaticRevIndex #-} lookupStaticRevIndex :: Int -> FieldValue -> RevResult lookupStaticRevIndex ix v = case staticRevIndex `unsafeAt` ix of-    StaticEntry i Nothing -> K i+    StaticEntry i Nothing -> K $ SIndex i     StaticEntry i (Just m) -> case M.lookup v m of-        Nothing -> K i-        Just j -> KV j+        Nothing -> K $ SIndex i+        Just j -> KV $ SIndex j +lookupRevIndexS+    :: Token+    -> FieldValue+    -> RevResult+lookupRevIndexS Token{..} v+    | ix < 0 = N+    | otherwise = lookupStaticRevIndex ix v+  where+    ix = quicIx tokenIx+ ----------------------------------------------------------------  newDynamicRevIndex :: IO DynamicRevIndex@@ -109,49 +122,85 @@     let ref = drev `unsafeAt` ix     m <- readIORef ref     case M.lookup v m of-        Just i -> return $ KV i+        Just i -> return $ KV $ DIndex i         Nothing -> return $ lookupStaticRevIndex ix v  {-# INLINE insertDynamicRevIndex #-} insertDynamicRevIndex-    :: Token -> FieldValue -> HIndex -> DynamicRevIndex -> IO ()+    :: Token -> FieldValue -> AbsoluteIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i   where-    ref = drev `unsafeAt` tokenIx t+    ref = drev `unsafeAt` quicIx (tokenIx t)  {-# INLINE deleteDynamicRevIndex #-}-deleteDynamicRevIndex :: Token -> FieldValue -> DynamicRevIndex -> IO ()-deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v+deleteDynamicRevIndex+    :: Token -> FieldValue -> AbsoluteIndex -> DynamicRevIndex -> IO ()+deleteDynamicRevIndex t v ai drev = modifyIORef ref $ M.alter adjust v   where-    ref = drev `unsafeAt` tokenIx t+    ref = drev `unsafeAt` quicIx (tokenIx t)+    adjust Nothing = Nothing+    adjust x@(Just ai')+        | ai == ai' = Nothing+        -- This previous entry is already deleted by "duplicate"+        | otherwise = x  ---------------------------------------------------------------- -newOtherRevIndex :: IO OtherRevIdex+newOtherRevIndex :: IO OtherRevIndex newOtherRevIndex = newIORef M.empty -renewOtherRevIndex :: OtherRevIdex -> IO ()+renewOtherRevIndex :: OtherRevIndex -> IO () renewOtherRevIndex ref = writeIORef ref M.empty  {-# INLINE lookupOtherRevIndex #-}-lookupOtherRevIndex :: (FieldName, FieldValue) -> OtherRevIdex -> IO RevResult+lookupOtherRevIndex :: (FieldName, FieldValue) -> OtherRevIndex -> IO RevResult lookupOtherRevIndex (k, v) ref = do     oth <- readIORef ref-    case M.lookup (KeyValue k v) oth of+    case M.lookup k oth of         Nothing -> return N-        Just i -> return $ KV i+        Just psq -> case PSQ.lookup v psq of+            Nothing -> case PSQ.findMin psq of+                Nothing -> return N+                Just (_, _, ai) -> return $ K $ DIndex ai+            Just (_, i) -> return $ KV $ DIndex i +isKeyRegistered :: FieldName -> RevIndex -> IO (Maybe AbsoluteIndex)+isKeyRegistered k (RevIndex _ ref) = do+    oth <- readIORef ref+    return $ case M.lookup k oth of+        Nothing -> Nothing+        Just psq -> case PSQ.findMin psq of+            Nothing -> Nothing+            Just (_, _, ai) -> Just ai+ {-# INLINE insertOtherRevIndex #-}-insertOtherRevIndex :: Token -> FieldValue -> HIndex -> OtherRevIdex -> IO ()-insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i+insertOtherRevIndex+    :: Token -> FieldValue -> AbsoluteIndex -> OtherRevIndex -> IO ()+insertOtherRevIndex t v ai@(AbsoluteIndex i) ref = modifyIORef' ref $ M.alter adjust k   where+    adjust Nothing = Just $ PSQ.singleton v i ai+    adjust (Just psq) = Just $ PSQ.insert v i ai psq     k = tokenFoldedKey t  {-# INLINE deleteOtherRevIndex #-}-deleteOtherRevIndex :: Token -> FieldValue -> OtherRevIdex -> IO ()-deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v)+deleteOtherRevIndex+    :: Token -> FieldValue -> AbsoluteIndex -> OtherRevIndex -> IO ()+deleteOtherRevIndex t v ai ref = modifyIORef' ref $ M.alter adjust k   where     k = tokenFoldedKey t+    -- This previous entry is already deleted by "adjustDrainingPoint"+    adjust Nothing = Nothing+    adjust (Just psq)+        | PSQ.null psq' = Nothing+        | otherwise = Just psq'+      where+        psq' = snd $ PSQ.alter adj v psq+        adj x@(Just (_, ai'))+            | ai == ai' = ((), Nothing)+            -- This previous entry is already deleted by "duplicate"+            | otherwise = ((), x)+        -- This previous entry is already deleted by "adjustDrainingPoint"+        adj Nothing = ((), Nothing)  ---------------------------------------------------------------- @@ -178,8 +227,6 @@     ix = quicIx tokenIx     k = tokenFoldedKey t ---    ent = toEntryToken t v -- fixme- {-# INLINE lookupRevIndex' #-} lookupRevIndex'     :: Token@@ -187,28 +234,28 @@     -> RevResult lookupRevIndex' Token{..} v     | ix >= 0 = lookupStaticRevIndex ix v-    | otherwise = N -- fixme+    | otherwise = N   where     ix = quicIx tokenIx ---    k = tokenFoldedKey t -- fixme+tokenToStaticIndex :: Token -> Maybe AbsoluteIndex+tokenToStaticIndex Token{..}+    | ix >= 0 = case staticRevIndex `unsafeAt` ix of+        StaticEntry i _ -> Just i+    | otherwise = Nothing+  where+    ix = quicIx tokenIx  ----------------------------------------------------------------  {-# INLINE insertRevIndex #-}-insertRevIndex :: Entry -> HIndex -> RevIndex -> IO ()+insertRevIndex :: Entry -> AbsoluteIndex -> RevIndex -> IO () insertRevIndex (Entry _ t v) i (RevIndex dyn oth)     | quicIx (tokenIx t) >= 0 = insertDynamicRevIndex t v i dyn     | otherwise = insertOtherRevIndex t v i oth  {-# INLINE deleteRevIndex #-}-deleteRevIndex :: RevIndex -> Entry -> IO ()-deleteRevIndex (RevIndex dyn oth) (Entry _ t v)-    | quicIx (tokenIx t) >= 0 = deleteDynamicRevIndex t v dyn-    | otherwise = deleteOtherRevIndex t v oth--{-# INLINE deleteRevIndexList #-}-deleteRevIndexList :: [Entry] -> RevIndex -> IO ()-deleteRevIndexList es rev = mapM_ (deleteRevIndex rev) es---- isStaticToken+deleteRevIndex :: RevIndex -> Entry -> AbsoluteIndex -> IO ()+deleteRevIndex (RevIndex dyn oth) (Entry _ t v) ai+    | quicIx (tokenIx t) >= 0 = deleteDynamicRevIndex t v ai dyn+    | otherwise = deleteOtherRevIndex t v ai oth

@@ -34,7 +34,7 @@ toStaticEntry :: AbsoluteIndex -> Entry toStaticEntry (AbsoluteIndex sidx)     | sidx < staticTableSize = staticTable `unsafeAt` sidx-    | otherwise = E.throw IllegalStaticIndex+    | otherwise = E.throw $ IllegalStaticIndex sidx  -- | Pre-defined static table. staticTable :: Array Index Entry

@@ -7,11 +7,17 @@  newtype AbsoluteIndex = AbsoluteIndex Int deriving (Eq, Ord, Show, Num) newtype InsRelativeIndex = InsRelativeIndex Int deriving (Eq, Ord, Show, Num)-newtype HBRelativeIndex = HBRelativeIndex Int deriving (Eq, Ord, Show, Num)+newtype PreBaseIndex = PreBaseIndex Int deriving (Eq, Ord, Show, Num) newtype PostBaseIndex = PostBaseIndex Int deriving (Eq, Ord, Show, Num)-newtype InsertionPoint = InsertionPoint Int deriving (Eq, Ord, Show, Num) newtype BasePoint = BasePoint Int deriving (Eq, Ord, Show, Num) +-- Point to insert an entry next+newtype InsertionPoint = InsertionPoint Int deriving (Eq, Ord, Show, Num)++-- Counter of how many entries must be inserted+newtype RequiredInsertCount = RequiredInsertCount Int+    deriving (Eq, Ord, Show, Num)+ data HIndex     = SIndex AbsoluteIndex     | DIndex AbsoluteIndex@@ -27,8 +33,8 @@       | Entries  |             Entries             | Space  |       +----------+---------------------------------+--------+ |  d  |                            |n-4|n-3|n-2|n-1|          Absolute-|n-d-1|                            | 3 | 2 | 1 | 0 |          Relative ins-|n-d-3|                            | 1 | 0 |                  Relative HB+|n-d-1|                            | 3 | 2 | 1 | 0 |          Ins Relative+|n-d-3|                            | 1 | 0 |                  Pre-Base                                            | 0 | 1 |          Post-Base                                            ^                                            |@@ -36,8 +42,8 @@                                                     ip = 100 |  d  |                            | 96| 97| 98| 99|          Absolute-|n-d-1|                            | 3 | 2 | 1 | 0 |          Relative ins-|n-d-3|                            | 1 | 0 |                  Relative HB+|n-d-1|                            | 3 | 2 | 1 | 0 |          Ins Relative+|n-d-3|                            | 1 | 0 |                  Pre-Base                                            | 0 | 1 |          Post-Base                                            bp = 98 -}@@ -71,24 +77,29 @@ fromInsRelativeIndex (InsRelativeIndex ri) (InsertionPoint ip) =     AbsoluteIndex (ip - ri - 1) +toBaseIndex :: AbsoluteIndex -> BasePoint -> Either PreBaseIndex PostBaseIndex+toBaseIndex (AbsoluteIndex idx) (BasePoint bp)+    | idx < bp = Left $ PreBaseIndex (bp - idx - 1)+    | otherwise = Right $ PostBaseIndex (idx - bp)+ -- | ----- >>> toHBRelativeIndex 96 98--- HBRelativeIndex 1--- >>> toHBRelativeIndex 97 98--- HBRelativeIndex 0-toHBRelativeIndex :: AbsoluteIndex -> BasePoint -> HBRelativeIndex-toHBRelativeIndex (AbsoluteIndex idx) (BasePoint bp) =-    HBRelativeIndex (bp - idx - 1)+-- >>> toPreBaseIndex 96 98+-- PreBaseIndex 1+-- >>> toPreBaseIndex 97 98+-- PreBaseIndex 0+toPreBaseIndex :: AbsoluteIndex -> BasePoint -> PreBaseIndex+toPreBaseIndex (AbsoluteIndex idx) (BasePoint bp) =+    PreBaseIndex (bp - idx - 1)  -- | ----- >>> fromHBRelativeIndex 1 98+-- >>> fromPreBaseIndex 1 98 -- AbsoluteIndex 96--- >>> fromHBRelativeIndex 0 98+-- >>> fromPreBaseIndex 0 98 -- AbsoluteIndex 97-fromHBRelativeIndex :: HBRelativeIndex -> BasePoint -> AbsoluteIndex-fromHBRelativeIndex (HBRelativeIndex ri) (BasePoint bp) =+fromPreBaseIndex :: PreBaseIndex -> BasePoint -> AbsoluteIndex+fromPreBaseIndex (PreBaseIndex ri) (BasePoint bp) =     AbsoluteIndex (bp - ri - 1)  -- |@@ -122,6 +133,7 @@     , set0100     , set0101     , set0010+    , set00000     , set00001         :: Setter @@ -139,8 +151,9 @@  set0, set00, set000, set0000 :: Setter -set0    = id-set00   = id-set000  = id-set0000 = id+set0     = id+set00    = id+set000   = id+set0000  = id+set00000 = id {- FOURMOLU_ENABLE -}

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               http3-version:            0.0.24+version:            0.1.0 license:            BSD-3-Clause license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -16,7 +16,6 @@     test/serverkey.pem     test/inputFile     qifs/qifs/*.qif-    qifs/encoded/qpack-05/examples/*.1     qifs/encoded/qpack-05/f5/*.0     qifs/encoded/qpack-05/f5/*.1     qifs/encoded/qpack-05/ls-qpack/*.0@@ -88,10 +87,12 @@         iproute >= 1.7 && < 1.8,         network,         network-byte-order,+        network-control >= 0.1.7 && <0.2,+        psqueues,         quic >= 0.2.11 && < 0.3,         sockaddr,         stm,-        time-manager >= 0.2 && < 0.3,+        time-manager >= 0.2.3 && <0.3,         utf8-string >=1.0 && <1.1  executable h3-server@@ -149,9 +150,10 @@     else         buildable: False -executable qif-    main-is:            qif.hs+executable qif-enc+    main-is:            qif-enc.hs     hs-source-dirs:     util+    other-modules:      QIF     default-language:   Haskell2010     default-extensions: Strict StrictData     ghc-options:        -Wall -threaded -rtsopts@@ -159,8 +161,11 @@         base >=4.9 && <5,         attoparsec,         bytestring,+        cereal,         conduit,         conduit-extra,+        containers,+        filepath,         http3,         quic,         stm@@ -170,11 +175,34 @@     else         buildable: False +executable qif-dec+    main-is:            qif-dec.hs+    hs-source-dirs:     util+    other-modules:      QIF+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall -threaded -rtsopts+    build-depends:+        base >=4.9 && <5,+        attoparsec,+        bytestring,+        conduit,+        conduit-extra,+        containers,+        http3,+        quic,+        stm++    if flag(devel)++    else+        buildable: False+ test-suite spec     type:               exitcode-stdio-1.0     main-is:            Spec.hs     build-tool-depends: hspec-discover:hspec-discover-    hs-source-dirs:     test+    hs-source-dirs:     test util     other-modules:         HTTP3.Config         HTTP3.Error@@ -183,7 +211,9 @@         HTTP3.ServerSpec         QPACK.InstructionSpec         QPACK.QIFSpec+        QPACK.QIF2Spec         QPACK.TableSpec+        QIF      default-language:   Haskell2010     default-extensions: Strict StrictData@@ -195,8 +225,10 @@         async,         base16-bytestring,         bytestring,+        case-insensitive,         conduit,         conduit-extra,+        containers,         crypton,         hspec >=1.3,         http-semantics,

binary file changed (182 → absent bytes)

@@ -1,9 +0,0 @@-# stream 4-:path	/index.html--# stream 8-:authority	www.ietf.org--# stream 12-:authority	www.ietf.org-

@@ -52,4 +52,4 @@     mhqidx = "hq" `L.elemIndex` protos  testH3ClientConfig :: H3.ClientConfig-testH3ClientConfig = H3.ClientConfig "https" "127.0.0.1"+testH3ClientConfig = H3.defaultClientConfig{H3.authority = "127.0.0.1"}

@@ -9,6 +9,6 @@  spec :: Spec spec =-    beforeAll setup $+    beforeAll (setup server 4096) $         afterAll teardown $             h3ErrorSpec testClientConfig testH3ClientConfig 2000 -- 2 seconds

@@ -3,6 +3,7 @@  module HTTP3.Server (     setup,+    server,     teardown,     trailersMaker,     firstTrailerValue,@@ -31,14 +32,21 @@  import HTTP3.Config -setup :: IO ThreadId-setup = do+setup :: Server -> Int -> IO ThreadId+setup svr siz = do     sc <- makeTestServerConfig     tid <- forkIO $ QUIC.run sc loop     threadDelay 500000 -- give enough time to the server     return tid   where-    loop conn = E.bracket allocSimpleConfig freeSimpleConfig $ \conf -> run conn conf server+    loop conn = E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+        let conf =+                conf0+                    { confQEncoderConfig = defaultQEncoderConfig{ecMaxTableCapacity = siz}+                    , confQDecoderConfig = defaultQDecoderConfig{dcMaxTableCapacity = siz}+                    }++        run conn conf svr  teardown :: ThreadId -> IO () teardown tid = killThread tid

@@ -17,7 +17,7 @@ import HTTP3.Server  spec :: Spec-spec = beforeAll setup $ afterAll teardown h3spec+spec = beforeAll (setup server 4096) $ afterAll teardown h3spec  h3spec :: SpecWith a h3spec = do

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module QPACK.QIF2Spec where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import qualified Data.ByteString as B+import Data.ByteString.Builder (Builder, byteString)+import qualified Data.ByteString.Char8 as C8+import Data.CaseInsensitive hiding (map)+import Data.List+import Data.Maybe+import Network.HTTP.Semantics+import Network.HTTP.Semantics.Client.Internal+import Network.HTTP.Semantics.Server+import Network.HTTP.Types (RequestHeaders, notFound404, ok200)+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Server+import qualified Network.HTTP3.Server as S+import qualified Network.QUIC.Client as QUIC+import System.IO+import Test.Hspec++import HTTP3.Config+import HTTP3.Server hiding (server)+import QIF++qiffile :: FilePath+qiffile = "qifs/qifs/fb-req-hq.qif"++spec :: Spec+spec = do+    describe "QIF server" $ do+        it "handles dynamic table of 0-bytes" $ do+            let size = 0+            E.bracket (setup server size) (teardown) $+                \_ -> runClient size+    describe "QIF server" $ do+        it "handles dynamic table of 256-bytes" $ do+            let size = 256+            E.bracket (setup server size) (teardown) $+                \_ -> runClient size+    describe "QIF server" $ do+        it "handles dynamic table of 512-bytes" $ do+            let size = 512+            E.bracket (setup server size) (teardown) $+                \_ -> runClient size+    describe "QIF server" $ do+        it "handles dynamic table of 4096-bytes" $ do+            let size = 4096+            E.bracket (setup server size) (teardown) $+                \_ -> runClient size++runClient :: Int -> IO ()+runClient siz = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+        let conf =+                conf0+                    { S.confQEncoderConfig = S.defaultQEncoderConfig{S.ecMaxTableCapacity = siz}+                    , S.confQDecoderConfig = S.defaultQDecoderConfig{S.dcMaxTableCapacity = siz}+                    }++        withFile qiffile ReadMode $ \hdl ->+            C.run conn testH3ClientConfig conf $ client hdl++client :: Handle -> (C.Request -> (C.Response -> IO ()) -> IO a) -> p -> IO ()+client hdl sendRequest _aux = do+    -- delay for set table capacity+    threadDelay 10000+    ms <- forkClient 0 id+    mapM_ takeMVar ms+  where+    forkClient n build = do+        hs <- headerlist hdl+        if null hs+            then return $ build []+            else do+                var <- newEmptyMVar+                _ <- forkIO $ do+                    let req = requestBuilder2 hs mempty+                    _ <- sendRequest req $ checkHeader hs+                    putMVar var ()+                when ((n :: Int) `mod` 50 == 0) $ threadDelay 100000+                forkClient (n + 1) (build . (var :))+    checkHeader hs rsp = do+        bs <- getBody+        let hs0 = map keyValue $ split bs+            hs0' = sort $ filter (\(k, _) -> k == "cookie:") hs0+            hs' = sort $ filter (\(k, _) -> k == "cookie:") hs+        hs0' `shouldBe` hs'+      where+        getBody = B.concat <$> loop id+        loop build = do+            bs <- C.getResponseBodyChunk rsp+            if bs == ""+                then return $ build []+                else loop (build . (bs :))+        split ls0 = go ls0 id+          where+            go "" build = build []+            go ls build = go ls'' (build . (l :))+              where+                (l, ls') = C8.break (== '\n') ls+                ls'' = C8.drop 1 ls'+        keyValue kv = (mk k, v)+          where+            (k, v') = C8.break (== ' ') kv+            v = C8.drop 1 v'++server :: Server+server req _aux sendResponse = case requestMethod req of+    Just "GET" -> sendResponse (responseSection req) []+    _ -> sendResponse (responseNoBody notFound404 []) []++responseSection :: S.Request -> S.Response+responseSection req = responseBuilder ok200 header body+  where+    header =+        [ ("Content-Type", "text/plain")+        , ("Server", "HaskellQuic/0.0.0")+        ]+    (thl, vt) = requestHeaders req+    pseudos = [tokenAuthority, tokenMethod, tokenPath, tokenScheme]+    pthl = map (\t -> (t, fromJust (getFieldValue t vt))) pseudos+    body =+        foldr1 (<>) $+            map (\(k, v) -> byteString (k <> " " <> v <> "\n")) $+                map (\(k, v) -> (tokenFoldedKey k, v)) (pthl ++ thl)++-- | Creating request with builder only from headers+--   where :path and :method are included.+requestBuilder2 :: RequestHeaders -> Builder -> C.Request+requestBuilder2 hdr builder = Request $ OutObj hdr (OutBodyBuilder builder) defaultTrailersMaker

@@ -3,118 +3,89 @@  module QPACK.QIFSpec where -import Conduit hiding (yield)-import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E import Control.Monad-import Data.Attoparsec.ByteString (Parser)-import qualified Data.Attoparsec.ByteString as P import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8 import Data.Conduit.Attoparsec+import Data.IORef+import Data.Sequence (Seq, ViewR (..), viewr, (<|))+import qualified Data.Sequence as Seq import Network.QUIC (StreamId) import System.IO import Test.Hspec  import Network.QPACK+import Network.QPACK.Internal +import QIF+ spec :: Spec spec = do     describe "simple decoder" $ do-        it "decodes well" $ do+        it "decodes with dynamic table" $ do             forM_ ["fb-req-hq", "fb-resp-hq", "netbsd-hq"] $ \svc ->-                forM_ ["f5", "ls-qpack", "nghttp3", "proxygen", "qthingey", "quinn"] $ \impl -> do-                    putStrLn $ impl ++ " with " ++ svc-                    let inp = "qifs/encoded/qpack-05/" ++ impl ++ "/" ++ svc ++ ".out.4096.0.0"-                        out = "qifs/qifs/" ++ svc ++ ".qif"-                    test inp out+                forM_ ["f5", "ls-qpack", "nghttp3", "proxygen", "qthingey", "quinn"] $ \impl ->+                    forM_ [".0.0", ".0.1", ".100.0", ".100.1"] $ \suffix ->+                        forM_ [256, 512, 4096 :: Int] $ \size -> do+                            let inp =+                                    "qifs/encoded/qpack-05/" ++ impl ++ "/" ++ svc ++ ".out." ++ show size ++ suffix+                                out = "qifs/qifs/" ++ svc ++ ".qif"+                            putStrLn inp+                            test size inp out -data Block = Block Int ByteString deriving (Show)+        it "decodes only with static table" $ do+            forM_ ["fb-req-hq", "fb-resp-hq", "netbsd-hq"] $ \svc ->+                forM_ ["ls-qpack", "nghttp3", "qthingey", "quinn"] $ \impl ->+                    forM_ [".0.0", ".0.1", ".100.0", ".100.1"] $ \suffix -> do+                        let size = 0+                        let inp =+                                "qifs/encoded/qpack-05/" ++ impl ++ "/" ++ svc ++ ".out." ++ show size ++ suffix+                            out = "qifs/qifs/" ++ svc ++ ".qif"+                        putStrLn inp+                        test size inp out  ---------------------------------------------------------------- -test :: FilePath -> FilePath -> IO ()-test efile qfile = do-    (dec, insthdr) <- newQDecoderS defaultQDecoderConfig (\_ -> return ()) False-    q <- newTQueueIO-    let recv = atomically $ readTQueue q-        send x = atomically $ writeTQueue q x-    mvar <- newEmptyMVar+test :: Int -> FilePath -> FilePath -> IO ()+test size efile qfile = do+    (dec, insthdr) <-+        newQDecoderS+            defaultQDecoderConfig{dcMaxTableCapacity = size}+            (\_ -> return ())+            False+    _ <- encodeEncoderInstructions [SetDynamicTableCapacity size] False >>= insthdr+    ref <- newIORef Seq.empty     withFile qfile ReadMode $ \h -> do-        tid <- forkIO $ decode dec h recv mvar-        runConduitRes-            (sourceFile efile .| conduitParser block .| mapM_C (liftIO . switch send insthdr))-        takeMVar mvar-        killThread tid+        processBlock efile $ testSwitch dec insthdr ref h -switch-    :: (Block -> IO ())+testSwitch+    :: (StreamId -> ByteString -> IO (Maybe [Header]))     -> EncoderInstructionHandlerS+    -> IORef (Seq Block)+    -> Handle     -> (PositionRange, Block)     -> IO ()-switch send insthdr (_, blk@(Block n bs))+testSwitch dec insthdr ref h (_, blk@(Block n bs))     | n == 0 = do-        insthdr bs-        yield-    | otherwise = send blk--decode-    :: (StreamId -> ByteString -> IO [Header])-    -> Handle-    -> IO Block-    -> MVar ()-    -> IO ()-decode dec h recv mvar = loop+        _ <- insthdr bs+        fifo <- readIORef ref+        loop fifo+    -- to avoid blocking by "dec", ask decoding to the other thread+    | otherwise = do+        mhdr <- dec n bs+        case mhdr of+            Nothing -> modifyIORef' ref (blk <|)+            Just hdr -> compareHeaders hdr   where-    loop = do+    loop fifo = do+        case viewr fifo of+            EmptyR -> writeIORef ref Seq.empty+            fifo' :> Block n1 bs1 -> do+                mhdr <- dec n1 bs1+                case mhdr of+                    Nothing -> writeIORef ref fifo+                    Just hdr -> do+                        compareHeaders hdr+                        loop fifo'+    compareHeaders hdr = do         hdr' <- fromCaseSensitive <$> headerlist h-        if null hdr'-            then-                putMVar mvar ()-            else do-                Block n bs <- recv-                hdr <- dec n bs-                hdr `shouldBe` hdr'-                loop--fromCaseSensitive :: [Header] -> [Header]-fromCaseSensitive = map (\(k, v) -> (foldedCase $ mk k, v))--block :: Parser Block-block = do-    num <- toInt <$> P.take 8-    len <- toInt <$> P.take 4-    dat <- P.take len-    return $ Block num dat--toInt :: ByteString -> Int-toInt bs = BS.foldl' f 0 bs-  where-    f n w8 = n * 256 + fromIntegral w8--------------------------------------------------------------------headerlist :: Handle -> IO [Header]-headerlist h = loop id-  where-    loop b = do-        ml <- line h-        case ml of-            Nothing -> return $ b []-            Just l-                | l == "" -> return $ b []-                | otherwise -> do-                    let (k, v0) = BS8.break (== '\t') l-                        v = BS8.drop 1 v0-                    loop (b . ((mk k, v) :))--line :: Handle -> IO (Maybe ByteString)-line h = do-    el <- E.try $ BS8.hGetLine h-    case el of-        Left (_ :: E.IOException) -> return Nothing-        Right l-            | BS8.take 1 l == "#" -> line h-            | otherwise -> return $ Just l+        fromCaseSensitive hdr `shouldBe` hdr'

@@ -9,13 +9,13 @@ spec = do     describe "encodeRequiredInsertCount and decodeRequiredInsertCount" $ do         prop "duality" $ \(Triple m ei di) -> do-            let ereq = encodeRequiredInsertCount m (InsertionPoint ei)-                InsertionPoint ei' = decodeRequiredInsertCount m (InsertionPoint di) ereq+            let ereq = encodeRequiredInsertCount m (RequiredInsertCount ei)+                RequiredInsertCount ei' = decodeRequiredInsertCount m (InsertionPoint di) ereq             ei' `shouldBe` ei     describe "encodeBase and decodeBase" $ do         prop "duality" $ \(Doubl base reqInsCnt) -> do-            let (s, delta) = encodeBase (InsertionPoint reqInsCnt) (BasePoint base)-                BasePoint base' = decodeBase (InsertionPoint reqInsCnt) s delta+            let (s, delta) = encodeBase (RequiredInsertCount reqInsCnt) (BasePoint base)+                BasePoint base' = decodeBase (RequiredInsertCount reqInsCnt) s delta             base' `shouldBe` base  data Doubl = Doubl Int Int deriving (Eq, Show)

@@ -51,9 +51,8 @@     run conn cliconf conf $ client aux n0 paths   where     cliconf =-        ClientConfig-            { scheme = "https"-            , authority = auxAuthority+        H3.defaultClientConfig+            { authority = auxAuthority             }  client :: Aux -> Int -> [Path] -> Client ()

@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module QIF (+    processBlock,+    Block (..),+    headerlist,+    fromCaseSensitive,+    headerSize,+) where++import qualified Control.Exception as E+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as P+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import System.IO++import Network.QPACK++import Conduit+import Data.Conduit.Attoparsec++----------------------------------------------------------------++data Block = Block Int ByteString deriving (Show)++----------------------------------------------------------------++processBlock :: FilePath -> ((PositionRange, Block) -> IO ()) -> IO ()+processBlock efile func =+    runConduitRes+        ( sourceFile efile+            .| conduitParser block+            .| mapM_C (liftIO . func)+        )++----------------------------------------------------------------++block :: Parser Block+block = do+    num <- toInt <$> P.take 8+    len <- toInt <$> P.take 4+    dat <- P.take len+    return $ Block num dat++toInt :: ByteString -> Int+toInt = BS.foldl' f 0+  where+    f n w8 = n * 256 + fromIntegral w8++----------------------------------------------------------------++headerlist :: Handle -> IO [Header]+headerlist h = loop id+  where+    loop b = do+        ml <- line h+        case ml of+            Nothing -> return $ b []+            Just l+                | l == "" -> return $ b []+                | otherwise -> do+                    let (k, v0) = BS8.break (== '\t') l+                        v = BS8.drop 1 v0+                    loop (b . ((mk k, v) :))++line :: Handle -> IO (Maybe ByteString)+line h = do+    el <- E.try $ BS8.hGetLine h+    case el of+        Left (_ :: E.IOException) -> return Nothing+        Right l+            | BS8.take 1 l == "#" -> line h+            | otherwise -> return $ Just l++----------------------------------------------------------------++fromCaseSensitive :: [Header] -> [Header]+fromCaseSensitive = map (\(k, v) -> (foldedCase $ mk k, v))++headerSize :: Header -> Int+headerSize (k, v) = BS.length (foldedCase k) + BS.length v

@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Conduit.Attoparsec+import Data.IORef+import Data.Sequence (Seq, ViewR (..), viewr, (<|))+import qualified Data.Sequence as Seq+import Network.QUIC (StreamId)+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++import Network.QPACK+import Network.QPACK.Internal++import QIF++data Options = Options+    { optDebug :: Bool+    }++defaultOptions :: Options+defaultOptions =+    Options+        { optDebug = False+        }++options :: [OptDescr (Options -> Options)]+options =+    [ Option+        ['d']+        ["debug"]+        (NoArg (\o -> o{optDebug = True}))+        "dump encode instructions while checking"+    ]++usage :: String+usage = "Usage: qif-dec <size> <encode-file> [<qif-file>]"++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+    putStrLn msg+    putStrLn $ usageInfo usage options+    exitFailure++decoderOpts :: [String] -> IO (Options, [String])+decoderOpts argv =+    case getOpt Permute options argv of+        (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+        (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+    args <- getArgs+    (Options{..}, spec) <- decoderOpts args+    case spec of+        [size, efile] -> dump (read size) efile+        [size, efile, qfile] -> test (read size) efile qfile optDebug+        _ -> showUsageAndExit "Illegal arguments"++----------------------------------------------------------------++dump :: Int -> FilePath -> IO ()+dump size efile = do+    (dec, insthdr) <-+        newQDecoderS+            defaultQDecoderConfig{dcMaxTableCapacity = size}+            (\_ -> return ())+            True+    _ <- encodeEncoderInstructions [SetDynamicTableCapacity size] False >>= insthdr+    ref <- newIORef Seq.empty+    processBlock efile $ dumpSwitch dec insthdr ref++dumpSwitch+    :: (StreamId -> ByteString -> IO (Maybe [Header]))+    -> EncoderInstructionHandlerS+    -> IORef (Seq Block)+    -> (PositionRange, Block)+    -> IO ()+dumpSwitch dec insthdr ref (_, blk@(Block n bs))+    | n == 0 = do+        putStrLn "---- Encoder Stream"+        _ <- insthdr bs+        fifo <- readIORef ref+        loop fifo+    | otherwise = do+        mhdr <- dec n bs+        case mhdr of+            Nothing -> modifyIORef' ref (blk <|)+            Just _ -> return ()+  where+    loop fifo = do+        case viewr fifo of+            EmptyR -> writeIORef ref Seq.empty+            fifo' :> Block n1 bs1 -> do+                mhdr <- dec n1 bs1+                case mhdr of+                    Nothing -> writeIORef ref fifo+                    Just _ -> loop fifo'++----------------------------------------------------------------++data Ratio = Ratio+    { ratioInst :: Int+    , ratioHeader :: Int+    }++test :: Int -> FilePath -> FilePath -> Bool -> IO ()+test size efile qfile debug = do+    (dec, insthdr) <-+        newQDecoderS+            defaultQDecoderConfig{dcMaxTableCapacity = size}+            (\_ -> return ())+            debug+    _ <- encodeEncoderInstructions [SetDynamicTableCapacity size] False >>= insthdr+    ref <- newIORef Seq.empty+    ratio <- newIORef $ Ratio{ratioInst = 0, ratioHeader = 0}+    withFile qfile ReadMode $ \h -> do+        processBlock efile $ testSwitch dec insthdr ref h ratio+        r <- readIORef ratio+        let (x, y) = ((ratioInst r * 1000) `div` ratioHeader r) `divMod` 10+        putStrLn $ show x ++ "." ++ show y++testSwitch+    :: (StreamId -> ByteString -> IO (Maybe [Header]))+    -> EncoderInstructionHandlerS+    -> IORef (Seq Block)+    -> Handle+    -> IORef Ratio+    -> (PositionRange, Block)+    -> IO ()+testSwitch dec insthdr ref h ratio (_, blk@(Block n bs))+    | n == 0 = do+        _ <- insthdr bs+        modifyIORef' ratio $ \r -> r{ratioInst = ratioInst r + BS.length bs}+        fifo <- readIORef ref+        loop fifo+    -- to avoid blocking by "dec", ask decoding to the other thread+    | otherwise = do+        mhdr <- dec n bs+        case mhdr of+            Nothing -> modifyIORef' ref (blk <|)+            Just hdr -> compareHeaders hdr+  where+    loop fifo = do+        case viewr fifo of+            EmptyR -> writeIORef ref Seq.empty+            fifo' :> Block n1 bs1 -> do+                mhdr <- dec n1 bs1+                case mhdr of+                    Nothing -> writeIORef ref fifo+                    Just hdr -> do+                        compareHeaders hdr+                        loop fifo'+    compareHeaders hdr = do+        hdr' <- fromCaseSensitive <$> headerlist h+        if fromCaseSensitive hdr == hdr'+            then modifyIORef' ratio $ \r ->+                r+                    { ratioInst = ratioInst r + BS.length bs+                    , ratioHeader = ratioHeader r + sum (map headerSize hdr)+                    }+            else do+                putStrLn $ "---- Stream " ++ show n+                let hdrt = zip hdr hdr'+                mapM_ printDiff hdrt+                exitFailure++----------------------------------------------------------------++printDiff :: (Header, Header) -> IO ()+printDiff (kv0, kv1)+    | kv0 == kv1 = print kv1+    | otherwise = do+        putStrLn $ "EXPECT: " ++ show kv1+        putStrLn $ "ACTUAL: " ++ show kv0

@@ -0,0 +1,85 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import qualified Data.ByteString as BS+import Data.Serialize.Put+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.FilePath+import System.IO++import Network.QPACK++import QIF++data Options = Options+    { optDebug :: Bool+    }++defaultOptions :: Options+defaultOptions =+    Options+        { optDebug = False+        }++options :: [OptDescr (Options -> Options)]+options =+    [ Option+        ['d']+        ["debug"]+        (NoArg (\o -> o{optDebug = True}))+        "dump encode instructions"+    ]++usage :: String+usage = "Usage: qif-enc <qif-file> <capacity> <blocked> <ack>"++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+    putStrLn msg+    putStrLn $ usageInfo usage options+    exitFailure++encoderOpts :: [String] -> IO (Options, [String])+encoderOpts argv =+    case getOpt Permute options argv of+        (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+        (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+    args <- getArgs+    (Options{..}, spec) <- encoderOpts args+    case spec of+        [qfile, cap, blk, ack] -> do+            let efile = takeBaseName qfile ++ ".out." ++ cap ++ "." ++ blk ++ "." ++ ack+                capacity = read cap+                blocked = read blk+                immack = ack == "1"+            encode qfile efile capacity blocked immack optDebug+        _ -> showUsageAndExit "Illegal arguments"++encode :: FilePath -> FilePath -> Int -> Int -> Bool -> Bool -> IO ()+encode qfile efile capacity blocked immack debug = do+    let encConf = defaultQEncoderConfig{ecMaxTableCapacity = capacity}+        save sid bs = do+            let header = runPut $ do+                    putWord64be $ fromIntegral (sid :: Int)+                    putWord32be $ fromIntegral $ BS.length bs+            BS.appendFile efile $ header <> bs+    enc <- newQEncoderS encConf (save 0) blocked immack debug+    withFile qfile ReadMode $ qencode enc save++qencode :: QEncoderS -> (Int -> BS.ByteString -> IO ()) -> Handle -> IO ()+qencode enc save hdl = loop 1+  where+    loop sid = do+        hs <- headerlist hdl+        if null hs+            then return ()+            else do+                bs <- enc sid hs+                save sid bs+                loop (sid + 1)

@@ -1,161 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main where--import Conduit hiding (yield)-import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Monad-import Data.Attoparsec.ByteString (Parser)-import qualified Data.Attoparsec.ByteString as P-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Data.Conduit.Attoparsec-import Network.QUIC (StreamId)-import System.Environment-import System.IO--import Network.QPACK--data Block = Block Int ByteString deriving (Show)--------------------------------------------------------------------main :: IO ()-main = do-    args <- getArgs-    case args of-        [size, efile] -> dump (read size) efile-        [size, efile, qfile] -> test (read size) efile qfile-        _ -> putStrLn "qif size <encode-file> [<qif-file>]"--------------------------------------------------------------------dump :: Int -> FilePath -> IO ()-dump size efile = do-    (dec, insthdr) <--        newQDecoderS-            defaultQDecoderConfig{dcDynamicTableSize = size}-            (\_ -> return ())-            True-    runConduitRes-        ( sourceFile efile-            .| conduitParser block-            .| mapM_C (liftIO . dumpSwitch dec insthdr)-        )--dumpSwitch-    :: (StreamId -> ByteString -> IO [Header])-    -> EncoderInstructionHandlerS-    -> (a, Block)-    -> IO ()-dumpSwitch dec insthdr (_, Block n bs)-    | n == 0 = do-        putStrLn "---- Encoder Stream"-        insthdr bs-    | otherwise = do-        putStrLn $ "---- Stream " ++ show n-        _ <- dec n bs-        return ()--------------------------------------------------------------------test :: Int -> FilePath -> FilePath -> IO ()-test size efile qfile = do-    (dec, insthdr') <--        newQDecoderS-            defaultQDecoderConfig{dcDynamicTableSize = size}-            (\_ -> return ())-            False-    q <- newTQueueIO-    let recv = atomically $ readTQueue q-        send x = atomically $ writeTQueue q x-        insthdr bs = do-            emp <- atomically $ isEmptyTQueue q-            unless emp yield-            insthdr' bs-            yield-    mvar <- newEmptyMVar-    withFile qfile ReadMode $ \h -> do-        tid <- forkIO $ decode dec h recv mvar-        runConduitRes-            ( sourceFile efile-                .| conduitParser block-                .| mapM_C (liftIO . testSwitch send insthdr)-            )-        takeMVar mvar-        killThread tid--testSwitch-    :: (Block -> IO ())-    -> EncoderInstructionHandlerS-    -> (a, Block)-    -> IO ()-testSwitch send insthdr (_, blk@(Block n bs))-    | n == 0 = insthdr bs-    | otherwise = send blk--decode :: QDecoderS -> Handle -> IO Block -> MVar () -> IO ()-decode dec h recv mvar = loop-  where-    loop = do-        hdr' <- fromCaseSensitive <$> headerlist h-        if null hdr'-            then putMVar mvar ()-            else do-                Block n bs <- recv-                hdr <- dec n bs-                if hdr == hdr'-                    then loop-                    else do-                        putStrLn $ "---- Stream " ++ show n-                        mapM_ print hdr-                        putStrLn "----"-                        mapM_ print hdr'-                        putStrLn "----"-                        putMVar mvar ()--fromCaseSensitive :: [Header] -> [Header]-fromCaseSensitive = map (\(k, v) -> (foldedCase $ mk k, v))--------------------------------------------------------------------block :: Parser Block-block = do-    num <- toInt <$> P.take 8-    len <- toInt <$> P.take 4-    dat <- P.take len-    return $ Block num dat--toInt :: ByteString -> Int-toInt = BS.foldl' f 0-  where-    f n w8 = n * 256 + fromIntegral w8--------------------------------------------------------------------headerlist :: Handle -> IO [Header]-headerlist h = loop id-  where-    loop b = do-        ml <- line h-        case ml of-            Nothing -> return $ b []-            Just l-                | l == "" -> return $ b []-                | otherwise -> do-                    let (k, v0) = BS8.break (== '\t') l-                        v = BS8.drop 1 v0-                    loop (b . ((mk k, v) :))--line :: Handle -> IO (Maybe ByteString)-line h = do-    el <- E.try $ BS8.hGetLine h-    case el of-        Left (_ :: E.IOException) -> return Nothing-        Right l-            | BS8.take 1 l == "#" -> line h-            | otherwise -> return $ Just l