{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HPACK.HeaderBlock.Decode (
    decodeHeader,
    decodeTokenHeader,
    ValueTable,
    HeaderTable,
    toHeaderTable,
    getHeaderValue,
    decodeString,
    decodeS,
    decodeSophisticated,
    decodeSimple, -- testing
) where

import Control.Exception (catch, throwIO)
import Data.Array (Array)
import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite)
import qualified Data.Array.IO as IOA
import qualified Data.Array.Unsafe as Unsafe
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.CaseInsensitive (CI (..))
import Data.Char (isUpper)
import Network.ByteOrder

import Imports hiding (empty)
import Network.HPACK.Builder
import Network.HPACK.HeaderBlock.Integer
import Network.HPACK.Huffman
import Network.HPACK.Table
import Network.HPACK.Token
import Network.HPACK.Types

-- | An array to get 'HeaderValue' quickly.
--   'getHeaderValue' should be used.
--   Internally, the key is 'tokenIx'.
type ValueTable = Array Int (Maybe HeaderValue)

-- | Accessing 'HeaderValue' with 'Token'.
{-# INLINE getHeaderValue #-}
getHeaderValue :: Token -> ValueTable -> Maybe HeaderValue
getHeaderValue :: Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
t ValueTable
tbl = ValueTable
tbl ValueTable -> Int -> Maybe HeaderValue
forall i.
Ix i =>
Array i (Maybe HeaderValue) -> Int -> Maybe HeaderValue
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Token -> Int
tokenIx Token
t

----------------------------------------------------------------

-- | Converting the HPACK format to 'HeaderList'.
--
--   * Headers are decoded as is.
--   * 'DecodeError' would be thrown if the HPACK format is broken.
--   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.
decodeHeader
    :: DynamicTable
    -> ByteString
    -- ^ An HPACK format
    -> IO HeaderList
decodeHeader :: DynamicTable -> HeaderValue -> IO HeaderList
decodeHeader DynamicTable
dyntbl HeaderValue
inp = DynamicTable
-> HeaderValue -> (ReadBuffer -> IO HeaderList) -> IO HeaderList
forall a.
DynamicTable -> HeaderValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl HeaderValue
inp ((Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO HeaderList
decodeSimple (DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl))

-- | Converting the HPACK format to 'TokenHeaderList'
--   and 'ValueTable'.
--
--   * Multiple values of Cookie: are concatenated.
--   * If a pseudo header appears multiple times,
--     'IllegalHeaderName' is thrown.
--   * If unknown pseudo headers appear,
--     'IllegalHeaderName' is thrown.
--   * If pseudo headers are found after normal headers,
--     'IllegalHeaderName' is thrown.
--   * If a header key contains capital letters,
--     'IllegalHeaderName' is thrown.
--   * 'DecodeError' would be thrown if the HPACK format is broken.
--   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.
decodeTokenHeader
    :: DynamicTable
    -> ByteString
    -- ^ An HPACK format
    -> IO HeaderTable
decodeTokenHeader :: DynamicTable -> HeaderValue -> IO HeaderTable
decodeTokenHeader DynamicTable
dyntbl HeaderValue
inp =
    DynamicTable
-> HeaderValue -> (ReadBuffer -> IO HeaderTable) -> IO HeaderTable
forall a.
DynamicTable -> HeaderValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl HeaderValue
inp ((Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO HeaderTable
decodeSophisticated (DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl)) IO HeaderTable
-> (BufferOverrun -> IO HeaderTable) -> IO HeaderTable
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \BufferOverrun
BufferOverrun -> DecodeError -> IO HeaderTable
forall e a. Exception e => e -> IO a
throwIO DecodeError
HeaderBlockTruncated

decodeHPACK
    :: DynamicTable
    -> ByteString
    -> (ReadBuffer -> IO a)
    -> IO a
decodeHPACK :: forall a.
DynamicTable -> HeaderValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl HeaderValue
inp ReadBuffer -> IO a
dec = HeaderValue -> (ReadBuffer -> IO a) -> IO a
forall a. HeaderValue -> (ReadBuffer -> IO a) -> IO a
withReadBuffer HeaderValue
inp ReadBuffer -> IO a
chkChange
  where
    chkChange :: ReadBuffer -> IO a
chkChange ReadBuffer
rbuf = do
        Word8
w <- ReadBuffer -> IO Word8
forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
        if Word8 -> Bool
isTableSizeUpdate Word8
w
            then do
                DynamicTable -> Word8 -> ReadBuffer -> IO ()
tableSizeUpdate DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
                ReadBuffer -> IO a
chkChange ReadBuffer
rbuf
            else do
                ReadBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff ReadBuffer
rbuf (-Int
1)
                ReadBuffer -> IO a
dec ReadBuffer
rbuf

-- | Converting to 'HeaderList'.
--
--   * Headers are decoded as is.
--   * 'DecodeError' would be thrown if the HPACK format is broken.
--   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.
decodeSimple
    :: (Word8 -> ReadBuffer -> IO TokenHeader)
    -> ReadBuffer
    -> IO HeaderList
decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO HeaderList
decodeSimple Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader ReadBuffer
rbuf = Builder TokenHeader -> IO HeaderList
go Builder TokenHeader
forall a. Builder a
empty
  where
    go :: Builder TokenHeader -> IO HeaderList
go Builder TokenHeader
builder = do
        Int
leftover <- ReadBuffer -> IO Int
forall a. Readable a => a -> IO Int
remainingSize ReadBuffer
rbuf
        if Int
leftover Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
            then do
                Word8
w <- ReadBuffer -> IO Word8
forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
                TokenHeader
tv <- Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader Word8
w ReadBuffer
rbuf
                let builder' :: Builder TokenHeader
builder' = Builder TokenHeader
builder Builder TokenHeader -> TokenHeader -> Builder TokenHeader
forall a. Builder a -> a -> Builder a
<< TokenHeader
tv
                Builder TokenHeader -> IO HeaderList
go Builder TokenHeader
builder'
            else do
                let tvs :: [TokenHeader]
tvs = Builder TokenHeader -> [TokenHeader]
forall a. Builder a -> [a]
run Builder TokenHeader
builder
                    kvs :: HeaderList
kvs = (TokenHeader -> (HeaderValue, HeaderValue))
-> [TokenHeader] -> HeaderList
forall a b. (a -> b) -> [a] -> [b]
map (\(Token
t, HeaderValue
v) -> let k :: HeaderValue
k = Token -> HeaderValue
tokenFoldedKey Token
t in (HeaderValue
k, HeaderValue
v)) [TokenHeader]
tvs
                HeaderList -> IO HeaderList
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderList
kvs

headerLimit :: Int
headerLimit :: Int
headerLimit = Int
200

-- | Converting to 'TokenHeaderList' and 'ValueTable'.
--
--   * Multiple values of Cookie: are concatenated.
--   * If a pseudo header appears multiple times,
--     'IllegalHeaderName' is thrown.
--   * If unknown pseudo headers appear,
--     'IllegalHeaderName' is thrown.
--   * If pseudo headers are found after normal headers,
--     'IllegalHeaderName' is thrown.
--   * If a header key contains capital letters,
--     'IllegalHeaderName' is thrown.
--   * If the number of header fields is too large,
--     'TooLargeHeader' is thrown
--   * 'DecodeError' would be thrown if the HPACK format is broken.
--   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.
decodeSophisticated
    :: (Word8 -> ReadBuffer -> IO TokenHeader)
    -> ReadBuffer
    -> IO HeaderTable
decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO HeaderTable
decodeSophisticated Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader ReadBuffer
rbuf = do
    -- using maxTokenIx to reduce condition
    IOArray Int (Maybe HeaderValue)
arr <- (Int, Int)
-> Maybe HeaderValue -> IO (IOArray Int (Maybe HeaderValue))
forall i.
Ix i =>
(i, i) -> Maybe HeaderValue -> IO (IOArray i (Maybe HeaderValue))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
IOA.newArray (Int
minTokenIx, Int
maxTokenIx) Maybe HeaderValue
forall a. Maybe a
Nothing
    [TokenHeader]
tvs <- IOArray Int (Maybe HeaderValue) -> IO [TokenHeader]
pseudoNormal IOArray Int (Maybe HeaderValue)
arr
    ValueTable
tbl <- IOArray Int (Maybe HeaderValue) -> IO ValueTable
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
Unsafe.unsafeFreeze IOArray Int (Maybe HeaderValue)
arr
    HeaderTable -> IO HeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TokenHeader]
tvs, ValueTable
tbl)
  where
    pseudoNormal :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList
    pseudoNormal :: IOArray Int (Maybe HeaderValue) -> IO [TokenHeader]
pseudoNormal IOArray Int (Maybe HeaderValue)
arr = IO [TokenHeader]
pseudo
      where
        pseudo :: IO [TokenHeader]
pseudo = do
            Int
leftover <- ReadBuffer -> IO Int
forall a. Readable a => a -> IO Int
remainingSize ReadBuffer
rbuf
            if Int
leftover Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                then do
                    Word8
w <- ReadBuffer -> IO Word8
forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
                    tv :: TokenHeader
tv@(Token{Bool
Int
CI HeaderValue
tokenIx :: Token -> Int
tokenIx :: Int
shouldBeIndexed :: Bool
isPseudo :: Bool
tokenKey :: CI HeaderValue
shouldBeIndexed :: Token -> Bool
isPseudo :: Token -> Bool
tokenKey :: Token -> CI HeaderValue
..}, HeaderValue
v) <- Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader Word8
w ReadBuffer
rbuf
                    if Bool
isPseudo
                        then do
                            Maybe HeaderValue
mx <- IOArray Int (Maybe HeaderValue) -> Int -> IO (Maybe HeaderValue)
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> IO (Maybe HeaderValue)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead IOArray Int (Maybe HeaderValue)
arr Int
tokenIx
                            -- duplicated
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe HeaderValue -> Bool
forall a. Maybe a -> Bool
isJust Maybe HeaderValue
mx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                            -- unknown
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isMaxTokenIx Int
tokenIx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                            IOArray Int (Maybe HeaderValue)
-> Int -> Maybe HeaderValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> Maybe HeaderValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe HeaderValue)
arr Int
tokenIx (HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
v)
                            IO [TokenHeader]
