{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE RecordWildCards #-}
module Network.QPACK.HeaderBlock.Encode (
encodeHeader
, encodeTokenHeader
, EncodedFieldSection
, EncodedEncoderInstruction
, EncodeStrategy(..)
, CompressionAlgo(..)
) where
import qualified Data.ByteString as B
import Data.IORef
import Network.ByteOrder
import Network.HPACK (HeaderList, EncodeStrategy(..), TokenHeaderList, CompressionAlgo(..))
import Network.HPACK.Internal
import Network.HPACK.Token
import qualified UnliftIO.Exception as E
import Imports
import Network.QPACK.HeaderBlock.Prefix
import Network.QPACK.Instruction
import Network.QPACK.Table
import Network.QPACK.Types
type EncodedFieldSection = B.ByteString
type EncodedEncoderInstruction = B.ByteString
encodeHeader :: EncodeStrategy -> DynamicTable -> HeaderList -> IO (EncodedFieldSection,EncodedEncoderInstruction)
EncodeStrategy
stgy DynamicTable
dyntbl HeaderList
hs = do
(EncodedFieldSection
hb0, EncodedFieldSection
insb) <- BufferSize
-> (WriteBuffer -> IO EncodedFieldSection)
-> IO (EncodedFieldSection, EncodedFieldSection)
forall a.
BufferSize -> (WriteBuffer -> IO a) -> IO (EncodedFieldSection, a)
withWriteBuffer' BufferSize
2048 ((WriteBuffer -> IO EncodedFieldSection)
-> IO (EncodedFieldSection, EncodedFieldSection))
-> (WriteBuffer -> IO EncodedFieldSection)
-> IO (EncodedFieldSection, EncodedFieldSection)
forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf1 ->
BufferSize -> (WriteBuffer -> IO ()) -> IO EncodedFieldSection
withWriteBuffer BufferSize
2048 ((WriteBuffer -> IO ()) -> IO EncodedFieldSection)
-> (WriteBuffer -> IO ()) -> IO EncodedFieldSection
forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf2 -> do
TokenHeaderList
hs1 <- WriteBuffer
-> WriteBuffer
-> EncodeStrategy
-> DynamicTable
-> TokenHeaderList
-> IO TokenHeaderList
encodeTokenHeader WriteBuffer
wbuf1 WriteBuffer
wbuf2 EncodeStrategy
stgy DynamicTable
dyntbl TokenHeaderList
ts
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TokenHeaderList -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TokenHeaderList
hs1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BufferOverrun -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO BufferOverrun
BufferOverrun
EncodedFieldSection
prefix <- BufferSize -> (WriteBuffer -> IO ()) -> IO EncodedFieldSection
withWriteBuffer BufferSize
32 ((WriteBuffer -> IO ()) -> IO EncodedFieldSection)
-> (WriteBuffer -> IO ()) -> IO EncodedFieldSection
forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> WriteBuffer -> DynamicTable -> IO ()
encodePrefix WriteBuffer
wbuf DynamicTable
dyntbl
let hb :: EncodedFieldSection
hb = EncodedFieldSection
prefix EncodedFieldSection -> EncodedFieldSection -> EncodedFieldSection
`B.append` EncodedFieldSection
hb0
(EncodedFieldSection, EncodedFieldSection)
-> IO (EncodedFieldSection, EncodedFieldSection)
forall (m :: * -> *) a. Monad m => a -> m a
return (EncodedFieldSection
hb,EncodedFieldSection
insb)
where
ts :: TokenHeaderList
ts = ((EncodedFieldSection, EncodedFieldSection)
-> (Token, EncodedFieldSection))
-> HeaderList -> TokenHeaderList
forall a b. (a -> b) -> [a] -> [b]
map (\(EncodedFieldSection
k,EncodedFieldSection
v) -> let t :: Token
t = EncodedFieldSection -> Token
toToken EncodedFieldSection
k in (Token
t,EncodedFieldSection
v)) HeaderList
hs
encodeTokenHeader :: WriteBuffer
-> WriteBuffer
-> EncodeStrategy
-> DynamicTable
-> TokenHeaderList
-> IO TokenHeaderList
WriteBuffer
wbuf1 WriteBuffer
wbuf2 EncodeStrategy{Bool
CompressionAlgo
compressionAlgo :: EncodeStrategy -> CompressionAlgo
useHuffman :: EncodeStrategy -> Bool
useHuffman :: Bool
compressionAlgo :: CompressionAlgo
..} DynamicTable
dyntbl TokenHeaderList
ts0 = do
WriteBuffer -> IO ()
clearWriteBuffer WriteBuffer
wbuf1
WriteBuffer -> IO ()
clearWriteBuffer WriteBuffer
wbuf2
DynamicTable -> IO ()
setBasePointToInsersionPoint DynamicTable
dyntbl
let revidx :: RevIndex
revidx = DynamicTable -> RevIndex
getRevIndex DynamicTable
dyntbl
IORef TokenHeaderList
ref <- TokenHeaderList -> IO (IORef TokenHeaderList)
forall a. a -> IO (IORef a)
newIORef TokenHeaderList
ts0
case CompressionAlgo
compressionAlgo of
CompressionAlgo
Static -> WriteBuffer
-> WriteBuffer
-> DynamicTable
-> RevIndex
-> Bool
-> IORef TokenHeaderList
-> TokenHeaderList
-> IO ()
encodeStatic WriteBuffer
wbuf1 WriteBuffer
wbuf2 DynamicTable
dyntbl RevIndex
revidx Bool
useHuffman IORef TokenHeaderList
ref TokenHeaderList
ts0 IO () -> (BufferOverrun -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \BufferOverrun
BufferOverrun -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CompressionAlgo
_ -> WriteBuffer
-> WriteBuffer
-> DynamicTable
-> RevIndex
-> Bool
-> IORef TokenHeaderList
-> TokenHeaderList
-> IO ()
encodeLinear WriteBuffer
wbuf1 WriteBuffer
wbuf2 DynamicTable
dyntbl RevIndex
revidx Bool
useHuffman IORef TokenHeaderList
ref TokenHeaderList
ts0 IO () -> (BufferOverrun -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \BufferOverrun
BufferOverrun -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TokenHeaderList
ts <- IORef TokenHeaderList -> IO TokenHeaderList
forall a. IORef a -> IO a
readIORef IORef TokenHeaderList
ref
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TokenHeaderList -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TokenHeaderList
ts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
WriteBuffer -> IO ()
forall a. Readable a => a -> IO ()
goBack WriteBuffer
wbuf1
WriteBuffer -> IO ()
forall a. Readable a => a -> IO ()
goBack WriteBuffer
wbuf2
TokenHeaderList -> IO TokenHeaderList
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeaderList
ts
encodeStatic :: WriteBuffer -> WriteBuffer
-> DynamicTable -> RevIndex -> Bool
-> IORef TokenHeaderList
-> TokenHeaderList -> IO ()
encodeStatic :: WriteBuffer
-> WriteBuffer
-> DynamicTable
-> RevIndex
-> Bool
-> IORef TokenHeaderList
-> TokenHeaderList
-> IO ()
encodeStatic WriteBuffer
wbuf1 WriteBuffer
_wbuf2 DynamicTable
dyntbl RevIndex
revidx Bool
huff IORef TokenHeaderList
ref TokenHeaderList
ts0 = TokenHeaderList -> IO ()
loop TokenHeaderList
ts0
where
loop :: TokenHeaderList -> IO ()
loop [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop ((Token
t,EncodedFieldSection
val):TokenHeaderList
ts) = do
RevResult
rr <- Token -> EncodedFieldSection -> RevIndex -> IO RevResult
lookupRevIndex Token
t EncodedFieldSection
val RevIndex
revidx
case RevResult
rr of
KV HIndex
hi -> do
WriteBuffer -> DynamicTable -> HIndex -> IO ()
encodeIndexedFieldLine WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi
K HIndex
hi -> do
WriteBuffer
-> DynamicTable -> HIndex -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithNameReference WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi EncodedFieldSection
val Bool
huff
RevResult
N -> do
WriteBuffer -> Token -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithoutNameReference WriteBuffer
wbuf1 Token
t EncodedFieldSection
val Bool
huff
WriteBuffer -> IO ()
forall a. Readable a => a -> IO ()
save WriteBuffer
wbuf1
IORef TokenHeaderList -> TokenHeaderList -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TokenHeaderList
ref TokenHeaderList
ts
TokenHeaderList -> IO ()
loop TokenHeaderList
ts
encodeLinear :: WriteBuffer -> WriteBuffer
-> DynamicTable -> RevIndex -> Bool
-> IORef TokenHeaderList
-> TokenHeaderList -> IO ()
encodeLinear :: WriteBuffer
-> WriteBuffer
-> DynamicTable
-> RevIndex
-> Bool
-> IORef TokenHeaderList
-> TokenHeaderList
-> IO ()
encodeLinear WriteBuffer
wbuf1 WriteBuffer
wbuf2 DynamicTable
dyntbl RevIndex
revidx Bool
huff IORef TokenHeaderList
ref TokenHeaderList
ts0 = TokenHeaderList -> IO ()
loop TokenHeaderList
ts0
where
loop :: TokenHeaderList -> IO ()
loop [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop ((Token
t,EncodedFieldSection
val):TokenHeaderList
ts) = do
RevResult
rr <- Token -> EncodedFieldSection -> RevIndex -> IO RevResult
lookupRevIndex Token
t EncodedFieldSection
val RevIndex
revidx
case RevResult
rr of
KV HIndex
hi -> do
WriteBuffer -> DynamicTable -> HIndex -> IO ()
encodeIndexedFieldLine WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi
K HIndex
hi
| Token -> Bool
shouldBeIndexed Token
t -> do
Either AbsoluteIndex InsRelativeIndex
insidx <- case HIndex
hi of
SIndex AbsoluteIndex
i -> Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex))
-> Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex)
forall a b. (a -> b) -> a -> b
$ AbsoluteIndex -> Either AbsoluteIndex InsRelativeIndex
forall a b. a -> Either a b
Left AbsoluteIndex
i
DIndex AbsoluteIndex
i -> do
InsertionPoint
ip <- DynamicTable -> IO InsertionPoint
getInsertionPoint DynamicTable
dyntbl
Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex))
-> Either AbsoluteIndex InsRelativeIndex
-> IO (Either AbsoluteIndex InsRelativeIndex)
forall a b. (a -> b) -> a -> b
$ InsRelativeIndex -> Either AbsoluteIndex InsRelativeIndex
forall a b. b -> Either a b
Right (InsRelativeIndex -> Either AbsoluteIndex InsRelativeIndex)
-> InsRelativeIndex -> Either AbsoluteIndex InsRelativeIndex
forall a b. (a -> b) -> a -> b
$ AbsoluteIndex -> InsertionPoint -> InsRelativeIndex
toInsRelativeIndex AbsoluteIndex
i InsertionPoint
ip
let ins :: EncoderInstruction
ins = Either AbsoluteIndex InsRelativeIndex
-> EncodedFieldSection -> EncoderInstruction
InsertWithNameReference Either AbsoluteIndex InsRelativeIndex
insidx EncodedFieldSection
val
WriteBuffer -> Bool -> EncoderInstruction -> IO ()
encodeEI WriteBuffer
wbuf2 Bool
True EncoderInstruction
ins
AbsoluteIndex
dai <- Entry -> DynamicTable -> IO AbsoluteIndex
insertEntryToEncoder (Token -> EncodedFieldSection -> Entry
toEntryToken Token
t EncodedFieldSection
val) DynamicTable
dyntbl
WriteBuffer -> DynamicTable -> AbsoluteIndex -> IO ()
encodeIndexedFieldLineWithPostBaseIndex WriteBuffer
wbuf1 DynamicTable
dyntbl AbsoluteIndex
dai
| Bool
otherwise -> do
WriteBuffer
-> DynamicTable -> HIndex -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithNameReference WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi EncodedFieldSection
val Bool
huff
RevResult
N
| Token -> Bool
shouldBeIndexed Token
t -> do
let ins :: EncoderInstruction
ins = Token -> EncodedFieldSection -> EncoderInstruction
InsertWithoutNameReference Token
t EncodedFieldSection
val
WriteBuffer -> Bool -> EncoderInstruction -> IO ()
encodeEI WriteBuffer
wbuf2 Bool
True EncoderInstruction
ins
AbsoluteIndex
dai <- Entry -> DynamicTable -> IO AbsoluteIndex
insertEntryToEncoder (Token -> EncodedFieldSection -> Entry
toEntryToken Token
t EncodedFieldSection
val) DynamicTable
dyntbl
WriteBuffer -> DynamicTable -> AbsoluteIndex -> IO ()
encodeIndexedFieldLineWithPostBaseIndex WriteBuffer
wbuf1 DynamicTable
dyntbl AbsoluteIndex
dai
| Bool
otherwise -> do
WriteBuffer -> Token -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithoutNameReference WriteBuffer
wbuf1 Token
t EncodedFieldSection
val Bool
huff
WriteBuffer -> IO ()
forall a. Readable a => a -> IO ()
save WriteBuffer
wbuf1
WriteBuffer -> IO ()
forall a. Readable a => a -> IO ()
save WriteBuffer
wbuf2
IORef TokenHeaderList -> TokenHeaderList -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TokenHeaderList
ref TokenHeaderList
ts
TokenHeaderList -> IO ()
loop TokenHeaderList
ts
encodeIndexedFieldLine :: WriteBuffer -> DynamicTable -> HIndex -> IO ()
encodeIndexedFieldLine :: WriteBuffer -> DynamicTable -> HIndex -> IO ()
encodeIndexedFieldLine WriteBuffer
wbuf DynamicTable
dyntbl HIndex
hi = do
(BufferSize
idx, Setter
set) <- case HIndex
hi of
SIndex (AbsoluteIndex BufferSize
i) -> (BufferSize, Setter) -> IO (BufferSize, Setter)
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferSize
i, Setter
set11)
DIndex AbsoluteIndex
ai-> do
DynamicTable -> AbsoluteIndex -> IO ()
updateLargestReference DynamicTable
dyntbl AbsoluteIndex
ai
BasePoint
bp <- DynamicTable -> IO BasePoint
getBasePoint DynamicTable
dyntbl
let HBRelativeIndex BufferSize
i = AbsoluteIndex -> BasePoint -> HBRelativeIndex
toHBRelativeIndex AbsoluteIndex
ai BasePoint
bp
(BufferSize, Setter) -> IO (BufferSize, Setter)
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferSize
i, Setter
set10)
WriteBuffer -> Setter -> BufferSize -> BufferSize -> IO ()
encodeI WriteBuffer
wbuf Setter
set BufferSize
6 BufferSize
idx
encodeIndexedFieldLineWithPostBaseIndex :: WriteBuffer
-> DynamicTable
-> AbsoluteIndex
-> IO ()
encodeIndexedFieldLineWithPostBaseIndex :: WriteBuffer -> DynamicTable -> AbsoluteIndex -> IO ()
encodeIndexedFieldLineWithPostBaseIndex WriteBuffer
wbuf DynamicTable
dyntbl AbsoluteIndex
ai = do
BasePoint
bp <- DynamicTable -> IO BasePoint
getBasePoint DynamicTable
dyntbl
let HBRelativeIndex BufferSize
idx = AbsoluteIndex -> BasePoint -> HBRelativeIndex
toHBRelativeIndex AbsoluteIndex
ai BasePoint
bp
WriteBuffer -> Setter -> BufferSize -> BufferSize -> IO ()
encodeI WriteBuffer
wbuf Setter
set0001 BufferSize
4 BufferSize
idx
encodeLiteralFieldLineWithNameReference :: WriteBuffer -> DynamicTable -> HIndex -> ByteString -> Bool -> IO ()
encodeLiteralFieldLineWithNameReference :: WriteBuffer
-> DynamicTable -> HIndex -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithNameReference WriteBuffer
wbuf DynamicTable
dyntbl HIndex
hi EncodedFieldSection
val Bool
huff = do
(BufferSize
idx, Setter
set) <- case HIndex
hi of
SIndex (AbsoluteIndex BufferSize
i) -> (BufferSize, Setter) -> IO (BufferSize, Setter)
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferSize
i, Setter
set0101)
DIndex AbsoluteIndex
ai-> do
DynamicTable -> AbsoluteIndex -> IO ()
updateLargestReference DynamicTable
dyntbl AbsoluteIndex
ai
BasePoint
bp <- DynamicTable -> IO BasePoint
getBasePoint DynamicTable
dyntbl
let HBRelativeIndex BufferSize
i = AbsoluteIndex -> BasePoint -> HBRelativeIndex
toHBRelativeIndex AbsoluteIndex
ai BasePoint
bp
(BufferSize, Setter) -> IO (BufferSize, Setter)
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferSize
i, Setter
set0100)
WriteBuffer -> Setter -> BufferSize -> BufferSize -> IO ()
encodeI WriteBuffer
wbuf Setter
set BufferSize
4 BufferSize
idx
WriteBuffer
-> Bool
-> Setter
-> Setter
-> BufferSize
-> EncodedFieldSection
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff Setter
forall a. a -> a
id Setter
set1 BufferSize
7 EncodedFieldSection
val
encodeLiteralFieldLineWithoutNameReference :: WriteBuffer -> Token -> ByteString -> Bool -> IO ()
encodeLiteralFieldLineWithoutNameReference :: WriteBuffer -> Token -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithoutNameReference WriteBuffer
wbuf Token
token EncodedFieldSection
val Bool
huff = do
let key :: EncodedFieldSection
key = Token -> EncodedFieldSection
tokenFoldedKey Token
token
WriteBuffer
-> Bool
-> Setter
-> Setter
-> BufferSize
-> EncodedFieldSection
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff Setter
set0010 Setter
set00001 BufferSize
3 EncodedFieldSection
key
WriteBuffer
-> Bool
-> Setter
-> Setter
-> BufferSize
-> EncodedFieldSection
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff Setter
forall a. a -> a
id Setter
set1 BufferSize
7 EncodedFieldSection
val