{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HPACK.HeaderBlock.Encode (
encodeHeader,
encodeTokenHeader,
encodeString,
encodeS,
) where
import Control.Exception (bracket, throwIO)
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Data.ByteString.Internal (create)
import Data.IORef
import Foreign.Marshal.Alloc (free, mallocBytes)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (minusPtr)
import Network.ByteOrder
import Network.HTTP.Semantics
import Imports
import Network.HPACK.HeaderBlock.Integer
import Network.HPACK.Huffman
import Network.HPACK.Table
import Network.HPACK.Types
changeTableSize :: DynamicTable -> WriteBuffer -> IO ()
changeTableSize :: DynamicTable -> WriteBuffer -> IO ()
changeTableSize DynamicTable
dyntbl WriteBuffer
wbuf = do
msiz <- DynamicTable -> IO TableSizeAction
needChangeTableSize DynamicTable
dyntbl
case msiz of
TableSizeAction
Keep -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Change Int
lim -> do
Int -> DynamicTable -> IO ()
renewDynamicTable Int
lim DynamicTable
dyntbl
WriteBuffer -> Int -> IO ()
change WriteBuffer
wbuf Int
lim
Ignore Int
lim -> do
DynamicTable -> IO ()
resetLimitForEncoding DynamicTable
dyntbl
WriteBuffer -> Int -> IO ()
change WriteBuffer
wbuf Int
lim
encodeHeader
:: EncodeStrategy
-> Size
-> DynamicTable
-> [Header]
-> IO ByteString
EncodeStrategy
stgy Int
siz DynamicTable
dyntbl [Header]
hs = EncodeStrategy
-> Int -> DynamicTable -> TokenHeaderList -> IO ByteString
encodeHeader' EncodeStrategy
stgy Int
siz DynamicTable
dyntbl TokenHeaderList
hs'
where
mk' :: (CI ByteString, b) -> (Token, b)
mk' (CI ByteString
k, b
v) = (Token
t, b
v)
where
t :: Token
t = ByteString -> Token
toToken (ByteString -> Token) -> ByteString -> Token
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
foldedCase CI ByteString
k
hs' :: TokenHeaderList
hs' = (Header -> (Token, ByteString)) -> [Header] -> TokenHeaderList
forall a b. (a -> b) -> [a] -> [b]
map Header -> (Token, ByteString)
forall {b}. (CI ByteString, b) -> (Token, b)
mk' [Header]
hs
encodeHeader'
:: EncodeStrategy
-> Size
-> DynamicTable
-> TokenHeaderList
-> IO ByteString
EncodeStrategy
stgy Int
siz DynamicTable
dyntbl TokenHeaderList
hs = IO (Ptr Word8)
-> (Ptr Word8 -> IO ())
-> (Ptr Word8 -> IO ByteString)
-> IO ByteString
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
siz) Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8 -> IO ByteString
enc
where
enc :: Ptr Word8 -> IO ByteString
enc Ptr Word8
buf = do
(hs', len) <- Ptr Word8
-> Int
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
encodeTokenHeader Ptr Word8
buf Int
siz EncodeStrategy
stgy Bool
True DynamicTable
dyntbl TokenHeaderList
hs
case hs' of
[] -> Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
len ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
p Ptr Word8
buf Int
len
TokenHeaderList
_ -> BufferOverrun -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO BufferOverrun
BufferOverrun
encodeTokenHeader
:: Buffer
-> BufferSize
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Ptr Word8
buf Int
siz EncodeStrategy{Bool
CompressionAlgo
compressionAlgo :: CompressionAlgo
useHuffman :: Bool
useHuffman :: EncodeStrategy -> Bool
compressionAlgo :: EncodeStrategy -> CompressionAlgo
..} Bool
first DynamicTable
dyntbl TokenHeaderList
hs0 = do
wbuf <- Ptr Word8 -> Int -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf Int
siz
when first $ changeTableSize dyntbl wbuf
let fa = DynamicTable -> WriteBuffer -> Bool -> FA
indexedHeaderField DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fb = DynamicTable -> WriteBuffer -> Bool -> FB
literalHeaderFieldWithIncrementalIndexingIndexedName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fc = DynamicTable -> WriteBuffer -> Bool -> FC
literalHeaderFieldWithIncrementalIndexingNewName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fd = DynamicTable -> WriteBuffer -> Bool -> FD
literalHeaderFieldWithoutIndexingIndexedName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fe = DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fe' = DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName' DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
rev = DynamicTable -> RevIndex
getRevIndex DynamicTable
dyntbl
step0 = case CompressionAlgo
compressionAlgo of
CompressionAlgo
Naive -> FE -> Token -> ByteString -> IO ()
naiveStep FE
fe'
CompressionAlgo
Static -> FA -> FD -> FE -> Token -> ByteString -> IO ()
staticStep FA
fa FD
fd FE
fe
CompressionAlgo
Linear -> RevIndex -> FA -> FB -> FC -> FD -> Token -> ByteString -> IO ()
linearStep RevIndex
rev FA
fa FB
fb FC
fc FD
fd
ref1 <- currentOffset wbuf >>= newIORef
ref2 <- newIORef hs0
loop wbuf ref1 ref2 step0 hs0 `E.catch` \BufferOverrun
BufferOverrun -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
end <- readIORef ref1
let len = Ptr Word8
end Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
buf
hs <- readIORef ref2
return (hs, len)
where
loop :: WriteBuffer
-> IORef (Ptr Word8)
-> IORef [(t, t)]
-> (t -> t -> IO a)
-> [(t, t)]
-> IO ()
loop WriteBuffer
wbuf IORef (Ptr Word8)
ref1 IORef [(t, t)]
ref2 t -> t -> IO a
step [(t, t)]
hsx = [(t, t)] -> IO ()
go [(t, t)]
hsx
where
go :: [(t, t)] -> IO ()
go [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go ((t
t, t
v) : [(t, t)]
hs) = do
_ <- t -> t -> IO a
step t
t t
v
currentOffset wbuf >>= writeIORef ref1
writeIORef ref2 hs
go hs
naiveStep
:: (FieldName -> FieldValue -> IO ()) -> Token -> FieldValue -> IO ()
naiveStep :: FE -> Token -> ByteString -> IO ()
naiveStep FE
fe Token
t ByteString
v = FE
fe (Token -> ByteString
tokenFoldedKey Token
t) ByteString
v
staticStep :: FA -> FD -> FE -> Token -> FieldValue -> IO ()
staticStep :: FA -> FD -> FE -> Token -> ByteString -> IO ()
staticStep FA
fa FD
fd FE
fe Token
t ByteString
v = Token -> ByteString -> FA -> FD -> FE -> IO ()
lookupRevIndex' Token
t ByteString
v FA
fa FD
fd FE
fe
linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> FieldValue -> IO ()
linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> ByteString -> IO ()
linearStep RevIndex
rev FA
fa FB
fb FC
fc FD
fd Token
t ByteString
v = Token -> ByteString -> FA -> FB -> FC -> FD -> RevIndex -> IO ()
lookupRevIndex Token
t ByteString
v FA
fa FB
fb FC
fc FD
fd RevIndex
rev
type FA = HIndex -> IO ()
type FB = FieldValue -> Entry -> HIndex -> IO ()
type FC = FieldName -> FieldValue -> Entry -> IO ()
type FD = FieldValue -> HIndex -> IO ()
type FE = FieldName -> FieldValue -> IO ()
indexedHeaderField
:: DynamicTable -> WriteBuffer -> Bool -> FA
DynamicTable
dyntbl WriteBuffer
wbuf Bool
_ HIndex
hidx =
DynamicTable -> HIndex -> IO Int
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer -> Int -> IO ()
index WriteBuffer
wbuf
literalHeaderFieldWithIncrementalIndexingIndexedName
:: DynamicTable -> WriteBuffer -> Bool -> FB
DynamicTable
dyntbl WriteBuffer
wbuf Bool
huff ByteString
v Entry
ent HIndex
hidx = do
DynamicTable -> HIndex -> IO Int
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer -> Bool -> Int -> Setter -> ByteString -> Int -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Int
6 Setter
set01 ByteString
v
Entry -> DynamicTable -> IO ()
insertEntry Entry
ent DynamicTable
dyntbl
literalHeaderFieldWithIncrementalIndexingNewName
:: DynamicTable -> WriteBuffer -> Bool -> FC
DynamicTable
dyntbl WriteBuffer
wbuf Bool
huff ByteString
k ByteString
v Entry
ent = do
WriteBuffer -> Bool -> Setter -> FE
newName WriteBuffer
wbuf Bool
huff Setter
set01 ByteString
k ByteString
v
Entry -> DynamicTable -> IO ()
insertEntry Entry
ent DynamicTable
dyntbl
literalHeaderFieldWithoutIndexingIndexedName
:: DynamicTable -> WriteBuffer -> Bool -> FD
DynamicTable
dyntbl WriteBuffer
wbuf Bool
huff ByteString
v HIndex
hidx =
DynamicTable -> HIndex -> IO Int
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer -> Bool -> Int -> Setter -> ByteString -> Int -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Int
4 Setter
set0000 ByteString
v
literalHeaderFieldWithoutIndexingNewName
:: DynamicTable -> WriteBuffer -> Bool -> FE
DynamicTable
_ WriteBuffer
wbuf Bool
huff ByteString
k ByteString
v =
WriteBuffer -> Bool -> Setter -> FE
newName WriteBuffer
wbuf Bool
huff Setter
set0000 ByteString
k ByteString
v
literalHeaderFieldWithoutIndexingNewName'
:: DynamicTable -> WriteBuffer -> Bool -> FieldName -> FieldValue -> IO ()
DynamicTable
_ WriteBuffer
wbuf Bool
huff ByteString
k ByteString
v =
WriteBuffer -> Bool -> Setter -> FE
newName WriteBuffer
wbuf Bool
huff Setter
set0000 ByteString
k ByteString
v
{-# INLINE change #-}
change :: WriteBuffer -> Int -> IO ()
change :: WriteBuffer -> Int -> IO ()
change WriteBuffer
wbuf Int
i = WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf Setter
set001 Int
5 Int
i
{-# INLINE index #-}
index :: WriteBuffer -> Int -> IO ()
index :: WriteBuffer -> Int -> IO ()
index WriteBuffer
wbuf Int
i = WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf Setter
set1 Int
7 Int
i
{-# INLINE indexedName #-}
indexedName
:: WriteBuffer -> Bool -> Int -> Setter -> FieldValue -> Index -> IO ()
indexedName :: WriteBuffer -> Bool -> Int -> Setter -> ByteString -> Int -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Int
n Setter
set ByteString
v Int
idx = do
WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf Setter
set Int
n Int
idx
WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
huff ByteString
v
{-# INLINE newName #-}
newName :: WriteBuffer -> Bool -> Setter -> FieldName -> FieldValue -> IO ()
newName :: WriteBuffer -> Bool -> Setter -> FE
newName WriteBuffer
wbuf Bool
huff Setter
set ByteString
k ByteString
v = do
WriteBuffer -> Word8 -> IO ()
write8 WriteBuffer
wbuf (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Setter
set Word8
0
WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
huff ByteString
k
WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
huff ByteString
v
type Setter = Word8 -> Word8
set1, set01, set001, set0000 :: Setter
set1 :: Setter
set1 Word8
x = Word8
x Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
7
set01 :: Setter
set01 Word8
x = Word8
x Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
6
set001 :: Setter
set001 Word8
x = Word8
x Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
5
set0000 :: Setter
set0000 = Setter
forall a. a -> a
id
encodeS
:: WriteBuffer
-> Bool
-> (Word8 -> Word8)
-> (Word8 -> Word8)
-> Int
-> ByteString
-> IO ()
encodeS :: WriteBuffer
-> Bool -> Setter -> Setter -> Int -> ByteString -> IO ()
encodeS WriteBuffer
wbuf Bool
False Setter
set Setter
_ Int
n ByteString
bs = do
let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf Setter
set Int
n Int
len
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
bs
encodeS WriteBuffer
wbuf Bool
True Setter
set Setter
setH Int
n ByteString
bs = do
let origLen :: Int
origLen = ByteString -> Int
BS.length ByteString
bs
expectedLen :: Int
expectedLen = (Int
origLen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
expectedIntLen :: Int
expectedIntLen = Int -> Int -> Int
integerLength Int
n Int
expectedLen
WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf Int
expectedIntLen
len <- WriteBuffer -> ByteString -> IO Int
encodeH WriteBuffer
wbuf ByteString
bs
let intLen = Int -> Int -> Int
integerLength Int
n Int
len
if origLen < len
then do
ff wbuf (negate (expectedIntLen + len))
encodeI wbuf set n origLen
copyByteString wbuf bs
else
if intLen == expectedIntLen
then do
ff wbuf (negate (expectedIntLen + len))
encodeI wbuf (set . setH) n len
ff wbuf len
else do
let gap = Int
intLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
expectedIntLen
shiftLastN wbuf gap len
ff wbuf (negate (intLen + len))
encodeI wbuf (set . setH) n len
ff wbuf len
{-# INLINE encStr #-}
encStr :: WriteBuffer -> Bool -> ByteString -> IO ()
encStr :: WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
h ByteString
bs = WriteBuffer
-> Bool -> Setter -> Setter -> Int -> ByteString -> IO ()
encodeS WriteBuffer
wbuf Bool
h Setter
forall a. a -> a
id (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
7) Int
7 ByteString
bs
encodeString
:: Bool
-> ByteString
-> IO ByteString
encodeString :: Bool -> ByteString -> IO ByteString
encodeString Bool
h ByteString
bs = Int -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer Int
4096 ((WriteBuffer -> IO ()) -> IO ByteString)
-> (WriteBuffer -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
h ByteString
bs
{-# INLINE integerLength #-}
integerLength :: Int -> Int -> Int
integerLength :: Int -> Int -> Int
integerLength Int
8 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
254 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
382 = Int
2
| Bool
otherwise = Int
3
integerLength Int
7 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
126 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
254 = Int
2
| Bool
otherwise = Int
3
integerLength Int
6 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
62 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
190 = Int
2
| Bool
otherwise = Int
3
integerLength Int
5 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
30 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
158 = Int
2
| Bool
otherwise = Int
3
integerLength Int
4 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
14 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
142 = Int
2
| Bool
otherwise = Int
3
integerLength Int
3 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
134 = Int
2
| Bool
otherwise = Int
3
integerLength Int
2 Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
130 = Int
2
| Bool
otherwise = Int
3
integerLength Int
_ Int
l
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int
1
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
128 = Int
2
| Bool
otherwise = Int
3