{-# LANGUAGE BinaryLiterals #-}

module Network.QPACK.HeaderBlock.Decode where

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

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

decodeTokenHeader
    :: DynamicTable
    -> ReadBuffer
    -> IO TokenHeaderTable
decodeTokenHeader :: DynamicTable -> ReadBuffer -> IO TokenHeaderTable
decodeTokenHeader DynamicTable
dyntbl ReadBuffer
rbuf = do
    (InsertionPoint
reqip, BasePoint
bp) <- ReadBuffer -> DynamicTable -> IO (InsertionPoint, BasePoint)
decodePrefix ReadBuffer
rbuf DynamicTable
dyntbl
    DynamicTable -> InsertionPoint -> IO ()
checkInsertionPoint DynamicTable
dyntbl InsertionPoint
reqip
    (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO TokenHeaderTable
decodeSophisticated (DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl BasePoint
bp) ReadBuffer
rbuf

decodeTokenHeaderS
    :: DynamicTable
    -> ReadBuffer
    -> IO [Header]
decodeTokenHeaderS :: DynamicTable -> ReadBuffer -> IO [Header]
decodeTokenHeaderS DynamicTable
dyntbl ReadBuffer
rbuf = do
    (InsertionPoint
reqip, BasePoint
bp) <- ReadBuffer -> DynamicTable -> IO (InsertionPoint, BasePoint)
decodePrefix ReadBuffer
rbuf DynamicTable
dyntbl
    Bool
debug <- DynamicTable -> IO Bool
getDebugQPACK DynamicTable
dyntbl
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynamicTable -> InsertionPoint -> IO ()
checkInsertionPoint DynamicTable
dyntbl InsertionPoint
reqip
    (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO [Header]
decodeSimple (DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl BasePoint
bp) ReadBuffer
rbuf

toTokenHeader
    :: DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader :: DynamicTable -> BasePoint -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl BasePoint
bp Word8
w8 ReadBuffer
rbuf
    | Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 = ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLine ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8
    | Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6 = ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8
    | Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
5 = ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithoutNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8
    | Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
4 = ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLineWithPostBaseIndex ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8
    | Bool
otherwise =
        ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithPostBaseNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8

-- 4.5.2.  Indexed Field Line
decodeIndexedFieldLine
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLine :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLine ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8 = do
    Int
i <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
6 (Word8
w8 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b00111111) ReadBuffer
rbuf
    let static :: Bool
static = Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6
        hidx :: HIndex
hidx
            | Bool
static = AbsoluteIndex -> HIndex
SIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ Int -> AbsoluteIndex
AbsoluteIndex Int
i
            | Bool
otherwise = AbsoluteIndex -> HIndex
DIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ HBRelativeIndex -> BasePoint -> AbsoluteIndex
fromHBRelativeIndex (Int -> HBRelativeIndex
HBRelativeIndex Int
i) BasePoint
bp
    TokenHeader
ret <- STM TokenHeader -> IO TokenHeader
forall a. STM a -> IO a
atomically (Entry -> TokenHeader
entryTokenHeader (Entry -> TokenHeader) -> STM Entry -> STM TokenHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
hidx)
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"IndexedFieldLine (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HIndex -> String
forall a. Show a => a -> String
show HIndex
hidx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenHeader -> String
showTokenHeader TokenHeader
ret
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
ret

-- 4.5.4.  Literal Field Line With Name Reference
decodeLiteralFieldLineWithNameReference
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8 = do
    Int
i <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
4 (Word8
w8 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b00001111) ReadBuffer
rbuf
    let static :: Bool
static = Word8
w8 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
4
        hidx :: HIndex
hidx
            | Bool
static = AbsoluteIndex -> HIndex
SIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ Int -> AbsoluteIndex
AbsoluteIndex Int
i
            | Bool
otherwise = AbsoluteIndex -> HIndex
DIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ HBRelativeIndex -> BasePoint -> AbsoluteIndex
fromHBRelativeIndex (Int -> HBRelativeIndex
HBRelativeIndex Int
i) BasePoint
bp
    Token
key <- STM Token -> IO Token
forall a. STM a -> IO a
atomically (Entry -> Token
entryToken (Entry -> Token) -> STM Entry -> STM Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
hidx)
    let hufdec :: HuffmanDecoder
hufdec = DynamicTable -> HuffmanDecoder
getHuffmanDecoder DynamicTable
dyntbl
    ByteString
val <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO ByteString
decodeS (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
7) (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7) Int
7 HuffmanDecoder
hufdec ReadBuffer
rbuf
    let ret :: TokenHeader
ret = (Token
key, ByteString
val)
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"LiteralFieldLineWithNameReference ("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ HIndex -> String
forall a. Show a => a -> String
show HIndex
hidx
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenHeader -> String
showTokenHeader TokenHeader
ret
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
ret

-- 4.5.6.  Literal Field Line Without Name Reference
decodeLiteralFieldLineWithoutNameReference
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithoutNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithoutNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
_bp Word8
_w8 = do
    ReadBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff ReadBuffer
rbuf (-Int
1)
    let hufdec :: HuffmanDecoder
hufdec = DynamicTable -> HuffmanDecoder
getHuffmanDecoder DynamicTable
dyntbl
    Token
key <- ByteString -> Token
toToken (ByteString -> Token) -> IO ByteString -> IO Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO ByteString
decodeS (Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b00000111) (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
3) Int
3 HuffmanDecoder
hufdec ReadBuffer
rbuf
    ByteString
val <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO ByteString
decodeS (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
7) (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7) Int
7 HuffmanDecoder
hufdec ReadBuffer
rbuf
    let ret :: TokenHeader
ret = (Token
key, ByteString
val)
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"LiteralFieldLineWithoutNameReference " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenHeader -> String
showTokenHeader TokenHeader
ret
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
ret

-- 4.5.3.  Indexed Field Line With Post-Base Index
decodeIndexedFieldLineWithPostBaseIndex
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLineWithPostBaseIndex :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeIndexedFieldLineWithPostBaseIndex ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8 = do
    Int
i <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
4 (Word8
w8 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b00001111) ReadBuffer
rbuf
    let hidx :: HIndex
hidx = AbsoluteIndex -> HIndex
DIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ PostBaseIndex -> BasePoint -> AbsoluteIndex
fromPostBaseIndex (Int -> PostBaseIndex
PostBaseIndex Int
i) BasePoint
bp
    TokenHeader
ret <- STM TokenHeader -> IO TokenHeader
forall a. STM a -> IO a
atomically (Entry -> TokenHeader
entryTokenHeader (Entry -> TokenHeader) -> STM Entry -> STM TokenHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
hidx)
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"IndexedFieldLineWithPostBaseIndex ("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ HIndex -> String
forall a. Show a => a -> String
show HIndex
hidx
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ BasePoint -> String
forall a. Show a => a -> String
show BasePoint
bp
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenHeader -> String
showTokenHeader TokenHeader
ret
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
ret

-- 4.5.5.  Literal Field Line With Post-Base Name Reference
decodeLiteralFieldLineWithPostBaseNameReference
    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithPostBaseNameReference :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader
decodeLiteralFieldLineWithPostBaseNameReference ReadBuffer
rbuf DynamicTable
dyntbl BasePoint
bp Word8
w8 = do
    Int
i <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
3 (Word8
w8 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0b00000111) ReadBuffer
rbuf
    let hidx :: HIndex
hidx = AbsoluteIndex -> HIndex
DIndex (AbsoluteIndex -> HIndex) -> AbsoluteIndex -> HIndex
forall a b. (a -> b) -> a -> b
$ PostBaseIndex -> BasePoint -> AbsoluteIndex
fromPostBaseIndex (Int -> PostBaseIndex
PostBaseIndex Int
i) BasePoint
bp
    Token
key <- STM Token -> IO Token
forall a. STM a -> IO a
atomically (Entry -> Token
entryToken (Entry -> Token) -> STM Entry -> STM Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> HIndex -> STM Entry
toIndexedEntry DynamicTable
dyntbl HIndex
hidx)
    let hufdec :: HuffmanDecoder
hufdec = DynamicTable -> HuffmanDecoder
getHuffmanDecoder DynamicTable
dyntbl
    ByteString
val <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO ByteString
decodeS (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
7) (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7) Int
7 HuffmanDecoder
hufdec ReadBuffer
rbuf
    let ret :: TokenHeader
ret = (Token
key, ByteString
val)
    DynamicTable -> IO () -> IO ()
qpackDebug DynamicTable
dyntbl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"LiteralFieldLineWithPostBaseNameReference ("
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ HIndex -> String
forall a. Show a => a -> String
show HIndex
hidx
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenHeader -> String
showTokenHeader TokenHeader
ret
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
ret

showTokenHeader :: TokenHeader -> String
showTokenHeader :: TokenHeader -> String
showTokenHeader (Token
t, ByteString
val) = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS8.unpack ByteString
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
  where
    key :: String
key = ByteString -> String
BS8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
foldedCase (CI ByteString -> ByteString) -> CI ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Token -> CI ByteString
tokenKey Token
t