{-# 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

-- | 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 -> HeaderList -> IO (EncodedFieldSection,EncodedEncoderInstruction)
encodeHeader :: EncodeStrategy
-> DynamicTable
-> HeaderList
-> IO (EncodedFieldSection, EncodedFieldSection)
encodeHeader 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

-- | 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 :: 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
              -- 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 (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 (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
                  -- 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 (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

-- 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 (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

-- 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