{-# 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.Internal (
    CompressionAlgo (..),
    EncodeStrategy (..),
    encodeI,
    encodeS,
    toEntryToken,
 )
import Network.HTTP.Semantics
import Network.HTTP.Types
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

-- | Encoded field section including prefix.
type EncodedFieldSection = B.ByteString

-- | Encoded encoder instruction.
type EncodedEncoderInstruction = B.ByteString

-- | Encoding headers with QPACK.
--   Header block with prefix and instructions are returned.
--   2048, 32, and 2048 bytes-buffers are
--   temporally allocated for header block, prefix and encoder instructions.
encodeHeader
    :: EncodeStrategy
    -> DynamicTable
    -> [Header]
    -> IO (EncodedFieldSection, EncodedEncoderInstruction)
encodeHeader :: EncodeStrategy
-> DynamicTable
-> [Header]
-> IO (EncodedFieldSection, EncodedFieldSection)
encodeHeader EncodeStrategy
stgy DynamicTable
dyntbl [Header]
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 a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncodedFieldSection
hb, EncodedFieldSection
insb)
  where
    ts :: TokenHeaderList
ts = (Header -> (Token, EncodedFieldSection))
-> [Header] -> TokenHeaderList
forall a b. (a -> b) -> [a] -> [b]
map (\(CI EncodedFieldSection
k, EncodedFieldSection
v) -> let t :: Token
t = EncodedFieldSection -> Token
toToken (CI EncodedFieldSection -> EncodedFieldSection
forall s. CI s -> s
foldedCase CI EncodedFieldSection
k) in (Token
t, EncodedFieldSection
v)) [Header]
hs

-- | Converting 'TokenHeaderList' to the QPACK format.
encodeTokenHeader
    :: WriteBuffer
    -- ^ Workspace for the body of header block
    -> WriteBuffer
    -- ^ Workspace for encoder instructions
    -> EncodeStrategy
    -> DynamicTable
    -> TokenHeaderList
    -> IO TokenHeaderList
    -- ^ Leftover
encodeTokenHeader :: WriteBuffer
-> WriteBuffer
-> EncodeStrategy
-> DynamicTable
-> TokenHeaderList
-> IO TokenHeaderList
encodeTokenHeader WriteBuffer
wbuf1 WriteBuffer
wbuf2 EncodeStrategy{Bool
CompressionAlgo
compressionAlgo :: CompressionAlgo
useHuffman :: Bool
compressionAlgo :: EncodeStrategy -> CompressionAlgo
useHuffman :: EncodeStrategy -> Bool
..} 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 a. a -> IO a
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 a. a -> IO a
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 a. [a] -> 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 a. a -> IO a
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 a. a -> IO a
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
                -- 4.5.2.  Indexed Field Line
                WriteBuffer -> DynamicTable -> HIndex -> IO ()
encodeIndexedFieldLine WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi
            K HIndex
hi -> do
                -- 4.5.4.  Literal Field Line With Name Reference
                WriteBuffer
-> DynamicTable -> HIndex -> EncodedFieldSection -> Bool -> IO ()
encodeLiteralFieldLineWithNameReference WriteBuffer
wbuf1 DynamicTable
dyntbl HIndex
hi EncodedFieldSection
val Bool
huff
            RevResult
N -> do
                -- 4.5.6.  Literal Field Line Without Name Reference
                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 a. a -> IO a
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
                -- 4.5.2.  Indexed Field Line
                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 a. a -> IO a
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 a. a -> IO a
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
                    -- 4.5.3.  Indexed Field Line With Post-Base Index
                    WriteBuffer -> DynamicTable -> AbsoluteIndex -> IO ()
encodeIndexedFieldLineWithPostBaseIndex WriteBuffer
wbuf1 DynamicTable
dyntbl AbsoluteIndex
dai
                | Bool
otherwise -> do
                    -- 4.5.4.  Literal Field Line With Name Reference
                    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
                    -- 4.5.6.  Literal Field Line Without Name Reference
                    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

-- 4.5.2.  Indexed Field Line
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 a. a -> IO a
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 a. a -> IO a
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

-- 4.5.3.  Indexed Field Line With Post-Base Index
encodeIndexedFieldLineWithPostBaseIndex
    :: WriteBuffer
    -> DynamicTable
    -> AbsoluteIndex -- in Dynamic table
    -> 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

-- 4.5.4.  Literal Field Line With Name Reference
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 a. a -> IO a
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 a. a -> IO a
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

-- 4.5.5.  Literal Field Line With Post-Base Name Reference
-- not implemented

-- 4.5.6.  Literal Field Line Without Name Reference
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