{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Thread-safe QPACK encoder/decoder.
module Network.QPACK (
    -- * Encoder
    QEncoderConfig (..),
    defaultQEncoderConfig,
    QEncoder,
    newQEncoder,
    TableOperation (..),

    -- ** Encoder for debugging
    QEncoderS,
    newQEncoderS,

    -- * Decoder
    QDecoderConfig (..),
    defaultQDecoderConfig,
    QDecoder,
    newQDecoder,

    -- ** Decoder for debugging
    QDecoderS,
    newQDecoderS,

    -- * Types
    EncodedEncoderInstruction,
    EncoderInstructionHandler,
    EncoderInstructionHandlerS,
    EncodedDecoderInstruction,
    DecoderInstructionHandler,
    InstructionHandler,
    Size,

    -- * Re-exports
    TokenHeaderTable,
    TokenHeaderList,
    ValueTable,
    Header,
    getFieldValue,
    toTokenHeaderTable,
    original,
    foldedCase,
    mk,
) where

import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
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,
    Size,
    entryToken,
    toEntryToken,
    toTokenHeaderTable,
 )
import Network.HTTP.Types
import Network.QUIC.Internal (StreamId)

import Imports
import Network.QPACK.Error
import Network.QPACK.HeaderBlock
import Network.QPACK.Instruction
import Network.QPACK.Table
import Network.QPACK.Types

----------------------------------------------------------------

-- | QPACK encoder.
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 (Maybe [Header])

-- | Encoder instruction handler.
type EncoderInstructionHandler = (Int -> IO EncodedEncoderInstruction) -> IO ()

-- | Simple encoder instruction handler.
--   Leftover is returned.
type EncoderInstructionHandlerS =
    EncodedEncoderInstruction -> IO EncodedEncoderInstruction

-- | Encoded decoder instruction.
type EncodedDecoderInstruction = ByteString

-- | Decoder instruction handler.
type DecoderInstructionHandler = (Int -> IO EncodedDecoderInstruction) -> IO ()

-- | A type to integrating handlers.
type InstructionHandler = (Int -> IO ByteString) -> IO ()

data TableOperation = TableOperation
    { TableOperation -> Int -> IO ()
setCapacity :: Int -> IO ()
    , TableOperation -> Int -> IO ()
setBlockedStreams :: Int -> IO ()
    , TableOperation -> Int -> IO ()
setHeaderSize :: Int -> IO ()
    }

----------------------------------------------------------------

-- | Configuration for QPACK encoder.
data QEncoderConfig = QEncoderConfig
    { QEncoderConfig -> Int
ecMaxTableCapacity :: Size
    , QEncoderConfig -> Int
ecHeaderBlockBufferSize :: Size
    , QEncoderConfig -> Int
ecInstructionBufferSize :: Size
    }
    deriving (Int -> QEncoderConfig -> ShowS
[QEncoderConfig] -> ShowS
QEncoderConfig -> [Char]
(Int -> QEncoderConfig -> ShowS)
-> (QEncoderConfig -> [Char])
-> ([QEncoderConfig] -> ShowS)
-> Show QEncoderConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QEncoderConfig -> ShowS
showsPrec :: Int -> QEncoderConfig -> ShowS
$cshow :: QEncoderConfig -> [Char]
show :: QEncoderConfig -> [Char]
$cshowList :: [QEncoderConfig] -> ShowS
showList :: [QEncoderConfig] -> ShowS
Show)

-- | Default configuration for QPACK encoder.
--
-- >>> defaultQEncoderConfig
-- QEncoderConfig {ecMaxTableCapacity = 4096, ecHeaderBlockBufferSize = 4096, ecInstructionBufferSize = 4096}
defaultQEncoderConfig :: QEncoderConfig
defaultQEncoderConfig :: QEncoderConfig
defaultQEncoderConfig =
    QEncoderConfig
        { ecMaxTableCapacity :: Int
ecMaxTableCapacity = Int
4096
        , ecHeaderBlockBufferSize :: Int
ecHeaderBlockBufferSize = Int
4096
        , ecInstructionBufferSize :: Int
ecInstructionBufferSize = Int
4096
        }

-- | Creating a new QPACK encoder.
newQEncoder
    :: QEncoderConfig
    -> (EncodedEncoderInstruction -> IO ())
    -> IO (QEncoder, DecoderInstructionHandler, TableOperation)
newQEncoder :: QEncoderConfig
-> (EncodedEncoderInstruction -> IO ())
-> IO (QEncoder, DecoderInstructionHandler, TableOperation)
newQEncoder QEncoderConfig{Int
ecMaxTableCapacity :: QEncoderConfig -> Int
ecHeaderBlockBufferSize :: QEncoderConfig -> Int
ecInstructionBufferSize :: QEncoderConfig -> Int
ecMaxTableCapacity :: Int
ecHeaderBlockBufferSize :: Int
ecInstructionBufferSize :: Int
..} EncodedEncoderInstruction -> IO ()
sendEI = do
    let bufsiz1 :: Int
bufsiz1 = Int
ecHeaderBlockBufferSize
        bufsiz2 :: Int
bufsiz2 = Int
ecInstructionBufferSize
    ForeignPtr Word8
gcbuf1 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
bufsiz1
    ForeignPtr Word8
gcbuf2 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
bufsiz2
    DynamicTable
dyntbl <- (EncodedEncoderInstruction -> IO ()) -> IO DynamicTable
newDynamicTableForEncoding EncodedEncoderInstruction -> IO ()
sendEI
    MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let enc :: QEncoder
enc =
            ForeignPtr Word8
-> Int
-> ForeignPtr Word8
-> Int
-> DynamicTable
-> MVar ()
-> QEncoder
qpackEncoder
                ForeignPtr Word8
gcbuf1
                Int
bufsiz1
                ForeignPtr Word8
gcbuf2
                Int
bufsiz2
                DynamicTable
dyntbl
                MVar ()
lock
        handler :: DecoderInstructionHandler
handler = DynamicTable -> DecoderInstructionHandler
decoderInstructionHandler DynamicTable
dyntbl
        ctl :: TableOperation
