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

module Network.HPACK.HeaderBlock.Encode (
    encodeHeader,
    encodeTokenHeader,
    encodeString,
    encodeS,
) where

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 UnliftIO.Exception (bracket, throwIO)
import qualified UnliftIO.Exception as E

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
    TableSizeAction
msiz <- DynamicTable -> IO TableSizeAction
needChangeTableSize DynamicTable
dyntbl
    case TableSizeAction
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

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

-- | Converting '[Header]' to the HPACK format.
--   This function has overhead of allocating/freeing a temporary buffer.
--   'BufferOverrun' will be thrown if the temporary buffer is too small.
encodeHeader
    :: EncodeStrategy
    -> Size
    -- ^ The size of a temporary buffer.
    -> DynamicTable
    -> [Header]
    -> IO ByteString
    -- ^ An HPACK format
encodeHeader :: EncodeStrategy -> Int -> DynamicTable -> [Header] -> IO ByteString
encodeHeader 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

-- | Converting 'TokenHeaderList' to the HPACK format.
--   'BufferOverrun' will be thrown if the temporary buffer is too small.
encodeHeader'
    :: EncodeStrategy
    -> Size
    -- ^ The size of a temporary buffer.
    -> DynamicTable
    -> TokenHeaderList
    -> IO ByteString
    -- ^ An HPACK format
