diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.5.0 + +* New API for HPACK. HPACK is much faster than 1.4.x (roughly x3.2). + The default encoding is now Linear instead of LinearH. + ## 1.4.5 * Removing zero reset from priority queues. diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -3,25 +3,26 @@ -- | HPACK() encoding and decoding a header list. module Network.HPACK ( -- * Encoding and decoding - HPACKEncoding - , HPACKDecoding - , encodeHeader + encodeHeader , decodeHeader - -- * Encoding with builders - , HPACKEncodingBuilder - , encodeHeaderBuilder + -- * Encoding in a buffer + , encodeHeaderBuffer -- * DynamicTable , DynamicTable , defaultDynamicTableSize , newDynamicTableForEncoding , newDynamicTableForDecoding + , clearDynamicTable + , withDynamicTableForEncoding + , withDynamicTableForDecoding , setLimitForEncoding -- * Strategy for encoding , CompressionAlgo(..) , EncodeStrategy(..) , defaultEncodeStrategy - -- * Errors for decoding + -- * Errors , DecodeError(..) + , BufferOverrun(..) -- * Headers , HeaderList , Header @@ -30,17 +31,15 @@ -- * Basic types , Size , Index + , Buffer + , BufferSize ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif -import Control.Arrow (second) -import Control.Exception (throwIO) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteString, fromByteString, toBuilder) -import Network.HPACK.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding, setLimitForEncoding) +import Network.HPACK.HeaderBlock +import Network.HPACK.Table import Network.HPACK.Types -- | Default dynamic table size. @@ -50,37 +49,3 @@ -- 4096 defaultDynamicTableSize :: Int defaultDynamicTableSize = 4096 - ----------------------------------------------------------------- - --- | HPACK encoding from 'HeaderList' to 'ByteString'. -type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteString) - --- | HPACK encoding from 'HeaderList' to 'Builder'. -type HPACKEncodingBuilder = DynamicTable -> HeaderList -> IO (DynamicTable, Builder) - --- | HPACK decoding from 'ByteString' to 'HeaderList'. -type HPACKDecoding = DynamicTable -> ByteString -> IO (DynamicTable, HeaderList) - ----------------------------------------------------------------- - --- | Converting 'HeaderList' for HTTP header to the low level format. -encodeHeader :: EncodeStrategy -> HPACKEncoding -encodeHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs - where - algo = compressionAlgo stgy - toBS = toByteString (useHuffman stgy) - --- | Converting 'HeaderList' for HTTP header to bytestring builder. -encodeHeaderBuilder :: EncodeStrategy -> HPACKEncodingBuilder -encodeHeaderBuilder stgy ctx hs = second toBB <$> toHeaderBlock algo ctx hs - where - algo = compressionAlgo stgy - toBB = toBuilder (useHuffman stgy) - --- | Converting the low level format for HTTP header to 'HeaderList'. --- 'DecodeError' would be thrown. -decodeHeader :: HPACKDecoding -decodeHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb - where - ehb = fromByteString bs diff --git a/Network/HPACK/Buffer.hs b/Network/HPACK/Buffer.hs new file mode 100644 --- /dev/null +++ b/Network/HPACK/Buffer.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, CPP #-} + +module Network.HPACK.Buffer ( + Buffer + , BufferSize + , WorkingBuffer + , newWorkingBuffer + , wind + , readWord8 + , writeWord8 + , shiftLastN + , returnLength + , toByteString + , copyByteString + , withTemporaryBuffer + , currentOffset + , ReadBuffer + , withReadBuffer + , hasOneByte + , hasMoreBytes + , rewindOneByte + , getByte + , extractByteString + ) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Exception (bracket, throwIO) +import Data.ByteString.Internal (ByteString(..), create, memcpy) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') +import Data.Word (Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc +import Foreign.Ptr (plusPtr, minusPtr) +import Foreign.Storable (peek, poke) +import Network.HPACK.Types (Buffer, BufferSize, BufferOverrun(..)) + +---------------------------------------------------------------- + +data WorkingBuffer = WorkingBuffer { + start :: !Buffer + , limit :: !Buffer + , offset :: !(IORef Buffer) + } + +newWorkingBuffer :: Buffer -> BufferSize -> IO WorkingBuffer +newWorkingBuffer buf siz = WorkingBuffer buf (buf `plusPtr` siz) <$> newIORef buf + +{-# INLINE wind #-} +wind :: WorkingBuffer -> Int -> IO () +wind WorkingBuffer{..} n = do + ptr <- readIORef offset + let !ptr' = ptr `plusPtr` n + writeIORef offset ptr' + +{-# INLINE readWord8 #-} +readWord8 :: WorkingBuffer -> IO Word8 +readWord8 WorkingBuffer{..} = readIORef offset >>= peek + +{-# INLINE writeWord8 #-} +writeWord8 :: WorkingBuffer -> Word8 -> IO () +writeWord8 WorkingBuffer{..} w = do + ptr <- readIORef offset + if ptr >= limit then + throwIO BufferOverrun + else do + poke ptr w + let !ptr' = ptr `plusPtr` 1 + writeIORef offset ptr' + +{-# INLINE shiftLastN #-} +shiftLastN :: WorkingBuffer -> Int -> Int -> IO () +shiftLastN WorkingBuffer{..} i len = do + ptr <- readIORef offset + let !src = ptr `plusPtr` negate len + !dst = src `plusPtr` i + !ptr' = ptr `plusPtr` i + if ptr' >= limit then + throwIO BufferOverrun + else do + memcpy dst src len + writeIORef offset ptr' + +{-# INLINE copyByteString #-} +copyByteString :: WorkingBuffer -> ByteString -> IO () +copyByteString WorkingBuffer{..} (PS fptr off len) = withForeignPtr fptr $ \ptr -> do + let src = ptr `plusPtr` off + dst <- readIORef offset + let !dst' = dst `plusPtr` len + if dst' >= limit then + throwIO BufferOverrun + else do + memcpy dst src len + writeIORef offset dst' + +toByteString :: WorkingBuffer -> IO ByteString +toByteString WorkingBuffer{..} = do + ptr <- readIORef offset + let !len = ptr `minusPtr` start + create len $ \p -> memcpy p start len + +{-# INLINE returnLength #-} +returnLength :: WorkingBuffer -> IO () -> IO Int +returnLength WorkingBuffer{..} body = do + beg <- readIORef offset + body + end <- readIORef offset + return $ end `minusPtr` beg + +withTemporaryBuffer :: Int -> (WorkingBuffer -> IO ()) -> IO ByteString +withTemporaryBuffer siz action = bracket (mallocBytes siz) free $ \buf -> do + wbuf <- newWorkingBuffer buf 4096 + action wbuf + toByteString wbuf + +currentOffset :: WorkingBuffer -> IO Buffer +currentOffset WorkingBuffer{..} = readIORef offset + +---------------------------------------------------------------- + +data ReadBuffer = ReadBuffer { + beg :: !Buffer + , end :: !Buffer + , cur :: !(IORef Buffer) + } + +withReadBuffer :: ByteString -> (ReadBuffer -> IO a) -> IO a +withReadBuffer (PS fp off len) action = withForeignPtr fp $ \ptr -> do + let !bg = ptr `plusPtr` off + !ed = bg `plusPtr` len + nsrc <- ReadBuffer bg ed <$> newIORef bg + action nsrc + +{-# INLINE hasOneByte #-} +hasOneByte :: ReadBuffer -> IO Bool +hasOneByte ReadBuffer{..} = do + ptr <- readIORef cur + return $! ptr < end + +{-# INLINE hasMoreBytes #-} +hasMoreBytes :: ReadBuffer -> Int -> IO Bool +hasMoreBytes ReadBuffer{..} n = do + ptr <- readIORef cur + return $! (end `minusPtr` ptr) >= n + +{-# INLINE rewindOneByte #-} +rewindOneByte :: ReadBuffer -> IO () +rewindOneByte ReadBuffer{..} = modifyIORef' cur (`plusPtr` (-1)) + +{-# INLINE getByte #-} +getByte :: ReadBuffer -> IO Word8 +getByte ReadBuffer{..} = do + ptr <- readIORef cur + w <- peek ptr + writeIORef cur $! ptr `plusPtr` 1 + return w + +extractByteString :: ReadBuffer -> Int -> IO ByteString +extractByteString ReadBuffer{..} len = do + src <- readIORef cur + bs <- create len $ \dst -> memcpy dst src len + writeIORef cur $! src `plusPtr` len + return bs diff --git a/Network/HPACK/Builder/Word8.hs b/Network/HPACK/Builder/Word8.hs deleted file mode 100644 --- a/Network/HPACK/Builder/Word8.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Network.HPACK.Builder.Word8 where - -import Data.ByteString.Internal (ByteString, unsafeCreate) -import Data.Word (Word8) -import Foreign.Storable (poke) -import Foreign.Ptr (plusPtr) - -data Word8Builder = Word8Builder !Int ([Word8] -> [Word8]) - -(<|) :: Word8Builder -> Word8 -> Word8Builder -Word8Builder i b <| w = Word8Builder (i+1) $ b . (w :) - -w8empty :: Word8Builder -w8empty = Word8Builder 0 id - -{- -singleton :: Word8 -> Word8Builder -singleton x = Word8Builder 1 (x :) --} - -toByteString :: Word8Builder -> ByteString -toByteString (Word8Builder i b) = unsafeCreate i $ \ptr -> go ptr ws - where - ws = b [] - go _ [] = return () - go ptr (x:xs) = do - poke ptr x - go (ptr `plusPtr` 1) xs diff --git a/Network/HPACK/HeaderBlock.hs b/Network/HPACK/HeaderBlock.hs --- a/Network/HPACK/HeaderBlock.hs +++ b/Network/HPACK/HeaderBlock.hs @@ -1,18 +1,8 @@ module Network.HPACK.HeaderBlock ( - -- * Types for header block - module Network.HPACK.HeaderBlock.HeaderField - -- * Header block from/to Low level - , toByteString - , fromByteString - , fromByteStringDebug - , toBuilder - -- * Header block from/to header list - , toHeaderBlock - , fromHeaderBlock + decodeHeader + , encodeHeader + , encodeHeaderBuffer ) where import Network.HPACK.HeaderBlock.Decode import Network.HPACK.HeaderBlock.Encode -import Network.HPACK.HeaderBlock.From -import Network.HPACK.HeaderBlock.HeaderField -import Network.HPACK.HeaderBlock.To diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -1,121 +1,133 @@ +{-# LANGUAGE BangPatterns, CPP #-} + module Network.HPACK.HeaderBlock.Decode ( - fromByteString - , fromByteStringDebug + decodeHeader ) where +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Exception (throwIO) +import Control.Monad (unless) import Data.Bits (testBit, clearBit, (.&.)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Word (Word8) +import Network.HPACK.Buffer import Network.HPACK.Builder -import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I -import qualified Network.HPACK.HeaderBlock.String as S +import Network.HPACK.Huffman +import Network.HPACK.Table import Network.HPACK.Types ---------------------------------------------------------------- --- | Converting the low level format to 'HeaderBlock'. -fromByteString :: ByteString -> Either DecodeError HeaderBlock -fromByteString inp = go inp empty +-- | Converting the HPACK format to 'HeaderList'. +-- 'DecodeError' would be thrown if the HPACK format is broken. +-- 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. +decodeHeader :: DynamicTable + -> ByteString -- ^ An HPACK format + -> IO HeaderList +decodeHeader dyntbl inp = withReadBuffer inp $ \rbuf -> chkChange rbuf where - go bs builder - | BS.null bs = Right $ run builder - | otherwise = do - (hf, bs') <- toHeaderField bs - go bs' (builder << hf) + chkChange rbuf = do + more <- hasOneByte rbuf + if more then do + w <- getByte rbuf + if isTableSizeUpdate w then do + tableSizeUpdate dyntbl w rbuf + chkChange rbuf + else do + rewindOneByte rbuf + go rbuf empty + else + return [] + go rbuf builder = do + more <- hasOneByte rbuf + if more then do + w <- getByte rbuf + !kv <- toHeader dyntbl w rbuf + let builder' = builder << kv + go rbuf builder' + else + return $! run builder --- | Converting the low level format to 'HeaderBlock'. --- 'HeaderBlock' forms a pair with corresponding 'ByteString'. -fromByteStringDebug :: ByteString -> Either DecodeError [(ByteString,HeaderField)] -fromByteStringDebug inp = go inp empty - where - go bs builder - | BS.null bs = Right $ run builder - | otherwise = do - (hf, bs') <- toHeaderField bs - let len = BS.length bs - BS.length bs' - consumed = BS.take len bs - go bs' (builder << (consumed,hf)) +toHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO Header +toHeader dyntbl w rbuf + | w `testBit` 7 = indexed dyntbl w rbuf + | w `testBit` 6 = incrementalIndexing dyntbl w rbuf + | w `testBit` 5 = throwIO IllegalTableSizeUpdate + | w `testBit` 4 = neverIndexing dyntbl w rbuf + | otherwise = withoutIndexing dyntbl w rbuf -toHeaderField :: ByteString - -> Either DecodeError (HeaderField, ByteString) -toHeaderField bs - | BS.null bs = Left EmptyBlock - | w `testBit` 7 = indexed w bs' - | w `testBit` 6 = incrementalIndexing w bs' - | w `testBit` 5 = maxSize w bs' - | w `testBit` 4 = neverIndexing w bs' - | otherwise = withoutIndexing w bs' - where - w = BS.head bs - bs' = BS.tail bs +tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO () +tableSizeUpdate dyntbl w rbuf = do + let !w' = mask5 w + !siz <- I.decode 5 w' rbuf + suitable <- isSuitableSize siz dyntbl + unless suitable $ throwIO TooLargeTableSize + renewDynamicTable siz dyntbl ---------------------------------------------------------------- -indexed :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) -indexed w ws = Right (Indexed idx , ws') - where - w' = clearBit w 7 - (idx, ws') = I.parseInteger 7 w' ws - -incrementalIndexing :: Word8 -> ByteString - -> Either DecodeError (HeaderField, ByteString) -incrementalIndexing w ws - | isIndexedName1 w = indexedName Add w ws 6 mask6 - | otherwise = newName Add ws +indexed :: DynamicTable -> Word8 -> ReadBuffer -> IO Header +indexed dyntbl w rbuf = do + let !w' = clearBit w 7 + !idx <- I.decode 7 w' rbuf + fromEntry <$> toIndexedEntry dyntbl idx -maxSize :: Word8 -> ByteString -> Either DecodeError (HeaderField, ByteString) -maxSize w ws = Right (ChangeTableSize siz, ws') - where - w' = mask5 w - (siz, ws') = I.parseInteger 5 w' ws +incrementalIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO Header +incrementalIndexing dyntbl w rbuf = do + kv <- if isIndexedName1 w then + indexedName dyntbl w rbuf 6 mask6 + else + newName dyntbl rbuf + let !e = toEntry kv + insertEntry e dyntbl + return kv -withoutIndexing :: Word8 -> ByteString - -> Either DecodeError (HeaderField, ByteString) -withoutIndexing w ws - | isIndexedName2 w = indexedName NotAdd w ws 4 mask4 - | otherwise = newName NotAdd ws +withoutIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO Header +withoutIndexing dyntbl w rbuf + | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4 + | otherwise = newName dyntbl rbuf -neverIndexing :: Word8 -> ByteString - -> Either DecodeError (HeaderField, ByteString) -neverIndexing w ws - | isIndexedName2 w = indexedName Never w ws 4 mask4 - | otherwise = newName Never ws +neverIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO Header +neverIndexing dyntbl w rbuf + | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4 + | otherwise = newName dyntbl rbuf ---------------------------------------------------------------- -indexedName :: Indexing -> Word8 -> ByteString -> Int -> (Word8 -> Word8) - -> Either DecodeError (HeaderField, ByteString) -indexedName indexing w ws n mask = do - (val,ws'') <- headerStuff ws' - let hf = Literal indexing (Idx idx) val - return (hf, ws'') - where - p = mask w - (idx,ws') = I.parseInteger n p ws +indexedName :: DynamicTable -> Word8 -> ReadBuffer + -> Int -> (Word8 -> Word8) + -> IO Header +indexedName dyntbl w rbuf n mask = do + let !p = mask w + !idx <- I.decode n p rbuf + !key <- entryHeaderName <$> toIndexedEntry dyntbl idx + !val <- headerStuff dyntbl rbuf + let !kv = (key,val) + return kv -newName :: Indexing -> ByteString - -> Either DecodeError (HeaderField, ByteString) -newName indexing ws = do - (key,ws') <- headerStuff ws - (val,ws'') <- headerStuff ws' - let hf = Literal indexing (Lit key) val - return (hf, ws'') +newName :: DynamicTable -> ReadBuffer -> IO Header +newName dyntbl rbuf = do + !key <- headerStuff dyntbl rbuf + !val <- headerStuff dyntbl rbuf + let !kv = (key,val) + return kv ---------------------------------------------------------------- -headerStuff :: ByteString - -> Either DecodeError (HeaderStuff, ByteString) -headerStuff bs - | BS.null bs = Left EmptyEncodedString - | otherwise = S.parseString huff len bs'' - where - w = BS.head bs - bs' = BS.tail bs - p = dropHuffman w - huff = isHuffman w - (len, bs'') = I.parseInteger 7 p bs' +headerStuff :: DynamicTable -> ReadBuffer -> IO HeaderStuff +headerStuff dyntbl rbuf = do + more <- hasOneByte rbuf + if more then do + w <- getByte rbuf + let !p = dropHuffman w + !huff = isHuffman w + !len <- I.decode 7 p rbuf + decodeString huff (huffmanDecoder dyntbl) rbuf len + else + throwIO EmptyEncodedString ---------------------------------------------------------------- @@ -134,6 +146,9 @@ isIndexedName2 :: Word8 -> Bool isIndexedName2 w = mask4 w /= 0 +isTableSizeUpdate :: Word8 -> Bool +isTableSizeUpdate w = w .&. 0xe0 == 0x20 + ---------------------------------------------------------------- isHuffman :: Word8 -> Bool @@ -141,3 +156,16 @@ dropHuffman :: Word8 -> Word8 dropHuffman w = w `clearBit` 7 + +---------------------------------------------------------------- + +decodeString :: Bool -> HuffmanDecoding -> ReadBuffer -> Int -> IO HeaderStuff +decodeString huff hufdec rbuf len = do + more <- hasMoreBytes rbuf len + if more then + if huff then + hufdec rbuf len + else + extractByteString rbuf len + else + throwIO HeaderBlockTruncated diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -1,109 +1,222 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Encode ( - toByteString - , toBuilder + encodeHeader + , encodeHeaderBuffer ) where -import Data.Bits (setBit) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Prim as P -import qualified Data.ByteString.Lazy as BL -import Data.List (foldl') #if __GLASGOW_HASKELL__ < 709 -import Data.Monoid (mempty) +import Control.Applicative ((<$>)) #endif -import Data.Monoid ((<>)) +import Control.Exception (bracket, try, throwIO) +import Control.Monad (when) +import Data.Bits (setBit) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString, create, memcpy) import Data.Word (Word8) -import Network.HPACK.HeaderBlock.HeaderField +import Foreign.Marshal.Alloc +import Foreign.Ptr (minusPtr) +import Network.HPACK.Buffer import qualified Network.HPACK.HeaderBlock.Integer as I -import qualified Network.HPACK.HeaderBlock.String as S +import qualified Network.HPACK.Huffman as Huffman +import Network.HPACK.Table +import Network.HPACK.Types ---------------------------------------------------------------- --- | Converting 'HeaderBlock' to the low level format. -toByteString :: Bool -> HeaderBlock -> ByteString -toByteString huff hbs = BL.toStrict $ BB.toLazyByteString $ toBuilder huff hbs +changeTableSize :: DynamicTable -> WorkingBuffer -> IO () +changeTableSize dyntbl wbuf = do + msiz <- needChangeTableSize dyntbl + case msiz of + Keep -> return () + Change lim -> do + renewDynamicTable lim dyntbl + change wbuf lim + Ignore lim -> do + resetLimitForEncoding dyntbl + change wbuf lim -toBuilder :: Bool -> [HeaderField] -> Builder -toBuilder huff hbs = foldl' op mempty hbs +---------------------------------------------------------------- + +-- | 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 + -> HeaderList + -> IO ByteString -- ^ An HPACK format +encodeHeader stgy siz dyntbl hs = bracket (mallocBytes siz) free enc where - b `op` x = b <> toBB x - toBB = fromHeaderField huff + enc buf = do + (hs',len) <- encodeHeaderBuffer buf siz stgy True dyntbl hs + case hs' of + [] -> create len $ \p -> memcpy p buf len + _ -> throwIO BufferOverrun -fromHeaderField :: Bool -> HeaderField -> Builder -fromHeaderField _ (ChangeTableSize siz) = change siz -fromHeaderField _ (Indexed idx) = index idx -fromHeaderField huff (Literal Add (Idx idx) v) = indexedName huff 6 set01 idx v -fromHeaderField huff (Literal Add (Lit key) v) = newName huff set01 key v -fromHeaderField huff (Literal NotAdd (Idx idx) v) = indexedName huff 4 set0000 idx v -fromHeaderField huff (Literal NotAdd (Lit key) v) = newName huff set0000 key v -fromHeaderField huff (Literal Never (Idx idx) v) = indexedName huff 4 set0001 idx v -fromHeaderField huff (Literal Never (Lit key) v) = newName huff set0001 key v +---------------------------------------------------------------- +-- | Converting 'HeaderList' to the HPACK format directly in the buffer. +-- +-- 4th argument is relating to dynamic table size update. +-- When calling this function for a new 'HeaderList', +-- it must be 'True'. +-- If 'True' and set by 'setLimitForEncoding', +-- dynamic table size update is generated at the beginning of +-- the HPACK format. +-- +-- If the buffer for encoding is small, leftover 'HeaderList' will +-- be returned. In this case, this function should be called with it +-- again. 4th argument must be 'False'. +-- +encodeHeaderBuffer :: Buffer + -> BufferSize + -> EncodeStrategy + -> Bool -- ^ 'True' at the first time, 'False' when continued. + -> DynamicTable + -> HeaderList + -> IO (HeaderList, Int) -- ^ Leftover 'HeaderList' and the number of filled bytes. +encodeHeaderBuffer buf siz EncodeStrategy{..} first dyntbl hs0 = do + let step = case compressionAlgo of + Naive -> naiveStep useHuffman + Static -> staticStep useHuffman + Linear -> linearStep useHuffman + wbuf <- newWorkingBuffer buf siz + when first $ changeTableSize dyntbl wbuf + loop wbuf step hs0 + where + loop wbuf _ [] = do + end <- currentOffset wbuf + let !len = end `minusPtr` buf + return ([], len) + loop wbuf step hhs@(h:hs) = do + end <- currentOffset wbuf + ex <- try $ step dyntbl wbuf h + case ex of + Right () -> loop wbuf step hs + Left BufferOverrun -> do + let !len = end `minusPtr` buf + return (hhs,len) + ---------------------------------------------------------------- -word8s :: [Word8] -> Builder -word8s = P.primMapListFixed P.word8 +naiveStep :: Bool -> DynamicTable -> WorkingBuffer -> Header -> IO () +naiveStep huff _dyntbl wbuf (k,v) = newName wbuf huff set0000 k v -change :: Int -> Builder -change i = word8s (w':ws) - where - (w:ws) = I.encode 5 i - w' = set001 w +---------------------------------------------------------------- -index :: Int -> Builder -index i = word8s (w':ws) - where - (w:ws) = I.encode 7 i - w' = set1 w +staticStep :: Bool -> DynamicTable -> WorkingBuffer -> Header -> IO () +staticStep huff dyntbl wbuf h@(k,v) = do + let ent = toEntryToken h + res <- lookupRevIndex ent $ getRevIndex dyntbl + case res of + (KV hidx,_) -> fromHIndexToIndex dyntbl hidx >>= index wbuf + (K hidx,_) -> fromHIndexToIndex dyntbl hidx + >>= indexedName wbuf huff 4 set0000 v + (N,_ ) -> newName wbuf huff set0000 k v +---------------------------------------------------------------- + +linearStep :: Bool -> DynamicTable -> WorkingBuffer -> Header -> IO () +linearStep huff dyntbl wbuf h@(k,v) = do + let ent = toEntryToken h + res <- lookupRevIndex ent $ getRevIndex dyntbl + case res of + (KV hidx,_) -> + -- 6.1. Indexed Header Field Representation + -- Indexed Header Field + fromHIndexToIndex dyntbl hidx >>= index wbuf + (K hidx, True) -> do + -- 6.2.1. Literal Header Field with Incremental Indexing + -- Literal Header Field with Incremental Indexing + -- -- Indexed Name + fromHIndexToIndex dyntbl hidx >>= indexedName wbuf huff 6 set01 v + insertEntry ent dyntbl + (N, True) -> do + -- 6.2.1. Literal Header Field with Incremental Indexing + -- Literal Header Field with Incremental Indexing -- New Name + newName wbuf huff set01 k v + insertEntry ent dyntbl + (K hidx, False) -> + -- 6.2.2. Literal Header Field without Indexing + -- Literal Header Field without Indexing -- Indexed Name + fromHIndexToIndex dyntbl hidx + >>= indexedName wbuf huff 4 set0000 v + (N, False) -> + -- 6.2.2. Literal Header Field without Indexing + -- Literal Header Field without Indexing -- New Name + newName wbuf huff set0000 k v + +---------------------------------------------------------------- + +{-# INLINE change #-} +change :: WorkingBuffer -> Int -> IO () +change wbuf i = I.encode wbuf set001 5 i + +{-# INLINE index #-} +index :: WorkingBuffer -> Int -> IO () +index wbuf i = I.encode wbuf set1 7 i + -- Using Huffman encoding -indexedName :: Bool -> Int -> Setter -> Int -> HeaderValue -> Builder -indexedName huff n set idx v = pre <> vlen <> val - where - (p:ps) = I.encode n idx - pre = word8s $ set p : ps - value = S.encode huff v - valueLen = BS.length value - vlen - | huff = word8s $ setH $ I.encode 7 valueLen - | otherwise = word8s $ I.encode 7 valueLen - val = BB.byteString value +{-# INLINE indexedName #-} +indexedName :: WorkingBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO () +indexedName wbuf huff n set v idx = do + I.encode wbuf set n idx + encodeString huff v wbuf -- Using Huffman encoding -newName :: Bool -> Setter -> HeaderName -> HeaderValue -> Builder -newName huff set k v = pre <> klen <> key <> vlen <> val - where - pre = BB.word8 $ set 0 - key0 = S.encode huff k - keyLen = BS.length key0 - value = S.encode huff v - valueLen = BS.length value - klen - | huff = word8s $ setH $ I.encode 7 keyLen - | otherwise = word8s $ I.encode 7 keyLen - vlen - | huff = word8s $ setH $ I.encode 7 valueLen - | otherwise = word8s $ I.encode 7 valueLen - key = BB.byteString key0 - val = BB.byteString value +{-# INLINE newName #-} +newName :: WorkingBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO () +newName wbuf huff set k v = do + writeWord8 wbuf $ set 0 + encodeString huff k wbuf + encodeString huff v wbuf ---------------------------------------------------------------- type Setter = Word8 -> Word8 -- Assuming MSBs are 0. -set1, set01, set001, set0001, set0000 :: Setter +set1, set01, set001, set0000, setH :: Setter set1 x = x `setBit` 7 set01 x = x `setBit` 6 set001 x = x `setBit` 5 -set0001 x = x `setBit` 4 +-- set0001 x = x `setBit` 4 -- Never indexing set0000 = id +setH = set1 -setH :: [Word8] -> [Word8] -setH [] = error "setH" -setH (x:xs) = (x `setBit` 7) : xs +---------------------------------------------------------------- + +{-# INLINE encodeString #-} +encodeString :: Bool -> ByteString -> WorkingBuffer -> IO () +encodeString False bs wbuf = do + let !len = BS.length bs + I.encode wbuf id 7 len + copyByteString wbuf bs +encodeString True bs wbuf = do + let !origLen = BS.length bs + !expectedLen = (origLen `div` 10) * 8 -- 80%: decided by examples + !expectedIntLen = integerLength expectedLen + wind wbuf expectedIntLen + len <- Huffman.encode wbuf bs + let !intLen = integerLength len + if intLen == expectedIntLen then do + wind wbuf (negate (expectedIntLen + len)) + I.encode wbuf setH 7 len + wind wbuf len + else do + let !gap = intLen - expectedIntLen + shiftLastN wbuf gap len + wind wbuf (negate (intLen + len)) + I.encode wbuf setH 7 len + wind wbuf len + +-- For 7+: +-- 1 byte: 0 - 126 +-- 2 bytes: 127 - 254 +-- 3 bytes: 255 - 16510 +{-# INLINE integerLength #-} +integerLength :: Int -> Int +integerLength n + | n <= 126 = 1 + | n <= 254 = 2 + | otherwise = 3 diff --git a/Network/HPACK/HeaderBlock/From.hs b/Network/HPACK/HeaderBlock/From.hs deleted file mode 100644 --- a/Network/HPACK/HeaderBlock/From.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - -module Network.HPACK.HeaderBlock.From ( - fromHeaderBlock - , decodeStep - ) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>)) -#endif -import Control.Exception (throwIO) -import Control.Monad (unless) -import Network.HPACK.Builder -import Network.HPACK.HeaderBlock.HeaderField -import Network.HPACK.Table -import Network.HPACK.Types - ----------------------------------------------------------------- - -type Ctx = (DynamicTable, Builder Header, Bool) -type Step = Ctx -> HeaderField -> IO Ctx - --- | Decoding 'HeaderBlock' to 'HeaderList'. -fromHeaderBlock :: DynamicTable - -> HeaderBlock - -> IO (DynamicTable, HeaderList) -fromHeaderBlock !dyntbl rs = decodeLoop rs (dyntbl,empty,True) - ----------------------------------------------------------------- - -decodeLoop :: HeaderBlock -> Ctx -> IO (DynamicTable, HeaderList) -decodeLoop (r:rs) !dyntbl = decodeStep dyntbl r >>= decodeLoop rs -decodeLoop [] !dyntbl = decodeFinal dyntbl - ----------------------------------------------------------------- - --- | Decoding step for one 'HeaderField'. Exporting for the --- test purpose. -decodeStep :: Step -decodeStep (!dyntbl,!builder,beginning) (ChangeTableSize siz) - | beginning = do - unless (isSuitableSize siz dyntbl) $ throwIO TooLargeTableSize - dyntbl' <- renewDynamicTable siz dyntbl - return (dyntbl',builder,True) - | otherwise = throwIO IllegalTableSizeUpdate -decodeStep (!dyntbl,!builder,_) (Indexed idx) = do - w <- which dyntbl idx - case w of - (InStaticTable, e) -> do - let b = builder << fromEntry e - return (dyntbl,b,False) - (InDynamicTable, e) -> do - let b = builder << fromEntry e - return (dyntbl,b,False) -decodeStep (!dyntbl,!builder,_) (Literal NotAdd naming v) = do - k <- fromNaming naming dyntbl - let b = builder << (k,v) - return (dyntbl, b, False) -decodeStep (!dyntbl,!builder,_) (Literal Never naming v) = do - k <- fromNaming naming dyntbl - let b = builder << (k,v) - return (dyntbl, b, False) -decodeStep (!dyntbl,!builder,_) (Literal Add naming v) = do - k <- fromNaming naming dyntbl - let h = (k,v) - e = toEntry h - b = builder << h - dyntbl' <- insertEntry e dyntbl - return (dyntbl',b,False) - -decodeFinal :: Ctx -> IO (DynamicTable, HeaderList) -decodeFinal (!dyntbl,!builder,_) = return (dyntbl, run builder) - ----------------------------------------------------------------- - -fromNaming :: Naming -> DynamicTable -> IO HeaderName -fromNaming (Lit k) _ = return k -fromNaming (Idx idx) dyntbl = entryHeaderName . snd <$> which dyntbl idx diff --git a/Network/HPACK/HeaderBlock/HeaderField.hs b/Network/HPACK/HeaderBlock/HeaderField.hs deleted file mode 100644 --- a/Network/HPACK/HeaderBlock/HeaderField.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Network.HPACK.HeaderBlock.HeaderField ( - -- * Type - HeaderBlock - , emptyHeaderBlock - , HeaderField(..) - , HeaderName -- re-exporting - , HeaderValue -- re-exporting - , Index -- re-exporting - , Indexing(..) - , Naming(..) - ) where - -import Network.HPACK.Types - ----------------------------------------------------------------- - --- | Type for header block. -type HeaderBlock = [HeaderField] - --- | Empty header block. -emptyHeaderBlock :: HeaderBlock -emptyHeaderBlock = [] - --- | Type for representation. -data HeaderField = ChangeTableSize !Int - | Indexed !Index - | Literal !Indexing !Naming !HeaderValue - deriving (Eq,Show) - --- | Whether or not adding to a table. -data Indexing = Add | NotAdd | Never deriving (Eq,Show) - --- | Index or literal. -data Naming = Idx !Index | Lit !HeaderName deriving (Eq,Show) diff --git a/Network/HPACK/HeaderBlock/Integer.hs b/Network/HPACK/HeaderBlock/Integer.hs --- a/Network/HPACK/HeaderBlock/Integer.hs +++ b/Network/HPACK/HeaderBlock/Integer.hs @@ -1,22 +1,24 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Network.HPACK.HeaderBlock.Integer ( encode + , encodeInteger , decode - , parseInteger + , decodeInteger ) where +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif import Data.Array (Array, listArray, (!)) -import Data.Bits ((.&.), shiftR) +import Data.Bits ((.&.), shiftR, testBit) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Word (Word8) +import Network.HPACK.Buffer -- $setup -- >>> import qualified Data.ByteString as BS ----------------------------------------------------------------- - powerArray :: Array Int Int powerArray = listArray (1,8) [1,3,7,15,31,63,127,255] @@ -33,29 +35,27 @@ encode I on 8 bits -} --- | Integer encoding. The first argument is N of prefix. --- --- >>> encode 5 10 --- [10] --- >>> encode 5 1337 --- [31,154,10] --- >>> encode 8 42 --- [42] -encode :: Int -> Int -> [Word8] -encode n i - | i < p = fromIntegral i : [] - | otherwise = fromIntegral p : encode' (i - p) - where - p = powerArray ! n +encodeInteger :: Int -> Int -> IO ByteString +encodeInteger n i = withTemporaryBuffer 4096 $ \wbuf -> encode wbuf id n i -encode' :: Int -> [Word8] -encode' i - | i < 128 = fromIntegral i : [] - | otherwise = fromIntegral (r + 128) : encode' q +{-# INLINABLE encode #-} +encode :: WorkingBuffer -> (Word8 -> Word8) -> Int -> Int -> IO () +encode wbuf set n i + | i < p = writeWord8 wbuf $ set $ fromIntegral i + | otherwise = do + writeWord8 wbuf $ set $ fromIntegral p + encode' (i - p) where --- (q,r) = i `divMod` 128 - q = i `shiftR` 7 - r = i .&. 0x7f + p = powerArray ! n + encode' :: Int -> IO () + encode' j + | j < 128 = writeWord8 wbuf $ fromIntegral j + | otherwise = do + writeWord8 wbuf $ fromIntegral (r + 128) + encode' q + where + q = j `shiftR` 7 + r = j .&. 0x7f ---------------------------------------------------------------- @@ -74,44 +74,28 @@ -- | Integer decoding. The first argument is N of prefix. -- --- >>> decode 5 10 $ BS.empty +-- >>> decodeInteger 5 10 $ BS.empty -- 10 --- >>> decode 5 31 $ BS.pack [154,10] +-- >>> decodeInteger 5 31 $ BS.pack [154,10] -- 1337 --- >>> decode 8 42 $ BS.empty +-- >>> decodeInteger 8 42 $ BS.empty -- 42 -decode :: Int -> Word8 -> ByteString -> Int -decode n w bs - | i < p = i - | BS.null bs = error $ "decode: n = " ++ show n ++ ", w = " ++ show w ++ ", bs = empty" - | otherwise = decode' bs 0 i - where - p = powerArray ! n - i = fromIntegral w - -decode' :: ByteString -> Int -> Int -> Int -decode' "" _ i = i -decode' bs m i = decode' bs' m' i' - where - !b = fromIntegral $ BS.head bs - !bs' = BS.tail bs - !i' = i + (b .&. 127) * 2 ^ m - !m' = m + 7 - ----------------------------------------------------------------- +decodeInteger :: Int -> Word8 -> ByteString -> IO Int +decodeInteger n w bs = withReadBuffer bs $ \rbuf -> decode n w rbuf --- | --- --- >>> parseInteger 7 127 $ BS.pack [210,211,212,87,88,89,90] --- (183839313,"XYZ") -parseInteger :: Int -> Word8 -> ByteString -> (Int, ByteString) -parseInteger n w bs - | i < p = (i, bs) - | otherwise = (len, rest) +{-# INLINABLE decode #-} +-- | Integer decoding. The first argument is N of prefix. +decode :: Int -> Word8 -> ReadBuffer -> IO Int +decode n w rbuf + | i < p = return i + | otherwise = decode' 0 i where p = powerArray ! n i = fromIntegral w - Just idx = BS.findIndex (< 128) bs - (bs', rest) = BS.splitAt (idx + 1) bs - len = decode n w bs' - + decode' :: Int -> Int -> IO Int + decode' m j = do + !b <- fromIntegral <$> getByte rbuf + let !j' = j + (b .&. 0x7f) * 2 ^ m + !m' = m + 7 + !cont = b `testBit` 7 + if cont then decode' m' j' else return j' diff --git a/Network/HPACK/HeaderBlock/String.hs b/Network/HPACK/HeaderBlock/String.hs deleted file mode 100644 --- a/Network/HPACK/HeaderBlock/String.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Network.HPACK.HeaderBlock.String ( - encode - , parseString - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Network.HPACK.Huffman as Huffman -import Network.HPACK.Types - --- | Encoding 'HeaderStuff' to 'ByteString' according to 'HuffmanEncoding'. -encode :: Bool -> HeaderStuff -> ByteString -encode True h = Huffman.encode h -encode _ h = h - --- | Parsing 'HeaderStuff' from 'ByteString'. --- The second 'Bool' is whether or not huffman encoding is used. --- The third 'Int' is the length of the encoded string. -parseString :: Bool -> Int -> ByteString - -> Either DecodeError (HeaderStuff, ByteString) -parseString False len bs = Right (es, bs') - where - (es, bs') = BS.splitAt len bs -parseString True len bs = Huffman.decode es >>= \x -> return (x,bs') - where - (es, bs') = BS.splitAt len bs diff --git a/Network/HPACK/HeaderBlock/To.hs b/Network/HPACK/HeaderBlock/To.hs deleted file mode 100644 --- a/Network/HPACK/HeaderBlock/To.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} - -module Network.HPACK.HeaderBlock.To ( - toHeaderBlock - ) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>)) -#endif -import Control.Arrow (second) -import Network.HPACK.Builder -import Network.HPACK.HeaderBlock.HeaderField -import Network.HPACK.Table -import Network.HPACK.Types - -type Ctx = (DynamicTable, Builder HeaderField) -type Step = Ctx -> Header -> IO Ctx - --- | Encoding 'HeaderList' to 'HeaderBlock'. -toHeaderBlock :: CompressionAlgo - -> DynamicTable - -> HeaderList - -> IO (DynamicTable, HeaderBlock) -toHeaderBlock algo !dyntbl hs = do - msiz <- needChangeTableSize dyntbl - (dyntbl', op) <- case msiz of - Keep -> do - return (dyntbl, id) - Change lim -> do - tbl <- renewDynamicTable lim dyntbl - return (tbl, (ChangeTableSize lim :)) - Ignore lim -> do - resetLimitForEncoding dyntbl - return (dyntbl, (ChangeTableSize lim :)) - second op <$> toHeaderBlock' algo dyntbl' hs - -toHeaderBlock' :: CompressionAlgo - -> DynamicTable - -> HeaderList - -> IO (DynamicTable, HeaderBlock) -toHeaderBlock' Naive !dyntbl hs = encodeLoop naiveStep hs (dyntbl,empty) -toHeaderBlock' Static !dyntbl hs = encodeLoop staticStep hs (dyntbl,empty) -toHeaderBlock' Linear !dyntbl hs = encodeLoop linearStep hs (dyntbl,empty) - ----------------------------------------------------------------- - -encodeFinal :: Ctx -> IO (DynamicTable, HeaderBlock) -encodeFinal (!dyntbl, !builder) = return (dyntbl, run builder) - -encodeLoop :: Step - -> HeaderList - -> Ctx - -> IO (DynamicTable, HeaderBlock) -encodeLoop step (h:hs) !dyntbl = step dyntbl h >>= encodeLoop step hs -encodeLoop _ [] !dyntbl = encodeFinal dyntbl - ----------------------------------------------------------------- - -naiveStep :: Step -naiveStep (!dyntbl,!builder) (k,v) = do - let builder' = builder << Literal NotAdd (Lit k) v - return (dyntbl, builder') - ----------------------------------------------------------------- - -staticStep :: Step -staticStep (!dyntbl,!builder) h@(k,v) = return (dyntbl, builder') - where - b = case lookupTable h dyntbl of - None -> Literal NotAdd (Lit k) v - KeyOnly InStaticTable i -> Literal NotAdd (Idx i) v - KeyOnly InDynamicTable _ -> Literal NotAdd (Lit k) v - KeyValue InStaticTable i -> Literal NotAdd (Idx i) v - KeyValue InDynamicTable _ -> Literal NotAdd (Lit k) v - builder' = builder << b - ----------------------------------------------------------------- --- A simple encoding strategy to reset the reference set first --- by 'Index 0' and uses indexing as much as possible. - -linearStep :: Step -linearStep cb@(!dyntbl,!builder) h = smartStep linear cb h - where - linear i = return (dyntbl,builder << Indexed i) - ----------------------------------------------------------------- - -smartStep :: (Index -> IO Ctx) -> Step -smartStep func cb@(!dyntbl,!builder) h@(k,_) = do - let cache = lookupTable h dyntbl - case cache of - None -> check cb h (Lit k) - KeyOnly InStaticTable i -> check cb h (Idx i) - KeyOnly InDynamicTable i -> check cb h (Idx i) - KeyValue InStaticTable i -> return (dyntbl, builder << Indexed i) - KeyValue InDynamicTable i -> func i - -check :: Ctx -> Header -> Naming -> IO Ctx -check (dyntbl,builder) h@(k,v) x - | k `elem` headersNotToIndex = do - let builder' = builder << Literal NotAdd x v - return (dyntbl, builder') - | otherwise = do - let e = toEntry h - dyntbl' <- insertEntry e dyntbl - let builder' = builder << Literal Add x v - return (dyntbl', builder') - -headersNotToIndex :: [HeaderName] -headersNotToIndex = [ - ":path" - , "content-length" - , "location" - , "etag" - , "set-cookie" - ] diff --git a/Network/HPACK/Huffman.hs b/Network/HPACK/Huffman.hs --- a/Network/HPACK/Huffman.hs +++ b/Network/HPACK/Huffman.hs @@ -4,7 +4,9 @@ , HuffmanDecoding -- * Encoding/decoding , encode + , encodeHuffman , decode + , decodeHuffman ) where import Network.HPACK.Huffman.Decode diff --git a/Network/HPACK/Huffman/Decode.hs b/Network/HPACK/Huffman/Decode.hs --- a/Network/HPACK/Huffman/Decode.hs +++ b/Network/HPACK/Huffman/Decode.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + module Network.HPACK.Huffman.Decode ( -- * Huffman decoding HuffmanDecoding , decode + , decodeHuffman ) where -import Data.ByteString (ByteString) +import Control.Exception (throwIO) import Data.Array (Array, (!), listArray) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) import Data.Word (Word8) -import Network.HPACK.Builder.Word8 +import Network.HPACK.Buffer import Network.HPACK.Huffman.Bit -import Network.HPACK.Huffman.ByteString import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table import Network.HPACK.Huffman.Tree @@ -18,7 +22,7 @@ ---------------------------------------------------------------- -- | Huffman decoding. -type HuffmanDecoding = ByteString -> Either DecodeError ByteString +type HuffmanDecoding = ReadBuffer -> Int -> IO ByteString ---------------------------------------------------------------- @@ -26,35 +30,53 @@ | Forward {-# UNPACK #-} !Word8 -- node no. | GoBack {-# UNPACK #-} !Word8 -- node no. {-# UNPACK #-} !Word8 -- a decoded value + | GoBack2 {-# UNPACK #-} !Word8 -- node no. + {-# UNPACK #-} !Word8 -- a decoded value + {-# UNPACK #-} !Word8 -- a decoded value deriving Show -data Way16 = Way16 !(Maybe Int) !(Array Word8 Pin) -type Way256 = Array Word8 Way16 +data WayStep = WayStep !(Maybe Int) !(Array Word8 Pin) +type Way256 = Array Word8 WayStep -next :: Way16 -> Word8 -> Pin -next (Way16 _ a16) w = a16 ! w +next :: WayStep -> Word8 -> Pin +next (WayStep _ a16) w = a16 ! w ---------------------------------------------------------------- -- | Huffman decoding. -decode :: HuffmanDecoding -decode bs = dec qs - where - qs = unpack4bits bs +decode :: Buffer -> BufferSize -> HuffmanDecoding +decode buf siz rbuf len = do + wbuf <- newWorkingBuffer buf siz + dec wbuf rbuf len + toByteString wbuf -dec :: [Word8] -> Either DecodeError ByteString -dec inp = go (way256 ! 0) inp w8empty +dec :: WorkingBuffer -> ReadBuffer -> Int -> IO () +dec wbuf rbuf len = go len (way256 ! 0) where - go :: Way16 -> [Word8] -> Word8Builder -> Either DecodeError ByteString - go (Way16 Nothing _) [] _ = Left IllegalEos - go (Way16 (Just i) _) [] builder - | i <= 8 = Right $ toByteString builder - | otherwise = Left TooLongEos - go way (w:ws) builder = case next way w of - EndOfString -> Left EosInTheMiddle - Forward n -> go (way256 ! n) ws builder - GoBack n v -> go (way256 ! n) ws (builder <| v) + go 0 way0 = case way0 of + WayStep Nothing _ -> throwIO IllegalEos + WayStep (Just i) _ + | i <= 8 -> return () + | otherwise -> throwIO TooLongEos + go !n !way0 = do + w <- getByte rbuf + way <- doit way0 w + go (n - 1) way + doit !way !w = case next way w of + EndOfString -> throwIO EosInTheMiddle + Forward n -> return $ way256 ! n + GoBack n v -> do + writeWord8 wbuf v + return $ way256 ! n + GoBack2 n v1 v2 -> do + writeWord8 wbuf v1 + writeWord8 wbuf v2 + return $ way256 ! n +decodeHuffman :: ByteString -> IO ByteString +decodeHuffman bs = withTemporaryBuffer 4096 $ \wbuf -> + withReadBuffer bs $ \rbuf -> dec wbuf rbuf (BS.length bs) + ---------------------------------------------------------------- way256 :: Way256 @@ -63,37 +85,289 @@ construct :: HTree -> Way256 construct decoder = listArray (0,255) $ map to16ways $ flatten decoder where - to16ways x = Way16 ei a16 + to16ways x = WayStep ei a16 where - ei = eosInfo x - a16 = listArray (0,15) $ map (step decoder x Nothing) bits4s + !ei = eosInfo x + !a16 = listArray (0,255) $ map (step decoder x Non) bits8s -step :: HTree -> HTree -> Maybe Word8 -> [B] -> Pin -step root (Tip _ v) _ bss +data Chara = Non + | One !Word8 + | Two !Word8 !Word8 + +inc :: Chara -> Word8 -> Chara +inc Non w = One w +inc (One v) w = Two v w +inc _ _ = error "inc" + +step :: HTree -> HTree -> Chara -> [B] -> Pin +step root (Tip _ v) x bss | v == idxEos = EndOfString - | otherwise = let w = fromIntegral v - in step root root (Just w) bss -step _ (Bin _ n _ _) Nothing [] = Forward (fromIntegral n) -step _ (Bin _ n _ _) (Just w) [] = GoBack (fromIntegral n) w -step root (Bin _ _ l _) mx (F:bs) = step root l mx bs -step root (Bin _ _ _ r) mx (T:bs) = step root r mx bs + | otherwise = let !w = fromIntegral v + !x' = inc x w + in step root root x' bss +step _ (Bin _ n _ _) Non [] = Forward (fromIntegral n) +step _ (Bin _ n _ _) (One w) [] = GoBack (fromIntegral n) w +step _ (Bin _ n _ _) (Two w z) [] = GoBack2 (fromIntegral n) w z +step root (Bin _ _ l _) mx (F:bs) = step root l mx bs +step root (Bin _ _ _ r) mx (T:bs) = step root r mx bs -bits4s :: [[B]] -bits4s = [ - [F,F,F,F] - , [F,F,F,T] - , [F,F,T,F] - , [F,F,T,T] - , [F,T,F,F] - , [F,T,F,T] - , [F,T,T,F] - , [F,T,T,T] - , [T,F,F,F] - , [T,F,F,T] - , [T,F,T,F] - , [T,F,T,T] - , [T,T,F,F] - , [T,T,F,T] - , [T,T,T,F] - , [T,T,T,T] +bits8s :: [[B]] +bits8s = [ + [F,F,F,F,F,F,F,F] + , [F,F,F,F,F,F,F,T] + , [F,F,F,F,F,F,T,F] + , [F,F,F,F,F,F,T,T] + , [F,F,F,F,F,T,F,F] + , [F,F,F,F,F,T,F,T] + , [F,F,F,F,F,T,T,F] + , [F,F,F,F,F,T,T,T] + , [F,F,F,F,T,F,F,F] + , [F,F,F,F,T,F,F,T] + , [F,F,F,F,T,F,T,F] + , [F,F,F,F,T,F,T,T] + , [F,F,F,F,T,T,F,F] + , [F,F,F,F,T,T,F,T] + , [F,F,F,F,T,T,T,F] + , [F,F,F,F,T,T,T,T] + , [F,F,F,T,F,F,F,F] + , [F,F,F,T,F,F,F,T] + , [F,F,F,T,F,F,T,F] + , [F,F,F,T,F,F,T,T] + , [F,F,F,T,F,T,F,F] + , [F,F,F,T,F,T,F,T] + , [F,F,F,T,F,T,T,F] + , [F,F,F,T,F,T,T,T] + , [F,F,F,T,T,F,F,F] + , [F,F,F,T,T,F,F,T] + , [F,F,F,T,T,F,T,F] + , [F,F,F,T,T,F,T,T] + , [F,F,F,T,T,T,F,F] + , [F,F,F,T,T,T,F,T] + , [F,F,F,T,T,T,T,F] + , [F,F,F,T,T,T,T,T] + , [F,F,T,F,F,F,F,F] + , [F,F,T,F,F,F,F,T] + , [F,F,T,F,F,F,T,F] + , [F,F,T,F,F,F,T,T] + , [F,F,T,F,F,T,F,F] + , [F,F,T,F,F,T,F,T] + , [F,F,T,F,F,T,T,F] + , [F,F,T,F,F,T,T,T] + , [F,F,T,F,T,F,F,F] + , [F,F,T,F,T,F,F,T] + , [F,F,T,F,T,F,T,F] + , [F,F,T,F,T,F,T,T] + , [F,F,T,F,T,T,F,F] + , [F,F,T,F,T,T,F,T] + , [F,F,T,F,T,T,T,F] + , [F,F,T,F,T,T,T,T] + , [F,F,T,T,F,F,F,F] + , [F,F,T,T,F,F,F,T] + , [F,F,T,T,F,F,T,F] + , [F,F,T,T,F,F,T,T] + , [F,F,T,T,F,T,F,F] + , [F,F,T,T,F,T,F,T] + , [F,F,T,T,F,T,T,F] + , [F,F,T,T,F,T,T,T] + , [F,F,T,T,T,F,F,F] + , [F,F,T,T,T,F,F,T] + , [F,F,T,T,T,F,T,F] + , [F,F,T,T,T,F,T,T] + , [F,F,T,T,T,T,F,F] + , [F,F,T,T,T,T,F,T] + , [F,F,T,T,T,T,T,F] + , [F,F,T,T,T,T,T,T] + , [F,T,F,F,F,F,F,F] + , [F,T,F,F,F,F,F,T] + , [F,T,F,F,F,F,T,F] + , [F,T,F,F,F,F,T,T] + , [F,T,F,F,F,T,F,F] + , [F,T,F,F,F,T,F,T] + , [F,T,F,F,F,T,T,F] + , [F,T,F,F,F,T,T,T] + , [F,T,F,F,T,F,F,F] + , [F,T,F,F,T,F,F,T] + , [F,T,F,F,T,F,T,F] + , [F,T,F,F,T,F,T,T] + , [F,T,F,F,T,T,F,F] + , [F,T,F,F,T,T,F,T] + , [F,T,F,F,T,T,T,F] + , [F,T,F,F,T,T,T,T] + , [F,T,F,T,F,F,F,F] + , [F,T,F,T,F,F,F,T] + , [F,T,F,T,F,F,T,F] + , [F,T,F,T,F,F,T,T] + , [F,T,F,T,F,T,F,F] + , [F,T,F,T,F,T,F,T] + , [F,T,F,T,F,T,T,F] + , [F,T,F,T,F,T,T,T] + , [F,T,F,T,T,F,F,F] + , [F,T,F,T,T,F,F,T] + , [F,T,F,T,T,F,T,F] + , [F,T,F,T,T,F,T,T] + , [F,T,F,T,T,T,F,F] + , [F,T,F,T,T,T,F,T] + , [F,T,F,T,T,T,T,F] + , [F,T,F,T,T,T,T,T] + , [F,T,T,F,F,F,F,F] + , [F,T,T,F,F,F,F,T] + , [F,T,T,F,F,F,T,F] + , [F,T,T,F,F,F,T,T] + , [F,T,T,F,F,T,F,F] + , [F,T,T,F,F,T,F,T] + , [F,T,T,F,F,T,T,F] + , [F,T,T,F,F,T,T,T] + , [F,T,T,F,T,F,F,F] + , [F,T,T,F,T,F,F,T] + , [F,T,T,F,T,F,T,F] + , [F,T,T,F,T,F,T,T] + , [F,T,T,F,T,T,F,F] + , [F,T,T,F,T,T,F,T] + , [F,T,T,F,T,T,T,F] + , [F,T,T,F,T,T,T,T] + , [F,T,T,T,F,F,F,F] + , [F,T,T,T,F,F,F,T] + , [F,T,T,T,F,F,T,F] + , [F,T,T,T,F,F,T,T] + , [F,T,T,T,F,T,F,F] + , [F,T,T,T,F,T,F,T] + , [F,T,T,T,F,T,T,F] + , [F,T,T,T,F,T,T,T] + , [F,T,T,T,T,F,F,F] + , [F,T,T,T,T,F,F,T] + , [F,T,T,T,T,F,T,F] + , [F,T,T,T,T,F,T,T] + , [F,T,T,T,T,T,F,F] + , [F,T,T,T,T,T,F,T] + , [F,T,T,T,T,T,T,F] + , [F,T,T,T,T,T,T,T] + , [T,F,F,F,F,F,F,F] + , [T,F,F,F,F,F,F,T] + , [T,F,F,F,F,F,T,F] + , [T,F,F,F,F,F,T,T] + , [T,F,F,F,F,T,F,F] + , [T,F,F,F,F,T,F,T] + , [T,F,F,F,F,T,T,F] + , [T,F,F,F,F,T,T,T] + , [T,F,F,F,T,F,F,F] + , [T,F,F,F,T,F,F,T] + , [T,F,F,F,T,F,T,F] + , [T,F,F,F,T,F,T,T] + , [T,F,F,F,T,T,F,F] + , [T,F,F,F,T,T,F,T] + , [T,F,F,F,T,T,T,F] + , [T,F,F,F,T,T,T,T] + , [T,F,F,T,F,F,F,F] + , [T,F,F,T,F,F,F,T] + , [T,F,F,T,F,F,T,F] + , [T,F,F,T,F,F,T,T] + , [T,F,F,T,F,T,F,F] + , [T,F,F,T,F,T,F,T] + , [T,F,F,T,F,T,T,F] + , [T,F,F,T,F,T,T,T] + , [T,F,F,T,T,F,F,F] + , [T,F,F,T,T,F,F,T] + , [T,F,F,T,T,F,T,F] + , [T,F,F,T,T,F,T,T] + , [T,F,F,T,T,T,F,F] + , [T,F,F,T,T,T,F,T] + , [T,F,F,T,T,T,T,F] + , [T,F,F,T,T,T,T,T] + , [T,F,T,F,F,F,F,F] + , [T,F,T,F,F,F,F,T] + , [T,F,T,F,F,F,T,F] + , [T,F,T,F,F,F,T,T] + , [T,F,T,F,F,T,F,F] + , [T,F,T,F,F,T,F,T] + , [T,F,T,F,F,T,T,F] + , [T,F,T,F,F,T,T,T] + , [T,F,T,F,T,F,F,F] + , [T,F,T,F,T,F,F,T] + , [T,F,T,F,T,F,T,F] + , [T,F,T,F,T,F,T,T] + , [T,F,T,F,T,T,F,F] + , [T,F,T,F,T,T,F,T] + , [T,F,T,F,T,T,T,F] + , [T,F,T,F,T,T,T,T] + , [T,F,T,T,F,F,F,F] + , [T,F,T,T,F,F,F,T] + , [T,F,T,T,F,F,T,F] + , [T,F,T,T,F,F,T,T] + , [T,F,T,T,F,T,F,F] + , [T,F,T,T,F,T,F,T] + , [T,F,T,T,F,T,T,F] + , [T,F,T,T,F,T,T,T] + , [T,F,T,T,T,F,F,F] + , [T,F,T,T,T,F,F,T] + , [T,F,T,T,T,F,T,F] + , [T,F,T,T,T,F,T,T] + , [T,F,T,T,T,T,F,F] + , [T,F,T,T,T,T,F,T] + , [T,F,T,T,T,T,T,F] + , [T,F,T,T,T,T,T,T] + , [T,T,F,F,F,F,F,F] + , [T,T,F,F,F,F,F,T] + , [T,T,F,F,F,F,T,F] + , [T,T,F,F,F,F,T,T] + , [T,T,F,F,F,T,F,F] + , [T,T,F,F,F,T,F,T] + , [T,T,F,F,F,T,T,F] + , [T,T,F,F,F,T,T,T] + , [T,T,F,F,T,F,F,F] + , [T,T,F,F,T,F,F,T] + , [T,T,F,F,T,F,T,F] + , [T,T,F,F,T,F,T,T] + , [T,T,F,F,T,T,F,F] + , [T,T,F,F,T,T,F,T] + , [T,T,F,F,T,T,T,F] + , [T,T,F,F,T,T,T,T] + , [T,T,F,T,F,F,F,F] + , [T,T,F,T,F,F,F,T] + , [T,T,F,T,F,F,T,F] + , [T,T,F,T,F,F,T,T] + , [T,T,F,T,F,T,F,F] + , [T,T,F,T,F,T,F,T] + , [T,T,F,T,F,T,T,F] + , [T,T,F,T,F,T,T,T] + , [T,T,F,T,T,F,F,F] + , [T,T,F,T,T,F,F,T] + , [T,T,F,T,T,F,T,F] + , [T,T,F,T,T,F,T,T] + , [T,T,F,T,T,T,F,F] + , [T,T,F,T,T,T,F,T] + , [T,T,F,T,T,T,T,F] + , [T,T,F,T,T,T,T,T] + , [T,T,T,F,F,F,F,F] + , [T,T,T,F,F,F,F,T] + , [T,T,T,F,F,F,T,F] + , [T,T,T,F,F,F,T,T] + , [T,T,T,F,F,T,F,F] + , [T,T,T,F,F,T,F,T] + , [T,T,T,F,F,T,T,F] + , [T,T,T,F,F,T,T,T] + , [T,T,T,F,T,F,F,F] + , [T,T,T,F,T,F,F,T] + , [T,T,T,F,T,F,T,F] + , [T,T,T,F,T,F,T,T] + , [T,T,T,F,T,T,F,F] + , [T,T,T,F,T,T,F,T] + , [T,T,T,F,T,T,T,F] + , [T,T,T,F,T,T,T,T] + , [T,T,T,T,F,F,F,F] + , [T,T,T,T,F,F,F,T] + , [T,T,T,T,F,F,T,F] + , [T,T,T,T,F,F,T,T] + , [T,T,T,T,F,T,F,F] + , [T,T,T,T,F,T,F,T] + , [T,T,T,T,F,T,T,F] + , [T,T,T,T,F,T,T,T] + , [T,T,T,T,T,F,F,F] + , [T,T,T,T,T,F,F,T] + , [T,T,T,T,T,F,T,F] + , [T,T,T,T,T,F,T,T] + , [T,T,T,T,T,T,F,F] + , [T,T,T,T,T,T,F,T] + , [T,T,T,T,T,T,T,F] + , [T,T,T,T,T,T,T,T] ] + diff --git a/Network/HPACK/Huffman/Encode.hs b/Network/HPACK/Huffman/Encode.hs --- a/Network/HPACK/Huffman/Encode.hs +++ b/Network/HPACK/Huffman/Encode.hs @@ -4,25 +4,22 @@ -- * Huffman encoding HuffmanEncoding , encode + , encodeHuffman ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif -import Control.Monad (when) +import Control.Monad (when, void) import Data.Array import Data.Bits ((.|.)) import qualified Data.ByteString as BS -import Data.ByteString.Internal (ByteString(..), create) +import Data.ByteString.Internal (ByteString(..)) import Data.Word (Word8) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek, poke) +import Network.HPACK.Buffer import Network.HPACK.Huffman.Bit -import Network.HPACK.Huffman.ByteString import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table -import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- @@ -30,9 +27,9 @@ type ShiftedArray = Array Int Shifted -data Shifted = Shifted !Int -- Total bytes - !Int -- How many bits in the last byte - !ByteString -- Up to 5 bytes +data Shifted = Shifted !Int -- How many bits in the last byte + !Word8 -- First word. If Int is 0, this is dummy + !ByteString -- Following words, up to 4 bytes deriving Show ---------------------------------------------------------------- @@ -43,22 +40,20 @@ -- | -- -- >>> toShifted [T,T,T,T] 0 --- Shifted 1 4 "\240" +-- Shifted 4 240 "" -- >>> toShifted [T,T,T,T] 4 --- Shifted 1 0 "\SI" +-- Shifted 0 15 "" -- >>> toShifted [T,T,T,T] 5 --- Shifted 2 1 "\a\128" +-- Shifted 1 7 "\128" toShifted :: Bits -> Int -> Shifted -toShifted bits n = Shifted total r bs +toShifted bits n = Shifted r w bs where shifted = replicate n F ++ bits len = length shifted - (q,r) = len `divMod` 8 - total - | r == 0 = q - | otherwise = q + 1 - bs = BS.pack $ map fromBits $ group8 shifted + !r = len `mod` 8 + bs0 = BS.pack $ map fromBits $ group8 shifted + (!w,!bs) = (BS.head bs0, BS.tail bs0) group8 xs | null zs = pad ys : [] | otherwise = ys : group8 zs @@ -66,52 +61,40 @@ (ys,zs) = splitAt 8 xs pad xs = take 8 $ xs ++ repeat F - toShiftedArray :: Bits -> ShiftedArray toShiftedArray bits = listArray (0,7) $ map (toShifted bits) [0..7] ---------------------------------------------------------------- -- | Huffman encoding. -type HuffmanEncoding = ByteString -> ByteString +type HuffmanEncoding = WorkingBuffer -> ByteString -> IO Int -- | Huffman encoding. encode :: HuffmanEncoding -encode (PS fptr off len) = unsafePerformIO $ withForeignPtr fptr $ \ptr -> do - let beg = ptr `plusPtr` off - end = beg `plusPtr` len - size <- accumSize beg end 0 0 - create size (\dst -> go dst 0 beg end) +encode dst bs = withReadBuffer bs $ enc dst + +enc :: WorkingBuffer -> ReadBuffer -> IO Int +enc dst rbuf = returnLength dst $ go 0 where - accumSize :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO Int - accumSize src lim n acc - | src == lim = return acc - | otherwise = do - i <- fromIntegral <$> peek src - let Shifted l n' _ = (aosa ! i) ! n - let !acc' - | n == 0 = acc + l - | otherwise = acc + l - 1 - accumSize (src `plusPtr` 1) lim n' acc' - go :: Ptr Word8 -> Int -> Ptr Word8 -> Ptr Word8 -> IO () - go dst n src lim - | src == lim = do - when (n /= 0) $ do - let Shifted _ _ bs = (aosa ! idxEos) ! n - w0 <- peek dst - let w1 = BS.head bs - poke dst (w0 .|. w1) - | otherwise = do - i <- fromIntegral <$> peek src - let Shifted l n' bs = (aosa ! i) ! n - if n == 0 then - copy dst bs - else do - w0 <- peek dst - copy dst bs - w1 <- peek dst - poke dst (w0 .|. w1) - let dst' - | n' == 0 = dst `plusPtr` l - | otherwise = dst `plusPtr` (l - 1) - go dst' n' (src `plusPtr` 1) lim + go n = do + more <- hasOneByte rbuf + if more then do + !i <- fromIntegral <$> getByte rbuf + let Shifted n' b bs = (aosa ! i) ! n + if n == 0 then + writeWord8 dst b + else do + b0 <- readWord8 dst + writeWord8 dst (b0 .|. b) + copyByteString dst bs + when (n' /= 0) $ wind dst (-1) + go n' + else + when (n /= 0) $ do + let Shifted _ b _ = (aosa ! idxEos) ! n + b0 <- readWord8 dst + writeWord8 dst (b0 .|. b) + +encodeHuffman :: ByteString -> IO ByteString +encodeHuffman bs = withTemporaryBuffer 4096 $ \wbuf -> + void $ encode wbuf bs diff --git a/Network/HPACK/Table.hs b/Network/HPACK/Table.hs --- a/Network/HPACK/Table.hs +++ b/Network/HPACK/Table.hs @@ -5,6 +5,10 @@ DynamicTable , newDynamicTableForEncoding , newDynamicTableForDecoding + , clearDynamicTable + , withDynamicTableForEncoding + , withDynamicTableForDecoding + , huffmanDecoder , renewDynamicTable , printDynamicTable , isDynamicTableEmpty @@ -15,69 +19,19 @@ , resetLimitForEncoding -- * Insertion , insertEntry - -- * Header to index - , HeaderCache(..) - , lookupTable -- * Entry , module Network.HPACK.Table.Entry - -- * Which tables - , WhichTable(..) - , which + -- * Reverse index + , getRevIndex + , module Network.HPACK.Table.RevIndex + -- * Index to entry + , toIndexedEntry + , fromHIndexToIndex ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif -import Control.Exception (throwIO) -import qualified Data.Map as M import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry import Network.HPACK.Table.RevIndex -import Network.HPACK.Table.Static -import Network.HPACK.Types - ----------------------------------------------------------------- - --- | Which table does `Index` refer to? -data WhichTable = InDynamicTable | InStaticTable deriving (Eq,Show) - --- | Is header key-value stored in the tables? -data HeaderCache = None - | KeyOnly !WhichTable !Index - | KeyValue !WhichTable !Index - deriving Show - ----------------------------------------------------------------- - --- | Resolving an index from a header. --- Static table is prefer to dynamic table. -lookupTable :: Header -> DynamicTable -> HeaderCache -lookupTable (k,v) dyntbl = case reverseIndex dyntbl of - Nothing -> None - Just (Outer rev) -> case M.lookup k rev of - Nothing -> None - Just (Inner ss ds) -> case lookup v ss of - Just sidx -> KeyValue InStaticTable $ fromSIndexToIndex sidx - Nothing -> case lookup v ds of - Just didx -> KeyValue InDynamicTable $ fromDIndexToIndex dyntbl didx - Nothing -> case ss of - ((_,sidx):_) -> KeyOnly InStaticTable $ fromSIndexToIndex sidx - [] -> case ds of - ((_,didx):_) -> KeyOnly InDynamicTable $ fromDIndexToIndex dyntbl didx - _ -> error "search" - ----------------------------------------------------------------- - -{-# INLINE isIn #-} -isIn :: Int -> DynamicTable -> Bool -isIn idx DynamicTable{..} = idx > staticTableSize - --- | Which table does 'Index' belong to? -which :: DynamicTable -> Index -> IO (WhichTable, Entry) -which dyntbl idx - | idx `isIn` dyntbl = (InDynamicTable,) <$> toHeaderEntry dyntbl hidx - | isSIndexValid sidx = return (InStaticTable, toStaticEntry sidx) - | otherwise = throwIO $ IndexOverrun idx - where - hidx = fromIndexToDIndex dyntbl idx - sidx = fromIndexToSIndex idx diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -1,10 +1,12 @@ {-# LANGUAGE TupleSections, RecordWildCards, FlexibleContexts #-} +{-# LANGUAGE BangPatterns, CPP #-} module Network.HPACK.Table.Dynamic ( DynamicTable(..) , newDynamicTableForEncoding , newDynamicTableForDecoding , renewDynamicTable + , huffmanDecoder , printDynamicTable , isDynamicTableEmpty , isSuitableSize @@ -13,32 +15,50 @@ , setLimitForEncoding , resetLimitForEncoding , insertEntry - , toHeaderEntry - , fromDIndexToIndex - , fromIndexToDIndex + , toDynamicEntry + , CodeInfo(..) + , clearDynamicTable + , withDynamicTableForEncoding + , withDynamicTableForDecoding + , toIndexedEntry + , fromHIndexToIndex + , getRevIndex ) where -import Control.Monad (forM) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Exception (bracket, throwIO) +import Control.Monad (forM, when, (>=>)) import Data.Array.IO (IOArray, newArray, readArray, writeArray) import qualified Data.ByteString.Char8 as BS import Data.IORef +import Foreign.Marshal.Alloc +import Network.HPACK.Huffman import Network.HPACK.Table.Entry import Network.HPACK.Table.RevIndex import Network.HPACK.Table.Static +import Network.HPACK.Types ---------------------------------------------------------------- -{-# INLINE fromDIndexToIndex #-} -fromDIndexToIndex :: DynamicTable -> DIndex -> Index -fromDIndexToIndex DynamicTable{..} (DIndex didx) = idx - where - idx = adj maxNumOfEntries (didx - offset) + staticTableSize +-- For decoder +{-# INLINE toIndexedEntry #-} +toIndexedEntry :: DynamicTable -> Index -> IO Entry +toIndexedEntry dyntbl idx + | idx <= 0 = throwIO $ IndexOverrun idx + | idx <= staticTableSize = return $! toStaticEntry idx + | otherwise = toDynamicEntry dyntbl idx -{-# INLINE fromIndexToDIndex #-} -fromIndexToDIndex :: DynamicTable -> Index -> DIndex -fromIndexToDIndex DynamicTable{..} idx = DIndex didx - where - didx = adj maxNumOfEntries (idx + offset - staticTableSize) +-- For encoder +{-# INLINE fromHIndexToIndex #-} +fromHIndexToIndex :: DynamicTable -> HIndex -> IO Index +fromHIndexToIndex _ (SIndex idx) = return idx +fromHIndexToIndex DynamicTable{..} (DIndex didx) = do + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + x <- adj maxN (didx - off) + return $! x + staticTableSize ---------------------------------------------------------------- @@ -62,49 +82,63 @@ 1 2 3 4 (numOfEntries = 4) -} +data CodeInfo = + EncodeInfo !RevIndex -- Reverse index + -- The value informed by SETTINGS_HEADER_TABLE_SIZE. + -- If 'Nothing', dynamic table size update is not necessary. + -- Otherwise, dynamic table size update is sent + -- and this value should be set to 'Nothing'. + !(IORef (Maybe Size)) + | DecodeInfo !HuffmanDecoding + !(IORef Size) -- The limit size + !(IO ()) -- Action to free the buffer + -- | Type for dynamic table. data DynamicTable = DynamicTable { + codeInfo :: !CodeInfo -- | An array - circularTable :: !Table + , circularTable :: !(IORef Table) -- | Start point - , offset :: !Index + , offset :: !(IORef Index) -- | The current number of entries - , numOfEntries :: !Int + , numOfEntries :: !(IORef Int) -- | The size of the array - , maxNumOfEntries :: !Int + , maxNumOfEntries :: !(IORef Int) -- | The current dynamic table size (defined in HPACK) - , dynamicTableSize :: !Size + , dynamicTableSize :: !(IORef Size) -- | The max dynamic table size (defined in HPACK) - , maxDynamicTableSize :: !Size - -- | The value informed by SETTINGS_HEADER_TABLE_SIZE. - -- If 'Nothing', dynamic table size update is not necessary. - -- Otherwise, dynamic table size update is sent - -- and this value should be set to 'Nothing'. - , limitForEncoding :: !(IORef (Maybe Size)) - -- | The limit size of a dynamic table for decoding - , limitForDecoding :: !Size - -- | Header to the index in Dynamic Table for encoder. - -- Static Table is not included. - -- Nothing for decoder. - , reverseIndex :: !(Maybe Outer) + , maxDynamicTableSize :: !(IORef Size) } -adj :: Int -> Int -> Int -adj maxN x = (x + maxN) `mod` maxN +{-# INLINE adj #-} +adj :: Int -> Int -> IO Int +adj maxN x + | maxN == 0 = throwIO TooSmallTableSize + | otherwise = let !ret = (x + maxN) `mod` maxN + in return ret +huffmanDecoder :: DynamicTable -> HuffmanDecoding +huffmanDecoder DynamicTable{..} = dec + where + DecodeInfo dec _ _ = codeInfo + ---------------------------------------------------------------- -- | Printing 'DynamicTable'. printDynamicTable :: DynamicTable -> IO () printDynamicTable DynamicTable{..} = do - es <- mapM (readArray circularTable . adj maxNumOfEntries) [beg .. end] - let ts = zip [1..] es + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + n <- readIORef numOfEntries + let !beg = off + 1 + !end = off + n + tbl <- readIORef circularTable + es <- mapM (adj maxN >=> readArray tbl) [beg .. end] + let !ts = zip [1..] es mapM_ printEntry ts - putStrLn $ " Table size: " ++ show dynamicTableSize ++ "/" ++ show maxDynamicTableSize - print reverseIndex - where - beg = offset + 1 - end = offset + numOfEntries + dsize <- readIORef dynamicTableSize + maxdsize <- readIORef maxDynamicTableSize + putStrLn $ " Table size: " ++ show dsize ++ "/" ++ show maxdsize printEntry :: (Index,Entry) -> IO () printEntry (i,e) = do @@ -119,170 +153,245 @@ ---------------------------------------------------------------- -isDynamicTableEmpty :: DynamicTable -> Bool -isDynamicTableEmpty dyntbl = numOfEntries dyntbl == 0 +isDynamicTableEmpty :: DynamicTable -> IO Bool +isDynamicTableEmpty DynamicTable{..} = do + n <- readIORef numOfEntries + return $! n == 0 -isSuitableSize :: Size -> DynamicTable -> Bool -isSuitableSize siz tbl = siz <= limitForDecoding tbl +isSuitableSize :: Size -> DynamicTable -> IO Bool +isSuitableSize siz DynamicTable{..} = do + let DecodeInfo _ limref _ = codeInfo + lim <- readIORef limref + return $! siz <= lim data TableSizeAction = Keep | Change !Size | Ignore !Size needChangeTableSize :: DynamicTable -> IO TableSizeAction -needChangeTableSize tbl = do - mlim <- getLimitForEncoding tbl +needChangeTableSize DynamicTable{..} = do + let EncodeInfo _ limref = codeInfo + mlim <- readIORef limref + maxsiz <- readIORef maxDynamicTableSize return $ case mlim of Nothing -> Keep Just lim | lim < maxsiz -> Change lim | otherwise -> Ignore maxsiz - where - maxsiz = maxDynamicTableSize tbl -getLimitForEncoding :: DynamicTable -> IO (Maybe Size) -getLimitForEncoding dyntbl = readIORef $ limitForEncoding dyntbl - -- | When SETTINGS_HEADER_TABLE_SIZE is received from a peer, -- its value should be set by this function. setLimitForEncoding :: Size -> DynamicTable -> IO () -setLimitForEncoding siz dyntbl = writeIORef (limitForEncoding dyntbl) $ Just siz +setLimitForEncoding siz DynamicTable{..} = do + let EncodeInfo _ limref = codeInfo + writeIORef limref $! Just siz resetLimitForEncoding :: DynamicTable -> IO () -resetLimitForEncoding dyntbl = writeIORef (limitForEncoding dyntbl) Nothing +resetLimitForEncoding DynamicTable{..} = do + let EncodeInfo _ limref = codeInfo + writeIORef limref Nothing ---------------------------------------------------------------- --- | Creating 'DynamicTable'. -newDynamicTableForEncoding :: Size -> IO DynamicTable -newDynamicTableForEncoding maxsiz = newDynamicTable maxsiz maxsiz (Just defaultRevIndex) +-- | Creating 'DynamicTable' for encoding. +newDynamicTableForEncoding :: Size -- ^ The dynamic table size + -> IO DynamicTable +newDynamicTableForEncoding maxsiz = do + rev <- newRevIndex + lim <- newIORef Nothing + let !info = EncodeInfo rev lim + newDynamicTable maxsiz info --- | Creating 'DynamicTable'. -newDynamicTableForDecoding :: Size -> IO DynamicTable -newDynamicTableForDecoding maxsiz = newDynamicTable maxsiz maxsiz Nothing +-- | Creating 'DynamicTable' for decoding. +newDynamicTableForDecoding :: Size -- ^ The dynamic table size + -> Size -- ^ The size of temporary buffer for Huffman decoding + -> IO DynamicTable +newDynamicTableForDecoding maxsiz huftmpsiz = do + lim <- newIORef maxsiz + buf <- mallocBytes huftmpsiz + let !decoder = decode buf huftmpsiz + !clear = free buf + !info = DecodeInfo decoder lim clear + newDynamicTable maxsiz info -newDynamicTable :: Size -> Size -> Maybe Outer -> IO DynamicTable -newDynamicTable maxsiz dlim mhp = do +newDynamicTable :: Size -> CodeInfo -> IO DynamicTable +newDynamicTable maxsiz info = do tbl <- newArray (0,end) dummyEntry - lim <- newIORef Nothing - return DynamicTable { - maxNumOfEntries = maxN - , offset = end - , numOfEntries = 0 - , circularTable = tbl - , dynamicTableSize = 0 - , maxDynamicTableSize = maxsiz - , limitForEncoding = lim - , limitForDecoding = dlim - , reverseIndex = mhp - } + DynamicTable info <$> newIORef tbl -- circularTable + <*> newIORef end -- offset + <*> newIORef 0 -- numOfEntries + <*> newIORef maxN -- maxNumOfEntries + <*> newIORef 0 -- dynamicTableSize + <*> newIORef maxsiz -- maxDynamicTableSize where - maxN = maxNumbers maxsiz - end = maxN - 1 + !maxN = maxNumbers maxsiz + !end = maxN - 1 -- | Renewing 'DynamicTable' with necessary entries copied. -renewDynamicTable :: Size -> DynamicTable -> IO DynamicTable -renewDynamicTable maxsiz olddyntbl | shouldRenew olddyntbl maxsiz = - newDynamicTable maxsiz dlim mhp >>= copyTable olddyntbl - where - dlim = limitForDecoding olddyntbl - mhp = case reverseIndex olddyntbl of - Nothing -> Nothing - _ -> Just defaultRevIndex -renewDynamicTable _ olddyntbl = return olddyntbl - -copyTable :: DynamicTable -> DynamicTable -> IO DynamicTable -copyTable olddyntbl newdyntbl = getEntries olddyntbl >>= copyEntries newdyntbl +renewDynamicTable :: Size -> DynamicTable -> IO () +renewDynamicTable maxsiz dyntbl@DynamicTable{..} = do + renew <- shouldRenew dyntbl maxsiz + when renew $ do + !entries <- getEntries dyntbl + let !maxN = maxNumbers maxsiz + !end = maxN - 1 + newtbl <- newArray (0,end) dummyEntry + writeIORef circularTable newtbl + writeIORef offset end + writeIORef numOfEntries 0 + writeIORef maxNumOfEntries maxN + writeIORef dynamicTableSize 0 + writeIORef maxDynamicTableSize maxsiz + case codeInfo of + EncodeInfo rev _ -> renewRevIndex rev + _ -> return () + copyEntries dyntbl entries getEntries :: DynamicTable -> IO [Entry] -getEntries DynamicTable{..} = forM [1 .. numOfEntries] readTable - where - readTable i = readArray circularTable $ adj maxNumOfEntries (offset + i) +getEntries DynamicTable{..} = do + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + n <- readIORef numOfEntries + table <- readIORef circularTable + let readTable i = adj maxN (off + i) >>= readArray table + forM [1 .. n] readTable -copyEntries :: DynamicTable -> [Entry] -> IO DynamicTable -copyEntries dyntbl [] = return dyntbl -copyEntries dyntbl@DynamicTable{..} (e:es) - | dynamicTableSize + entrySize e <= maxDynamicTableSize = do - dyntbl' <- insertEnd e dyntbl - copyEntries dyntbl' es - | otherwise = return dyntbl +copyEntries :: DynamicTable -> [Entry] -> IO () +copyEntries _ [] = return () +copyEntries dyntbl@DynamicTable{..} (e:es) = do + dsize <- readIORef dynamicTableSize + maxdsize <- readIORef maxDynamicTableSize + when (dsize + entrySize e <= maxdsize) $ do + insertEnd e dyntbl + copyEntries dyntbl es -- | Is the size of 'DynamicTable' really changed? -shouldRenew :: DynamicTable -> Size -> Bool -shouldRenew DynamicTable{..} maxsiz = maxDynamicTableSize /= maxsiz +shouldRenew :: DynamicTable -> Size -> IO Bool +shouldRenew DynamicTable{..} maxsiz = do + maxdsize <- readIORef maxDynamicTableSize + return $! maxdsize /= maxsiz ---------------------------------------------------------------- +-- | Creating 'DynamicTable' for encoding, +-- performing the action and +-- clearing the 'DynamicTable'. +withDynamicTableForEncoding :: Size -- ^ The dynamic table size + -> (DynamicTable -> IO a) + -> IO a +withDynamicTableForEncoding maxsiz action = + bracket (newDynamicTableForEncoding maxsiz) clearDynamicTable action + +-- | Creating 'DynamicTable' for decoding, +-- performing the action and +-- clearing the 'DynamicTable'. +withDynamicTableForDecoding :: Size -- ^ The dynamic table size + -> Size -- ^ The size of temporary buffer for Huffman + -> (DynamicTable -> IO a) + -> IO a +withDynamicTableForDecoding maxsiz huftmpsiz action = + bracket (newDynamicTableForDecoding maxsiz huftmpsiz) clearDynamicTable action + +-- | Clearing 'DynamicTable'. +-- Currently, this frees the temporary buffer for Huffman decoding. +clearDynamicTable :: DynamicTable -> IO () +clearDynamicTable DynamicTable{..} = case codeInfo of + EncodeInfo _ _ -> return () + DecodeInfo _ _ clear -> clear + +---------------------------------------------------------------- + -- | Inserting 'Entry' to 'DynamicTable'. -- New 'DynamicTable', the largest new 'Index' -- and a set of dropped OLD 'Index' -- are returned. -insertEntry :: Entry -> DynamicTable -> IO DynamicTable -insertEntry e dyntbl = do - (dyntbl', hs) <- insertFront e dyntbl >>= adjustTableSize - let dyntbl'' = case reverseIndex dyntbl' of - Nothing -> dyntbl' - Just rev -> dyntbl' { reverseIndex = Just (deleteDynamicList hs rev) } - return dyntbl'' +insertEntry :: Entry -> DynamicTable -> IO () +insertEntry e dyntbl@DynamicTable{..} = do + insertFront e dyntbl + es <- adjustTableSize dyntbl + case codeInfo of + EncodeInfo rev _ -> deleteRevIndexList es rev + _ -> return () -insertFront :: Entry -> DynamicTable -> IO DynamicTable -insertFront e dyntbl@DynamicTable{..} = do - writeArray circularTable i e - return $ dyntbl { - offset = offset' - , numOfEntries = numOfEntries + 1 - , dynamicTableSize = dynamicTableSize' - , reverseIndex = reverseIndex' - } +insertFront :: Entry -> DynamicTable -> IO () +insertFront e DynamicTable{..} = do + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + n <- readIORef numOfEntries + dsize <- readIORef dynamicTableSize + table <- readIORef circularTable + let i = off + !dsize' = dsize + entrySize e + !off' <- adj maxN (off - 1) + writeArray table i e + writeIORef offset off' + writeIORef numOfEntries $ n + 1 + writeIORef dynamicTableSize dsize' + case codeInfo of + EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev + _ -> return () + +adjustTableSize :: DynamicTable -> IO [Entry] +adjustTableSize dyntbl@DynamicTable{..} = adjust [] where - i = offset - dynamicTableSize' = dynamicTableSize + entrySize e - offset' = adj maxNumOfEntries (offset - 1) - reverseIndex' = case reverseIndex of - Nothing -> Nothing - Just rev -> Just $ insertDynamic (entryHeader e) (DIndex i) rev + adjust :: [Entry] -> IO [Entry] + adjust !es = do + dsize <- readIORef dynamicTableSize + maxdsize <- readIORef maxDynamicTableSize + if dsize <= maxdsize then + return es + else do + e <- removeEnd dyntbl + adjust (e:es) -adjustTableSize :: DynamicTable -> IO (DynamicTable, [Header]) -adjustTableSize dyntbl = adjust dyntbl [] +---------------------------------------------------------------- -adjust :: DynamicTable -> [Header] -> IO (DynamicTable, [Header]) -adjust dyntbl@DynamicTable{..} hs - | dynamicTableSize <= maxDynamicTableSize = return (dyntbl, hs) - | otherwise = do - (dyntbl', h) <- removeEnd dyntbl - adjust dyntbl' (h:hs) +insertEnd :: Entry -> DynamicTable -> IO () +insertEnd e DynamicTable{..} = do + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + n <- readIORef numOfEntries + dsize <- readIORef dynamicTableSize + table <- readIORef circularTable + !i <- adj maxN (off + n + 1) + let !dsize' = dsize + entrySize e + writeArray table i e + writeIORef numOfEntries $ n + 1 + writeIORef dynamicTableSize dsize' + case codeInfo of + EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev + _ -> return () ---------------------------------------------------------------- -insertEnd :: Entry -> DynamicTable -> IO DynamicTable -insertEnd e dyntbl@DynamicTable{..} = do - writeArray circularTable i e - return $ dyntbl { - numOfEntries = numOfEntries + 1 - , dynamicTableSize = dynamicTableSize' - , reverseIndex = reverseIndex' - } - where - i = adj maxNumOfEntries (offset + numOfEntries + 1) - dynamicTableSize' = dynamicTableSize + entrySize e - reverseIndex' = case reverseIndex of - Nothing -> Nothing - Just rev -> Just $ insertDynamic (entryHeader e) (DIndex i) rev +removeEnd :: DynamicTable -> IO Entry +removeEnd DynamicTable{..} = do + maxN <- readIORef maxNumOfEntries + off <- readIORef offset + n <- readIORef numOfEntries + !i <- adj maxN (off + n) + table <- readIORef circularTable + e <- readArray table i + writeArray table i dummyEntry -- let the entry GCed + dsize <- readIORef dynamicTableSize + let !dsize' = dsize - entrySize e + writeIORef numOfEntries (n - 1) + writeIORef dynamicTableSize dsize' + return e ---------------------------------------------------------------- -removeEnd :: DynamicTable -> IO (DynamicTable,Header) -removeEnd dyntbl@DynamicTable{..} = do - let i = adj maxNumOfEntries (offset + numOfEntries) - e <- readArray circularTable i - writeArray circularTable i dummyEntry -- let the entry GCed - let tsize = dynamicTableSize - entrySize e - h = entryHeader e - dyntbl' = dyntbl { - numOfEntries = numOfEntries - 1 - , dynamicTableSize = tsize - } - return (dyntbl', h) +{-# INLINE toDynamicEntry #-} +toDynamicEntry :: DynamicTable -> Index -> IO Entry +toDynamicEntry DynamicTable{..} idx = do + !maxN <- readIORef maxNumOfEntries + !off <- readIORef offset + !didx <- adj maxN (idx + off - staticTableSize) + !table <- readIORef circularTable + readArray table didx ---------------------------------------------------------------- -toHeaderEntry :: DynamicTable -> DIndex -> IO Entry -toHeaderEntry DynamicTable{..} (DIndex didx) = readArray circularTable didx +{-# INLINE getRevIndex #-} +getRevIndex :: DynamicTable-> RevIndex +getRevIndex DynamicTable{..} = rev + where + EncodeInfo rev _ = codeInfo diff --git a/Network/HPACK/Table/Entry.hs b/Network/HPACK/Table/Entry.hs --- a/Network/HPACK/Table/Entry.hs +++ b/Network/HPACK/Table/Entry.hs @@ -3,13 +3,14 @@ module Network.HPACK.Table.Entry ( -- * Type Size - , Entry + , Entry(..) , Header -- re-exporting , HeaderName -- re-exporting , HeaderValue -- re-exporting , Index -- re-exporting -- * Header and Entry , toEntry + , toEntryToken , fromEntry -- * Getters , entrySize @@ -22,6 +23,7 @@ ) where import qualified Data.ByteString as BS +import Network.HPACK.Table.Token import Network.HPACK.Types ---------------------------------------------------------------- @@ -30,7 +32,7 @@ type Size = Int -- | Type for table entry. Size includes the 32 bytes magic number. -type Entry = (Size,Header) +data Entry = Entry Size Token Header deriving Show ---------------------------------------------------------------- @@ -46,37 +48,43 @@ -- | From 'Header' to 'Entry'. toEntry :: Header -> Entry -toEntry h = (siz,h) +toEntry kv = Entry siz TOTHER kv where - !siz = headerSize h + !siz = headerSize kv +toEntryToken :: Header -> Entry +toEntryToken kv@(k,_) = Entry siz t kv + where + !siz = headerSize kv + !t = toToken k + -- | From 'Entry' to 'Header'. fromEntry :: Entry -> Header -fromEntry = snd +fromEntry (Entry _ _ kv) = kv ---------------------------------------------------------------- -- | Getting the size of 'Entry'. entrySize :: Entry -> Size -entrySize = fst +entrySize (Entry siz _ _) = siz -- | Getting 'Header'. entryHeader :: Entry -> Header -entryHeader (_,h) = h +entryHeader (Entry _ _ kv) = kv -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName -entryHeaderName (_,(k,_)) = k +entryHeaderName (Entry _ _ (k,_)) = k -- | Getting 'HeaderValue'. entryHeaderValue :: Entry -> HeaderValue -entryHeaderValue (_,(_,v)) = v +entryHeaderValue (Entry _ _ (_,v)) = v ---------------------------------------------------------------- -- | Dummy 'Entry' to initialize a dynamic table. dummyEntry :: Entry -dummyEntry = (0,("dummy","dummy")) +dummyEntry = Entry 0 TOTHER ("dummy","dummy") -- | How many entries can be stored in a dynamic table? maxNumbers :: Size -> Int diff --git a/Network/HPACK/Table/RevIndex.hs b/Network/HPACK/Table/RevIndex.hs --- a/Network/HPACK/Table/RevIndex.hs +++ b/Network/HPACK/Table/RevIndex.hs @@ -1,46 +1,213 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} -module Network.HPACK.Table.RevIndex where +module Network.HPACK.Table.RevIndex ( + RevIndex + , RevResult(..) + , newRevIndex + , renewRevIndex + , lookupRevIndex + , insertRevIndex + , deleteRevIndexList + ) where +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>), (<*>)) +#endif +import Data.Array (Array, (!)) +import qualified Data.Array as A +import qualified Data.Array.IO as IOA +import Data.Array.Unboxed (UArray) +import qualified Data.Array.Unboxed as U +import qualified Data.Array.Unsafe as Unsafe +import Data.Function (on) +import Data.IORef +import Data.List (groupBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Network.HPACK.Types +import Network.HPACK.Table.Entry import Network.HPACK.Table.Static +import Network.HPACK.Table.Token +import Network.HPACK.Types --- Physical array index for Dynamic Table. --- Defining here due to dependency, sigh. -newtype DIndex = DIndex Int deriving (Eq, Ord, Show) +import System.IO.Unsafe -data Inner = Inner [(HeaderValue, SIndex)] [(HeaderValue, DIndex)] deriving Show +---------------------------------------------------------------- -newtype Outer = Outer (Map HeaderName Inner) deriving Show +data RevResult = N | K HIndex | KV HIndex -defaultRevIndex :: Outer -defaultRevIndex = Outer $! foldr op M.empty lst +---------------------------------------------------------------- + +data RevIndex = RevIndex DynamicRevIndex OtherRevIdex + +type DynamicRevIndex = Array Token (IORef ValueMap) + +-- We always create an index for a pair of an unknown header and its value +-- in Linear{H}. +type OtherRevIdex = IORef (Map (HeaderName,HeaderValue) HIndex) + +---------------------------------------------------------------- + +type StaticRevIndex = Array Token StaticEntry + +data StaticEntry = StaticEntry !HIndex !(Maybe ValueMap) + +type ValueMap = Map HeaderValue HIndex + +---------------------------------------------------------------- + +beg :: Token +beg = minBound + +end :: Token +end = toEnum (fromEnum (maxBound :: Token) - 1) + +---------------------------------------------------------------- + +staticRevIndex :: StaticRevIndex +staticRevIndex = A.array (minBound, end) $ map toEnt zs where - lst = zip staticTableList $ map SIndex [1..] - op ((k,v),i) m = M.alter f k m + toEnt (k,xs) = (toToken k, m) where - f Nothing = Just $! Inner [(v,i)] [] - f (Just (Inner ss ds)) = let ss' = (v,i):ss - in Just $! Inner ss' ds + m = case xs of + [] -> error "staticRevIndex" + [(_,i)] -> StaticEntry i Nothing + (_,i):_ -> let !vs = M.fromList xs + in StaticEntry i (Just vs) + zs = map extract $ groupBy ((==) `on` fst) lst + where + lst = zipWith (\(k,v) i -> (k,(v,i))) staticTableList $ map SIndex [1..] + extract xs = (fst (head xs), map snd xs) -insertDynamic :: Header -> DIndex -> Outer -> Outer -insertDynamic (k,v) didx (Outer rev) = Outer $! M.alter f k rev +{-# INLINE lookupStaticRevIndex #-} +lookupStaticRevIndex :: Token -> HeaderValue -> RevResult +lookupStaticRevIndex t v = case staticRevIndex ! t of + StaticEntry i Nothing -> K i + StaticEntry i (Just m) -> case M.lookup v m of + Nothing -> K i + Just j -> KV j + +---------------------------------------------------------------- + +newDynamicRevIndex :: IO DynamicRevIndex +newDynamicRevIndex = A.listArray (beg,end) <$> mapM mk lst where - f Nothing = Just $! Inner [] [(v,didx)] - f (Just (Inner ss ds)) = let ds' = (v,didx):ds - in Just $! Inner ss ds' + mk _ = newIORef M.empty + lst = [beg..end] -deleteDynamic :: Header -> Map HeaderName Inner -> Map HeaderName Inner -deleteDynamic (k,v) rev = M.alter f k rev +renewDynamicRevIndex :: DynamicRevIndex -> IO () +renewDynamicRevIndex drev = mapM_ clear [beg..end] where - f Nothing = Nothing - f (Just (Inner ss ds)) = case filter (\(a,_) -> a /= v) ds of - [] -> case ss of - [] -> Nothing - _ -> Just $! Inner ss [] - ds' -> Just $! Inner ss ds' + clear t = writeIORef (drev ! t) M.empty -deleteDynamicList :: [Header] -> Outer -> Outer -deleteDynamicList hs (Outer rev) = Outer $! foldr deleteDynamic rev hs +{-# INLINE lookupDynamicRevIndex #-} +lookupDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO RevResult +lookupDynamicRevIndex t v drev = do + let ref = drev ! t + m <- readIORef ref + return $! case M.lookup v m of + Nothing -> N + Just i -> KV i + +{-# INLINE insertDynamicRevIndex #-} +insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO () +insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i + where + ref = drev ! t + +{-# INLINE deleteDynamicRevIndex#-} +deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO () +deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v + where + ref = drev ! t + +---------------------------------------------------------------- + +newOtherRevIndex :: IO OtherRevIdex +newOtherRevIndex = newIORef M.empty + +renewOtherRevIndex :: OtherRevIdex -> IO () +renewOtherRevIndex ref = writeIORef ref M.empty + +{-# INLINE lookupOtherRevIndex #-} +lookupOtherRevIndex :: HeaderName -> HeaderValue -> OtherRevIdex -> IO RevResult +lookupOtherRevIndex k v ref = do + oth <- readIORef ref + return $! case M.lookup (k,v) oth of + Nothing -> N + Just i -> KV i + +{-# INLINE insertOtherRevIndex #-} +insertOtherRevIndex :: HeaderName -> HeaderValue -> HIndex -> OtherRevIdex -> IO () +insertOtherRevIndex k v i ref = modifyIORef' ref $ M.insert (k,v) i + +{-# INLINE deleteOtherRevIndex #-} +deleteOtherRevIndex :: HeaderName -> HeaderValue -> OtherRevIdex -> IO () +deleteOtherRevIndex k v ref = modifyIORef' ref $ M.delete (k,v) + +---------------------------------------------------------------- + +newRevIndex :: IO RevIndex +newRevIndex = RevIndex <$> newDynamicRevIndex <*> newOtherRevIndex + +renewRevIndex :: RevIndex -> IO () +renewRevIndex (RevIndex dyn oth) = do + renewDynamicRevIndex dyn + renewOtherRevIndex oth + +{-# INLINE lookupRevIndex #-} +lookupRevIndex :: Entry -> RevIndex -> IO (RevResult,Bool) +lookupRevIndex (Entry _ t (k,v)) (RevIndex dyn oth) = do + res <- get + return (res, shouldBeIndexed t) + where + get + | t == TOTHER = lookupOtherRevIndex k v oth + | otherwise = do + mx <- lookupDynamicRevIndex t v dyn + return $! case mx of + N -> lookupStaticRevIndex t v + _ -> mx + +---------------------------------------------------------------- + +{-# INLINE insertRevIndex #-} +insertRevIndex :: Entry -> HIndex -> RevIndex -> IO () +insertRevIndex (Entry _ t (k,v)) i (RevIndex dyn oth) + | t == TOTHER = insertOtherRevIndex k v i oth + | otherwise = insertDynamicRevIndex t v i dyn + +{-# INLINE deleteRevIndex #-} +deleteRevIndex :: RevIndex -> Entry -> IO () +deleteRevIndex (RevIndex dyn oth) (Entry _ t (k,v)) + | t == TOTHER = deleteOtherRevIndex k v oth + | otherwise = deleteDynamicRevIndex t v dyn + +{-# INLINE deleteRevIndexList #-} +deleteRevIndexList :: [Entry] -> RevIndex -> IO () +deleteRevIndexList es rev = mapM_ (deleteRevIndex rev) es + +---------------------------------------------------------------- + +headersNotToIndex :: [HeaderName] +headersNotToIndex = [ + ":path" + , "content-length" + , "location" + , "etag" + , "set-cookie" + ] + +indexedOrNot :: UArray Int Bool +indexedOrNot = unsafePerformIO $ do + arr <- IOA.newArray (ib,ie) True :: IO (IOA.IOUArray Int Bool) + mapM_ (toTrue arr) $ map (fromEnum . toToken) headersNotToIndex + Unsafe.unsafeFreeze arr + where + ib = fromEnum (minBound :: Token) + ie = fromEnum (maxBound :: Token) + toTrue :: IOA.IOUArray Int Bool -> Int -> IO () + toTrue arr i = IOA.writeArray arr i False + +{-# INLINE shouldBeIndexed #-} +shouldBeIndexed :: Token -> Bool +shouldBeIndexed t = indexedOrNot U.! fromEnum t diff --git a/Network/HPACK/Table/Static.hs b/Network/HPACK/Table/Static.hs --- a/Network/HPACK/Table/Static.hs +++ b/Network/HPACK/Table/Static.hs @@ -1,11 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Table.Static ( - SIndex(..) - , fromSIndexToIndex - , fromIndexToSIndex - , isSIndexValid - , toStaticEntry + toStaticEntry , staticTableSize , staticTableList ) where @@ -15,25 +11,6 @@ ---------------------------------------------------------------- --- Physical array index for Static Table. -newtype SIndex = SIndex Int deriving (Eq,Ord,Show) - -{-# INLINE fromSIndexToIndex #-} -fromSIndexToIndex :: SIndex -> Index -fromSIndexToIndex (SIndex idx) = idx - -{-# INLINE fromIndexToSIndex #-} -fromIndexToSIndex :: Index -> SIndex -fromIndexToSIndex idx = SIndex idx - ----------------------------------------------------------------- - -{-# INLINE isSIndexValid #-} -isSIndexValid :: SIndex -> Bool -isSIndexValid (SIndex sidx) = 1 <= sidx && sidx <= staticTableSize - ----------------------------------------------------------------- - -- | The size of static table. staticTableSize :: Size staticTableSize = length staticTableList @@ -41,14 +18,14 @@ {-# INLINE toStaticEntry #-} -- | Get 'Entry' from the static table. -- --- >>> toStaticEntry (SIndex 1) --- (42,(":authority","")) --- >>> toStaticEntry (SIndex 8) --- (42,(":status","200")) --- >>> toStaticEntry (SIndex 50) --- (37,("range","")) -toStaticEntry :: SIndex -> Entry -toStaticEntry (SIndex sidx) = staticTable ! sidx +-- >>> toStaticEntry 1 +-- Entry 42 TOTHER (":authority","") +-- >>> toStaticEntry 8 +-- Entry 42 TOTHER (":status","200") +-- >>> toStaticEntry 50 +-- Entry 37 TOTHER ("range","") +toStaticEntry :: Index -> Entry +toStaticEntry sidx = staticTable ! sidx -- | Pre-defined static table. staticTable :: Array Index Entry diff --git a/Network/HPACK/Table/Token.hs b/Network/HPACK/Table/Token.hs new file mode 100644 --- /dev/null +++ b/Network/HPACK/Table/Token.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HPACK.Table.Token where + +import Data.Ix +import Data.ByteString (ByteString) +import qualified Data.ByteString as B + +-- $setup +-- >>> :set -XOverloadedStrings + +data Token = TAuthority + | TMethod + | TPath + | TScheme + | TStatus + | TAcceptCharset + | TAcceptEncoding + | TAcceptLanguage + | TAcceptRanges + | TAccept + | TAccessControlAllowOrigin + | TAge + | TAllow + | TAuthorization + | TCacheControl + | TContentDisposition + | TContentEncoding + | TContentLanguage + | TContentLength + | TContentLocation + | TContentRange + | TContentType + | TCookie + | TDate + | TEtag + | TExpect + | TExpires + | TFrom + | THost + | TIfMatch + | TIfModifiedSince + | TIfNoneMatch + | TIfRange + | TIfUnmodifiedSince + | TLastModified + | TLink + | TLocation + | TMaxForwards + | TProxyAuthenticate + | TProxyAuthorization + | TRange + | TReferer + | TRefresh + | TRetryAfter + | TServer + | TSetCookie + | TStrictTransportSecurity + | TTransferEncoding + | TUserAgent + | TVary + | TVia + | TWwwAuthenticate + | TOTHER + deriving (Eq,Ord,Show,Enum,Bounded,Ix) + +-- | +-- +-- >>> toToken ":authority" +-- TAuthority +-- >>> toToken ":method" +-- TMethod +-- >>> toToken ":path" +-- TPath +-- >>> toToken ":scheme" +-- TScheme +-- >>> toToken ":status" +-- TStatus +-- >>> toToken "accept-charset" +-- TAcceptCharset +-- >>> toToken "accept-encoding" +-- TAcceptEncoding +-- >>> toToken "accept-language" +-- TAcceptLanguage +-- >>> toToken "accept-ranges" +-- TAcceptRanges +-- >>> toToken "accept" +-- TAccept +-- >>> toToken "access-control-allow-origin" +-- TAccessControlAllowOrigin +-- >>> toToken "age" +-- TAge +-- >>> toToken "allow" +-- TAllow +-- >>> toToken "authorization" +-- TAuthorization +-- >>> toToken "cache-control" +-- TCacheControl +-- >>> toToken "content-disposition" +-- TContentDisposition +-- >>> toToken "content-encoding" +-- TContentEncoding +-- >>> toToken "content-language" +-- TContentLanguage +-- >>> toToken "content-length" +-- TContentLength +-- >>> toToken "content-location" +-- TContentLocation +-- >>> toToken "content-range" +-- TContentRange +-- >>> toToken "content-type" +-- TContentType +-- >>> toToken "cookie" +-- TCookie +-- >>> toToken "date" +-- TDate +-- >>> toToken "etag" +-- TEtag +-- >>> toToken "expect" +-- TExpect +-- >>> toToken "expires" +-- TExpires +-- >>> toToken "from" +-- TFrom +-- >>> toToken "host" +-- THost +-- >>> toToken "if-match" +-- TIfMatch +-- >>> toToken "if-modified-since" +-- TIfModifiedSince +-- >>> toToken "if-none-match" +-- TIfNoneMatch +-- >>> toToken "if-range" +-- TIfRange +-- >>> toToken "if-unmodified-since" +-- TIfUnmodifiedSince +-- >>> toToken "last-modified" +-- TLastModified +-- >>> toToken "link" +-- TLink +-- >>> toToken "location" +-- TLocation +-- >>> toToken "max-forwards" +-- TMaxForwards +-- >>> toToken "proxy-authenticate" +-- TProxyAuthenticate +-- >>> toToken "proxy-authorization" +-- TProxyAuthorization +-- >>> toToken "range" +-- TRange +-- >>> toToken "referer" +-- TReferer +-- >>> toToken "refresh" +-- TRefresh +-- >>> toToken "retry-after" +-- TRetryAfter +-- >>> toToken "server" +-- TServer +-- >>> toToken "set-cookie" +-- TSetCookie +-- >>> toToken "strict-transport-security" +-- TStrictTransportSecurity +-- >>> toToken "transfer-encoding" +-- TTransferEncoding +-- >>> toToken "user-agent" +-- TUserAgent +-- >>> toToken "vary" +-- TVary +-- >>> toToken "via" +-- TVia +-- >>> toToken "www-authenticate" +-- TWwwAuthenticate +-- >>> toToken "foo" +-- TOTHER +toToken :: ByteString -> Token +toToken bs = case len of + 3 -> case lst of + 97 -> if bs == "via" then TVia else TOTHER + 101 -> if bs == "age" then TAge else TOTHER + _ -> TOTHER + 4 -> case lst of + 101 -> if bs == "date" then TDate else TOTHER + 103 -> if bs == "etag" then TEtag else TOTHER + 107 -> if bs == "link" then TLink else TOTHER + 109 -> if bs == "from" then TFrom else TOTHER + 116 -> if bs == "host" then THost else TOTHER + 121 -> if bs == "vary" then TVary else TOTHER + _ -> TOTHER + 5 -> case lst of + 101 -> if bs == "range" then TRange else TOTHER + 104 -> if bs == ":path" then TPath else TOTHER + 119 -> if bs == "allow" then TAllow else TOTHER + _ -> TOTHER + 6 -> case lst of + 101 -> if bs == "cookie" then TCookie else TOTHER + 114 -> if bs == "server" then TServer else TOTHER + 116 -> if bs == "expect" then TExpect else + if bs == "accept" then TAccept else TOTHER + _ -> TOTHER + 7 -> case lst of + 100 -> if bs == ":method" then TMethod else TOTHER + 101 -> if bs == ":scheme" then TScheme else TOTHER + 104 -> if bs == "refresh" then TRefresh else TOTHER + 114 -> if bs == "referer" then TReferer else TOTHER + 115 -> if bs == "expires" then TExpires else + if bs == ":status" then TStatus else TOTHER + _ -> TOTHER + 8 -> case lst of + 101 -> if bs == "if-range" then TIfRange else TOTHER + 104 -> if bs == "if-match" then TIfMatch else TOTHER + 110 -> if bs == "location" then TLocation else TOTHER + _ -> TOTHER + 10 -> case lst of + 101 -> if bs == "set-cookie" then TSetCookie else TOTHER + 116 -> if bs == "user-agent" then TUserAgent else TOTHER + 121 -> if bs == ":authority" then TAuthority else TOTHER + _ -> TOTHER + 11 -> case lst of + 114 -> if bs == "retry-after" then TRetryAfter else TOTHER + _ -> TOTHER + 12 -> case lst of + 101 -> if bs == "content-type" then TContentType else TOTHER + 115 -> if bs == "max-forwards" then TMaxForwards else TOTHER + _ -> TOTHER + 13 -> case lst of + 100 -> if bs == "last-modified" then TLastModified else TOTHER + 101 -> if bs == "content-range" then TContentRange else TOTHER + 104 -> if bs == "if-none-match" then TIfNoneMatch else TOTHER + 108 -> if bs == "cache-control" then TCacheControl else TOTHER + 110 -> if bs == "authorization" then TAuthorization else TOTHER + 115 -> if bs == "accept-ranges" then TAcceptRanges else TOTHER + _ -> TOTHER + 14 -> case lst of + 104 -> if bs == "content-length" then TContentLength else TOTHER + 116 -> if bs == "accept-charset" then TAcceptCharset else TOTHER + _ -> TOTHER + 15 -> case lst of + 101 -> if bs == "accept-language" then TAcceptLanguage else TOTHER + 103 -> if bs == "accept-encoding" then TAcceptEncoding else TOTHER + _ -> TOTHER + 16 -> case lst of + 101 -> if bs == "content-language" then TContentLanguage else + if bs == "www-authenticate" then TWwwAuthenticate else TOTHER + 103 -> if bs == "content-encoding" then TContentEncoding else TOTHER + 110 -> if bs == "content-location" then TContentLocation else TOTHER + _ -> TOTHER + 17 -> case lst of + 101 -> if bs == "if-modified-since" then TIfModifiedSince else TOTHER + 103 -> if bs == "transfer-encoding" then TTransferEncoding else TOTHER + _ -> TOTHER + 18 -> case lst of + 101 -> if bs == "proxy-authenticate" then TProxyAuthenticate else TOTHER + _ -> TOTHER + 19 -> case lst of + 101 -> if bs == "if-unmodified-since" then TIfUnmodifiedSince else TOTHER + 110 -> if bs == "proxy-authorization" then TProxyAuthorization else + if bs == "content-disposition" then TContentDisposition else TOTHER + _ -> TOTHER + 25 -> case lst of + 121 -> if bs == "strict-transport-security" then TStrictTransportSecurity else TOTHER + _ -> TOTHER + 27 -> case lst of + 110 -> if bs == "access-control-allow-origin" then TAccessControlAllowOrigin else TOTHER + _ -> TOTHER + _ -> TOTHER + where + len = B.length bs + lst = B.last bs diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -9,17 +9,26 @@ , HeaderList -- * Misc , Index + , HIndex(..) -- * Encoding and decoding , CompressionAlgo(..) , EncodeStrategy(..) , defaultEncodeStrategy , DecodeError(..) + -- * Buffer + , Buffer + , BufferSize + , BufferOverrun(..) ) where import Control.Exception as E import Data.ByteString (ByteString) import Data.Typeable +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +---------------------------------------------------------------- + -- | Header name. type HeaderName = ByteString @@ -35,13 +44,19 @@ -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString +---------------------------------------------------------------- + -- | Index for table. type Index = Int +data HIndex = SIndex Int | DIndex Int deriving (Eq, Ord, Show) + +---------------------------------------------------------------- + -- | Compression algorithms for HPACK encoding. data CompressionAlgo = Naive -- ^ No compression - | Static -- ^ Using the static table only - | Linear -- ^ Using indices only + | Static -- ^ Using indices in the static table only + | Linear -- ^ Using indices deriving (Eq, Show) -- | Strategy for HPACK encoding. @@ -55,13 +70,14 @@ -- | Default 'EncodeStrategy'. -- -- >>> defaultEncodeStrategy --- EncodeStrategy {compressionAlgo = Linear, useHuffman = True} +-- EncodeStrategy {compressionAlgo = Linear, useHuffman = False} defaultEncodeStrategy :: EncodeStrategy defaultEncodeStrategy = EncodeStrategy { compressionAlgo = Linear - , useHuffman = True + , useHuffman = False } +---------------------------------------------------------------- -- | Errors for decoder. data DecodeError = IndexOverrun Index -- ^ Index is out of range @@ -69,9 +85,23 @@ | IllegalEos -- ^ Non-eos appears in the end of huffman string | TooLongEos -- ^ Eos of huffman string is more than 7 bits | EmptyEncodedString -- ^ Encoded string has no length - | EmptyBlock -- ^ Header block is empty + | TooSmallTableSize -- ^ A peer set the dynamic table size less than 32 | TooLargeTableSize -- ^ A peer tried to change the dynamic table size over the limit | IllegalTableSizeUpdate -- ^ Table size update at the non-beginning + | HeaderBlockTruncated deriving (Eq,Show,Typeable) instance Exception DecodeError + +---------------------------------------------------------------- + +-- | Buffer type. +type Buffer = Ptr Word8 + +-- | The size of buffer. +type BufferSize = Int + +data BufferOverrun = BufferOverrun -- ^ The buffer size is not enough + deriving (Eq,Show,Typeable) + +instance Exception BufferOverrun diff --git a/Network/HTTP2/Priority/PSQ.hs b/Network/HTTP2/Priority/PSQ.hs --- a/Network/HTTP2/Priority/PSQ.hs +++ b/Network/HTTP2/Priority/PSQ.hs @@ -16,17 +16,17 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) +import Data.Word (Word) #endif import Data.Array (Array, listArray, (!)) import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as P -import Data.Word (Word64) ---------------------------------------------------------------- type Key = Int type Weight = Int -type Deficit = Word64 +type Deficit = Word -- Deficit can be overflowed -- | Internal representation of priority in priority queues. -- The precedence of a dequeued entry should be specified @@ -46,13 +46,12 @@ Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2 instance Ord Precedence where - Precedence d1 _ _ < Precedence d2 _ _ = d1 < d2 - Precedence d1 _ _ <= Precedence d2 _ _ = d1 <= d2 + -- This is correct even if one of them is overflowed + Precedence d1 _ _ < Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW + Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW type Heap a = IntPSQ Precedence a --- FIXME: The base (Word64) would be overflowed. --- In that case, the heap must be re-constructed. data PriorityQueue a = PriorityQueue { baseDeficit :: {-# UNPACK #-} !Deficit , queue :: !(Heap a) @@ -63,6 +62,9 @@ deficitSteps :: Int deficitSteps = 65536 +deficitStepsW :: Word +deficitStepsW = fromIntegral deficitSteps + deficitList :: [Deficit] deficitList = map calc idxs where @@ -75,9 +77,6 @@ weightToDeficit :: Weight -> Deficit weightToDeficit w = deficitTable ! w -deficitLimit :: Deficit -deficitLimit = 10000000000000000000 -- more than 2^63 and less than 2^63 + 2^62 - ---------------------------------------------------------------- empty :: PriorityQueue a @@ -87,27 +86,14 @@ isEmpty PriorityQueue{..} = P.null queue enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a -enqueue k p v PriorityQueue{..} - | deficit' < deficitLimit = fastPath - | otherwise = slowPath +enqueue k p@Precedence{..} v PriorityQueue{..} = + PriorityQueue baseDeficit queue' where - !d = weightToDeficit (weight p) - !b = if deficit p == 0 then baseDeficit else deficit p - !deficit' = b + d - fastPath = PriorityQueue baseDeficit queue' - where - !p' = p { deficit = deficit' } - !queue' = P.insert k p' v queue - slowPath = PriorityQueue 0 queue'' - where - adjust (x,y,z) = (x,y',z) - where - !d' = deficit y - baseDeficit - !y' = y { deficit = d' } - !queue' = P.fromList $ map adjust $ P.toList queue - !deficit'' = deficit' - baseDeficit - !p'' = p { deficit = deficit'' } - !queue'' = P.insert k p'' v queue' + !d = weightToDeficit weight + !b = if deficit == 0 then baseDeficit else deficit + !deficit' = max (b + d) baseDeficit + !p' = p { deficit = deficit' } + !queue' = P.insert k p' v queue dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a) dequeue PriorityQueue{..} = case P.minView queue of diff --git a/bench-hpack/Main.hs b/bench-hpack/Main.hs --- a/bench-hpack/Main.hs +++ b/bench-hpack/Main.hs @@ -7,17 +7,32 @@ import Network.HPACK import Data.ByteString (ByteString) +---------------------------------------------------------------- + +naive, naiveh, static, statich, linear, linearh :: EncodeStrategy +naive = EncodeStrategy {compressionAlgo = Naive, useHuffman = False} +naiveh = EncodeStrategy {compressionAlgo = Naive, useHuffman = True} +static = EncodeStrategy {compressionAlgo = Static, useHuffman = False} +statich = EncodeStrategy {compressionAlgo = Static, useHuffman = True} +linear = EncodeStrategy {compressionAlgo = Linear, useHuffman = False} +linearh = EncodeStrategy {compressionAlgo = Linear, useHuffman = True} + main :: IO () main = do hdrs <- read <$> readFile "bench-hpack/headers.hs" hpacks <- prepare hdrs _ <- evaluate hpacks defaultMain [ - bgroup "HPACK encoding" [ - bench "Pure" $ nfIO (enc hdrs) + bgroup "HPACK decoding" [ + bench "LinearH" $ nfIO (dec hpacks) ] - , bgroup "HPACK decoding" [ - bench "Pure" $ nfIO (dec hpacks) + , bgroup "HPACK encoding" [ + bench "Naive" $ nfIO (enc naive hdrs) + , bench "HaiveH" $ nfIO (enc naiveh hdrs) + , bench "Static" $ nfIO (enc static hdrs) + , bench "StaticH" $ nfIO (enc statich hdrs) + , bench "Linear" $ nfIO (enc linear hdrs) + , bench "LinearH" $ nfIO (enc linearh hdrs) ] ] @@ -29,25 +44,25 @@ where go _ [] b = return (b []) go !tbl (h:hs) b = do - (tbl', frag) <- encodeHeader defaultEncodeStrategy tbl h - go tbl' hs (b . (frag :)) - -enc :: [HeaderList] -> IO () -enc hdrs = do - tbl <- newDynamicTableForEncoding defaultDynamicTableSize - go tbl hdrs - where - go _ [] = return () - go !tbl (h:hs) = do - (tbl', !_) <- encodeHeader defaultEncodeStrategy tbl h - go tbl' hs + !frag <- encodeHeader linearh 4096 tbl h + go tbl hs (b . (frag :)) dec :: [ByteString] -> IO () dec hpacks = do - tbl <- newDynamicTableForDecoding defaultDynamicTableSize + tbl <- newDynamicTableForDecoding defaultDynamicTableSize 4096 go tbl hpacks where go _ [] = return () go !tbl (f:fs) = do - (tbl', !_) <- decodeHeader tbl f - go tbl' fs + !_ <- decodeHeader tbl f + go tbl fs + +enc :: EncodeStrategy -> [HeaderList] -> IO () +enc stgy hdrs = do + tbl <- newDynamicTableForEncoding defaultDynamicTableSize + go tbl hdrs + where + go _ [] = return () + go !tbl (h:hs) = do + !_ <- encodeHeader stgy 4096 tbl h + go tbl hs diff --git a/bench-priority/BinaryHeap.hs b/bench-priority/BinaryHeap.hs --- a/bench-priority/BinaryHeap.hs +++ b/bench-priority/BinaryHeap.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, CPP #-} module BinaryHeap ( Entry @@ -15,17 +15,19 @@ , delete ) where +#if __GLASGOW_HASKELL__ < 709 +import Data.Word (Word) +#endif import Control.Monad (when, void) import Data.Array (Array, listArray, (!)) import Data.Array.IO (IOArray) import Data.Array.MArray (newArray_, readArray, writeArray) import Data.IORef -import Data.Word (Word64) ---------------------------------------------------------------- type Weight = Int -type Deficit = Word64 +type Deficit = Word -- | Abstract data type of entries for priority queues. -- This does not contain Key because Entry is assumed to be stored @@ -49,8 +51,6 @@ type Index = Int type MA a = IOArray Index (Entry a) --- FIXME: The base (Word64) would be overflowed. --- In that case, the heap must be re-constructed. data PriorityQueue a = PriorityQueue (IORef Deficit) (IORef Index) (MA a) @@ -63,6 +63,9 @@ deficitSteps :: Int deficitSteps = 65536 +deficitStepsW :: Word +deficitStepsW = fromIntegral deficitSteps + deficitList :: [Deficit] deficitList = map calc idxs where @@ -135,7 +138,7 @@ xc2 <- readArray arr c2 d1 <- readIORef $ deficit xc1 d2 <- readIORef $ deficit xc2 - let !c = if d1 < d2 then c1 else c2 + let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2 swapped <- swap arr p c when swapped $ shiftDown arr c n where diff --git a/bench-priority/BinaryHeapSTM.hs b/bench-priority/BinaryHeapSTM.hs --- a/bench-priority/BinaryHeapSTM.hs +++ b/bench-priority/BinaryHeapSTM.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, CPP #-} module BinaryHeapSTM ( Entry @@ -15,16 +15,18 @@ , delete ) where +#if __GLASGOW_HASKELL__ < 709 +import Data.Word (Word) +#endif import Control.Concurrent.STM import Control.Monad (when, void) import Data.Array (Array, listArray, (!)) import Data.Array.MArray (newArray_, readArray, writeArray) -import Data.Word (Word64) ---------------------------------------------------------------- type Weight = Int -type Deficit = Word64 +type Deficit = Word -- | Abstract data type of entries for priority queues. data Entry a = Entry { @@ -60,6 +62,9 @@ deficitSteps :: Int deficitSteps = 65536 +deficitStepsW :: Word +deficitStepsW = fromIntegral deficitSteps + deficitList :: [Deficit] deficitList = map calc idxs where @@ -132,7 +137,7 @@ xc2 <- readArray arr c2 d1 <- readTVar $ deficit xc1 d2 <- readTVar $ deficit xc2 - let !c = if d1 < d2 then c1 else c2 + let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2 swapped <- swap arr p c when swapped $ shiftDown arr c n where diff --git a/bench-priority/Heap.hs b/bench-priority/Heap.hs --- a/bench-priority/Heap.hs +++ b/bench-priority/Heap.hs @@ -15,17 +15,17 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) +import Data.Word (Word) #endif import Data.Array (Array, listArray, (!)) import Data.Heap (Heap) import qualified Data.Heap as H -import Data.Word (Word64) ---------------------------------------------------------------- type Key = Int type Weight = Int -type Deficit = Word64 +type Deficit = Word -- Deficit can be overflowed data Precedence = Precedence { deficit :: {-# UNPACK #-} !Deficit @@ -42,8 +42,9 @@ Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2 instance Ord Precedence where - Precedence d1 _ _ < Precedence d2 _ _ = d1 < d2 - Precedence d1 _ _ <= Precedence d2 _ _ = d1 <= d2 + -- This is correct even if one of them is overflowed + Precedence d1 _ _ < Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW + Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW data Entry a = Entry Key Precedence a @@ -69,6 +70,9 @@ deficitSteps :: Int deficitSteps = 65536 +deficitStepsW :: Word +deficitStepsW = fromIntegral deficitSteps + deficitList :: [Deficit] deficitList = map calc idxs where @@ -92,8 +96,9 @@ enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a enqueue k p v PriorityQueue{..} = PriorityQueue b queue' where + !d = weightToDeficit (weight p) !b = if deficit p == magicDeficit then baseDeficit else deficit p - !deficit' = b + weightToDeficit (weight p) + !deficit' = max (b + d) baseDeficit !p' = p { deficit = deficit' } !queue' = H.insert (Entry k p' v) queue diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 1.4.5 +Version: 1.5.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -51,8 +51,8 @@ Exposed-Modules: Network.HPACK Network.HTTP2 Network.HTTP2.Priority - Other-Modules: Network.HPACK.Builder - Network.HPACK.Builder.Word8 + Other-Modules: Network.HPACK.Buffer + Network.HPACK.Builder Network.HPACK.Huffman Network.HPACK.Huffman.Bit Network.HPACK.Huffman.ByteString @@ -64,16 +64,13 @@ Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode Network.HPACK.HeaderBlock.Encode - Network.HPACK.HeaderBlock.From - Network.HPACK.HeaderBlock.HeaderField Network.HPACK.HeaderBlock.Integer - Network.HPACK.HeaderBlock.String - Network.HPACK.HeaderBlock.To Network.HPACK.Table Network.HPACK.Table.Dynamic Network.HPACK.Table.Entry Network.HPACK.Table.RevIndex Network.HPACK.Table.Static + Network.HPACK.Table.Token Network.HPACK.Types Network.HTTP2.Decode Network.HTTP2.Encode @@ -87,7 +84,6 @@ , containers >= 0.5 , psqueues , stm - , unordered-containers ---------------------------------------------------------------- @@ -107,8 +103,8 @@ Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: HPACK.DecodeSpec + HPACK.EncodeSpec HPACK.HeaderBlock - HPACK.HeaderBlockSpec HPACK.HuffmanSpec HPACK.IntegerSpec HTTP2.FrameSpec @@ -122,7 +118,6 @@ , hspec >= 1.3 , psqueues , stm - , unordered-containers , word8 Test-Suite hpack @@ -235,8 +230,8 @@ , containers , directory , filepath - , text , unordered-containers + , text , vector , word8 diff --git a/test-hpack/HPACKDecode.hs b/test-hpack/HPACKDecode.hs --- a/test-hpack/HPACKDecode.hs +++ b/test-hpack/HPACKDecode.hs @@ -17,7 +17,6 @@ import Data.Hex import Data.List (sort) import Network.HPACK -import Network.HPACK.HeaderBlock import Network.HPACK.Table import JSON @@ -31,57 +30,52 @@ run :: Bool -> Test -> IO Result run _ (Test _ []) = return $ Pass run d (Test _ ccs) = do - -- 'size c' must not be used. Initial value is 4,096! - dhdrtbl <- newDynamicTableForDecoding 4096 - let conf = Conf { debug = d } - testLoop conf ccs dhdrtbl + -- 'size c' must not be used. Initial value is defaultDynamicTableSize! + withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dyntbl -> do + let conf = Conf { debug = d } + testLoop conf ccs dyntbl testLoop :: Conf -> [Case] -> DynamicTable -> IO Result -testLoop _ [] _ = return $ Pass -testLoop conf (c:cs) dhdrtbl = do - res <- test conf c dhdrtbl +testLoop _ [] _ = return $ Pass +testLoop conf (c:cs) dyntbl = do + res <- test conf c dyntbl case res of - Right dhdrtbl' -> testLoop conf cs dhdrtbl' - Left e -> return $ Fail e + Nothing -> testLoop conf cs dyntbl + Just e -> return $ Fail e test :: Conf -> Case -> DynamicTable - -> IO (Either String DynamicTable) -test conf c dhdrtbl = do + -> IO (Maybe String) +test conf c dyntbl = do -- context is destructive!!! when (debug conf) $ do putStrLn "--------------------------------" putStrLn "---- Input header list" printHeaderList $ sort hs putStrLn "---- Input header table" - printDynamicTable dhdrtbl + printDynamicTable dyntbl putStrLn "---- Input Hex" B8.putStrLn wirehex - putStrLn "---- Input header block" - print bshd' - dhdrtbl0 <- case size c of - Nothing -> return dhdrtbl - Just siz -> renewDynamicTable siz dhdrtbl - x <- try $ decodeHeader dhdrtbl0 inp + case size c of + Nothing -> return () + Just siz -> renewDynamicTable siz dyntbl + x <- try $ decodeHeader dyntbl inp case x of - Left e -> return $ Left $ show (e :: DecodeError) - Right (dhdrtbl',hs') -> do + Left e -> return $ Just $ show (e :: DecodeError) + Right hs' -> do let pass = sort hs == sort hs' if pass then - return $ Right (dhdrtbl') + return Nothing else - return $ Left $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs' + return $ Just $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hs ++ "\n" ++ show hs' where wirehex = wire c Just inp = unhex wirehex hs = headers c - bshd = fromByteStringDebug inp - hd = map snd <$> bshd - bshd' = map (\(x,y)->(hex x,y)) <$> bshd -- | Printing 'HeaderList'. printHeaderList :: HeaderList -> IO () diff --git a/test-hpack/HPACKEncode.hs b/test-hpack/HPACKEncode.hs --- a/test-hpack/HPACKEncode.hs +++ b/test-hpack/HPACKEncode.hs @@ -19,16 +19,16 @@ data Conf = Conf { debug :: Bool - , enc :: HPACKEncoding + , enc :: DynamicTable -> HeaderList -> IO ByteString } run :: Bool -> EncodeStrategy -> Test -> IO [ByteString] run _ _ (Test _ []) = return [] run d stgy (Test _ ccs@(c:_)) = do let siz = maybe 4096 id $ size c - ehdrtbl <- newDynamicTableForEncoding siz - let conf = Conf { debug = d, enc = encodeHeader stgy } - testLoop conf ccs ehdrtbl [] + withDynamicTableForEncoding siz $ \dyntbl -> do + let conf = Conf { debug = d, enc = encodeHeader stgy 4096 } + testLoop conf ccs dyntbl [] testLoop :: Conf -> [Case] @@ -36,21 +36,21 @@ -> [ByteString] -> IO [ByteString] testLoop _ [] _ hexs = return $ reverse hexs -testLoop conf (c:cs) ehdrtbl hxs = do - (ehdrtbl',hx) <- test conf c ehdrtbl - testLoop conf cs ehdrtbl' (C8.map toLower hx : hxs) +testLoop conf (c:cs) dyntbl hxs = do + hx <- test conf c dyntbl + testLoop conf cs dyntbl (C8.map toLower hx : hxs) test :: Conf -> Case -> DynamicTable - -> IO (DynamicTable, ByteString) -test conf c ehdrtbl = do - (ehdrtbl',out) <- enc conf ehdrtbl hs + -> IO ByteString +test conf c dyntbl = do + out <- enc conf dyntbl hs let hex' = hex out when (debug conf) $ do putStrLn "---- Output context" - printDynamicTable ehdrtbl' + printDynamicTable dyntbl putStrLn "--------------------------------" - return (ehdrtbl', hex') + return hex' where hs = headers c diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -2,9 +2,8 @@ module HPACK.DecodeSpec where -import Network.HPACK.HeaderBlock +import Network.HPACK import Network.HPACK.Table -import Network.HPACK.Types import Test.Hspec import HPACK.HeaderBlock @@ -13,30 +12,29 @@ spec = do describe "fromHeaderBlock" $ do it "decodes HeaderList in request" $ do - (c1,h1) <- newDynamicTableForDecoding 4096 >>= flip fromHeaderBlock d41 - h1 `shouldBe` d41h - (c2,h2) <- fromHeaderBlock c1 d42 - h2 `shouldBe` d42h - (_,h3) <- fromHeaderBlock c2 d43 - h3 `shouldBe` d43h + withDynamicTableForDecoding 4096 4096 $ \dyntabl -> do + h1 <- decodeHeader dyntabl d41b + h1 `shouldBe` d41h + h2 <- decodeHeader dyntabl d42b + h2 `shouldBe` d42h + h3 <- decodeHeader dyntabl d43b + h3 `shouldBe` d43h it "decodes HeaderList in response" $ do - (c1,h1) <- newDynamicTableForDecoding 256 >>= flip fromHeaderBlock d61 - h1 `shouldBe` d61h - (c2,h2) <- fromHeaderBlock c1 d62 - h2 `shouldBe` d62h - (_,h3) <- fromHeaderBlock c2 d63 - h3 `shouldBe` d63h - it "decodes HeaderList even if an entry is larger than DynamicTable" $ do - (c1,h1) <- newDynamicTableForDecoding 64 >>= flip fromHeaderBlock hb1 - h1 `shouldBe` hl1 - isDynamicTableEmpty c1 `shouldBe` True - -hb1 :: HeaderBlock -hb1 = [Literal Add (Lit "custom-key") "custom-value" - -- this is larger than the header table - ,Literal Add (Lit "loooooooooooooooooooooooooooooooooooooooooog-key") - "loooooooooooooooooooooooooooooooooooooooooog-value" - ] + withDynamicTableForDecoding 256 4096 $ \dyntabl -> do + h1 <- decodeHeader dyntabl d61b + h1 `shouldBe` d61h + h2 <- decodeHeader dyntabl d62b + h2 `shouldBe` d62h + h3 <- decodeHeader dyntabl d63b + h3 `shouldBe` d63h + it "decodes HeaderList even if an entry is larger than DynamicTable" $ + withDynamicTableForEncoding 64 $ \etbl -> + withDynamicTableForDecoding 64 4096 $ \dtbl -> do + hs <- encodeHeader defaultEncodeStrategy 4096 etbl hl1 + h1 <- decodeHeader dtbl hs + h1 `shouldBe` hl1 + isDynamicTableEmpty etbl `shouldReturn` True + isDynamicTableEmpty dtbl `shouldReturn` True hl1 :: HeaderList hl1 = [("custom-key","custom-value") diff --git a/test/HPACK/EncodeSpec.hs b/test/HPACK/EncodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPACK/EncodeSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +module HPACK.EncodeSpec where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Exception (onException) +import qualified Data.ByteString as BS +import Network.HPACK +import Test.Hspec + +spec :: Spec +spec = do + describe "encodeHeader and decodeHeader" $ do + it "works for Naive" $ + run EncodeStrategy {compressionAlgo = Naive, useHuffman = False} [] + it "works for NaiveH" $ + run EncodeStrategy {compressionAlgo = Naive, useHuffman = True} [] + it "works for Static" $ + run EncodeStrategy {compressionAlgo = Static, useHuffman = False} [] + it "works for StaticH" $ + run EncodeStrategy {compressionAlgo = Static, useHuffman = True} [] + it "works for Linear" $ + run EncodeStrategy {compressionAlgo = Linear, useHuffman = False} linearLens + it "works for LinearH" $ + run EncodeStrategy {compressionAlgo = Linear, useHuffman = True} [] + +run :: EncodeStrategy -> [Int] -> Expectation +run stgy lens = do + hdrs <- read <$> readFile "bench-hpack/headers.hs" + withDynamicTableForEncoding defaultDynamicTableSize $ \etbl -> + withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dtbl -> + go etbl dtbl stgy hdrs lens `shouldReturn` True + +go :: DynamicTable -> DynamicTable -> EncodeStrategy -> [HeaderList] -> [Int] -> IO Bool +go _ _ _ [] _ = return True +go etbl dtbl stgy (h:hs) lens = do + bs <- encodeHeader stgy 4096 etbl h `onException` print h + let lens' = case lens of + l:ls + | BS.length bs == l -> ls + | otherwise -> error $ show h ++ "\nshould be " ++ show l + [] -> [] + h' <- decodeHeader dtbl bs `onException` print h + if h == h' then + go etbl dtbl stgy hs lens' + else do + return False + +linearLens :: [Int] +linearLens = [250,312,26,390,288,204,224,204,200,202,204,204,206,206,228,100,204,204,218,208,228,434,208,608,232,208,208,208,98,202,208,256,168,208,208,224,208,208,382,84,242,208,208,232,208,208,208,210,210,210,210,208,210,222,208,210,400,224,238,206,206,230,252,222,202,202,198,138,250,204,216,204,204,108,96,306,250,242,208,94,226,206,264,222,40,224,810,204,38,266,144,158,254,100,206,110,132,38,254,144,102,132,102,102,102,102,102,210,230,208,204,464,224,142,198,198,410,156,250,218,130,18,26,338,284,238,222,36,142,208,92,34,552,152,206,1020,288,42,490,98,40,1884,434,300,240,206,278,278,268,252,460,632,178,220,298,144,430,746,724,202,330,144,204,206,782,146,206,206,146,240,228,204,206,208,300,144,160,146,146,38,280,220,144,146,100,144,418,206,204,294,144,300,228,204,204,146,144,240,204,244,218,230,286,102,256,202,208,206,144,146,206,836,204,842,300,220,326,182,300,148,150,204,144,144,98,146,204,206,146,100,204,222,202,202,166,268,146,40,38,142,38,206,418,318,226,174,256,246,274,208,208,208,208,208,544,254,146,146,144,268,160,572,362,178,224,590,362,3150,1034,316,402,204,228,206,206,40,146,142,266,158,142,354,380,264,702,74,424,674,410,688,322,250,300,204,188,60,298,204,206,468,230,200,232,222,208,210,272,282,252,218,724,144,238,206,208,210,100,254,146,144,124,38,112,204,204,216,168,208,276,100,206,116,100,326,892,194,102,210,102,210,206,40,126,102,100,208,98,242,206,218,278,282,292,234,144,40,144,202,288,206,98,40,146,148,40,116,850,242,38,40,40,148,204,110,290,162,662,212,218,230,100,100,134,100,1026,100,2442,100,100,100,208,100,100,112,100,164,144,100,100,100,110,100,518,202,232,342,728,46,384,204,230,100,398,100,208,114,102,290,208,246,324,782,296,280,796,636,268,84,74,246,34,38,284,612,1090,332,602,378,84,24,256,204,234,26,226,654,60,206,28,160,220,238,38,204,484,206,440,308,206,246,392,314,814,714,200,244,290,258,50,94,252,572,38,284,1050,286,24,252,24,728,46,400,390,330,214,740,368,244,38,252,32,244,252,246,36,94,22,638,296,206,304,32,34,246,240,20,306,340,28,276,226,814,638,278,40,226,50,38,34,42,630,552,252,84,244,252,240,20,198,346,284,290,202,240,300,206,102,214,204,210,430,210,208,144,252,210,240,208,304,224,208,100,354,102,210,764,102,240,210,208,208,102,208,102,208,208,100,102,208,210,100,100,154,268,222,286,256,260,92,642,232,208,262,204,146,100,260,226,146,72,206,38,98,394,1090,348,2602,112,102,490,526,312,486,366,368,368,368,368,674,46,462,202,220,210,516,906,154,384,300,280,206,102,102,102,102,102,102,102,626,102,160,88,226,50,248,34,36,632,308,1124,684,450,254,252,714,60] diff --git a/test/HPACK/HeaderBlock.hs b/test/HPACK/HeaderBlock.hs --- a/test/HPACK/HeaderBlock.hs +++ b/test/HPACK/HeaderBlock.hs @@ -5,7 +5,6 @@ import Data.ByteString (ByteString) import Data.Hex import Data.Maybe (fromJust) -import Network.HPACK.HeaderBlock import Network.HPACK.Types fromHexString :: ByteString -> ByteString @@ -13,14 +12,6 @@ ---------------------------------------------------------------- -d41 :: HeaderBlock -d41 = [ - Indexed 2 - , Indexed 6 - , Indexed 4 - , Literal Add (Idx 1) "www.example.com" - ] - d41h :: HeaderList d41h = [(":method","GET") ,(":scheme","http") @@ -31,15 +22,6 @@ d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" -d42 :: HeaderBlock -d42 = [ - Indexed 2 - , Indexed 6 - , Indexed 4 - , Indexed 62 - , Literal Add (Idx 24) "no-cache" - ] - d42h :: HeaderList d42h = [(":method","GET") ,(":scheme","http") @@ -50,15 +32,6 @@ d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" -d43 :: HeaderBlock -d43 = [ - Indexed 2 - , Indexed 7 - , Indexed 5 - , Indexed 63 - , Literal Add (Lit "custom-key") "custom-value" - ] - d43h :: HeaderList d43h = [(":method","GET") ,(":scheme","https") @@ -72,14 +45,6 @@ ---------------------------------------------------------------- -d61 :: HeaderBlock -d61 = [ - Literal Add (Idx 8) "302" - , Literal Add (Idx 24) "private" - , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:21 GMT" - , Literal Add (Idx 46) "https://www.example.com" - ] - d61h :: HeaderList d61h = [(":status","302") ,("cache-control","private") @@ -90,14 +55,6 @@ d61b :: ByteString d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" -d62 :: HeaderBlock -d62 = [ - Literal Add (Idx 8) "307" - , Indexed 65 - , Indexed 64 - , Indexed 63 - ] - d62h :: HeaderList d62h = [(":status","307") ,("cache-control","private") @@ -107,16 +64,6 @@ d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" - -d63 :: HeaderBlock -d63 = [ - Indexed 8 - , Indexed 65 - , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:22 GMT" - , Indexed 64 - , Literal Add (Idx 26) "gzip" - ,Literal Add (Idx 55) "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1" - ] d63h :: HeaderList d63h = [(":status","200") diff --git a/test/HPACK/HeaderBlockSpec.hs b/test/HPACK/HeaderBlockSpec.hs deleted file mode 100644 --- a/test/HPACK/HeaderBlockSpec.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HPACK.HeaderBlockSpec where - -import qualified Data.ByteString.Char8 as BS -import Network.HPACK.HeaderBlock -import Test.Hspec -import Test.Hspec.QuickCheck - -import HPACK.HeaderBlock - -spec :: Spec -spec = do - describe "toByteString" $ do - it "encodes HeaderBlock" $ do - toByteString True d41 `shouldBe` d41b - toByteString True d42 `shouldBe` d42b - toByteString True d43 `shouldBe` d43b - toByteString True d61 `shouldBe` d61b - toByteString True d62 `shouldBe` d62b - toByteString True d63 `shouldBe` d63b - - describe "fromByteString" $ do - it "encodes HeaderBlock" $ do - fromByteString d41b `shouldBe` Right d41 - fromByteString d42b `shouldBe` Right d42 - fromByteString d43b `shouldBe` Right d43 - fromByteString d61b `shouldBe` Right d61 - fromByteString d62b `shouldBe` Right d62 - fromByteString d63b `shouldBe` Right d63 - - describe "toByteString & fromByteString" $ do - prop "duality for request" $ \k v -> do - let key = BS.pack ('k':k) - val = BS.pack ('v':v) - hb = [Literal Add (Lit key) val] - fromByteString (toByteString True hb) `shouldBe` Right hb - prop "duality for response" $ \v -> do - let val = BS.pack ('v':v) - hb = [Literal Add (Idx 3) val] - fromByteString (toByteString True hb) `shouldBe` Right hb diff --git a/test/HPACK/HuffmanSpec.hs b/test/HPACK/HuffmanSpec.hs --- a/test/HPACK/HuffmanSpec.hs +++ b/test/HPACK/HuffmanSpec.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} module HPACK.HuffmanSpec where +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) @@ -28,27 +31,32 @@ ] shouldBeEncoded :: ByteString -> ByteString -> Expectation -shouldBeEncoded inp out = enc inp `shouldBe` out - where - enc = BS.map toLower . hex . encode +shouldBeEncoded inp out = do + out' <- BS.map toLower . hex <$> encodeHuffman inp + out' `shouldBe` out -shouldBeDecoded :: ByteString -> Either DecodeError ByteString -> Expectation -shouldBeDecoded inp out = dec inp `shouldBe` out - where - dec = decode . fromJust . unhex +shouldBeDecoded :: ByteString -> ByteString -> Expectation +shouldBeDecoded inp out = do + out' <- decodeHuffman $ fromJust $ unhex inp + out' `shouldBe` out +tryDecode :: ByteString -> IO ByteString +tryDecode inp = decodeHuffman $ fromJust $ unhex inp + spec :: Spec spec = do describe "encode and decode" $ do - prop "duality" $ \cs -> + prop "duality" $ \cs -> do let bs = BS.pack cs - in decode (encode bs) == Right bs + es <- encodeHuffman bs + ds <- decodeHuffman es + ds `shouldBe` bs describe "encode" $ do it "encodes" $ do mapM_ (\(x,y) -> x `shouldBeEncoded` y) testData describe "decode" $ do it "decodes" $ do - "ff" `shouldBeDecoded` Left TooLongEos - "ffffea" `shouldBeDecoded` Right "\9" - "ffffeaff" `shouldBeDecoded` Left TooLongEos - mapM_ (\(x,y) -> y `shouldBeDecoded` Right x) testData + tryDecode "ff" `shouldThrow` (== TooLongEos) + tryDecode "ffffeaff" `shouldThrow` (== TooLongEos) + "ffffea" `shouldBeDecoded` "\9" + mapM_ (\(x,y) -> y `shouldBeDecoded` x) testData diff --git a/test/HPACK/IntegerSpec.hs b/test/HPACK/IntegerSpec.hs --- a/test/HPACK/IntegerSpec.hs +++ b/test/HPACK/IntegerSpec.hs @@ -5,11 +5,13 @@ import Test.Hspec.QuickCheck import qualified Data.ByteString as BS -dual :: Int -> Int -> Bool -dual n i = decode n w (BS.pack ws) == x - where - w:ws = encode n x - x = abs i +dual :: Int -> Int -> Expectation +dual n i = do + let x = abs i + bs <- encodeInteger n x + let Just (w, ws) = BS.uncons bs + x' <- decodeInteger n w ws + x `shouldBe` x' spec :: Spec spec = do