Decode.hs

{-# LANGUAGE BinaryLiterals #-}

module Network.QPACK.HeaderBlock.Decode where

import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as BS8
import Data.CaseInsensitive
import Network.ByteOrder
import Network.HPACK.Internal (
    HuffmanDecoder,
    decodeH,
    decodeI,
    decodeS,
    decodeSimple,
    decodeSophisticated,
    entryToken,
    entryTokenHeader,
 )
import Network.HTTP.Types

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

decodeTokenHeader
    :: DynamicTable
    -> ReadBuffer
    -> IO (TokenHeaderTable, Bool)
decodeTokenHeader dyntbl rbuf = do
    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl
    ready <- checkRequiredInsertCountNB dyntbl reqInsertCount
    unless ready $ do
        ok <- tryIncreaseStreams dyntbl
        unless ok $ E.throwIO BlockedStreamsOverflow
        checkRequiredInsertCount dyntbl reqInsertCount
        decreaseStreams dyntbl
    checkRequiredInsertCount dyntbl reqInsertCount
    hufdec <- newHuffmanDecoder rbuf
    tbl <- decodeSophisticated (toTokenHeader dyntbl bp hufdec) rbuf
    return (tbl, needAck)

decodeTokenHeaderS
    :: DynamicTable
    -> ReadBuffer
    -> IO (Maybe ([Header], Bool))
decodeTokenHeaderS dyntbl rbuf = do
    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl
    ok <- checkRequiredInsertCountNB dyntbl reqInsertCount
    if ok
        then do
            hufdec <- newHuffmanDecoder rbuf
            hs <- decodeSimple (toTokenHeader dyntbl bp hufdec) rbuf
            return $ Just (hs, needAck)
        else return Nothing

-- | A Huffman decoder with room for anything the rest of this field section
-- can decode to.
--
-- The scratch buffer has to hold one decoded string, and the shortest Huffman
-- code is five bits, so an encoded string of n octets cannot come to more than
-- 8n\/5 symbols -- and the section that contains it is itself at most what is
-- left in the buffer.  Sizing from that means a header field is refused only
-- when the section it is in is, rather than at a fixed 2048 that nothing
-- announced: a 2100-octet value used to fail to decode while the section
-- carrying it was under 1.4K, well inside the SETTINGS_MAX_FIELD_SECTION_SIZE
-- we advertise.
--
-- Allocated per section rather than held on the table, because sections from
-- different streams decode concurrently and this buffer is not shared.
newHuffmanDecoder :: ReadBuffer -> IO HuffmanDecoder
newHuffmanDecoder rbuf = do
    siz <- remainingSize rbuf
    let bufsiz = max 1 ((siz * 8) `div` 5)
    gcbuf <- mallocPlainForeignPtrBytes bufsiz
    return $ decodeH gcbuf bufsiz

{- FOURMOLU_DISABLE -}
toTokenHeader
    :: DynamicTable
    -> BasePoint
    -> HuffmanDecoder
    -> Word8
    -> ReadBuffer
    -> IO TokenHeader
toTokenHeader dyntbl bp hufdec w8 rbuf
    | w8 `testBit` 7 =
        decodeIndexedFieldLine                  rbuf dyntbl        bp w8
    | w8 `testBit` 6 =
        decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8
    | w8 `testBit` 5 =
        decodeLiteralFieldLineWithLiteralName   rbuf dyntbl hufdec bp w8
    | w8 `testBit` 4 =
        decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl        bp w8
    | otherwise =
        decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8
{- FOURMOLU_ENABLE -}

-- 4.5.2.  Indexed Field Line
decodeIndexedFieldLine
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLine rbuf dyntbl bp w8 = do
    i <- decodeI 6 (w8 .&. 0b00111111) rbuf
    let static = w8 `testBit` 6
        hidx
            | static = SIndex $ AbsoluteIndex i
            | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp
    ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)
    qpackDebug dyntbl $
        putStrLn $
            "IndexedFieldLine (" ++ show hidx ++ ") " ++ showTokenHeader ret
    return ret

-- 4.5.3.  Indexed Field Line With Post-Base Index
decodeIndexedFieldLineWithPostBaseIndex
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8 = do
    i <- decodeI 4 (w8 .&. 0b00001111) rbuf
    let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp
    ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)
    qpackDebug dyntbl $
        putStrLn $
            "IndexedFieldLineWithPostBaseIndex ("
                ++ show hidx
                ++ " "
                ++ show bp
                ++ " after "
                ++ show i
                ++ ") "
                ++ showTokenHeader ret
    return ret

-- 4.5.4.  Literal Field Line With Name Reference
decodeLiteralFieldLineWithNameReference
    :: ReadBuffer
    -> DynamicTable
    -> HuffmanDecoder
    -> BasePoint
    -> Word8
    -> IO TokenHeader
decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8 = do
    i <- decodeI 4 (w8 .&. 0b00001111) rbuf
    let static = w8 `testBit` 4
        hidx
            | static = SIndex $ AbsoluteIndex i
            | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp
    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)
    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf
    let ret = (key, val)
    qpackDebug dyntbl $
        putStrLn $
            "LiteralFieldLineWithNameReference ("
                ++ show hidx
                ++ ") "
                ++ showTokenHeader ret
    return ret

-- 4.5.5.  Literal Field Line With Post-Base Name Reference
decodeLiteralFieldLineWithPostBaseNameReference
    :: ReadBuffer
    -> DynamicTable
    -> HuffmanDecoder
    -> BasePoint
    -> Word8
    -> IO TokenHeader
decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8 = do
    i <- decodeI 3 (w8 .&. 0b00000111) rbuf
    let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp
    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)
    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf
    let ret = (key, val)
    qpackDebug dyntbl $
        putStrLn $
            "LiteralFieldLineWithPostBaseNameReference ("
                ++ show hidx
                ++ ") "
                ++ showTokenHeader ret
    return ret

-- 4.5.6.  Literal Field Line With Literal Name
decodeLiteralFieldLineWithLiteralName
    :: ReadBuffer
    -> DynamicTable
    -> HuffmanDecoder
    -> BasePoint
    -> Word8
    -> IO TokenHeader
decodeLiteralFieldLineWithLiteralName rbuf dyntbl hufdec _bp _w8 = do
    ff rbuf (-1)
    key <- toToken <$> decodeS (.&. 0b00000111) (`testBit` 3) 3 hufdec rbuf
    val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf
    let ret = (key, val)
    qpackDebug dyntbl $
        putStrLn $
            "LiteralFieldLineWithLiteralName " ++ showTokenHeader ret
    return ret

showTokenHeader :: TokenHeader -> String
showTokenHeader (t, val) = "\"" ++ key ++ "\" \"" ++ BS8.unpack val ++ "\""
  where
    key = BS8.unpack $ foldedCase $ tokenKey t