http2 1.4.5 → 1.5.0
raw patch · 36 files changed
+1926/−1218 lines, 36 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Network.HPACK: EmptyBlock :: DecodeError
- Network.HPACK: encodeHeaderBuilder :: EncodeStrategy -> HPACKEncodingBuilder
- Network.HPACK: type HPACKDecoding = DynamicTable -> ByteString -> IO (DynamicTable, HeaderList)
- Network.HPACK: type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteString)
- Network.HPACK: type HPACKEncodingBuilder = DynamicTable -> HeaderList -> IO (DynamicTable, Builder)
+ Network.HPACK: BufferOverrun :: BufferOverrun
+ Network.HPACK: HeaderBlockTruncated :: DecodeError
+ Network.HPACK: TooSmallTableSize :: DecodeError
+ Network.HPACK: clearDynamicTable :: DynamicTable -> IO ()
+ Network.HPACK: data BufferOverrun
+ Network.HPACK: encodeHeaderBuffer :: Buffer -> BufferSize -> EncodeStrategy -> Bool -> DynamicTable -> HeaderList -> IO (HeaderList, Int)
+ Network.HPACK: type Buffer = Ptr Word8
+ Network.HPACK: type BufferSize = Int
+ Network.HPACK: withDynamicTableForDecoding :: Size -> Size -> (DynamicTable -> IO a) -> IO a
+ Network.HPACK: withDynamicTableForEncoding :: Size -> (DynamicTable -> IO a) -> IO a
- Network.HPACK: decodeHeader :: HPACKDecoding
+ Network.HPACK: decodeHeader :: DynamicTable -> ByteString -> IO HeaderList
- Network.HPACK: encodeHeader :: EncodeStrategy -> HPACKEncoding
+ Network.HPACK: encodeHeader :: EncodeStrategy -> Size -> DynamicTable -> HeaderList -> IO ByteString
- Network.HPACK: newDynamicTableForDecoding :: Size -> IO DynamicTable
+ Network.HPACK: newDynamicTableForDecoding :: Size -> Size -> IO DynamicTable
Files
- ChangeLog.md +5/−0
- Network/HPACK.hs +12/−47
- Network/HPACK/Buffer.hs +164/−0
- Network/HPACK/Builder/Word8.hs +0/−28
- Network/HPACK/HeaderBlock.hs +3/−13
- Network/HPACK/HeaderBlock/Decode.hs +118/−90
- Network/HPACK/HeaderBlock/Encode.hs +188/−75
- Network/HPACK/HeaderBlock/From.hs +0/−78
- Network/HPACK/HeaderBlock/HeaderField.hs +0/−34
- Network/HPACK/HeaderBlock/Integer.hs +45/−61
- Network/HPACK/HeaderBlock/String.hs +0/−26
- Network/HPACK/HeaderBlock/To.hs +0/−116
- Network/HPACK/Huffman.hs +2/−0
- Network/HPACK/Huffman/Decode.hs +326/−52
- Network/HPACK/Huffman/Encode.hs +41/−58
- Network/HPACK/Table.hs +10/−56
- Network/HPACK/Table/Dynamic.hs +266/−157
- Network/HPACK/Table/Entry.hs +18/−10
- Network/HPACK/Table/RevIndex.hs +197/−30
- Network/HPACK/Table/Static.hs +9/−32
- Network/HPACK/Table/Token.hs +268/−0
- Network/HPACK/Types.hs +35/−5
- Network/HTTP2/Priority/PSQ.hs +15/−29
- bench-hpack/Main.hs +34/−19
- bench-priority/BinaryHeap.hs +9/−6
- bench-priority/BinaryHeapSTM.hs +9/−4
- bench-priority/Heap.hs +10/−5
- http2.cabal +6/−11
- test-hpack/HPACKDecode.hs +20/−26
- test-hpack/HPACKEncode.hs +12/−12
- test/HPACK/DecodeSpec.hs +23/−25
- test/HPACK/EncodeSpec.hs +52/−0
- test/HPACK/HeaderBlock.hs +0/−53
- test/HPACK/HeaderBlockSpec.hs +0/−41
- test/HPACK/HuffmanSpec.hs +22/−14
- test/HPACK/IntegerSpec.hs +7/−5
ChangeLog.md view
@@ -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.
Network/HPACK.hs view
@@ -3,25 +3,26 @@ -- | HPACK(<https://tools.ietf.org/html/rfc7541>) 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
+ Network/HPACK/Buffer.hs view
@@ -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
− Network/HPACK/Builder/Word8.hs
@@ -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
Network/HPACK/HeaderBlock.hs view
@@ -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
Network/HPACK/HeaderBlock/Decode.hs view
@@ -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
Network/HPACK/HeaderBlock/Encode.hs view
@@ -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
− Network/HPACK/HeaderBlock/From.hs
@@ -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
− Network/HPACK/HeaderBlock/HeaderField.hs
@@ -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)
Network/HPACK/HeaderBlock/Integer.hs view
@@ -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'
− Network/HPACK/HeaderBlock/String.hs
@@ -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
− Network/HPACK/HeaderBlock/To.hs
@@ -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"- ]
Network/HPACK/Huffman.hs view
@@ -4,7 +4,9 @@ , HuffmanDecoding -- * Encoding/decoding , encode+ , encodeHuffman , decode+ , decodeHuffman ) where import Network.HPACK.Huffman.Decode
Network/HPACK/Huffman/Decode.hs view
@@ -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] ]+
Network/HPACK/Huffman/Encode.hs view
@@ -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
Network/HPACK/Table.hs view
@@ -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
Network/HPACK/Table/Dynamic.hs view
@@ -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
Network/HPACK/Table/Entry.hs view
@@ -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
Network/HPACK/Table/RevIndex.hs view
@@ -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
Network/HPACK/Table/Static.hs view
@@ -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
+ Network/HPACK/Table/Token.hs view
@@ -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
Network/HPACK/Types.hs view
@@ -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
Network/HTTP2/Priority/PSQ.hs view
@@ -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
bench-hpack/Main.hs view
@@ -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
bench-priority/BinaryHeap.hs view
@@ -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
bench-priority/BinaryHeapSTM.hs view
@@ -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
bench-priority/Heap.hs view
@@ -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
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 1.4.5+Version: 1.5.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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
test-hpack/HPACKDecode.hs view
@@ -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 ()
test-hpack/HPACKEncode.hs view
@@ -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
test/HPACK/DecodeSpec.hs view
@@ -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")
+ test/HPACK/EncodeSpec.hs view
@@ -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]
test/HPACK/HeaderBlock.hs view
@@ -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")
− test/HPACK/HeaderBlockSpec.hs
@@ -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
test/HPACK/HuffmanSpec.hs view
@@ -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
test/HPACK/IntegerSpec.hs view
@@ -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