pseudo
                        else do
                            -- 0-Length Headers Leak - CVE-2019-9516
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CI HeaderValue
tokenKey CI HeaderValue -> CI HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== CI HeaderValue
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isMaxTokenIx Int
tokenIx Bool -> Bool -> Bool
&& (Char -> Bool) -> HeaderValue -> Bool
B8.any Char -> Bool
isUpper (CI HeaderValue -> HeaderValue
forall s. CI s -> s
original CI HeaderValue
tokenKey)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                            IOArray Int (Maybe HeaderValue)
-> Int -> Maybe HeaderValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> Maybe HeaderValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe HeaderValue)
arr Int
tokenIx (HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
v)
                            if Int -> Bool
isCookieTokenIx Int
tokenIx
                                then Int
-> Builder TokenHeader -> Builder HeaderValue -> IO [TokenHeader]
normal Int
0 Builder TokenHeader
forall a. Builder a
empty (Builder HeaderValue
forall a. Builder a
empty Builder HeaderValue -> HeaderValue -> Builder HeaderValue
forall a. Builder a -> a -> Builder a
<< HeaderValue
v)
                                else Int
-> Builder TokenHeader -> Builder HeaderValue -> IO [TokenHeader]
normal Int
0 (Builder TokenHeader
forall a. Builder a
empty Builder TokenHeader -> TokenHeader -> Builder TokenHeader
forall a. Builder a -> a -> Builder a
<< TokenHeader
tv) Builder HeaderValue
forall a. Builder a
empty
                else [TokenHeader] -> IO [TokenHeader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        normal :: Int
-> Builder TokenHeader -> Builder HeaderValue -> IO [TokenHeader]
normal Int
n Builder TokenHeader
builder Builder HeaderValue
cookie
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
headerLimit = DecodeError -> IO [TokenHeader]
forall e a. Exception e => e -> IO a
throwIO DecodeError
TooLargeHeader
            | Bool
otherwise = do
                Int
leftover <- ReadBuffer -> IO Int
forall a. Readable a => a -> IO Int
remainingSize ReadBuffer
rbuf
                if Int
leftover Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                    then do
                        Word8
w <- ReadBuffer -> IO Word8
forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
                        tv :: TokenHeader
tv@(Token{Bool
Int
CI HeaderValue
tokenIx :: Token -> Int
shouldBeIndexed :: Token -> Bool
isPseudo :: Token -> Bool
tokenKey :: Token -> CI HeaderValue
tokenIx :: Int
shouldBeIndexed :: Bool
isPseudo :: Bool
tokenKey :: CI HeaderValue
..}, HeaderValue
v) <- Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader Word8
w ReadBuffer
rbuf
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPseudo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                        -- 0-Length Headers Leak - CVE-2019-9516
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CI HeaderValue
tokenKey CI HeaderValue -> CI HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== CI HeaderValue
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
isMaxTokenIx Int
tokenIx Bool -> Bool -> Bool
&& (Char -> Bool) -> HeaderValue -> Bool
B8.any Char -> Bool
isUpper (CI HeaderValue -> HeaderValue
forall s. CI s -> s
original CI HeaderValue
tokenKey)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalHeaderName
                        IOArray Int (Maybe HeaderValue)
-> Int -> Maybe HeaderValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> Maybe HeaderValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe HeaderValue)
arr Int
tokenIx (HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
v)
                        if Int -> Bool
