{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HPACK.HeaderBlock.Decode (
decodeHeader,
decodeTokenHeader,
ValueTable,
TokenHeaderTable,
toTokenHeaderTable,
getFieldValue,
decodeString,
decodeS,
decodeSophisticated,
decodeSimple,
) where
import Data.Array.Base (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.Char (isUpper)
import Network.ByteOrder
import Network.HTTP.Semantics
import UnliftIO.Exception (catch, throwIO)
import Imports hiding (empty)
import Network.HPACK.Builder
import Network.HPACK.HeaderBlock.Integer
import Network.HPACK.Huffman
import Network.HPACK.Table
import Network.HPACK.Types
decodeHeader
:: DynamicTable
-> ByteString
-> IO [Header]
DynamicTable
dyntbl FieldValue
inp = DynamicTable
-> FieldValue -> (ReadBuffer -> IO [Header]) -> IO [Header]
forall a.
DynamicTable -> FieldValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl FieldValue
inp ((Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO [Header]
decodeSimple (DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl))
decodeTokenHeader
:: DynamicTable
-> ByteString
-> IO TokenHeaderTable
DynamicTable
dyntbl FieldValue
inp =
DynamicTable
-> FieldValue
-> (ReadBuffer -> IO TokenHeaderTable)
-> IO TokenHeaderTable
forall a.
DynamicTable -> FieldValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl FieldValue
inp ((Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO TokenHeaderTable
decodeSophisticated (DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader
toTokenHeader DynamicTable
dyntbl)) IO TokenHeaderTable
-> (BufferOverrun -> IO TokenHeaderTable) -> IO TokenHeaderTable
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BufferOverrun
BufferOverrun -> DecodeError -> IO TokenHeaderTable
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
HeaderBlockTruncated
decodeHPACK
:: DynamicTable
-> ByteString
-> (ReadBuffer -> IO a)
-> IO a
decodeHPACK :: forall a.
DynamicTable -> FieldValue -> (ReadBuffer -> IO a) -> IO a
decodeHPACK DynamicTable
dyntbl FieldValue
inp ReadBuffer -> IO a
dec = FieldValue -> (ReadBuffer -> IO a) -> IO a
forall a. FieldValue -> (ReadBuffer -> IO a) -> IO a
withReadBuffer FieldValue
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
decodeSimple
:: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer
-> IO [Header]
decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO [Header]
decodeSimple Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader ReadBuffer
rbuf = Builder TokenHeader -> IO [Header]
go Builder TokenHeader
forall a. Builder a
empty
where
go :: Builder TokenHeader -> IO [Header]
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 [Header]
go Builder TokenHeader
builder'
else do
let tvs :: [TokenHeader]
tvs = Builder TokenHeader -> [TokenHeader]
forall a. Builder a -> [a]
run Builder TokenHeader
builder
kvs :: [Header]
kvs = (TokenHeader -> Header) -> [TokenHeader] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (\(Token
t, FieldValue
v) -> let k :: HeaderName
k = Token -> HeaderName
tokenKey Token
t in (HeaderName
k, FieldValue
v)) [TokenHeader]
tvs
[Header] -> IO [Header]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
kvs
headerLimit :: Int
= Int
200
decodeSophisticated
:: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer
-> IO TokenHeaderTable
decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader)
-> ReadBuffer -> IO TokenHeaderTable
decodeSophisticated Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader ReadBuffer
rbuf = do
IOArray Int (Maybe FieldValue)
arr <- (Int, Int)
-> Maybe FieldValue -> IO (IOArray Int (Maybe FieldValue))
forall i.
Ix i =>
(i, i) -> Maybe FieldValue -> IO (IOArray i (Maybe FieldValue))
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 FieldValue
forall a. Maybe a
Nothing
[TokenHeader]
tvs <- IOArray Int (Maybe FieldValue) -> IO [TokenHeader]
pseudoNormal IOArray Int (Maybe FieldValue)
arr
Array Int (Maybe FieldValue)
tbl <- IOArray Int (Maybe FieldValue) -> IO (Array Int (Maybe FieldValue))
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 FieldValue)
arr
TokenHeaderTable -> IO TokenHeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TokenHeader]
tvs, Array Int (Maybe FieldValue)
tbl)
where
pseudoNormal :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList
pseudoNormal :: IOArray Int (Maybe FieldValue) -> IO [TokenHeader]
pseudoNormal IOArray Int (Maybe FieldValue)
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
HeaderName
tokenKey :: Token -> HeaderName
tokenIx :: Int
shouldBeIndexed :: Bool
isPseudo :: Bool
tokenKey :: HeaderName
tokenIx :: Token -> Int
shouldBeIndexed :: Token -> Bool
isPseudo :: Token -> Bool
..}, FieldValue
v) <- Word8 -> ReadBuffer -> IO TokenHeader
decTokenHeader Word8
w ReadBuffer
rbuf
if Bool
isPseudo
then do
Maybe FieldValue
mx <- IOArray Int (Maybe FieldValue) -> Int -> IO (Maybe FieldValue)
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> IO (Maybe FieldValue)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead IOArray Int (Maybe FieldValue)
arr Int
tokenIx
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FieldValue -> Bool
forall a. Maybe a -> Bool
isJust Maybe FieldValue
mx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
IllegalHeaderName
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
IllegalHeaderName
IOArray Int (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe FieldValue)
arr Int
tokenIx (FieldValue -> Maybe FieldValue
forall a. a -> Maybe a
Just FieldValue
v)
IO [TokenHeader]
pseudo
else do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderName
tokenKey HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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) -> FieldValue -> Bool
B8.any Char -> Bool
isUpper (HeaderName -> FieldValue
forall s. CI s -> s
original HeaderName
tokenKey)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
DecodeError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
IllegalHeaderName
IOArray Int (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe FieldValue)
arr Int
tokenIx (FieldValue -> Maybe FieldValue
forall a. a -> Maybe a
Just FieldValue
v)
if Int -> Bool
isCookieTokenIx Int
tokenIx
then Int
-> Builder TokenHeader -> Builder FieldValue -> IO [TokenHeader]
normal Int
0 Builder TokenHeader
forall a. Builder a
empty (Builder FieldValue
forall a. Builder a
empty Builder FieldValue -> FieldValue -> Builder FieldValue
forall a. Builder a -> a -> Builder a
<< FieldValue
v)
else Int
-> Builder TokenHeader -> Builder FieldValue -> 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 FieldValue
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 FieldValue -> IO [TokenHeader]
normal Int
n Builder TokenHeader
builder Builder FieldValue
cookie
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
headerLimit = DecodeError -> IO [TokenHeader]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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
HeaderName
tokenKey :: Token -> HeaderName
tokenIx :: Token -> Int
shouldBeIndexed :: Token -> Bool
isPseudo :: Token -> Bool
tokenIx :: Int
shouldBeIndexed :: Bool
isPseudo :: Bool
tokenKey :: HeaderName
..}, FieldValue
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
IllegalHeaderName
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderName
tokenKey HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecodeError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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) -> FieldValue -> Bool
B8.any Char -> Bool
isUpper (HeaderName -> FieldValue
forall s. CI s -> s
original HeaderName
tokenKey)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
DecodeError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DecodeError
IllegalHeaderName
IOArray Int (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe FieldValue)
arr Int
tokenIx (FieldValue -> Maybe FieldValue
forall a. a -> Maybe a
Just FieldValue
v)
if Int -> Bool
isCookieTokenIx Int
tokenIx
then Int
-> Builder TokenHeader -> Builder FieldValue -> IO [TokenHeader]
normal (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Builder TokenHeader
builder (Builder FieldValue
cookie Builder FieldValue -> FieldValue -> Builder FieldValue
forall a. Builder a -> a -> Builder a
<< FieldValue
v)
else Int
-> Builder TokenHeader -> Builder FieldValue -> 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 FieldValue
cookie
else do
let tvs0 :: [TokenHeader]
tvs0 = Builder TokenHeader -> [TokenHeader]
forall a. Builder a -> [a]
run Builder TokenHeader
builder
cook :: [FieldValue]
cook = Builder FieldValue -> [FieldValue]
forall a. Builder a -> [a]
run Builder FieldValue
cookie
if [FieldValue] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldValue]
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 :: FieldValue
v = FieldValue -> [FieldValue] -> FieldValue
BS.intercalate FieldValue
"; " [FieldValue]
cook
tvs :: [TokenHeader]
tvs = (Token
tokenCookie, FieldValue
v) TokenHeader -> [TokenHeader] -> [TokenHeader]
forall a. a -> [a] -> [a]
: [TokenHeader]
tvs0
IOArray Int (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe FieldValue)
arr Int
cookieTokenIx (FieldValue -> Maybe FieldValue
forall a. a -> Maybe a
Just FieldValue
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
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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, FieldValue
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 -> FieldValue -> Entry
toEntryToken Token
t FieldValue
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
FieldValue
val <- HuffmanDecoder -> ReadBuffer -> IO FieldValue
decStr (DynamicTable -> HuffmanDecoder
huffmanDecoder DynamicTable
dyntbl) ReadBuffer
rbuf
let tv :: TokenHeader
tv = (Token
t, FieldValue
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 <- FieldValue -> Token
toToken (FieldValue -> Token) -> IO FieldValue -> IO Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HuffmanDecoder -> ReadBuffer -> IO FieldValue
decStr HuffmanDecoder
hufdec ReadBuffer
rbuf
FieldValue
val <- HuffmanDecoder -> ReadBuffer -> IO FieldValue
decStr HuffmanDecoder
hufdec ReadBuffer
rbuf
let tv :: TokenHeader
tv = (Token
t, FieldValue
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
decodeString :: ReadBuffer -> IO ByteString
decodeString :: ReadBuffer -> IO FieldValue
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 FieldValue
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 FieldValue
decStr = (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO FieldValue
decodeS Word8 -> Word8
dropHuffman Word8 -> Bool
isHuffman Int
7
decodeS
:: (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO ByteString
decodeS :: (Word8 -> Word8)
-> (Word8 -> Bool)
-> Int
-> HuffmanDecoder
-> ReadBuffer
-> IO FieldValue
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 FieldValue
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
toTokenHeaderTable :: [Header] -> IO TokenHeaderTable
[Header]
kvs = do
IOArray Int (Maybe FieldValue)
arr <- (Int, Int)
-> Maybe FieldValue -> IO (IOArray Int (Maybe FieldValue))
forall i.
Ix i =>
(i, i) -> Maybe FieldValue -> IO (IOArray i (Maybe FieldValue))
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 FieldValue
forall a. Maybe a
Nothing
[TokenHeader]
tvs <- IOArray Int (Maybe FieldValue) -> IO [TokenHeader]
conv IOArray Int (Maybe FieldValue)
arr
Array Int (Maybe FieldValue)
tbl <- IOArray Int (Maybe FieldValue) -> IO (Array Int (Maybe FieldValue))
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 FieldValue)
arr
TokenHeaderTable -> IO TokenHeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TokenHeader]
tvs, Array Int (Maybe FieldValue)
tbl)
where
conv :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList
conv :: IOArray Int (Maybe FieldValue) -> IO [TokenHeader]
conv IOArray Int (Maybe FieldValue)
arr = [Header] -> Builder TokenHeader -> IO [TokenHeader]
go [Header]
kvs Builder TokenHeader
forall a. Builder a
empty
where
go :: [Header] -> Builder TokenHeader -> IO TokenHeaderList
go :: [Header] -> 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 ((HeaderName
k, FieldValue
v) : [Header]
xs) Builder TokenHeader
builder = do
let t :: Token
t = FieldValue -> Token
toToken (HeaderName -> FieldValue
forall s. CI s -> s
foldedCase HeaderName
k)
IOArray Int (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall i.
Ix i =>
IOArray i (Maybe FieldValue) -> Int -> Maybe FieldValue -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOArray Int (Maybe FieldValue)
arr (Token -> Int
tokenIx Token
t) (FieldValue -> Maybe FieldValue
forall a. a -> Maybe a
Just FieldValue
v)
let tv :: TokenHeader
tv = (Token
t, FieldValue
v)
builder' :: Builder TokenHeader
builder' = Builder TokenHeader
builder Builder TokenHeader -> TokenHeader -> Builder TokenHeader
forall a. Builder a -> a -> Builder a
<< TokenHeader
tv
[Header] -> Builder TokenHeader -> IO [TokenHeader]
go [Header]
xs Builder TokenHeader
builder'