encodeHeader' :: EncodeStrategy
-> Int -> DynamicTable -> TokenHeaderList -> IO ByteString
encodeHeader' EncodeStrategy
stgy Int
siz DynamicTable
dyntbl TokenHeaderList
hs = IO (Ptr Word8)
-> (Ptr Word8 -> IO ())
-> (Ptr Word8 -> IO ByteString)
-> IO ByteString
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m 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
        (TokenHeaderList
hs', Int
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 TokenHeaderList
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BufferOverrun
BufferOverrun

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

-- | Converting 'TokenHeaderList' to the HPACK format directly in the buffer.
--
--   When calling this function for a new 'TokenHeaderList',
--   4th argument must be 'True'.
--
--   The return value is a pair of leftover 'TokenHeaderList' and
--   how many bytes are filled in the buffer.
--   If the leftover is empty, the encoding is finished.
--   Otherwise, this function should be called with it again.
--   4th argument must be 'False'.
--
--   4th argument is relating to dynamic table size update.
--   If 'True' and the limit is set by 'setLimitForEncoding',
--   dynamic table size update is generated at the beginning of
--   the HPACK format.
encodeTokenHeader
    :: Buffer
    -> BufferSize
    -> EncodeStrategy
    -> Bool
    -- ^ 'True' at the first time, 'False' when continued.
    -> DynamicTable
    -> TokenHeaderList
    -> IO (TokenHeaderList, Int)
    -- ^ Leftover, filled length
encodeTokenHeader :: Ptr Word8
-> Int
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
encodeTokenHeader Ptr Word8
buf Int
siz EncodeStrategy{Bool
CompressionAlgo
compressionAlgo :: CompressionAlgo
useHuffman :: Bool
compressionAlgo :: EncodeStrategy -> CompressionAlgo
useHuffman :: EncodeStrategy -> Bool
..} Bool
first DynamicTable
dyntbl TokenHeaderList
hs0 = do
    WriteBuffer
wbuf <- Ptr Word8 -> Int -> IO WriteBuffer
newWriteBuffer Ptr Word8
buf Int
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 a b. IO a -> (a -> IO b) -> IO b
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 (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \BufferOverrun
BufferOverrun -> () -> IO ()
forall a. a -> IO a
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 :: Int
len = Ptr Word8
end Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
buf
    TokenHeaderList
hs <- IORef TokenHeaderList -> IO TokenHeaderList
forall a. IORef a -> IO a
readIORef IORef TokenHeaderList
ref2
    (TokenHeaderList, Int) -> IO (TokenHeaderList, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TokenHeaderList
hs, Int
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
            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 a b. IO a -> (a -> IO b) -> IO b
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
    :: (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 ()

-- 6.1.  Indexed Header Field Representation
-- Indexed Header Field
indexedHeaderField
    :: DynamicTable -> WriteBuffer -> Bool -> FA
indexedHeaderField :: DynamicTable -> WriteBuffer -> Bool -> FA
indexedHeaderField 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

-- 6.2.1.  Literal Header Field with Incremental Indexing
-- Literal Header Field with Incremental Indexing -- Indexed Name
literalHeaderFieldWithIncrementalIndexingIndexedName
    :: DynamicTable -> WriteBuffer -> Bool -> FB
literalHeaderFieldWithIncrementalIndexingIndexedName :: DynamicTable -> WriteBuffer -> Bool -> FB
literalHeaderFieldWithIncrementalIndexingIndexedName 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

-- 6.2.1.  Literal Header Field with Incremental Indexing
-- Literal Header Field with Incremental Indexing -- New Name
literalHeaderFieldWithIncrementalIndexingNewName
    :: DynamicTable -> WriteBuffer -> Bool -> FC
literalHeaderFieldWithIncrementalIndexingNewName :: DynamicTable -> WriteBuffer -> Bool -> FC
literalHeaderFieldWithIncrementalIndexingNewName 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

-- 6.2.2.  Literal Header Field without Indexing
-- Literal Header Field without Indexing -- Indexed Name
literalHeaderFieldWithoutIndexingIndexedName
    :: DynamicTable -> WriteBuffer -> Bool -> FD
literalHeaderFieldWithoutIndexingIndexedName :: DynamicTable -> WriteBuffer -> Bool -> FD
literalHeaderFieldWithoutIndexingIndexedName 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

-- 6.2.2.  Literal Header Field without Indexing
-- Literal Header Field without Indexing -- New Name
literalHeaderFieldWithoutIndexingNewName
    :: DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName :: DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName 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 ()
literalHeaderFieldWithoutIndexingNewName' :: DynamicTable -> WriteBuffer -> Bool -> FE
literalHeaderFieldWithoutIndexingNewName' 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

-- Using Huffman encoding
{-# 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

-- Using Huffman encoding
{-# 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

-- Assuming MSBs are 0.
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
-- set0001 x = x `setBit` 4 -- Never indexing
set0000 :: Setter
set0000 = Setter
forall a. a -> a
id

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

-- | String encoding.
--   The algorithm based on copy avoidance and
--   selection of better result of huffman or raw.
encodeS
    :: WriteBuffer
    -> Bool
    -- ^ Use Huffman if efficient
    -> (Word8 -> Word8)
    -- ^ Setting prefix
    -> (Word8 -> Word8)
    -- ^ Setting huffman flag
    -> Int
    -- ^ N+
    -> ByteString
    -- ^ Target
    -> 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 -- 80%: decided by examples
        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
    Int
len <- WriteBuffer -> ByteString -> IO Int
encodeH WriteBuffer
wbuf ByteString
bs
    let intLen :: Int
intLen = Int -> Int -> Int
integerLength Int
n Int
len
    if Int
origLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
        then do
            WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf (Int -> Int
forall a. Num a => a -> a
negate (Int
expectedIntLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len))
            WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf Setter
set Int
n Int
origLen
            WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
bs
        else
            if Int
intLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedIntLen
                then do
                    WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf (Int -> Int
forall a. Num a => a -> a
negate (Int
expectedIntLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len))
                    WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf (Setter
set Setter -> Setter -> Setter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setter
setH) Int
n Int
len
                    WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf Int
len
                else do
                    let gap :: Int
gap = Int
intLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
expectedIntLen
                    WriteBuffer -> Int -> Int -> IO ()
shiftLastN WriteBuffer
wbuf Int
gap Int
len
                    WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf (Int -> Int
forall a. Num a => a -> a
negate (Int
intLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len))
                    WriteBuffer -> Setter -> Int -> Int -> IO ()
encodeI WriteBuffer
wbuf (Setter
set Setter -> Setter -> Setter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setter
setH) Int
n Int
len
                    WriteBuffer -> Int -> IO ()
forall a. Readable a => a -> Int -> IO ()
ff WriteBuffer
wbuf Int
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

-- | String encoding (7+) with a temporary buffer whose size is 4096.
encodeString
    :: Bool
    -- ^ Use Huffman if efficient
    -> ByteString
    -- ^ Target
    -> 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

{-
N+   1   2     3 <- bytes
8  254 382 16638
7  126 254 16510
6   62 190 16446
5   30 158 16414
4   14 142 16398
3    6 134 16390
2    2 130 16386
1    0 128 16384
-}

{-# 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