isCookieTokenIx Int
tokenIx
                            then Int
-> Builder TokenHeader -> Builder HeaderValue -> IO [TokenHeader]
normal (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Builder TokenHeader
builder (Builder HeaderValue
cookie Builder HeaderValue -> HeaderValue -> Builder HeaderValue
forall a. Builder a -> a -> Builder a
<< HeaderValue
v)
                            else Int
-> Builder TokenHeader -> Builder HeaderValue -> IO [TokenHeader]
normal (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Builder TokenHeader
builder Builder TokenHeader -> TokenHeader -> Builder TokenHeader
forall a. Builder a -> a -> Builder a
<< TokenHeader
tv) Builder HeaderValue
cookie
                    else do
                        let tvs0 :: [TokenHeader]
tvs0 = Builder TokenHeader -> [TokenHeader]
forall a. Builder a -> [a]
run Builder TokenHeader
builder
                            cook :: [HeaderValue]
cook = Builder HeaderValue -> [HeaderValue]
forall a. Builder a -> [a]
run Builder HeaderValue
cookie
                        if [HeaderValue] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HeaderValue]
cook
                            then [TokenHeader] -> IO [TokenHeader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [TokenHeader]
tvs0
                            else do
                                let v :: HeaderValue
v = HeaderValue -> [HeaderValue] -> HeaderValue
BS.intercalate HeaderValue
"; " [HeaderValue]
cook
                                    tvs :: [TokenHeader]
tvs = (Token
tokenCookie, HeaderValue
v) TokenHeader -> [TokenHeader] -> [TokenHeader]
forall a. a -> [a] -> [a]
: [TokenHeader]
tvs0
                                IOArray Int (Maybe HeaderValue)
-> Int -> Maybe HeaderValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> Maybe HeaderValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe HeaderValue)
arr Int
cookieTokenIx (HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
v)
                                [TokenHeader] -> IO [TokenHeader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [TokenHeader]
tvs

toTokenHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Word8
w Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 = DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
indexed DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Word8
w Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6 = DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
incrementalIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Word8
w Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
5 = DecodeError -> IO TokenHeader
forall e a. Exception e => e -> IO a
throwIO DecodeError
IllegalTableSizeUpdate
    | Word8
w Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
4 = DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
neverIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Bool
otherwise = DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
withoutIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf

tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO ()
tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO ()
tableSizeUpdate DynamicTable
dyntbl Word8
w ReadBuffer
rbuf = do
    let w' :: Word8
w' = Word8 -> Word8
mask5 Word8
w
    Int
siz <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
5 Word8
w' ReadBuffer
rbuf
    Bool
suitable <- Int -> DynamicTable -> IO Bool
isSuitableSize Int
siz DynamicTable
dyntbl
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
suitable (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall e a. Exception e => e -> IO a
throwIO DecodeError
TooLargeTableSize
    Int -> DynamicTable -> IO ()
renewDynamicTable Int
siz DynamicTable
dyntbl

----------------------------------------------------------------

indexed :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
indexed :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
indexed DynamicTable
dyntbl Word8
w ReadBuffer
rbuf = do
    let w' :: Word8
w' = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
clearBit Word8
w Int
7
    Int
idx <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
7 Word8
w' ReadBuffer
rbuf
    Entry -> TokenHeader
entryTokenHeader (Entry -> TokenHeader) -> IO Entry -> IO TokenHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> Int -> IO Entry
toIndexedEntry DynamicTable
dyntbl Int
idx

incrementalIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
incrementalIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
incrementalIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf = do
    tv :: TokenHeader
tv@(Token
t, HeaderValue
v) <-
        if Word8 -> Bool
isIndexedName1 Word8
w
            then DynamicTable
-> Word8 -> ReadBuffer -> Int -> (Word8 -> Word8) -> IO TokenHeader
indexedName DynamicTable
dyntbl Word8
w ReadBuffer
rbuf Int
6 Word8 -> Word8
mask6
            else DynamicTable -> ReadBuffer -> IO TokenHeader
newName DynamicTable
dyntbl ReadBuffer
rbuf
    let e :: Entry
e = Token -> HeaderValue -> Entry
toEntryToken Token
t HeaderValue
v
    Entry -> DynamicTable -> IO ()
insertEntry Entry
e DynamicTable
dyntbl
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
tv

withoutIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
withoutIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
withoutIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Word8 -> Bool
isIndexedName2 Word8
w = DynamicTable
-> Word8 -> ReadBuffer -> Int -> (Word8 -> Word8) -> IO TokenHeader
indexedName DynamicTable
dyntbl Word8
w ReadBuffer
rbuf Int
4 Word8 -> Word8
mask4
    | Bool
otherwise = DynamicTable -> ReadBuffer -> IO TokenHeader
newName DynamicTable
dyntbl ReadBuffer
rbuf

neverIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
neverIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
neverIndexing DynamicTable
dyntbl Word8
w ReadBuffer
rbuf
    | Word8 -> Bool
isIndexedName2 Word8
w = DynamicTable
-> Word8 -> ReadBuffer -> Int -> (Word8 -> Word8) -> IO TokenHeader
indexedName DynamicTable
dyntbl Word8
w ReadBuffer
rbuf Int
4 Word8 -> Word8
mask4
    | Bool
otherwise = DynamicTable -> ReadBuffer -> IO TokenHeader
newName DynamicTable
dyntbl ReadBuffer
rbuf

----------------------------------------------------------------

indexedName
    :: DynamicTable
    -> Word8
    -> ReadBuffer
    -> Int
    -> (Word8 -> Word8)
    -> IO TokenHeader
indexedName :: DynamicTable
-> Word8 -> ReadBuffer -> Int -> (Word8 -> Word8) -> IO TokenHeader
indexedName DynamicTable
dyntbl Word8
w ReadBuffer
rbuf Int
n Word8 -> Word8
mask = do
    let p :: Word8
p = Word8 -> Word8
mask Word8
w
    Int
idx <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
n Word8
p ReadBuffer
rbuf
    Token
t <- Entry -> Token
entryToken (Entry -> Token) -> IO Entry -> IO Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynamicTable -> Int -> IO Entry
toIndexedEntry DynamicTable
dyntbl Int
idx
    HeaderValue
val <- HuffmanDecoder -> ReadBuffer -> IO HeaderValue
decStr (DynamicTable -> HuffmanDecoder
huffmanDecoder DynamicTable
dyntbl) ReadBuffer
rbuf
    let tv :: TokenHeader
tv = (Token
t, HeaderValue
val)
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
tv

newName :: DynamicTable -> ReadBuffer -> IO TokenHeader
newName :: DynamicTable -> ReadBuffer -> IO TokenHeader
newName DynamicTable
dyntbl ReadBuffer
rbuf = do
    let hufdec :: HuffmanDecoder
hufdec = DynamicTable -> HuffmanDecoder
huffmanDecoder DynamicTable
dyntbl
    Token
t <- HeaderValue -> Token
toToken (HeaderValue -> Token) -> IO HeaderValue -> IO Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HuffmanDecoder -> ReadBuffer -> IO HeaderValue
decStr HuffmanDecoder
hufdec ReadBuffer
rbuf
    HeaderValue
val <- HuffmanDecoder -> ReadBuffer -> IO HeaderValue
decStr HuffmanDecoder
hufdec ReadBuffer
rbuf
    let tv :: TokenHeader
tv = (Token
t, HeaderValue
val)
    TokenHeader -> IO TokenHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeader
tv

----------------------------------------------------------------

isHuffman :: Word8 -> Bool
isHuffman :: Word8 -> Bool
isHuffman Word8
w = Word8
w Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7

dropHuffman :: Word8 -> Word8
dropHuffman :: Word8 -> Word8
dropHuffman Word8
w = Word8
w Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
7

-- | String decoding (7+) with a temporal Huffman decoder whose buffer is 4096.
decodeString :: ReadBuffer -> IO ByteString
decodeString :: ReadBuffer -> IO HeaderValue
decodeString ReadBuffer
rbuf = do
    let bufsiz :: Int
bufsiz = Int
4096
    ForeignPtr Word8
gcbuf <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
4096
    (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS Word8 -> Word8
dropHuffman Word8 -> Bool
isHuffman Int
7 (ForeignPtr Word8 -> Int -> HuffmanDecoder
decodeH ForeignPtr Word8
gcbuf Int
bufsiz) ReadBuffer
rbuf

decStr :: HuffmanDecoder -> ReadBuffer -> IO ByteString
decStr :: HuffmanDecoder -> ReadBuffer -> IO HeaderValue
decStr = (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS Word8 -> Word8
dropHuffman Word8 -> Bool
isHuffman Int
7

-- | String decoding with Huffman decoder.
decodeS
    :: (Word8 -> Word8)
    -- ^ Dropping prefix and Huffman
    -> (Word8 -> Bool)
    -- ^ Checking Huffman flag
    -> Int
    -- ^ N+
    -> HuffmanDecoder
    -> ReadBuffer
    -> IO ByteString
decodeS :: (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS Word8 -> Word8
mask Word8 -> Bool
isH Int
n HuffmanDecoder
hufdec ReadBuffer
rbuf = do
    Word8
w <- ReadBuffer -> IO Word8
forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
    let p :: Word8
p = Word8 -> Word8
mask Word8
w
        huff :: Bool
huff = Word8 -> Bool
isH Word8
w
    Int
len <- Int -> Word8 -> ReadBuffer -> IO Int
decodeI Int
n Word8
p ReadBuffer
rbuf
    if Bool
huff
        then HuffmanDecoder
hufdec ReadBuffer
rbuf Int
len
        else HuffmanDecoder
forall a. Readable a => a -> Int -> IO HeaderValue
extractByteString ReadBuffer
rbuf Int
len

----------------------------------------------------------------

mask6 :: Word8 -> Word8
mask6 :: Word8 -> Word8
mask6 Word8
w = Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
63

mask5 :: Word8 -> Word8
mask5 :: Word8 -> Word8
mask5 Word8
w = Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
31

mask4 :: Word8 -> Word8
mask4 :: Word8 -> Word8
mask4 Word8
w = Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
15

isIndexedName1 :: Word8 -> Bool
isIndexedName1 :: Word8 -> Bool
isIndexedName1 Word8
w = Word8 -> Word8
mask6 Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0

isIndexedName2 :: Word8 -> Bool
isIndexedName2 :: Word8 -> Bool
isIndexedName2 Word8
w = Word8 -> Word8
mask4 Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0

isTableSizeUpdate :: Word8 -> Bool
isTableSizeUpdate :: Word8 -> Bool
isTableSizeUpdate Word8
w = Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xe0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20

----------------------------------------------------------------

-- | A pair of token list and value table.
type HeaderTable = (TokenHeaderList, ValueTable)

-- | Converting a header list of the http-types style to
--   'TokenHeaderList' and 'ValueTable'.
toHeaderTable :: [(CI HeaderName, HeaderValue)] -> IO HeaderTable
toHeaderTable :: [(CI HeaderValue, HeaderValue)] -> IO HeaderTable
toHeaderTable [(CI HeaderValue, HeaderValue)]
kvs = do
    IOArray Int (Maybe HeaderValue)
arr <- (Int, Int)
-> Maybe HeaderValue -> IO (IOArray Int (Maybe HeaderValue))
forall i.
Ix i =>
(i, i) -> Maybe HeaderValue -> IO (IOArray i (Maybe HeaderValue))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
IOA.newArray (Int
minTokenIx, Int
maxTokenIx) Maybe HeaderValue
forall a. Maybe a
Nothing
    [TokenHeader]
tvs <- IOArray Int (Maybe HeaderValue) -> IO [TokenHeader]
conv IOArray Int (Maybe HeaderValue)
arr
    ValueTable
tbl <- IOArray Int (Maybe HeaderValue) -> IO ValueTable
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
Unsafe.unsafeFreeze IOArray Int (Maybe HeaderValue)
arr
    HeaderTable -> IO HeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TokenHeader]
tvs, ValueTable
tbl)
  where
    conv :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList
    conv :: IOArray Int (Maybe HeaderValue) -> IO [TokenHeader]
conv IOArray Int (Maybe HeaderValue)
arr = [(CI HeaderValue, HeaderValue)]
-> Builder TokenHeader -> IO [TokenHeader]
go [(CI HeaderValue, HeaderValue)]
kvs Builder TokenHeader
forall a. Builder a
empty
      where
        go
            :: [(CI HeaderName, HeaderValue)] -> Builder TokenHeader -> IO TokenHeaderList
        go :: [(CI HeaderValue, HeaderValue)]
-> Builder TokenHeader -> IO [TokenHeader]
go [] Builder TokenHeader
builder = [TokenHeader] -> IO [TokenHeader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TokenHeader] -> IO [TokenHeader])
-> [TokenHeader] -> IO [TokenHeader]
forall a b. (a -> b) -> a -> b
$ Builder TokenHeader -> [TokenHeader]
forall a. Builder a -> [a]
run Builder TokenHeader
builder
        go ((CI HeaderValue
k, HeaderValue
v) : [(CI HeaderValue, HeaderValue)]
xs) Builder TokenHeader
builder = do
            let t :: Token
t = HeaderValue -> Token
toToken (CI HeaderValue -> HeaderValue
forall s. CI s -> s
foldedCase CI HeaderValue
k)
            IOArray Int (Maybe HeaderValue)
-> Int -> Maybe HeaderValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe HeaderValue) -> Int -> Maybe HeaderValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe HeaderValue)
arr (Token -> Int
tokenIx Token
t) (HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
v)
            let tv :: TokenHeader
tv = (Token
t, HeaderValue
v)
                builder' :: Builder TokenHeader
builder' = Builder TokenHeader
builder Builder TokenHeader -> TokenHeader -> Builder TokenHeader
forall a. Builder a -> a -> Builder a
<< TokenHeader
tv
            [(CI HeaderValue, HeaderValue)]
-> Builder TokenHeader -> IO [TokenHeader]
go [(CI HeaderValue, HeaderValue)]
xs Builder TokenHeader
builder'