ctl =
            TableOperation
                { setCapacity :: Int -> IO ()
setCapacity = \Int
n -> do
                    -- "n" is decoder-proposed size via settings.
                    let tableSize :: Int
tableSize = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
ecMaxTableCapacity Int
n
                    DynamicTable -> Int -> IO ()
setTableCapacity DynamicTable
dyntbl Int
tableSize
                    EncodedEncoderInstruction
ins <- [EncoderInstruction] -> Bool -> IO EncodedEncoderInstruction
encodeEncoderInstructions [Int -> EncoderInstruction
SetDynamicTableCapacity Int
tableSize] Bool
False
                    DynamicTable -> EncodedEncoderInstruction -> IO ()
sendIns DynamicTable
dyntbl EncodedEncoderInstruction
ins
                , setBlockedStreams :: Int -> IO ()
setBlockedStreams = DynamicTable -> Int -> IO ()
setMaxBlockedStreams DynamicTable
dyntbl
                , setHeaderSize :: Int -> IO ()
setHeaderSize = DynamicTable -> Int -> IO ()
setMaxHeaderSize DynamicTable
dyntbl
                }
    (QEncoder, DecoderInstructionHandler, TableOperation)
-> IO (QEncoder, DecoderInstructionHandler, TableOperation)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QEncoder
enc, DecoderInstructionHandler
handler, TableOperation
ctl)

tokenHeaderSize :: TokenHeader -> Int
tokenHeaderSize :: TokenHeader -> Int
tokenHeaderSize (Token
t, EncodedEncoderInstruction
v) = EncodedEncoderInstruction -> Int
BS.length (CI EncodedEncoderInstruction -> EncodedEncoderInstruction
forall s. CI s -> s
CI.original (Token -> CI EncodedEncoderInstruction
tokenKey Token
t)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ EncodedEncoderInstruction -> Int
BS.length EncodedEncoderInstruction
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 -- adhoc overhead

split :: Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split :: Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split Int
lim TokenHeaderList
ts = Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split' Int
0 TokenHeaderList
ts
  where
    split' :: Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split' Int
_ [] = ([], [])
    split' Int
s xxs :: TokenHeaderList
xxs@(TokenHeader
x : TokenHeaderList
xs)
        | Int
siz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lim = BufferOverrun -> (TokenHeaderList, TokenHeaderList)
forall a e. Exception e => e -> a
E.throw BufferOverrun
BufferOverrun
        | Int
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lim =
            let (TokenHeaderList
ys, TokenHeaderList
zs) = Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split' Int
s' TokenHeaderList
xs
             in (TokenHeader
x TokenHeader -> TokenHeaderList -> TokenHeaderList
forall a. a -> [a] -> [a]
: TokenHeaderList
ys, TokenHeaderList
zs)
        | Bool
otherwise = ([], TokenHeaderList
xxs)
      where
        siz :: Int
siz = TokenHeader -> Int
tokenHeaderSize TokenHeader
x
        s' :: Int
s' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
siz

splitThrough :: Int -> TokenHeaderList -> [TokenHeaderList]
splitThrough :: Int -> TokenHeaderList -> [TokenHeaderList]
splitThrough Int
lim TokenHeaderList
ts0 = TokenHeaderList
-> ([TokenHeaderList] -> [TokenHeaderList]) -> [TokenHeaderList]
forall {c}. TokenHeaderList -> ([TokenHeaderList] -> c) -> c
loop TokenHeaderList
ts0 [TokenHeaderList] -> [TokenHeaderList]
forall a. a -> a
id
  where
    loop :: TokenHeaderList -> ([TokenHeaderList] -> c) -> c
loop [] [TokenHeaderList] -> c
builder = [TokenHeaderList] -> c
builder []
    loop TokenHeaderList
ts [TokenHeaderList] -> c
builder = TokenHeaderList -> ([TokenHeaderList] -> c) -> c
loop TokenHeaderList
ts2 ([TokenHeaderList] -> c
builder ([TokenHeaderList] -> c)
-> ([TokenHeaderList] -> [TokenHeaderList])
-> [TokenHeaderList]
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenHeaderList
ts1 TokenHeaderList -> [TokenHeaderList] -> [TokenHeaderList]
forall a. a -> [a] -> [a]
:))
      where
        (TokenHeaderList
ts1, TokenHeaderList
ts2) = Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList)
split Int
lim TokenHeaderList
ts

qpackEncoder
    :: GCBuffer
    -> Int
    -> GCBuffer
    -> Int
    -> DynamicTable
    -> MVar ()
    -> QEncoder
qpackEncoder :: ForeignPtr Word8
-> Int
-> ForeignPtr Word8
-> Int
-> DynamicTable
-> MVar ()
-> QEncoder
qpackEncoder ForeignPtr Word8
gcbuf1 Int
bufsiz1 ForeignPtr Word8
gcbuf2 Int
bufsiz2 DynamicTable
dyntbl MVar ()
lock Int
sid TokenHeaderList
ts =
    MVar ()
