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

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, memcpy)
import Data.IORef
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Ptr (minusPtr)
import Network.ByteOrder

import Imports
import Network.HPACK.HeaderBlock.Integer
import Network.HPACK.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

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

-- | Converting 'HeaderList' 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
             -> HeaderList
             -> IO ByteString -- ^ An HPACK format
encodeHeader :: EncodeStrategy
-> Size -> DynamicTable -> HeaderList -> IO ByteString
encodeHeader 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


-- | Converting 'HeaderList' 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
-> Size -> DynamicTable -> TokenHeaderList -> IO ByteString
encodeHeader' 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

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

-- | 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
-> Size
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Size)
encodeTokenHeader 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 ()

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

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

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

-- 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 -> HeaderName -> HeaderValue -> 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 -> Size -> IO ()
change WriteBuffer
wbuf Size
i = WriteBuffer -> Setter -> Size -> Size -> IO ()
encodeI 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 ()
encodeI WriteBuffer
wbuf Setter
set1 Size
7 Size
i

-- Using Huffman encoding
{-# 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 ()
encodeI WriteBuffer
wbuf Setter
set Size
n Size
idx
    WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
huff ByteString
v

-- Using Huffman encoding
{-# 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
    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 -> 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
-- 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 -> Size -> ByteString -> IO ()
encodeS WriteBuffer
wbuf Bool
False Setter
set Setter
_ Size
n ByteString
bs = do
    let len :: Size
len = ByteString -> Size
BS.length ByteString
bs
    WriteBuffer -> Setter -> Size -> Size -> IO ()
encodeI WriteBuffer
wbuf Setter
set Size
n Size
len
    WriteBuffer -> ByteString -> IO ()
copyByteString WriteBuffer
wbuf ByteString
bs
encodeS WriteBuffer
wbuf Bool
True  Setter
set Setter
setH Size
n ByteString
bs = 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 -- 80%: decided by examples
        expectedIntLen :: Size
expectedIntLen = Size -> Size -> Size
integerLength Size
n Size
expectedLen
    WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf Size
expectedIntLen
    Size
len <- WriteBuffer -> ByteString -> IO Size
encodeH WriteBuffer
wbuf ByteString
bs
    let intLen :: Size
intLen = Size -> Size -> Size
integerLength Size
n 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 ()
encodeI WriteBuffer
wbuf Setter
set Size
n 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 ()
encodeI WriteBuffer
wbuf (Setter
set Setter -> Setter -> Setter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setter
setH) Size
n 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 ()
encodeI WriteBuffer
wbuf (Setter
set Setter -> Setter -> Setter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setter
setH) Size
n  Size
len
        WriteBuffer -> Size -> IO ()
forall a. Readable a => a -> Size -> IO ()
ff WriteBuffer
wbuf Size
len

{-# INLINE encStr #-}
encStr :: WriteBuffer -> Bool -> ByteString -> IO ()
encStr :: WriteBuffer -> Bool -> ByteString -> IO ()
encStr WriteBuffer
wbuf Bool
h ByteString
bs = WriteBuffer
-> Bool -> Setter -> Setter -> Size -> ByteString -> IO ()
encodeS WriteBuffer
wbuf Bool
h Setter
forall a. a -> a
id (Word8 -> Size -> Word8
forall a. Bits a => a -> Size -> a
`setBit` Size
7) Size
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 = Size -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer Size
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 :: Size -> Size -> Size
integerLength Size
8 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
254  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
382  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
7 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
126  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
254  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
6 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=  Size
62  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
190  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
5 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=  Size
30  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
158  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
4 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=  Size
14  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
142  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
3 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=   Size
6  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
134  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
2 Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=   Size
2  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
130  = Size
2
  | Bool
otherwise = Size
3
integerLength Size
_ Size
l
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<=   Size
0  = Size
1
  | Size
l Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
128  = Size
2
  | Bool
otherwise = Size
3