{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-}
module Network.HPACK.HeaderBlock.Encode (
encodeHeader
, encodeTokenHeader
) where
import Control.Exception (bracket, throwIO)
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Data.ByteString.Internal (create, memcpy)
import Data.IORef
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Ptr (minusPtr)
import Network.ByteOrder
import Imports
import qualified Network.HPACK.HeaderBlock.Integer as I
import qualified Network.HPACK.Huffman as Huffman
import Network.HPACK.Table
import Network.HPACK.Token
import Network.HPACK.Types
changeTableSize :: DynamicTable -> WriteBuffer -> IO ()
changeTableSize :: DynamicTable -> WriteBuffer -> IO ()
changeTableSize DynamicTable
dyntbl WriteBuffer
wbuf = do
TableSizeAction
msiz <- DynamicTable -> IO TableSizeAction
needChangeTableSize DynamicTable
dyntbl
case TableSizeAction
msiz of
TableSizeAction
Keep -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Change Size
lim -> do
Size -> DynamicTable -> IO ()
renewDynamicTable Size
lim DynamicTable
dyntbl
WriteBuffer -> Size -> IO ()
change WriteBuffer
wbuf Size
lim
Ignore Size
lim -> do
DynamicTable -> IO ()
resetLimitForEncoding DynamicTable
dyntbl
WriteBuffer -> Size -> IO ()
change WriteBuffer
wbuf Size
lim
encodeHeader :: EncodeStrategy
-> Size
-> DynamicTable
-> HeaderList
-> IO ByteString
EncodeStrategy
stgy Size
siz DynamicTable
dyntbl HeaderList
hs = EncodeStrategy
-> Size -> DynamicTable -> TokenHeaderList -> IO ByteString
encodeHeader' EncodeStrategy
stgy Size
siz DynamicTable
dyntbl TokenHeaderList
hs'
where
hs' :: TokenHeaderList
hs' = ((ByteString, ByteString) -> (Token, ByteString))
-> HeaderList -> TokenHeaderList
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k,ByteString
v) -> let !t :: Token
t = ByteString -> Token
toToken ByteString
k in (Token
t,ByteString
v)) HeaderList
hs
encodeHeader' :: EncodeStrategy
-> Size
-> DynamicTable
-> TokenHeaderList
-> IO ByteString
EncodeStrategy
stgy Size
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 (Size -> IO (Ptr Word8)
forall a. Size -> IO (Ptr a)
mallocBytes Size
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
(TokenHeaderList
hs',Size
len) <- Ptr Word8
-> Size
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Size)
encodeTokenHeader Ptr Word8
buf Size
siz EncodeStrategy
stgy Bool
True DynamicTable
dyntbl TokenHeaderList
hs
case TokenHeaderList
hs' of
[] -> Size -> (Ptr Word8 -> IO ()) -> IO ByteString
create Size
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 -> Size -> IO ()
memcpy Ptr Word8
p Ptr Word8
buf Size
len
TokenHeaderList
_ -> BufferOverrun -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO BufferOverrun
BufferOverrun
encodeTokenHeader :: Buffer
-> BufferSize
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Ptr Word8
buf Size
siz EncodeStrategy{Bool
CompressionAlgo
useHuffman :: EncodeStrategy -> Bool
compressionAlgo :: EncodeStrategy -> CompressionAlgo
useHuffman :: Bool
compressionAlgo :: CompressionAlgo
..} Bool
first DynamicTable
dyntbl TokenHeaderList
hs0 = do
WriteBuffer
wbuf <- Ptr Word8 -> Size -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf Size
siz
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynamicTable -> WriteBuffer -> IO ()
changeTableSize DynamicTable
dyntbl WriteBuffer
wbuf
let fa :: FA
fa = DynamicTable -> WriteBuffer -> Bool -> FA
indexedHeaderField DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fb :: FB
fb = DynamicTable -> WriteBuffer -> Bool -> FB
literalHeaderFieldWithIncrementalIndexingIndexedName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fc :: FC
fc = DynamicTable -> WriteBuffer -> Bool -> FC
literalHeaderFieldWithIncrementalIndexingNewName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fd :: FD
fd = DynamicTable -> WriteBuffer -> Bool -> FD
literalHeaderFieldWithoutIndexingIndexedName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fe :: FE
fe = DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
fe' :: FE
fe' = DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName' DynamicTable
dyntbl WriteBuffer
wbuf Bool
useHuffman
rev :: RevIndex
rev = DynamicTable -> RevIndex
getRevIndex DynamicTable
dyntbl
step0 :: Token -> ByteString -> IO ()
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
IORef (Ptr Word8)
ref1 <- WriteBuffer -> IO (Ptr Word8)
currentOffset WriteBuffer
wbuf IO (Ptr Word8)
-> (Ptr Word8 -> IO (IORef (Ptr Word8))) -> IO (IORef (Ptr Word8))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Word8 -> IO (IORef (Ptr Word8))
forall a. a -> IO (IORef a)
newIORef
IORef TokenHeaderList
ref2 <- TokenHeaderList -> IO (IORef TokenHeaderList)
forall a. a -> IO (IORef a)
newIORef TokenHeaderList
hs0
WriteBuffer
-> IORef (Ptr Word8)
-> IORef TokenHeaderList
-> (Token -> ByteString -> IO ())
-> TokenHeaderList
-> IO ()
forall t t a.
WriteBuffer
-> IORef (Ptr Word8)
-> IORef [(t, t)]
-> (t -> t -> IO a)
-> [(t, t)]
-> IO ()
loop WriteBuffer
wbuf IORef (Ptr Word8)
ref1 IORef TokenHeaderList
ref2 Token -> ByteString -> IO ()
step0 TokenHeaderList
hs0 IO () -> (BufferOverrun -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \BufferOverrun
BufferOverrun -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Ptr Word8
end <- IORef (Ptr Word8) -> IO (Ptr Word8)
forall a. IORef a -> IO a
readIORef IORef (Ptr Word8)
ref1
let !len :: Size
len = Ptr Word8
end Ptr Word8 -> Ptr Word8 -> Size
forall a b. Ptr a -> Ptr b -> Size
`minusPtr` Ptr Word8
buf
TokenHeaderList
hs <- IORef TokenHeaderList -> IO TokenHeaderList
forall a. IORef a -> IO a
readIORef IORef TokenHeaderList
ref2
(TokenHeaderList, Size) -> IO (TokenHeaderList, Size)
forall (m :: * -> *) a. Monad m => a -> m a
return (TokenHeaderList
hs, Size
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 (m :: * -> *) a. Monad m => a -> m a
return ()
go ((t
t,t
v):[(t, t)]
hs) = do
a
_ <- t -> t -> IO a
step t
t t
v
WriteBuffer -> IO (Ptr Word8)
currentOffset WriteBuffer
wbuf IO (Ptr Word8) -> (Ptr Word8 -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef (Ptr Word8) -> Ptr Word8 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Ptr Word8)
ref1
IORef [(t, t)] -> [(t, t)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(t, t)]
ref2 [(t, t)]
hs
[(t, t)] -> IO ()
go [(t, t)]
hs
naiveStep :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> 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 -> HeaderValue -> 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 -> HeaderValue -> 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 = HeaderValue -> Entry -> HIndex -> IO ()
type FC = HeaderName -> HeaderValue -> Entry -> IO ()
type FD = HeaderValue -> HIndex -> IO ()
type FE = HeaderName -> HeaderValue -> IO ()
indexedHeaderField
:: DynamicTable -> WriteBuffer -> Bool -> FA
DynamicTable
dyntbl WriteBuffer
wbuf Bool
_ HIndex
hidx =
DynamicTable -> HIndex -> IO Size
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Size -> (Size -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer -> Size -> 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 Size
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Size -> (Size -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer
-> Bool -> Size -> Setter -> ByteString -> Size -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Size
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 Size
fromHIndexToIndex DynamicTable
dyntbl HIndex
hidx IO Size -> (Size -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer
-> Bool -> Size -> Setter -> ByteString -> Size -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Size
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 -> HeaderName -> HeaderValue -> 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 -> Size -> IO ()
change WriteBuffer
wbuf Size
i = WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
set001 Size
5 Size
i
{-# INLINE index #-}
index :: WriteBuffer -> Int -> IO ()
index :: WriteBuffer -> Size -> IO ()
index WriteBuffer
wbuf Size
i = WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
set1 Size
7 Size
i
{-# INLINE indexedName #-}
indexedName :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()
indexedName :: WriteBuffer
-> Bool -> Size -> Setter -> ByteString -> Size -> IO ()
indexedName WriteBuffer
wbuf Bool
huff Size
n Setter
set ByteString
v Size
idx = do
WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
set Size
n Size
idx
Bool -> ByteString -> WriteBuffer -> IO ()
encodeString Bool
huff ByteString
v WriteBuffer
wbuf
{-# INLINE newName #-}
newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> 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
Bool -> ByteString -> WriteBuffer -> IO ()
encodeString Bool
huff ByteString
k WriteBuffer
wbuf
Bool -> ByteString -> WriteBuffer -> IO ()
encodeString Bool
huff ByteString
v WriteBuffer
wbuf
type Setter = Word8 -> Word8
set1, set01, set001, set0000, setH :: Setter
set1 :: Setter
set1 Word8
x = Word8
x Word8 -> Size -> Word8
forall a. Bits a => a -> Size -> a
`setBit` Size
7
set01 :: Setter
set01 Word8
x = Word8
x Word8 -> Size -> Word8
forall a. Bits a => a -> Size -> a
`setBit` Size
6
set001 :: Setter
set001 Word8
x = Word8
x Word8 -> Size -> Word8
forall a. Bits a => a -> Size -> a
`setBit` Size
5
set0000 :: Setter
set0000 = Setter
forall a. a -> a
id
setH :: Setter
setH = Setter
set1
{-# INLINE encodeString #-}
encodeString :: Bool -> ByteString -> WriteBuffer -> IO ()
encodeString :: Bool -> ByteString -> WriteBuffer -> IO ()
encodeString Bool
False ByteString
bs WriteBuffer
wbuf = do
let !len :: Size
len = ByteString -> Size
BS.length ByteString
bs
WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
forall a. a -> a
id Size
7 Size
len
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
bs
encodeString Bool
True ByteString
bs WriteBuffer
wbuf = do
let !origLen :: Size
origLen = ByteString -> Size
BS.length ByteString
bs
!expectedLen :: Size
expectedLen = (Size
origLen Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
10) Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
8
!expectedIntLen :: Size
expectedIntLen = Size -> Size
integerLength Size
expectedLen
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf Size
expectedIntLen
Size
len <- HuffmanEncoding
Huffman.encode WriteBuffer
wbuf ByteString
bs
let !intLen :: Size
intLen = Size -> Size
integerLength Size
len
if Size
origLen Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
len then do
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf (Size -> Size
forall a. Num a => a -> a
negate (Size
expectedIntLen Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
len))
WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
forall a. a -> a
id Size
7 Size
origLen
WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
bs
else if Size
intLen Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
expectedIntLen then do
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf (Size -> Size
forall a. Num a => a -> a
negate (Size
expectedIntLen Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
len))
WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
setH Size
7 Size
len
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf Size
len
else do
let !gap :: Size
gap = Size
intLen Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
expectedIntLen
WriteBuffer -> Size -> Size -> IO ()
shiftLastN WriteBuffer
wbuf Size
gap Size
len
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf (Size -> Size
forall a. Num a => a -> a
negate (Size
intLen Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
len))
WriteBuffer -> Setter -> Size -> Size -> IO ()
I.encode WriteBuffer
wbuf Setter
setH Size
7 Size
len
WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf Size
len
{-# INLINE integerLength #-}
integerLength :: Int -> Int
integerLength :: Size -> Size
integerLength Size
n
| Size
n Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
126 = Size
1
| Size
n Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
254 = Size
2
| Bool
otherwise = Size
3