-> (() -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (() -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \()
_ ->
        ForeignPtr Word8
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
gcbuf1 ((Ptr Word8 -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf1 ->
            ForeignPtr Word8
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
gcbuf2 ((Ptr Word8 -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf2 -> do
                Int
siz <- DynamicTable -> IO Int
getTableCapacity DynamicTable
dyntbl
                DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"---- Stream " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sid [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"tblsiz: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
siz
                DynamicTable -> IO ()
setBasePointToInsersionPoint DynamicTable
dyntbl
                DynamicTable -> IO ()
clearRequiredInsertCount DynamicTable
dyntbl
                let tss :: [TokenHeaderList]
tss = Int -> TokenHeaderList -> [TokenHeaderList]
splitThrough Int
bufsiz1 TokenHeaderList
ts
                [(EncodedEncoderInstruction, [AbsoluteIndex])]
his <- (TokenHeaderList
 -> IO (EncodedEncoderInstruction, [AbsoluteIndex]))
-> [TokenHeaderList]
-> IO [(EncodedEncoderInstruction, [AbsoluteIndex])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ptr Word8
-> Int
-> Ptr Word8
-> Int
-> DynamicTable
-> TokenHeaderList
-> IO (EncodedEncoderInstruction, [AbsoluteIndex])
qpackEncodeHeader Ptr Word8
buf1 Int
bufsiz1 Ptr Word8
buf2 Int
bufsiz2 DynamicTable
dyntbl) [TokenHeaderList]
tss
                let ([EncodedEncoderInstruction]
hbs, [[AbsoluteIndex]]
daiss) = [(EncodedEncoderInstruction, [AbsoluteIndex])]
-> ([EncodedEncoderInstruction], [[AbsoluteIndex]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EncodedEncoderInstruction, [AbsoluteIndex])]
his
                EncodedEncoderInstruction
prefix <- Ptr Word8 -> Int -> DynamicTable -> IO EncodedEncoderInstruction
qpackEncodePrefix Ptr Word8
buf1 Int
bufsiz1 DynamicTable
dyntbl
                let section :: EncodedEncoderInstruction
section = [EncodedEncoderInstruction] -> EncodedEncoderInstruction
BS.concat (EncodedEncoderInstruction
prefix EncodedEncoderInstruction
-> [EncodedEncoderInstruction] -> [EncodedEncoderInstruction]
forall a. a -> [a] -> [a]
: [EncodedEncoderInstruction]
hbs)
                RequiredInsertCount
reqInsCnt <- DynamicTable -> IO RequiredInsertCount
getRequiredInsertCount DynamicTable
dyntbl
                -- To count only blocked sections,
                -- dont' register this section if reqInsCnt == 0.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequiredInsertCount
reqInsCnt RequiredInsertCount -> RequiredInsertCount -> Bool
forall a. Eq a => a -> a -> Bool
/= RequiredInsertCount
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    DynamicTable -> Int -> Section -> IO ()
insertSection DynamicTable
dyntbl Int
sid (Section -> IO ()) -> Section -> IO ()
forall a b. (a -> b) -> a -> b
$
                        RequiredInsertCount -> [AbsoluteIndex] -> Section
Section RequiredInsertCount
reqInsCnt ([AbsoluteIndex] -> Section) -> [AbsoluteIndex] -> Section
forall a b. (a -> b) -> a -> b
$
                            [[AbsoluteIndex]] -> [AbsoluteIndex]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AbsoluteIndex]]
daiss
                EncodedEncoderInstruction -> IO EncodedEncoderInstruction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodedEncoderInstruction
section

qpackEncoderS
    :: GCBuffer
    -> Int
    -> GCBuffer
    -> Int
    -> DynamicTable
    -> MVar ()
    -> QEncoderS
qpackEncoderS :: ForeignPtr Word8
-> Int
-> ForeignPtr Word8
-> Int
-> DynamicTable
-> MVar ()
-> QEncoderS
qpackEncoderS ForeignPtr Word8
gcbuf1 Int
bufsiz1 ForeignPtr Word8
gcbuf2 Int
bufsiz2 DynamicTable
dyntbl MVar ()
lock Int
sid [Header]
hs =
    MVar ()
-> (() -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (() -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \()
_ ->
        ForeignPtr Word8
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
gcbuf1 ((Ptr Word8 -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf1 ->
            ForeignPtr Word8
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
gcbuf2 ((Ptr Word8 -> IO EncodedEncoderInstruction)
 -> IO EncodedEncoderInstruction)
-> (Ptr Word8 -> IO EncodedEncoderInstruction)
-> IO EncodedEncoderInstruction
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf2 -> do
                Int
siz <- DynamicTable -> IO Int
getTableCapacity DynamicTable
dyntbl
                DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"---- Stream " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sid [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"tblsiz: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
siz
                DynamicTable -> IO ()
setBasePointToInsersionPoint DynamicTable
dyntbl
                DynamicTable -> IO ()
clearRequiredInsertCount DynamicTable
dyntbl
                let tss :: [TokenHeaderList]
tss = Int -> TokenHeaderList -> [TokenHeaderList]
splitThrough Int
bufsiz1 TokenHeaderList
ts
                [(EncodedEncoderInstruction, [AbsoluteIndex])]
his <- (TokenHeaderList
 -> IO (EncodedEncoderInstruction, [AbsoluteIndex]))
-> [TokenHeaderList]
-> IO [(EncodedEncoderInstruction, [AbsoluteIndex])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ptr Word8
-> Int
-> Ptr Word8
-> Int
-> DynamicTable
-> TokenHeaderList
-> IO (EncodedEncoderInstruction, [AbsoluteIndex])
qpackEncodeHeader Ptr Word8
buf1 Int
bufsiz1 Ptr Word8
buf2 Int
bufsiz2 DynamicTable
dyntbl) [TokenHeaderList]
tss
                let ([EncodedEncoderInstruction]
hbs, [[AbsoluteIndex]]
daiss) = [(EncodedEncoderInstruction, [AbsoluteIndex])]
-> ([EncodedEncoderInstruction], [[AbsoluteIndex]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(EncodedEncoderInstruction, [AbsoluteIndex])]
his
                EncodedEncoderInstruction
prefix <- Ptr Word8 -> Int -> DynamicTable -> IO EncodedEncoderInstruction
qpackEncodePrefix Ptr Word8
buf1 Int
bufsiz1 DynamicTable
dyntbl
                let section :: EncodedEncoderInstruction
section = [EncodedEncoderInstruction] -> EncodedEncoderInstruction
BS.concat (EncodedEncoderInstruction
prefix EncodedEncoderInstruction
-> [EncodedEncoderInstruction] -> [EncodedEncoderInstruction]
forall a. a -> [a] -> [a]
: [EncodedEncoderInstruction]
hbs)
                RequiredInsertCount
reqInsCnt <- DynamicTable -> IO RequiredInsertCount
getRequiredInsertCount DynamicTable
dyntbl
                -- To count only blocked sections,
                -- dont' register this section if reqInsCnt == 0.
                Bool
immAck <- DynamicTable -> IO Bool
getImmediateAck DynamicTable
dyntbl
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequiredInsertCount
reqInsCnt RequiredInsertCount -> RequiredInsertCount -> Bool
forall a. Eq a => a -> a -> Bool
/= RequiredInsertCount
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Bool
blocked <- DynamicTable -> RequiredInsertCount -> IO Bool
wouldSectionBeBlocked DynamicTable
dyntbl RequiredInsertCount
reqInsCnt
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
blocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynamicTable -> Int -> IO ()
insertBlockedStreamE DynamicTable
dyntbl Int
sid
                    let dais :: [AbsoluteIndex]
dais = [[AbsoluteIndex]] -> [AbsoluteIndex]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AbsoluteIndex]]
daiss
                    DynamicTable -> Int -> Section -> IO ()
insertSection DynamicTable
dyntbl Int
sid (Section -> IO ()) -> Section -> IO ()
forall a b. (a -> b) -> a -> b
$ RequiredInsertCount -> [AbsoluteIndex] -> Section
Section RequiredInsertCount
reqInsCnt [AbsoluteIndex]
dais
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
immAck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        -- The same logic of SectionAcknowledgement.
                        DynamicTable -> RequiredInsertCount -> IO ()
updateKnownReceivedCount DynamicTable
dyntbl RequiredInsertCount
reqInsCnt
                        (AbsoluteIndex -> IO ()) -> [AbsoluteIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynamicTable -> AbsoluteIndex -> IO ()
decreaseReference DynamicTable
dyntbl) [AbsoluteIndex]
dais
                        DynamicTable -> Int -> IO ()
deleteBlockedStreamE DynamicTable
dyntbl Int
sid
                -- Need to emulate InsertCountIncrement since
                -- SectionAcknowledgement is not returned if
                -- RequiredInsertCount is 0.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
immAck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynamicTable -> IO ()
setInsersionPointToKnownReceivedCount DynamicTable
dyntbl
                EncodedEncoderInstruction -> IO EncodedEncoderInstruction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodedEncoderInstruction
section
  where
    mk' :: (CI EncodedEncoderInstruction, b) -> (Token, b)
mk' (CI EncodedEncoderInstruction
k, b
v) = (Token
t, b
v)
      where
        t :: Token
t = EncodedEncoderInstruction -> Token
toToken (EncodedEncoderInstruction -> Token)
-> EncodedEncoderInstruction -> Token
forall a b. (a -> b) -> a -> b
$ CI EncodedEncoderInstruction -> EncodedEncoderInstruction
forall s. CI s -> s
foldedCase CI EncodedEncoderInstruction
k
    ts :: TokenHeaderList
ts = (Header -> TokenHeader) -> [Header] -> TokenHeaderList
forall a b. (a -> b) -> [a] -> [b]
map Header -> TokenHeader
forall {b}. (CI EncodedEncoderInstruction, b) -> (Token, b)
mk' [Header]
hs

qpackEncodeHeader
    :: Buffer
    -> BufferSize
    -> Buffer
    -> BufferSize
    -> DynamicTable
    -> TokenHeaderList
    -> IO (ByteString, [AbsoluteIndex])
qpackEncodeHeader :: Ptr Word8
-> Int
-> Ptr Word8
-> Int
-> DynamicTable
-> TokenHeaderList
-> IO (EncodedEncoderInstruction, [AbsoluteIndex])
qpackEncodeHeader Ptr Word8
buf1 Int
bufsiz1 Ptr Word8
buf2 Int
bufsiz2 DynamicTable
dyntbl TokenHeaderList
ts = do
    WriteBuffer
wbuf1 <- Ptr Word8 -> Int -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf1 Int
bufsiz1
    WriteBuffer
wbuf2 <- Ptr Word8 -> Int -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf2 Int
bufsiz2
    [AbsoluteIndex]
dais <- WriteBuffer
-> WriteBuffer
-> DynamicTable
-> TokenHeaderList
-> IO [AbsoluteIndex]
encodeTokenHeader WriteBuffer
wbuf1 WriteBuffer
wbuf2 DynamicTable
dyntbl TokenHeaderList
ts
    EncodedEncoderInstruction
hb <- WriteBuffer -> IO EncodedEncoderInstruction
toByteString WriteBuffer
wbuf1
    EncodedEncoderInstruction
ins <- WriteBuffer -> IO EncodedEncoderInstruction
toByteString WriteBuffer
wbuf2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EncodedEncoderInstruction
ins EncodedEncoderInstruction -> EncodedEncoderInstruction -> Bool
forall a. Eq a => a -> a -> Bool
/= EncodedEncoderInstruction
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynamicTable -> EncodedEncoderInstruction -> IO ()
sendIns DynamicTable
dyntbl EncodedEncoderInstruction
ins
    (EncodedEncoderInstruction, [AbsoluteIndex])
-> IO (EncodedEncoderInstruction, [AbsoluteIndex])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncodedEncoderInstruction
hb, [AbsoluteIndex]
dais)

qpackEncodePrefix :: Buffer -> BufferSize -> DynamicTable -> IO ByteString
qpackEncodePrefix :: Ptr Word8 -> Int -> DynamicTable -> IO EncodedEncoderInstruction
qpackEncodePrefix Ptr Word8
buf1 Int
bufsiz1 DynamicTable
dyntbl = do
    WriteBuffer
wbuf1 <- Ptr Word8 -> Int -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf1 Int
bufsiz1
    WriteBuffer -> DynamicTable -> IO ()
encodePrefix WriteBuffer
wbuf1 DynamicTable
dyntbl
    WriteBuffer -> IO EncodedEncoderInstruction
toByteString WriteBuffer
wbuf1

-- Note: dyntbl for encoder
decoderInstructionHandler :: DynamicTable -> DecoderInstructionHandler
decoderInstructionHandler :: DynamicTable -> DecoderInstructionHandler
decoderInstructionHandler DynamicTable
dyntbl Int -> IO EncodedEncoderInstruction
recv = EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
""
  where
    loop :: EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
bs0 = do
        EncodedEncoderInstruction
bs1 <- Int -> IO EncodedEncoderInstruction
recv Int
1024
        let bs :: EncodedEncoderInstruction
bs
                | EncodedEncoderInstruction
bs0 EncodedEncoderInstruction -> EncodedEncoderInstruction -> Bool
forall a. Eq a => a -> a -> Bool
== EncodedEncoderInstruction
"" = EncodedEncoderInstruction
bs1
                | Bool
otherwise = EncodedEncoderInstruction
bs0 EncodedEncoderInstruction
-> EncodedEncoderInstruction -> EncodedEncoderInstruction
forall a. Semigroup a => a -> a -> a
<> EncodedEncoderInstruction
bs1
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EncodedEncoderInstruction
bs EncodedEncoderInstruction -> EncodedEncoderInstruction -> Bool
forall a. Eq a => a -> a -> Bool
/= EncodedEncoderInstruction
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ([DecoderInstruction]
ins, EncodedEncoderInstruction
leftover) <- EncodedEncoderInstruction
-> IO ([DecoderInstruction], EncodedEncoderInstruction)
decodeDecoderInstructions EncodedEncoderInstruction
bs
            DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (DecoderInstruction -> IO ()) -> [DecoderInstruction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DecoderInstruction -> IO ()
forall a. Show a => a -> IO ()
print [DecoderInstruction]
ins
            (DecoderInstruction -> IO ()) -> [DecoderInstruction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DecoderInstruction -> IO ()
handle [DecoderInstruction]
ins
            EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
leftover
    handle :: DecoderInstruction -> IO ()
handle (SectionAcknowledgement Int
sid) = do
        Maybe Section
msec <- DynamicTable -> Int -> IO (Maybe Section)
getAndDelSection DynamicTable
dyntbl Int
sid
        case Maybe Section
msec of
            Maybe Section
Nothing -> DecoderInstructionError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO DecoderInstructionError
DecoderInstructionError
            Just (Section RequiredInsertCount
reqInsCnt [AbsoluteIndex]
ais) -> do
                DynamicTable -> RequiredInsertCount -> IO ()
updateKnownReceivedCount DynamicTable
dyntbl RequiredInsertCount
reqInsCnt
                (AbsoluteIndex -> IO ()) -> [AbsoluteIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynamicTable -> AbsoluteIndex -> IO ()
decreaseReference DynamicTable
dyntbl) [AbsoluteIndex]
ais
                DynamicTable -> Int -> IO ()
deleteBlockedStreamE DynamicTable
dyntbl Int
sid
    handle (StreamCancellation Int
_n) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- fixme
    handle (InsertCountIncrement Int
n)
        | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DecoderInstructionError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO DecoderInstructionError
DecoderInstructionError
        | Bool
otherwise = DynamicTable -> Int -> IO ()
incrementKnownReceivedCount DynamicTable
dyntbl Int
n

----------------------------------------------------------------

newQEncoderS
    :: QEncoderConfig -- capacity
    -> (EncodedEncoderInstruction -> IO ())
    -> Int -- blocked stream
    -> Bool -- immediate Acks
    -> Bool -- debug
    -> IO QEncoderS
newQEncoderS :: QEncoderConfig
-> (EncodedEncoderInstruction -> IO ())
-> Int
-> Bool
-> Bool
-> IO QEncoderS
newQEncoderS QEncoderConfig{Int
ecMaxTableCapacity :: QEncoderConfig -> Int
ecHeaderBlockBufferSize :: QEncoderConfig -> Int
ecInstructionBufferSize :: QEncoderConfig -> Int
ecMaxTableCapacity :: Int
ecHeaderBlockBufferSize :: Int
ecInstructionBufferSize :: Int
..} EncodedEncoderInstruction -> IO ()
saveEI Int
blocked Bool
immediateAck Bool
debug = do
    let bufsiz1 :: Int
bufsiz1 = Int
ecHeaderBlockBufferSize
        bufsiz2 :: Int
bufsiz2 = Int
ecInstructionBufferSize
    ForeignPtr Word8
gcbuf1 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
bufsiz1
    ForeignPtr Word8
gcbuf2 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
bufsiz2
    DynamicTable
dyntbl <- (EncodedEncoderInstruction -> IO ()) -> IO DynamicTable
newDynamicTableForEncoding EncodedEncoderInstruction -> IO ()
saveEI
    DynamicTable -> Int -> IO ()
setTableCapacity DynamicTable
dyntbl Int
ecMaxTableCapacity
    DynamicTable -> Int -> IO ()
setMaxBlockedStreams DynamicTable
dyntbl Int
blocked
    DynamicTable -> Bool -> IO ()
setImmediateAck DynamicTable
dyntbl Bool
immediateAck
    DynamicTable -> Bool -> IO ()
setDebugQPACK DynamicTable
dyntbl Bool
debug
    MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let enc :: QEncoderS
enc =
            ForeignPtr Word8
-> Int
-> ForeignPtr Word8
-> Int
-> DynamicTable
-> MVar ()
-> QEncoderS
qpackEncoderS
                ForeignPtr Word8
gcbuf1
                Int
bufsiz1
                ForeignPtr Word8
gcbuf2
                Int
bufsiz2
                DynamicTable
dyntbl
                MVar ()
lock
    QEncoderS -> IO QEncoderS
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QEncoderS
enc

----------------------------------------------------------------

-- | Configuration for QPACK decoder.
data QDecoderConfig = QDecoderConfig
    { QDecoderConfig -> Int
dcMaxTableCapacity :: Size
    , QDecoderConfig -> Int
dcHuffmanBufferSize :: Size -- for encoder insteruction handler
    , QDecoderConfig -> Int
dcBlockedSterams :: Int
    , QDecoderConfig -> Int
dcMaxFieldSectionSize :: Int
    }
    deriving (Int -> QDecoderConfig -> ShowS
[QDecoderConfig] -> ShowS
QDecoderConfig -> [Char]
(Int -> QDecoderConfig -> ShowS)
-> (QDecoderConfig -> [Char])
-> ([QDecoderConfig] -> ShowS)
-> Show QDecoderConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QDecoderConfig -> ShowS
showsPrec :: Int -> QDecoderConfig -> ShowS
$cshow :: QDecoderConfig -> [Char]
show :: QDecoderConfig -> [Char]
$cshowList :: [QDecoderConfig] -> ShowS
showList :: [QDecoderConfig] -> ShowS
Show)

-- | Default configuration for QPACK decoder.
--
-- >>> defaultQDecoderConfig
-- QDecoderConfig {dcMaxTableCapacity = 4096, dcHuffmanBufferSize = 2048, dcBlockedSterams = 100, dcMaxFieldSectionSize = 32768}
defaultQDecoderConfig :: QDecoderConfig
defaultQDecoderConfig :: QDecoderConfig
defaultQDecoderConfig =
    QDecoderConfig
        { dcMaxTableCapacity :: Int
dcMaxTableCapacity = Int
4096
        , dcHuffmanBufferSize :: Int
dcHuffmanBufferSize = Int
2048 -- no global locking
        , dcBlockedSterams :: Int
dcBlockedSterams = Int
100
        , dcMaxFieldSectionSize :: Int
dcMaxFieldSectionSize = Int
32768
        }

-- | Creating a new QPACK decoder.
newQDecoder
    :: QDecoderConfig
    -> (EncodedDecoderInstruction -> IO ())
    -> IO (QDecoder, EncoderInstructionHandler)
newQDecoder :: QDecoderConfig
-> (EncodedEncoderInstruction -> IO ())
-> IO (QDecoder, DecoderInstructionHandler)
newQDecoder QDecoderConfig{Int
dcMaxTableCapacity :: QDecoderConfig -> Int
dcHuffmanBufferSize :: QDecoderConfig -> Int
dcBlockedSterams :: QDecoderConfig -> Int
dcMaxFieldSectionSize :: QDecoderConfig -> Int
dcMaxTableCapacity :: Int
dcHuffmanBufferSize :: Int
dcBlockedSterams :: Int
dcMaxFieldSectionSize :: Int
..} EncodedEncoderInstruction -> IO ()
sendDI = do
    DynamicTable
dyntbl <-
        Int -> (EncodedEncoderInstruction -> IO ()) -> IO DynamicTable
newDynamicTableForDecoding Int
dcHuffmanBufferSize EncodedEncoderInstruction -> IO ()
sendDI
    DynamicTable -> Int -> IO ()
setMaxBlockedStreams DynamicTable
dyntbl Int
dcBlockedSterams
    let dec :: QDecoder
dec = DynamicTable -> QDecoder
qpackDecoder DynamicTable
dyntbl
        handler :: DecoderInstructionHandler
handler = Int -> DynamicTable -> DecoderInstructionHandler
encoderInstructionHandler Int
dcMaxTableCapacity DynamicTable
dyntbl
    (QDecoder, DecoderInstructionHandler)
-> IO (QDecoder, DecoderInstructionHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QDecoder
dec, DecoderInstructionHandler
handler)

-- | Creating a new simple QPACK decoder.
newQDecoderS
    :: QDecoderConfig
    -> (EncodedDecoderInstruction -> IO ())
    -> Bool
    -> IO (QDecoderS, EncoderInstructionHandlerS)
newQDecoderS :: QDecoderConfig
-> (EncodedEncoderInstruction -> IO ())
-> Bool
-> IO
     (QDecoderS,
      EncodedEncoderInstruction -> IO EncodedEncoderInstruction)
newQDecoderS QDecoderConfig{Int
dcMaxTableCapacity :: QDecoderConfig -> Int
dcHuffmanBufferSize :: QDecoderConfig -> Int
dcBlockedSterams :: QDecoderConfig -> Int
dcMaxFieldSectionSize :: QDecoderConfig -> Int
dcMaxTableCapacity :: Int
dcHuffmanBufferSize :: Int
dcBlockedSterams :: Int
dcMaxFieldSectionSize :: Int
..} EncodedEncoderInstruction -> IO ()
sendDI Bool
debug = do
    DynamicTable
dyntbl <-
        Int -> (EncodedEncoderInstruction -> IO ()) -> IO DynamicTable
newDynamicTableForDecoding Int
dcHuffmanBufferSize EncodedEncoderInstruction -> IO ()
sendDI
    DynamicTable -> Int -> IO ()
setMaxBlockedStreams DynamicTable
dyntbl Int
dcBlockedSterams
    DynamicTable -> Bool -> IO ()
setDebugQPACK DynamicTable
dyntbl Bool
debug
    let dec :: QDecoderS
dec = DynamicTable -> QDecoderS
qpackDecoderS DynamicTable
dyntbl
        handler :: EncodedEncoderInstruction -> IO EncodedEncoderInstruction
handler = Int
-> DynamicTable
-> EncodedEncoderInstruction
-> IO EncodedEncoderInstruction
encoderInstructionHandlerS Int
dcMaxTableCapacity DynamicTable
dyntbl
    (QDecoderS,
 EncodedEncoderInstruction -> IO EncodedEncoderInstruction)
-> IO
     (QDecoderS,
      EncodedEncoderInstruction -> IO EncodedEncoderInstruction)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QDecoderS
dec, EncodedEncoderInstruction -> IO EncodedEncoderInstruction
handler)

qpackDecoder
    :: DynamicTable -> StreamId -> EncodedFieldSection -> IO TokenHeaderTable
qpackDecoder :: DynamicTable -> QDecoder
qpackDecoder DynamicTable
dyntbl Int
sid EncodedEncoderInstruction
bs = do
    (TokenHeaderTable
tbl, Bool
needAck) <- EncodedEncoderInstruction
-> (ReadBuffer -> IO (TokenHeaderTable, Bool))
-> IO (TokenHeaderTable, Bool)
forall a. EncodedEncoderInstruction -> (ReadBuffer -> IO a) -> IO a
withReadBuffer EncodedEncoderInstruction
bs ((ReadBuffer -> IO (TokenHeaderTable, Bool))
 -> IO (TokenHeaderTable, Bool))
-> (ReadBuffer -> IO (TokenHeaderTable, Bool))
-> IO (TokenHeaderTable, Bool)
forall a b. (a -> b) -> a -> b
$ \ReadBuffer
rbuf -> DynamicTable -> ReadBuffer -> IO (TokenHeaderTable, Bool)
decodeTokenHeader DynamicTable
dyntbl ReadBuffer
rbuf
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [DecoderInstruction] -> IO EncodedEncoderInstruction
encodeDecoderInstructions [Int -> DecoderInstruction
SectionAcknowledgement Int
sid] IO EncodedEncoderInstruction
-> (EncodedEncoderInstruction -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynamicTable -> EncodedEncoderInstruction -> IO ()
sendIns DynamicTable
dyntbl
    TokenHeaderTable -> IO TokenHeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeaderTable
tbl

qpackDecoderS
    :: DynamicTable -> StreamId -> EncodedFieldSection -> IO (Maybe [Header])
qpackDecoderS :: DynamicTable -> QDecoderS
qpackDecoderS DynamicTable
dyntbl Int
sid EncodedEncoderInstruction
bs = do
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"---- Stream " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sid
    Maybe ([Header], Bool)
mhs <- EncodedEncoderInstruction
-> (ReadBuffer -> IO (Maybe ([Header], Bool)))
-> IO (Maybe ([Header], Bool))
forall a. EncodedEncoderInstruction -> (ReadBuffer -> IO a) -> IO a
withReadBuffer EncodedEncoderInstruction
bs ((ReadBuffer -> IO (Maybe ([Header], Bool)))
 -> IO (Maybe ([Header], Bool)))
-> (ReadBuffer -> IO (Maybe ([Header], Bool)))
-> IO (Maybe ([Header], Bool))
forall a b. (a -> b) -> a -> b
$ \ReadBuffer
rbuf -> DynamicTable -> ReadBuffer -> IO (Maybe ([Header], Bool))
decodeTokenHeaderS DynamicTable
dyntbl ReadBuffer
rbuf
    case Maybe ([Header], Bool)
mhs of
        Maybe ([Header], Bool)
Nothing -> Maybe [Header] -> IO (Maybe [Header])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Header]
forall a. Maybe a
Nothing
        Just ([Header]
hs, Bool
needAck) -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                [DecoderInstruction] -> IO EncodedEncoderInstruction
encodeDecoderInstructions [Int -> DecoderInstruction
SectionAcknowledgement Int
sid] IO EncodedEncoderInstruction
-> (EncodedEncoderInstruction -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynamicTable -> EncodedEncoderInstruction -> IO ()
sendIns DynamicTable
dyntbl
            Maybe [Header] -> IO (Maybe [Header])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Header] -> IO (Maybe [Header]))
-> Maybe [Header] -> IO (Maybe [Header])
forall a b. (a -> b) -> a -> b
$ [Header] -> Maybe [Header]
forall a. a -> Maybe a
Just [Header]
hs

-- Note: dyntbl for decoder
encoderInstructionHandler :: Int -> DynamicTable -> EncoderInstructionHandler
encoderInstructionHandler :: Int -> DynamicTable -> DecoderInstructionHandler
encoderInstructionHandler Int
decCapLim DynamicTable
dyntbl Int -> IO EncodedEncoderInstruction
recv = EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
""
  where
    loop :: EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
bs0 = do
        EncodedEncoderInstruction
bs1 <- Int -> IO EncodedEncoderInstruction
recv Int
1024
        let bs :: EncodedEncoderInstruction
bs
                | EncodedEncoderInstruction
bs0 EncodedEncoderInstruction -> EncodedEncoderInstruction -> Bool
forall a. Eq a => a -> a -> Bool
== EncodedEncoderInstruction
"" = EncodedEncoderInstruction
bs1
                | Bool
otherwise = EncodedEncoderInstruction
bs0 EncodedEncoderInstruction
-> EncodedEncoderInstruction -> EncodedEncoderInstruction
forall a. Semigroup a => a -> a -> a
<> EncodedEncoderInstruction
bs1
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EncodedEncoderInstruction
bs EncodedEncoderInstruction -> EncodedEncoderInstruction -> Bool
forall a. Eq a => a -> a -> Bool
/= EncodedEncoderInstruction
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            EncodedEncoderInstruction
leftover <- Int
-> DynamicTable
-> EncodedEncoderInstruction
-> IO EncodedEncoderInstruction
encoderInstructionHandlerS Int
decCapLim DynamicTable
dyntbl EncodedEncoderInstruction
bs
            EncodedEncoderInstruction -> IO ()
loop EncodedEncoderInstruction
leftover

-- Note: dyntbl for decoder
encoderInstructionHandlerS :: Int -> DynamicTable -> EncoderInstructionHandlerS
encoderInstructionHandlerS :: Int
-> DynamicTable
-> EncodedEncoderInstruction
-> IO EncodedEncoderInstruction
encoderInstructionHandlerS Int
_ DynamicTable
_dyntbl EncodedEncoderInstruction
"" = EncodedEncoderInstruction -> IO EncodedEncoderInstruction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodedEncoderInstruction
""
encoderInstructionHandlerS Int
decCapLim DynamicTable
dyntbl EncodedEncoderInstruction
bs = do
    ([EncoderInstruction]
ins, EncodedEncoderInstruction
leftover) <- HuffmanDecoder
-> EncodedEncoderInstruction
-> IO ([EncoderInstruction], EncodedEncoderInstruction)
decodeEncoderInstructions HuffmanDecoder
hufdec EncodedEncoderInstruction
bs
    Int
cnt <- [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> IO [Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EncoderInstruction -> IO Int) -> [EncoderInstruction] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM EncoderInstruction -> IO Int
forall {a}. Num a => EncoderInstruction -> IO a
handle [EncoderInstruction]
ins
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [DecoderInstruction] -> IO EncodedEncoderInstruction
encodeDecoderInstructions [Int -> DecoderInstruction
InsertCountIncrement Int
cnt] IO EncodedEncoderInstruction
-> (EncodedEncoderInstruction -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynamicTable -> EncodedEncoderInstruction -> IO ()
sendIns DynamicTable
dyntbl
    EncodedEncoderInstruction -> IO EncodedEncoderInstruction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodedEncoderInstruction
leftover
  where
    hufdec :: HuffmanDecoder
hufdec = DynamicTable -> HuffmanDecoder
getHuffmanDecoder DynamicTable
dyntbl -- only for encoder instruction handler
    handle :: EncoderInstruction -> IO a
handle ins :: EncoderInstruction
ins@(SetDynamicTableCapacity Int
n)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
decCapLim = EncoderInstructionError -> IO a
forall e a. Exception e => e -> IO a
E.throwIO EncoderInstructionError
EncoderInstructionError
        | Bool
otherwise = do
            DynamicTable -> Int -> IO ()
setTableCapacity DynamicTable
dyntbl Int
n
            DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstruction -> IO ()
forall a. Show a => a -> IO ()
print EncoderInstruction
ins
            a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
0
    handle ins :: EncoderInstruction
ins@(InsertWithNameReference InsIndex
ii EncodedEncoderInstruction
val) = do
        Bool
ready <- DynamicTable -> IO Bool
isTableReady DynamicTable
dyntbl
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstructionError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO EncoderInstructionError
EncoderInstructionError
        HIndex
dai <- STM HIndex -> IO HIndex
forall a. STM a -> IO a
atomically (STM HIndex -> IO HIndex) -> STM HIndex -> IO HIndex
forall a b. (a -> b) -> a -> b
$ do
            HIndex
idx <- case InsIndex
ii of
                Left AbsoluteIndex
ai -> HIndex -> STM HIndex
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (HIndex -> STM HIndex) -> HIndex -> STM HIndex
forall a b. (a -> b) -> a -> b
$ AbsoluteIndex -> HIndex
SIndex AbsoluteIndex
ai
                Right InsRelativeIndex
ri -> do
                    InsertionPoint
ip <- DynamicTable -> STM InsertionPoint
getInsertionPointSTM DynamicTable
dyntbl
                    HIndex -> STM HIndex
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (HIndex -> STM HIndex) -> HIndex -> STM HIndex
forall a b. (a -> b) -> a -> b
$ AbsoluteIndex -> HIndex
DIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ InsRelativeIndex -> InsertionPoint -> AbsoluteIndex
fromInsRelativeIndex InsRelativeIndex
ri InsertionPoint
ip
            Entry
ent0 <- DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
idx
            let ent :: Entry
ent = Token -> EncodedEncoderInstruction -> Entry
toEntryToken (Entry -> Token
entryToken Entry
ent0) EncodedEncoderInstruction
val
            AbsoluteIndex
_ <- Entry -> DynamicTable -> STM AbsoluteIndex
insertEntryToDecoder Entry
ent DynamicTable
dyntbl
            HIndex -> STM HIndex
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return HIndex
idx
        DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstruction -> [Char]
forall a. Show a => a -> [Char]
show EncoderInstruction
ins [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ HIndex -> [Char]
forall a. Show a => a -> [Char]
show HIndex
dai
        a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
1
    handle ins :: EncoderInstruction
ins@(InsertWithLiteralName Token
t EncodedEncoderInstruction
val) = do
        Bool
ready <- DynamicTable -> IO Bool
isTableReady DynamicTable
dyntbl
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstructionError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO EncoderInstructionError
EncoderInstructionError
        AbsoluteIndex
dai <- STM AbsoluteIndex -> IO AbsoluteIndex
forall a. STM a -> IO a
atomically (STM AbsoluteIndex -> IO AbsoluteIndex)
-> STM AbsoluteIndex -> IO AbsoluteIndex
forall a b. (a -> b) -> a -> b
$ do
            let ent :: Entry
ent = Token -> EncodedEncoderInstruction -> Entry
toEntryToken Token
t EncodedEncoderInstruction
val
            Entry -> DynamicTable -> STM AbsoluteIndex
insertEntryToDecoder Entry
ent DynamicTable
dyntbl
        DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstruction -> [Char]
forall a. Show a => a -> [Char]
show EncoderInstruction
ins [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ AbsoluteIndex -> [Char]
forall a. Show a => a -> [Char]
show AbsoluteIndex
dai
        a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
1
    handle ins :: EncoderInstruction
ins@(Duplicate InsRelativeIndex
ri) = do
        Bool
ready <- DynamicTable -> IO Bool
isTableReady DynamicTable
dyntbl
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncoderInstructionError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO EncoderInstructionError
EncoderInstructionError
        (AbsoluteIndex
dai, AbsoluteIndex
dai') <- STM (AbsoluteIndex, AbsoluteIndex)
-> IO (AbsoluteIndex, AbsoluteIndex)
forall a. STM a -> IO a
atomically (STM (AbsoluteIndex, AbsoluteIndex)
 -> IO (AbsoluteIndex, AbsoluteIndex))
-> STM (AbsoluteIndex, AbsoluteIndex)
-> IO (AbsoluteIndex, AbsoluteIndex)
forall a b. (a -> b) -> a -> b
$ do
            InsertionPoint
ip <- DynamicTable -> STM InsertionPoint
getInsertionPointSTM DynamicTable
dyntbl
            let ai :: AbsoluteIndex
ai = InsRelativeIndex -> InsertionPoint -> AbsoluteIndex
fromInsRelativeIndex InsRelativeIndex
ri InsertionPoint
ip
                idx :: HIndex
idx = AbsoluteIndex -> HIndex
DIndex AbsoluteIndex
ai
            Entry
ent <- DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
idx
            AbsoluteIndex
ai' <- Entry -> DynamicTable -> STM AbsoluteIndex
insertEntryToDecoder Entry
ent DynamicTable
dyntbl
            (AbsoluteIndex, AbsoluteIndex)
-> STM (AbsoluteIndex, AbsoluteIndex)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsoluteIndex
ai, AbsoluteIndex
ai')
        DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                EncoderInstruction -> [Char]
forall a. Show a => a -> [Char]
show EncoderInstruction
ins [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ AbsoluteIndex -> [Char]
forall a. Show a => a -> [Char]
show AbsoluteIndex
dai [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ AbsoluteIndex -> [Char]
forall a. Show a => a -> [Char]
show AbsoluteIndex
dai'
        a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
1