http2 0.1.1 → 0.1.2
raw patch · 42 files changed
+1601/−736 lines, 42 filesdep +PSQueuedep +containersdep +word8dep −hashtablesdep ~basedep ~bytestringnew-component:exe:hpack-debugnew-component:exe:hpack-encode
Dependencies added: PSQueue, containers, word8
Dependencies removed: hashtables
Dependency ranges changed: base, bytestring
Files
- Network/HPACK.hs +20/−9
- Network/HPACK/Builder/Word8.hs +28/−0
- Network/HPACK/Context.hs +72/−85
- Network/HPACK/Context/HeaderSet.hs +0/−13
- Network/HPACK/Context/ReferenceSet.hs +56/−17
- Network/HPACK/HeaderBlock/Decode.hs +37/−28
- Network/HPACK/HeaderBlock/Encode.hs +33/−23
- Network/HPACK/HeaderBlock/From.hs +37/−18
- Network/HPACK/HeaderBlock/Integer.hs +30/−32
- Network/HPACK/HeaderBlock/String.hs +16/−11
- Network/HPACK/HeaderBlock/To.hs +104/−47
- Network/HPACK/Huffman.hs +2/−1
- Network/HPACK/Huffman/Bit.hs +5/−31
- Network/HPACK/Huffman/ByteString.hs +53/−0
- Network/HPACK/Huffman/Code.hs +0/−112
- Network/HPACK/Huffman/Decode.hs +102/−0
- Network/HPACK/Huffman/Encode.hs +119/−0
- Network/HPACK/Huffman/Params.hs +4/−0
- Network/HPACK/Huffman/Request.hs +2/−1
- Network/HPACK/Huffman/Response.hs +2/−2
- Network/HPACK/Huffman/Tree.hs +82/−0
- Network/HPACK/Table.hs +188/−31
- Network/HPACK/Table/Entry.hs +5/−0
- Network/HPACK/Table/HashPSQ.hs +66/−0
- Network/HPACK/Table/Header.hs +0/−135
- Network/HPACK/Table/Static.hs +27/−55
- Network/HPACK/Types.hs +25/−0
- http2.cabal +60/−11
- test-hpack/HPACK.hs +106/−0
- test-hpack/HPACKSpec.hs +4/−3
- test-hpack/HexString.hs +53/−0
- test-hpack/Types.hs +99/−0
- test-hpack/hpack-debug.hs +20/−0
- test-hpack/hpack-encode.hs +44/−0
- test/BitSpec.hs +0/−12
- test/DecodeSpec.hs +12/−8
- test/HeaderBlock.hs +6/−7
- test/HeaderBlockSpec.hs +8/−8
- test/HexString.hs +49/−13
- test/HuffmanRequestSpec.hs +11/−11
- test/HuffmanResponseSpec.hs +11/−11
- test/IntegerSpec.hs +3/−1
Network/HPACK.hs view
@@ -11,7 +11,12 @@ , decodeResponseHeader -- * Contenxt , Context- , newContext+ , newContextForEncoding+ , newContextForDecoding+ -- * Strategy for encoding+ , CompressionAlgo(..)+ , EncodeStrategy(..)+ , defaultEncodeStrategy -- * Errors for decoding , DecodeError(..) -- * Headers@@ -28,11 +33,11 @@ import Control.Applicative ((<$>)) import Control.Arrow (second) import Control.Exception (throwIO)-import Network.HPACK.Context (Context, newContext, HeaderSet)+import Network.HPACK.Context (Context, newContextForEncoding, newContextForDecoding, HeaderSet) import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteStream, fromByteStream) import Network.HPACK.Huffman (huffmanEncodeInRequest, huffmanDecodeInRequest, huffmanEncodeInResponse, huffmanDecodeInResponse) import Network.HPACK.Table (Size)-import Network.HPACK.Types (ByteStream, DecodeError(..), Header, HeaderName, HeaderValue, Index)+import Network.HPACK.Types ---------------------------------------------------------------- @@ -45,10 +50,13 @@ ---------------------------------------------------------------- -- | Converting 'HeaderSet' for HTTP request to the low level format.-encodeRequestHeader :: HPACKEncoding-encodeRequestHeader ctx hs = second toBS <$> toHeaderBlock ctx hs+encodeRequestHeader :: EncodeStrategy -> HPACKEncoding+encodeRequestHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs where- toBS = toByteStream huffmanEncodeInRequest+ algo = compressionAlgo stgy+ toBS+ | useHuffman stgy = toByteStream huffmanEncodeInRequest True+ | otherwise = toByteStream id False -- | Converting the low level format for HTTP request to 'HeaderSet'. -- 'DecodeError' would be thrown.@@ -60,10 +68,13 @@ ---------------------------------------------------------------- -- | Converting 'HeaderSet' for HTTP response to the low level format.-encodeResponseHeader :: HPACKEncoding-encodeResponseHeader ctx hs = second toBS <$> toHeaderBlock ctx hs+encodeResponseHeader :: EncodeStrategy -> HPACKEncoding+encodeResponseHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs where- toBS = toByteStream huffmanEncodeInResponse+ algo = compressionAlgo stgy+ toBS+ | useHuffman stgy = toByteStream huffmanEncodeInResponse True+ | otherwise = toByteStream id False -- | Converting the low level format for HTTP response to 'HeaderSet'. -- 'DecodeError' would be thrown.
+ Network/HPACK/Builder/Word8.hs view
@@ -0,0 +1,28 @@+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/Context.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE BangPatterns #-}- module Network.HPACK.Context ( -- * Types HeaderSet -- re-exporting , Context- , newContext+ , newContextForEncoding+ , newContextForDecoding , DecodeError(..) , printContext -- * Initialization and final results- , clearHeaderSet- , getHeaderSet- , emitNotEmitted+ , emitNotEmittedForEncoding+ , emitNotEmittedForDecoding -- * Processing , clearRefSets , removeRef- , newEntry+ , newEntryForEncoding+ , newEntryForDecoding , pushRef- , emitOnly -- * Auxiliary functions , isPresentIn+ , Sequence(..)+ , checkAndUpdate , getEntry -- * Table , whichTable@@ -34,105 +34,99 @@ ---------------------------------------------------------------- -- | Context for HPACK encoding/decoding.+-- This is destructive! data Context = Context {- headerTable :: !HeaderTable -- ^ A cache of headers- , oldReferenceSet :: ReferenceSet -- ^ References for not emitted- , newReferenceSet :: ReferenceSet -- ^ References for already mitted- , headerSet :: HeaderSet -- ^ Emitted header set.- -- Encode: the previous ones.- -- Decode: the results.+ headerTable :: !HeaderTable -- ^ A cache of headers+ , referenceSet :: ReferenceSet -- ^ Reference set } -- | Printing 'Context' printContext :: Context -> IO ()-printContext (Context hdrtbl oldref newref hdrset) = do+printContext (Context hdrtbl refs) = do putStrLn "<<<Header table>>>" printHeaderTable hdrtbl putStr "\n"- putStrLn "<<<Reference set (old)>>>"- print $ getIndices oldref- putStr "\n"- putStrLn "<<<Reference set (new)>>>"- print $ getIndices newref- putStr "\n"- putStrLn "<<<Headers>>>"- printHeaderSet hdrset+ putStrLn "<<<Reference set>>>"+ print refs ---------------------------------------------------------------- -- | Creating a new 'Context'. -- The first argument is the size of a header table.-newContext :: Size -> IO Context-newContext maxsiz = do- hdrtbl <- newHeaderTable maxsiz- return $ Context hdrtbl- emptyReferenceSet- emptyReferenceSet- emptyHeaderSet+newContextForEncoding :: Size -> IO Context+newContextForEncoding maxsiz = do+ hdrtbl <- newHeaderTableForEncoding maxsiz+ return $ Context hdrtbl emptyReferenceSet +-- | Creating a new 'Context'.+-- The first argument is the size of a header table.+newContextForDecoding :: Size -> IO Context+newContextForDecoding maxsiz = do+ hdrtbl <- newHeaderTableForDecoding maxsiz+ return $ Context hdrtbl emptyReferenceSet+ ---------------------------------------------------------------- -- | The reference set is emptied.-clearRefSets :: Context -> IO Context-clearRefSets ctx = return ctx {- oldReferenceSet = emptyReferenceSet- , newReferenceSet = emptyReferenceSet+clearRefSets :: Context -> Context+clearRefSets ctx = ctx {+ referenceSet = emptyReferenceSet } -- | The entry is removed from the reference set.-removeRef :: Context -> Index -> IO Context-removeRef (Context hdrtbl oldref newref hdrset) idx = return ctx+removeRef :: Context -> Index -> Context+removeRef (Context hdrtbl refs) idx = ctx where- oldref' = removeIndex idx oldref- newref' = removeIndex idx newref- ctx = Context hdrtbl oldref' newref' hdrset+ refs' = removeIndex idx refs+ ctx = Context hdrtbl refs' --- | The header field is emitted.--- The header field is inserted at the beginning of the header table.+-- | The header field is inserted at the beginning of the header table. -- A reference to the new entry is added to the reference set.-newEntry :: Context -> Entry -> IO Context-newEntry (Context hdrtbl oldref newref hdrset) e = do+newEntryForEncoding :: Context -> Entry -> IO ([Index],Context)+newEntryForEncoding (Context hdrtbl refs) e = do (hdrtbl', is) <- insertEntry e hdrtbl- let oldref' = removeIndices is $ adjustReferenceSet oldref- newref' = addIndex 1 $ removeIndices is $ adjustReferenceSet newref- hdrset' = insertHeader (fromEntry e) hdrset- return $ Context hdrtbl' oldref' newref' hdrset'+ let ns = getCommon is refs+ refs' = addIndex 1 $ adjustReferenceSet $ removeIndices is refs+ ctx = Context hdrtbl' refs'+ return (ns, ctx) --- | The header field corresponding to the referenced entry is emitted.--- The referenced header table entry is added to the reference set.-pushRef :: Context -> Index -> Entry -> IO Context-pushRef (Context hdrtbl oldref newref hdrset) idx e = return ctx+-- | The header field is inserted at the beginning of the header table.+-- A reference to the new entry is added to the reference set.+newEntryForDecoding :: Context -> Entry -> IO Context+newEntryForDecoding (Context hdrtbl refs) e = do+ (hdrtbl', is) <- insertEntry e hdrtbl+ let refs' = addIndex 1 $ adjustReferenceSet $ removeIndices is refs+ return $ Context hdrtbl' refs'++-- | The referenced header table entry is added to the reference set.+pushRef :: Context -> Index -> Context+pushRef (Context hdrtbl refs) idx = ctx where- hdrset' = insertHeader (fromEntry e) hdrset -- isPresentIn ensures that idx does not exist in -- newref and oldref.- newref' = addIndex idx newref- ctx = Context hdrtbl oldref newref' hdrset'---- | The header field is emitted.-emitOnly :: Context -> Header -> IO Context-emitOnly (Context hdrtbl oldref newref hdrset) h = return ctx- where- hdrset' = insertHeader h hdrset- ctx = Context hdrtbl oldref newref hdrset'+ refs' = addIndex idx refs+ ctx = Context hdrtbl refs' ---------------------------------------------------------------- -- | Emitting non-emitted headers.-emitNotEmitted :: Context -> IO Context-emitNotEmitted ctx = emit ctx <$> getNotEmitted ctx+emitNotEmittedForEncoding :: Context -> IO ([Index],Context)+emitNotEmittedForEncoding (Context hdrtbl refs) = do+ let (removedIndces,refs') = renewForEncoding refs+ ctx' = Context hdrtbl refs'+ return (removedIndces, ctx') --- | Emit non-emitted headers.-emit :: Context -> HeaderSet -> Context-emit (Context hdrtbl oldref newref hdrset) notEmitted = ctx- where- hdrset' = meregeHeaderSet hdrset notEmitted- oldref' = mergeReferenceSet newref oldref- ctx = Context hdrtbl oldref' emptyReferenceSet hdrset'+-- | Emitting non-emitted headers.+emitNotEmittedForDecoding :: Context -> IO (HeaderSet,Context)+emitNotEmittedForDecoding ctx@(Context hdrtbl refs) = do+ hs <- getNotEmitted ctx+ let refs' = renewForDecoding refs+ ctx' = Context hdrtbl refs'+ return (hs,ctx') getNotEmitted :: Context -> IO HeaderSet getNotEmitted ctx = do- let is = getIndices $ oldReferenceSet ctx+ let is = getNotEmittedIndices $ referenceSet ctx hdrtbl = headerTable ctx map (fromEntry . snd) <$> mapM (which hdrtbl) is @@ -140,10 +134,13 @@ -- | Is 'Index' present in the reference set? isPresentIn :: Index -> Context -> Bool-isPresentIn idx ctx = idx `isMember` oldref || idx `isMember` newref+isPresentIn idx ctx = idx `isMember` referenceSet ctx++checkAndUpdate :: Index -> Context -> (Sequence, Context)+checkAndUpdate idx ctx = (s, ctx') where- oldref = oldReferenceSet ctx- newref = newReferenceSet ctx+ (s,refs') = lookupAndUpdate idx $ referenceSet ctx+ ctx' = ctx { referenceSet = refs' } ---------------------------------------------------------------- @@ -154,7 +151,7 @@ hdrtbl = headerTable ctx -- | Which table contains 'Header'?-lookupHeader :: Header -> Context -> IO HeaderCache+lookupHeader :: Header -> Context -> HeaderCache lookupHeader h ctx = lookupTable h (headerTable ctx) ----------------------------------------------------------------@@ -162,13 +159,3 @@ -- | Getting 'Entry' by 'Index'. getEntry :: Index -> Context -> IO Entry getEntry idx ctx = snd <$> whichTable idx ctx---------------------------------------------------------------------- | Clearing 'HeaderSet' in 'Context' for the next decode.-clearHeaderSet :: Context -> Context-clearHeaderSet ctx = ctx { headerSet = emptyHeaderSet }---- | Getting 'HeaderSet' as emitted headers.-getHeaderSet :: Context -> HeaderSet-getHeaderSet = headerSet
Network/HPACK/Context/HeaderSet.hs view
@@ -8,10 +8,6 @@ -- | Header set. type HeaderSet = [Header] --- | Empty header set.-emptyHeaderSet :: HeaderSet-emptyHeaderSet = []- -- | Printing 'HeaderSet'. printHeaderSet :: HeaderSet -> IO () printHeaderSet hs = mapM_ printHeader hs@@ -21,12 +17,3 @@ putStr ": " BS.putStr v putStr "\n"---- | Merging the emitted header set and the non-emitted header set.-meregeHeaderSet :: HeaderSet -> HeaderSet -> HeaderSet-meregeHeaderSet hdrset notEmitted = reverse $ notEmitted ++ hdrset---- | Inserting 'Header' to 'HeaderSet'.-insertHeader :: Header -> HeaderSet -> HeaderSet-insertHeader = (:)-
Network/HPACK/Context/ReferenceSet.hs view
@@ -3,56 +3,95 @@ ReferenceSet , emptyReferenceSet -- * Index and reference set- , getIndices , isMember , addIndex , removeIndex , removeIndices -- * Managing reference set+ , getNotEmittedIndices , adjustReferenceSet- , mergeReferenceSet+ , renewForEncoding+ , renewForDecoding+ , Sequence(..)+ , lookupAndUpdate+ , getCommon ) where -import Data.List (delete, (\\))+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M import Network.HPACK.Table ---------------------------------------------------------------- +data Status = Old -- E: Initial state for encoding+ | NotEmitted -- E&D: Initial state for decoding+ | Emitted -- E&D:+ deriving (Eq,Show)+ -- | Type for the reference set.-newtype ReferenceSet = ReferenceSet [Index] deriving Show+newtype ReferenceSet = ReferenceSet (Map Index Status) deriving Show+-- Must not use IntMap because its mapKeysMonotonic is slow -- | Empty reference set. emptyReferenceSet :: ReferenceSet-emptyReferenceSet = ReferenceSet []+emptyReferenceSet = ReferenceSet M.empty ---------------------------------------------------------------- --- | Get all 'Index' from 'ReferenceSet'.-getIndices :: ReferenceSet -> [Index]-getIndices (ReferenceSet is) = is- -- | Is 'Index' a member of 'ReferenceSet'? isMember :: Index -> ReferenceSet -> Bool-isMember idx (ReferenceSet is) = idx `elem` is+isMember idx (ReferenceSet m) = idx `M.member` m -- | Adding 'Index' to 'ReferenceSet'. addIndex :: Index -> ReferenceSet -> ReferenceSet-addIndex idx (ReferenceSet is) = ReferenceSet $ idx : is+addIndex idx (ReferenceSet m) = ReferenceSet $ M.insert idx Emitted m -- | Removing 'Index' from 'ReferenceSet'. removeIndex :: Index -> ReferenceSet -> ReferenceSet-removeIndex idx (ReferenceSet is) = ReferenceSet $ delete idx is+removeIndex idx (ReferenceSet m) = ReferenceSet $ M.delete idx m -- | Removing a set of 'Index' from 'ReferenceSet'. removeIndices :: [Index] -> ReferenceSet -> ReferenceSet-removeIndices idcs (ReferenceSet is) = ReferenceSet $ is \\ idcs+removeIndices idcs (ReferenceSet m) = ReferenceSet $ foldl' (flip M.delete) m idcs ---------------------------------------------------------------- +-- | Get all not emitted 'Index' from 'ReferenceSet'.+getNotEmittedIndices :: ReferenceSet -> [Index]+getNotEmittedIndices (ReferenceSet m) = M.keys $ M.filter (== NotEmitted) m++-- | Renewing 'ReferenceSet' for the next encoding step.+renewForEncoding :: ReferenceSet -> ([Index],ReferenceSet)+renewForEncoding (ReferenceSet m) = (removedIndces, ReferenceSet m')+ where+ (oldm,newm) = M.partition (== Old) m+ removedIndces = M.keys oldm+ m' = M.map (const Old) newm++-- | Renewing 'ReferenceSet' for the next decoding step.+renewForDecoding :: ReferenceSet -> ReferenceSet+renewForDecoding (ReferenceSet m) = ReferenceSet m'+ where+ m' = M.map (const NotEmitted) m+ -- | Incrementing all 'Index' by one. adjustReferenceSet :: ReferenceSet -> ReferenceSet-adjustReferenceSet (ReferenceSet is) = ReferenceSet $ map (+1) is+adjustReferenceSet (ReferenceSet m) = ReferenceSet $ M.mapKeysMonotonic (+1) m --- | Merging two 'ReferenceSet'.-mergeReferenceSet :: ReferenceSet -> ReferenceSet -> ReferenceSet-mergeReferenceSet (ReferenceSet xs) (ReferenceSet ys) = ReferenceSet $ xs ++ ys+data Sequence = Z | E0 | E2 | E4++lookupAndUpdate :: Index -> ReferenceSet -> (Sequence,ReferenceSet)+lookupAndUpdate idx rs@(ReferenceSet m) = case M.lookup idx m of+ Nothing -> (Z, rs)+ Just Old -> (E0, ReferenceSet $ M.adjust (const NotEmitted) idx m)+ Just NotEmitted -> (E4, ReferenceSet $ M.adjust (const Emitted) idx m)+ Just Emitted -> (E2, rs)++getCommon :: [Index] -> ReferenceSet -> [Index]+getCommon is (ReferenceSet m) = go is []+ where+ go [] ret = ret+ go (n:ns) ret = case M.lookup n m of+ Just NotEmitted -> go ns (n:ret)+ _ -> go ns ret
Network/HPACK/HeaderBlock/Decode.hs view
@@ -3,6 +3,7 @@ ) where import Data.Bits (testBit, clearBit, (.&.))+import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Word (Word8) import Network.HPACK.Builder@@ -17,44 +18,49 @@ -- | Converting the low level format to 'HeaderBlock'. fromByteStream :: HuffmanDecoding -> ByteStream -> Either DecodeError HeaderBlock-fromByteStream hd bs = go (BS.unpack bs) empty+fromByteStream hd inp = go inp empty where- go [] builder = Right $ run builder- go ws builder = do- (hf, ws') <- toHeaderField hd ws- go ws' (builder << hf)+ go bs builder+ | BS.null bs = Right $ run builder+ | otherwise = do+ (hf, bs') <- toHeaderField hd bs+ go bs' (builder << hf) -toHeaderField :: HuffmanDecoding -> [Word8]- -> Either DecodeError (HeaderField, [Word8])-toHeaderField _ [] = Left EmptyBlock-toHeaderField hd (w:ws)- | w `testBit` 7 = Right $ indexed w ws- | w `testBit` 6 = withoutIndexing hd w ws- | otherwise = incrementalIndexing hd w ws+toHeaderField :: HuffmanDecoding -> ByteString+ -> Either DecodeError (HeaderField, ByteString)+toHeaderField hd bs+ | BS.null bs = Left EmptyBlock+ | w `testBit` 7 = Right $ indexed w bs'+ | w `testBit` 6 = withoutIndexing hd w bs'+ | otherwise = incrementalIndexing hd w bs'+ where+ w = BS.head bs+ bs' = BS.tail bs ---------------------------------------------------------------- -indexed :: Word8 -> [Word8] -> (HeaderField, [Word8])-indexed w ws = (Indexed idx , ws)+indexed :: Word8 -> ByteString -> (HeaderField, ByteString)+indexed w ws = (Indexed idx , ws') where- idx = fromIntegral $ clearBit w 7+ w' = clearBit w 7+ (idx, ws') = I.parseInteger 7 w' ws -withoutIndexing :: HuffmanDecoding -> Word8 -> [Word8]- -> Either DecodeError (HeaderField, [Word8])+withoutIndexing :: HuffmanDecoding -> Word8 -> ByteString+ -> Either DecodeError (HeaderField, ByteString) withoutIndexing hd w ws | isIndexedName w = indexedName NotAdd hd w ws | otherwise = newName NotAdd hd ws -incrementalIndexing :: HuffmanDecoding -> Word8 -> [Word8]- -> Either DecodeError (HeaderField, [Word8])+incrementalIndexing :: HuffmanDecoding -> Word8 -> ByteString+ -> Either DecodeError (HeaderField, ByteString) incrementalIndexing hd w ws | isIndexedName w = indexedName Add hd w ws | otherwise = newName Add hd ws ---------------------------------------------------------------- -indexedName :: Indexing -> HuffmanDecoding -> Word8 -> [Word8]- -> Either DecodeError (HeaderField, [Word8])+indexedName :: Indexing -> HuffmanDecoding -> Word8 -> ByteString+ -> Either DecodeError (HeaderField, ByteString) indexedName indexing hd w ws = do (val,ws'') <- headerStuff hd ws' let hf = Literal indexing (Idx idx) val@@ -64,8 +70,8 @@ (idx,ws') = I.parseInteger 6 p ws -newName :: Indexing -> HuffmanDecoding -> [Word8]- -> Either DecodeError (HeaderField, [Word8])+newName :: Indexing -> HuffmanDecoding -> ByteString+ -> Either DecodeError (HeaderField, ByteString) newName indexing hd ws = do (key,ws') <- headerStuff hd ws (val,ws'') <- headerStuff hd ws'@@ -74,14 +80,17 @@ ---------------------------------------------------------------- -headerStuff :: HuffmanDecoding -> [Word8]- -> Either DecodeError (HeaderStuff, [Word8])-headerStuff _ [] = Left EmptyEncodedString-headerStuff hd (w:ws) = S.parseString hd huff len ws'+headerStuff :: HuffmanDecoding -> ByteString+ -> Either DecodeError (HeaderStuff, ByteString)+headerStuff hd bs+ | BS.null bs = Left EmptyEncodedString+ | otherwise = S.parseString hd huff len bs'' where+ w = BS.head bs+ bs' = BS.tail bs p = dropHuffman w huff = isHuffman w- (len, ws') = I.parseInteger 7 p ws+ (len, bs'') = I.parseInteger 7 p bs' ----------------------------------------------------------------
Network/HPACK/HeaderBlock/Encode.hs view
@@ -5,6 +5,7 @@ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB import Data.Bits (setBit)+import qualified Data.ByteString as BS import Data.List (foldl') import Data.Monoid ((<>), mempty) import Data.Word (Word8)@@ -17,47 +18,56 @@ ---------------------------------------------------------------- -- | Converting 'HeaderBlock' to the low level format.-toByteStream :: HuffmanEncoding -> HeaderBlock -> ByteStream-toByteStream he hbs = BB.toByteString $ foldl' (<>) mempty $ map toBB hbs+toByteStream :: HuffmanEncoding -> Bool -> HeaderBlock -> ByteStream+toByteStream he huff hbs = BB.toByteString $ foldl' (<>) mempty $ map toBB hbs where- toBB = fromHeaderField he+ toBB = fromHeaderField he huff -fromHeaderField :: HuffmanEncoding -> HeaderField -> Builder-fromHeaderField _ (Indexed idx) = index idx-fromHeaderField he (Literal NotAdd (Idx idx) v) = indexedName he set01 idx v-fromHeaderField he (Literal NotAdd (Lit key) v) = newName he set01 key v-fromHeaderField he (Literal Add (Idx idx) v) = indexedName he set00 idx v-fromHeaderField he (Literal Add (Lit key) v) = newName he set00 key v+fromHeaderField :: HuffmanEncoding -> Bool -> HeaderField -> Builder+fromHeaderField _ _ (Indexed idx) = index idx+fromHeaderField he huff (Literal NotAdd (Idx idx) v) = indexedName he huff set01 idx v+fromHeaderField he huff (Literal NotAdd (Lit key) v) = newName he huff set01 key v+fromHeaderField he huff (Literal Add (Idx idx) v) = indexedName he huff set00 idx v+fromHeaderField he huff (Literal Add (Lit key) v) = newName he huff set00 key v ---------------------------------------------------------------- index :: Int -> Builder-index = BB.fromWord8 . set1 . I.encodeOne+index i = BB.fromWord8s (w':ws)+ where+ (w:ws) = I.encode 7 i+ w' = set1 w -- Using Huffman encoding-indexedName :: HuffmanEncoding -> Setter -> Int -> HeaderValue -> Builder-indexedName he set idx v = pre <> vlen <> val+indexedName :: HuffmanEncoding -> Bool -> Setter -> Int -> HeaderValue -> Builder+indexedName he huff set idx v = pre <> vlen <> val where (p:ps) = I.encode 6 idx pre = BB.fromWord8s $ set p : ps value = S.encode he v- valueLen = length value -- FIXME: performance- vlen = BB.fromWord8s $ setH $ I.encode 7 valueLen- val = BB.fromWord8s value+ valueLen = BS.length value+ vlen+ | huff = BB.fromWord8s $ setH $ I.encode 7 valueLen+ | otherwise = BB.fromWord8s $ I.encode 7 valueLen+ val = BB.fromByteString value -- Using Huffman encoding-newName :: HuffmanEncoding -> Setter -> HeaderName -> HeaderValue -> Builder-newName he set k v = pre <> klen <> key <> vlen <> val+newName :: HuffmanEncoding -> Bool -> Setter -> HeaderName -> HeaderValue -> Builder+newName he huff set k v = pre <> klen <> key <> vlen <> val where pre = BB.fromWord8 $ set 0 key0 = S.encode he k- keyLen = length key0 -- FIXME: performance+ keyLen = BS.length key0 value = S.encode he v- valueLen = length value -- FIXME: performance- klen = BB.fromWord8s $ setH $ I.encode 7 keyLen- vlen = BB.fromWord8s $ setH $ I.encode 7 valueLen- key = BB.fromWord8s key0- val = BB.fromWord8s value+ valueLen = BS.length value+ klen+ | huff = BB.fromWord8s $ setH $ I.encode 7 keyLen+ | otherwise = BB.fromWord8s $ I.encode 7 keyLen+ vlen+ | huff = BB.fromWord8s $ setH $ I.encode 7 valueLen+ | otherwise = BB.fromWord8s $ I.encode 7 valueLen+ key = BB.fromByteString key0+ val = BB.fromByteString value ----------------------------------------------------------------
Network/HPACK/HeaderBlock/From.hs view
@@ -6,47 +6,66 @@ ) where import Control.Applicative ((<$>))+import Network.HPACK.Builder import Network.HPACK.Context import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table ---------------------------------------------------------------- +type Ctx = (Context, Builder Header)+type Step = Ctx -> HeaderField -> IO Ctx+ -- | Decoding 'HeaderBlock' to 'HeaderSet'. fromHeaderBlock :: Context -> HeaderBlock -> IO (Context, HeaderSet)-fromHeaderBlock !ctx (r:rs) = decodeStep ctx r >>= \cx -> fromHeaderBlock cx rs-fromHeaderBlock !ctx [] = decodeFinal ctx+fromHeaderBlock !ctx rs = decodeLoop rs (ctx,empty) ---------------------------------------------------------------- +decodeLoop :: HeaderBlock -> Ctx -> IO (Context, HeaderSet)+decodeLoop (r:rs) !ctx = decodeStep ctx r >>= decodeLoop rs+decodeLoop [] !ctx = decodeFinal ctx++----------------------------------------------------------------+ -- | Decoding step for one 'HeaderField'. Exporting for the -- test purpose.-decodeStep :: Context -> HeaderField -> IO Context-decodeStep !ctx (Indexed idx)- | idx == 0 = clearRefSets ctx- | isPresent = removeRef ctx idx+decodeStep :: Step+decodeStep (!ctx,!builder) (Indexed idx)+ | idx == 0 = return (clearRefSets ctx,builder)+ | isPresent = return (removeRef ctx idx, builder) | otherwise = do w <- whichTable idx ctx case w of- (InStaticTable, e) -> newEntry ctx e- (InHeaderTable, e) -> pushRef ctx idx e+ (InStaticTable, e) -> do+ c <- newEntryForDecoding ctx e+ let b = builder << fromEntry e+ return (c,b)+ (InHeaderTable, e) -> do+ let c = pushRef ctx idx+ b = builder << fromEntry e+ return (c,b) where isPresent = idx `isPresentIn` ctx-decodeStep !ctx (Literal NotAdd naming v) = do+decodeStep (!ctx,!builder) (Literal NotAdd naming v) = do k <- fromNaming naming ctx- emitOnly ctx (k,v)-decodeStep !ctx (Literal Add naming v) = do+ let b = builder << (k,v)+ return (ctx, b)+decodeStep (!ctx,!builder) (Literal Add naming v) = do k <- fromNaming naming ctx- newEntry ctx $ toEntry (k,v)+ let h = (k,v)+ e = toEntry (k,v)+ b = builder << h+ c <- newEntryForDecoding ctx e+ return (c,b) -decodeFinal :: Context -> IO (Context, HeaderSet)-decodeFinal ctx = do- !ctx' <- emitNotEmitted ctx- let !hs = getHeaderSet ctx'- !ctx'' = clearHeaderSet ctx'- return (ctx'', hs)+decodeFinal :: Ctx -> IO (Context, HeaderSet)+decodeFinal (!ctx, !builder) = do+ (hs,!ctx') <- emitNotEmittedForDecoding ctx+ let hs' = run builder ++ hs+ return (ctx', hs') ----------------------------------------------------------------
Network/HPACK/HeaderBlock/Integer.hs view
@@ -1,14 +1,18 @@ module Network.HPACK.HeaderBlock.Integer ( encode- , encodeOne , decode- , decodeOne , parseInteger ) where import Data.Array (Array, listArray, (!))+import Data.Bits ((.&.), shiftR)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.Word (Word8) +-- $setup+-- >>> import qualified Data.ByteString as BS+ ---------------------------------------------------------------- powerArray :: Array Int Int@@ -36,51 +40,45 @@ | i < 128 = fromIntegral i : [] | otherwise = fromIntegral (r + 128) : encode' q where- (q,r) = i `divMod` 128---------------------------------------------------------------------- | Integer encoding.-encodeOne :: Int -> Word8-encodeOne = fromIntegral+-- (q,r) = i `divMod` 128+ q = i `shiftR` 7+ r = i .&. 0x7f ---------------------------------------------------------------- -- | Integer decoding. The first argument is N of prefix. ----- >>> decode 5 [10]+-- >>> decode 5 10 $ BS.empty -- 10--- >>> decode 5 [31,154,10]+-- >>> decode 5 31 $ BS.pack [154,10] -- 1337--- >>> decode 8 [42]+-- >>> decode 8 42 $ BS.empty -- 42-decode :: Int -> [Word8] -> Int-decode _ [] = error "decode"-decode n ws- | i < p = i- | otherwise = foldr1 (\x y -> x - 128 + y * 128) is + i+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 = BS.foldr' (\x y -> fromIntegral x - 128 + y * 128) i0 bs' + i where p = powerArray ! n- (i:is) = map fromIntegral ws---- | Integer decoding.-decodeOne :: Word8 -> Int-decodeOne = fromIntegral+ i = fromIntegral w+ i0 = fromIntegral $ BS.last bs+ bs' = BS.init bs ---------------------------------------------------------------- -parseInteger :: Int -> Word8 -> [Word8] -> (Int, [Word8])-parseInteger n w ws- | i < p = (i, ws)+-- |+--+-- >>> 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) where p = powerArray ! n i = fromIntegral w- (ws', rest) = split ws- len = decode n (w:ws')+ Just idx = BS.findIndex (< 128) bs+ (bs', rest) = BS.splitAt (idx + 1) bs+ len = decode n w bs' -split :: [Word8] -> ([Word8],[Word8])-split [] = error "split"-split (w:ws)- | w >= 128 = let (xs,ys) = split ws in (w:xs, ys)- | otherwise = ([w], ws)
Network/HPACK/HeaderBlock/String.hs view
@@ -1,21 +1,26 @@ module Network.HPACK.HeaderBlock.String where +import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.Word (Word8) import Network.HPACK.Huffman import Network.HPACK.Types -encode :: HuffmanEncoding -> HeaderStuff -> [Word8]-encode he h = he $ BS.unpack h+-- | Encoding 'HeaderStuff' to 'ByteString' according to 'HuffmanEncoding'.+encode :: HuffmanEncoding -> HeaderStuff -> ByteString+encode he h = he h -decode :: HuffmanDecoding -> [Word8] -> Either DecodeError HeaderStuff-decode hd ws = hd ws >>= return . BS.pack+-- | Decoding 'ByteString' to 'HeaderStuff' according to 'HuffmanDecoding'.+decode :: HuffmanDecoding -> ByteString -> Either DecodeError HeaderStuff+decode hd ws = hd ws -parseString :: HuffmanDecoding -> Bool -> Int -> [Word8]- -> Either DecodeError (HeaderStuff, [Word8])-parseString _ False len ws = Right (BS.pack es, ws')+-- | 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 :: HuffmanDecoding -> Bool -> Int -> ByteString+ -> Either DecodeError (HeaderStuff, ByteString)+parseString _ False len bs = Right (es, bs') where- (es, ws') = splitAt len ws-parseString hd True len ws = decode hd es >>= \x -> return (x,ws')+ (es, bs') = BS.splitAt len bs+parseString hd True len bs = decode hd es >>= \x -> return (x,bs') where- (es, ws') = splitAt len ws+ (es, bs') = BS.splitAt len bs
Network/HPACK/HeaderBlock/To.hs view
@@ -1,73 +1,130 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Network.HPACK.HeaderBlock.To ( toHeaderBlock ) where -import Control.Applicative ((<$>))+import Data.List (foldl') import Network.HPACK.Builder import Network.HPACK.Context import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table+import Network.HPACK.Types type Ctx = (Context, Builder HeaderField)+type Step = Ctx -> Header -> IO Ctx -- | Encoding 'HeaderSet' to 'HeaderBlock'.-toHeaderBlock :: Context+toHeaderBlock :: CompressionAlgo+ -> Context -> HeaderSet -> IO (Context, HeaderBlock)-toHeaderBlock !ctx hs = encodeInit ctx >>= toHeaderBlock' hs+toHeaderBlock Naive !ctx hs = reset ctx >>= encodeLoop naiveStep hs+toHeaderBlock Linear !ctx hs = reset ctx >>= encodeLoop linearStep hs+toHeaderBlock Diff !ctx hs = encodeLoop diffStep hs (ctx, empty) -toHeaderBlock' :: HeaderSet- -> Ctx- -> IO (Context, HeaderBlock)-toHeaderBlock' (h:hs) !ctx = encodeStep ctx h >>= toHeaderBlock' hs-toHeaderBlock' [] !ctx = encodeFinal ctx+---------------------------------------------------------------- +encodeFinal :: Ctx -> IO (Context, HeaderBlock)+encodeFinal (!ctx, !builder) = do+ (is,!ctx') <- emitNotEmittedForEncoding ctx+ let builder' = foldl' (\b i -> b << Indexed i) builder is+ !hb = run builder'+ return (ctx', hb)++encodeLoop :: Step+ -> HeaderSet+ -> Ctx+ -> IO (Context, HeaderBlock)+encodeLoop step (h:hs) !ctx = step ctx h >>= encodeLoop step hs+encodeLoop _ [] !ctx = encodeFinal ctx+ ----------------------------------------------------------------++-- for naiveStep and linearStep+reset :: Context -> IO Ctx+reset ctx = do+ let ctx' = clearRefSets ctx+ initialHeaderBlock = singleton $ Indexed 0+ return (ctx', initialHeaderBlock)++----------------------------------------------------------------++naiveStep :: Step+naiveStep (!ctx,!builder) (k,v) = do+ let builder' = builder << Literal NotAdd (Lit k) v+ return (ctx, builder')++---------------------------------------------------------------- -- A simple encoding strategy to reset the reference set first -- by 'Index 0' and uses indexing as much as possible. -encodeStep :: Ctx -> Header -> IO Ctx-encodeStep (!ctx,!builder) h@(k,v) = do- cache <- lookupHeader h ctx- let e = toEntry h+linearStep :: Step+linearStep cb@(!ctx,!builder) h = smartStep linear cb h+ where+ linear i+ | i `isPresentIn` ctx = do+ let b = builder << Indexed i << Indexed i+ return (ctx,b)+ | otherwise = do+ let b = builder << Indexed i+ c = pushRef ctx i+ return (c,b)++----------------------------------------------------------------+-- See http://lists.w3.org/Archives/Public/ietf-http-wg/2013JulSep/1135.html++diffStep :: Step+diffStep cb@(!ctx,!builder) h = smartStep diff cb h+ where+ diff i = case checkAndUpdate i ctx of+ (Z, ctx') -> do+ let b = builder << Indexed i+ c = pushRef ctx' i+ return (c,b)+ (E0, ctx') -> return (ctx', builder)+ (E2, ctx') -> do+ let b = builder << Indexed i << Indexed i+ return (ctx',b)+ (E4, ctx') -> do+ let b = builder << Indexed i << Indexed i << Indexed i << Indexed i+ return (ctx',b)++----------------------------------------------------------------++smartStep :: (Index -> IO Ctx) -> Step+smartStep func cb@(!ctx,!builder) h@(k,_) = do+ let cache = lookupHeader h ctx case cache of- None -> do- let builder' = builder << Literal Add (Lit k) v- ctx' <- newEntry ctx e- return (ctx', builder')- KeyOnly InStaticTable i -> do- let builder' = builder << Literal Add (Idx i) v- ctx' <- newEntry ctx e- return (ctx', builder')- KeyOnly InHeaderTable i -> do- let builder' = builder << Literal Add (Idx i) v- ctx' <- newEntry ctx e- return (ctx', builder')+ None -> check cb h (Lit k)+ KeyOnly InStaticTable i -> check cb h (Idx i)+ KeyOnly InHeaderTable i -> check cb h (Idx i) KeyValue InStaticTable i -> do- let builder' = builder << Indexed i- ctx' <- newEntry ctx e- return (ctx', builder')- KeyValue InHeaderTable i -> do- (builder',ctx') <- if i `isPresentIn` ctx then do- let b = builder << Indexed i << Indexed i- c = ctx- return (b,c)- else do- let b = builder << Indexed i- c <- pushRef ctx i e- return (b,c)+ let e = toEntry h+ (is,ctx') <- newEntryForEncoding ctx e+ let builder' = double is builder << Indexed i return (ctx', builder')+ KeyValue InHeaderTable i -> func i -encodeInit :: Context -> IO Ctx-encodeInit ctx = do- ctx' <- clearHeaderSet <$> clearRefSets ctx- let initialHeaderBlock = singleton $ Indexed 0- return (ctx', initialHeaderBlock)+double :: [Index] -> Builder HeaderField -> Builder HeaderField+double is bldr = foldl' (\b i -> b << Indexed i << Indexed i) bldr is -encodeFinal :: Ctx -> IO (Context, HeaderBlock)-encodeFinal (ctx, builder) = do- !ctx' <- emitNotEmitted ctx- let !hb = run builder- return (ctx', hb)+check :: Ctx -> Header -> Naming -> IO Ctx+check (ctx,builder) h@(k,v) x+ | k `elem` headersNotToIndex = do+ let builder' = builder << Literal NotAdd x v+ return (ctx, builder')+ | otherwise = do+ let e = toEntry h+ (is,ctx') <- newEntryForEncoding ctx e+ let builder' = double is builder << Literal Add x v+ return (ctx', builder')++headersNotToIndex :: [HeaderName]+headersNotToIndex = [+ ":path"+ , "content-length"+ , "location"+ , "etag"+ , "set-cookie"+ ]
Network/HPACK/Huffman.hs view
@@ -9,6 +9,7 @@ , huffmanDecodeInResponse ) where +import Network.HPACK.Huffman.Decode+import Network.HPACK.Huffman.Encode import Network.HPACK.Huffman.Request import Network.HPACK.Huffman.Response-import Network.HPACK.Huffman.Code
Network/HPACK/Huffman/Bit.hs view
@@ -1,32 +1,25 @@-{-# LANGUAGE BangPatterns #-}- module Network.HPACK.Huffman.Bit (+ -- * Bits B(..) , Bits , fromBits- , toBits ) where -import Data.List (foldl') import Data.Word (Word8)+import Data.List (foldl') -- | Data type for Bit. data B = F -- ^ Zero | T -- ^ One deriving (Eq,Ord,Show) +-- | Bit stream.+type Bits = [B]+ fromBit :: B -> Word8 fromBit F = 0 fromBit T = 1 -toBit :: Word8 -> B-toBit 0 = F-toBit 1 = T-toBit _ = error "toBit"---- | Bit sequence.-type Bits = [B]- -- | From 'Bits' of length 8 to 'Word8'. -- -- >>> fromBits [T,F,T,F,T,F,T,F]@@ -35,22 +28,3 @@ -- 85 fromBits :: Bits -> Word8 fromBits = foldl' (\x y -> x * 2 + y) 0 . map fromBit---- | From 'Word8' to 'Bits' of length 8.------ >>> toBits 170--- [T,F,T,F,T,F,T,F]--- >>> toBits 85--- [F,T,F,T,F,T,F,T]-toBits :: Word8 -> Bits-toBits = toBits' [] 0--toBits' :: Bits -> Int -> Word8 -> Bits-toBits' bs !cnt 0- | cnt == 8 = bs- | otherwise = replicate (8 - cnt) F ++ bs -- filling missing bits from MSB-toBits' bs !cnt x = toBits' (b:bs) (cnt + 1) q- where- q = x `div` 2- r = x `mod` 2- b = toBit r
+ Network/HPACK/Huffman/ByteString.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Network.HPACK.Huffman.ByteString (+ unpack4bits+ , copy+ ) where++import Control.Monad (void)+import Data.Bits ((.&.), shiftR)+import Data.ByteString.Internal (ByteString(..), inlinePerformIO)+import Data.Word (Word8)+import Foreign.C.Types (CSize(..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek)++-- $setup+-- >>> import qualified Data.ByteString as BS++-- |+--+-- >>> let bs = BS.pack [0x12,0x34,0xf3,0xab]+-- >>> unpack4bits bs+-- [1,2,3,4,15,3,10,11]+-- >>> unpack4bits $ BS.tail bs+-- [3,4,15,3,10,11]++unpack4bits :: ByteString -> [Word8]+unpack4bits (PS fptr off len) = inlinePerformIO $+ withForeignPtr fptr $ \ptr -> do+ let lim = ptr `plusPtr` (off - 1)+ end = ptr `plusPtr` (off + len - 1)+ go lim end []+ where+ go lim p ws+ | lim == p = return ws+ | otherwise = do+ w <- peek p+ let w0 = w `shiftR` 4+ w1 = w .&. 0xf+ go lim (p `plusPtr` (-1)) (w0:w1:ws)+++copy :: Ptr Word8 -> ByteString -> IO ()+copy dst (PS fptr off len) = withForeignPtr fptr $ \ptr -> do+ let beg = ptr `plusPtr` off+ memcpy dst beg (fromIntegral len)++foreign import ccall unsafe "string.h memcpy" c_memcpy+ :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)++memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memcpy dst src s = void $ c_memcpy dst src (fromIntegral s)
− Network/HPACK/Huffman/Code.hs
@@ -1,112 +0,0 @@-module Network.HPACK.Huffman.Code (- -- * Huffman encoding- Encoder- , toEncoder- , HuffmanEncoding- , encode- -- * Huffman decoding- , Decoder- , toDecoder- , HuffmanDecoding- , decode- ) where--import Control.Arrow (second)-import Data.Array (Array, (!), listArray)-import Data.List (partition)-import Data.Word (Word8)-import Network.HPACK.Builder-import Network.HPACK.Huffman.Bit-import Network.HPACK.Types (DecodeError(..))---------------------------------------------------------------------- | Huffman encoding.-type HuffmanEncoding = [Word8] -> [Word8]---- | Huffman decoding.-type HuffmanDecoding = [Word8] -> Either DecodeError [Word8]--------------------------------------------------------------------idxEos :: Int-idxEos = 256---------------------------------------------------------------------- | Type for Huffman encoding.-newtype Encoder = Encoder (Array Int Bits)---- | Creating 'Encoder'.-toEncoder :: [Bits] -> Encoder-toEncoder bs = Encoder $ listArray (0,idxEos) bs---- | Huffman encoding.-encode :: Encoder -> HuffmanEncoding-encode encoder ws = map fromBits $ group8 bits- where- bits = concatMap (enc encoder . fromIntegral) ws- group8 xs- | null zs = eos ys- | otherwise = ys : group8 zs- where- (ys,zs) = splitAt 8 xs- eos xs- | len == 0 = [] -- only when ws == [], [] should be encoded to [].- | len == 8 = [xs]- | otherwise = [take 8 (xs ++ enc encoder idxEos)]- where- len = length xs--enc :: Encoder -> Int -> Bits-enc (Encoder ary) i = ary ! i---------------------------------------------------------------------- | Type for Huffman decoding.-data Decoder = Tip (Maybe Int) Int- | Bin (Maybe Int) Decoder Decoder- deriving Show---- | Creating 'Decoder'.-toDecoder :: [Bits] -> Decoder-toDecoder bs = mark 1 eos $ build $ zip [0..idxEos] bs- where- eos = bs !! idxEos--build :: [(Int,Bits)] -> Decoder-build [(v,[])] = Tip Nothing v-build xs = Bin Nothing (build fs) (build ts)- where- (fs',ts') = partition ((==) F . head . snd) xs- fs = map (second tail) fs'- ts = map (second tail) ts'--mark :: Int -> Bits -> Decoder -> Decoder-mark i [] (Tip Nothing v) = Tip (Just i) v-mark i (F:bs) (Bin Nothing l r) = Bin (Just i) (mark (i+1) bs l) r-mark i (T:bs) (Bin Nothing l r) = Bin (Just i) l (mark (i+1) bs r)-mark _ _ _ = error "mark"---- | Huffman decoding.-decode :: Decoder -> HuffmanDecoding-decode decoder ws = decodeBits decoder (concatMap toBits ws) empty--decodeBits :: Decoder -> Bits -> Builder Word8 -> Either DecodeError [Word8]-decodeBits decoder xs builder = case dec decoder xs of- Right (OK v xs') -> decodeBits decoder xs' (builder << fromIntegral v)- Right Eos -> Right $ run builder- Left err -> Left err--data DecodeOK = Eos | OK Int Bits--dec :: Decoder -> Bits -> Either DecodeError DecodeOK-dec (Tip Nothing v) xs = Right $ OK v xs-dec (Tip _ _) _ = Left EosInTheMiddle-dec (Bin _ l _) (F:xs) = dec l xs-dec (Bin _ _ r) (T:xs) = dec r xs-dec (Bin Nothing _ _) [] = Left IllegalEos-dec (Bin (Just i) _ _) []- -- i is 1 origin. 8 means Bits are consumed in the parent 7.- | i <= 8 = Right Eos- | otherwise = Left TooLongEos
+ Network/HPACK/Huffman/Decode.hs view
@@ -0,0 +1,102 @@+module Network.HPACK.Huffman.Decode (+ -- * Huffman decoding+ Decoder+ , toDecoder+ , HuffmanDecoding+ , decode+ ) where++import Data.ByteString (ByteString)+import Data.Array (Array, (!), listArray)+import Data.Word (Word8)+import Network.HPACK.Builder.Word8+import Network.HPACK.Huffman.Bit+import Network.HPACK.Huffman.ByteString+import Network.HPACK.Huffman.Params+import Network.HPACK.Huffman.Tree+import Network.HPACK.Types (DecodeError(..))++----------------------------------------------------------------++-- | Huffman decoding.+type HuffmanDecoding = ByteString -> Either DecodeError ByteString++----------------------------------------------------------------++data Pin = EndOfString+ | Forward {-# UNPACK #-} !Word8 -- node no.+ | GoBack {-# UNPACK #-} !Word8 -- node no.+ {-# UNPACK #-} !Word8 -- a decoded value+ deriving Show++data Way16 = Way16 (Maybe Int) (Array Word8 Pin)+type Way256 = Array Word8 Way16++next :: Way16 -> Word8 -> Pin+next (Way16 _ a16) w = a16 ! w++newtype Decoder = Decoder Way256++----------------------------------------------------------------++-- | Huffman decoding.+decode :: Decoder -> HuffmanDecoding+decode (Decoder way256) bs = dec way256 qs+ where+ qs = unpack4bits bs++dec :: Way256 -> [Word8] -> Either DecodeError ByteString+dec way256 inp = go (way256 ! 0) inp w8empty+ 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)++----------------------------------------------------------------++toDecoder :: [Bits] -> Decoder+toDecoder = construct . toHTree++construct :: HTree -> Decoder+construct decoder = Decoder $ listArray (0,255) $ map to16ways $ flatten decoder+ where+ to16ways x = Way16 ei a16+ where+ ei = eosInfo x+ a16 = listArray (0,15) $ map (step decoder x Nothing) bits4s++step :: HTree -> HTree -> Maybe Word8 -> [B] -> Pin+step root (Tip _ v) _ 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++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]+ ]
+ Network/HPACK/Huffman/Encode.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE BangPatterns #-}++module Network.HPACK.Huffman.Encode (+ -- * Huffman encoding+ Encoder+ , toEncoder+ , HuffmanEncoding+ , encode+ ) where++import Control.Applicative ((<$>))+import Control.Monad (when)+import Data.Array+import Data.Bits ((.|.))+import qualified Data.ByteString as BS+import Data.ByteString.Internal (ByteString(..), create)+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek, poke)+import Network.HPACK.Huffman.Bit+import Network.HPACK.Huffman.ByteString+import Network.HPACK.Huffman.Params+import System.IO.Unsafe (unsafePerformIO)++----------------------------------------------------------------++-- | Type for Huffman encoding.+newtype Encoder = Encoder (Array Int ShiftedArray) deriving Show++type ShiftedArray = Array Int Shifted++data Shifted = Shifted !Int -- Total bytes+ !Int -- How many bits in the last byte+ ByteString -- Up to 5 bytes+ deriving Show++----------------------------------------------------------------++-- | Creating 'Encoder'.+toEncoder :: [Bits] -> Encoder+toEncoder bss = Encoder $ listArray (0,idxEos) $ map toShiftedArray bss++-- fixme+-- |+--+-- >>> toShifted [T,T,T,T] 0+-- Shifted 1 4 "\240"+-- >>> toShifted [T,T,T,T] 4+-- Shifted 1 0 "\SI"+-- >>> toShifted [T,T,T,T] 5+-- Shifted 2 1 "\a\128"++toShifted :: Bits -> Int -> Shifted+toShifted bits n = Shifted total r 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+ group8 xs+ | null zs = pad ys : []+ | otherwise = ys : group8 zs+ where+ (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++-- | Huffman encoding.+encode :: Encoder -> HuffmanEncoding+encode (Encoder aoa) (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)+ 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' _ = (aoa ! 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 = (aoa ! 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 = (aoa ! 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
+ Network/HPACK/Huffman/Params.hs view
@@ -0,0 +1,4 @@+module Network.HPACK.Huffman.Params where++idxEos :: Int+idxEos = 256
Network/HPACK/Huffman/Request.hs view
@@ -4,7 +4,8 @@ ) where import Network.HPACK.Huffman.Bit-import Network.HPACK.Huffman.Code+import Network.HPACK.Huffman.Decode+import Network.HPACK.Huffman.Encode ----------------------------------------------------------------
Network/HPACK/Huffman/Response.hs view
@@ -4,7 +4,8 @@ ) where import Network.HPACK.Huffman.Bit-import Network.HPACK.Huffman.Code+import Network.HPACK.Huffman.Decode+import Network.HPACK.Huffman.Encode ---------------------------------------------------------------- @@ -285,4 +286,3 @@ , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,F,T,T] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,F] , [T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,T,F,T,T,T,F,T]]-
+ Network/HPACK/Huffman/Tree.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE BangPatterns #-}++module Network.HPACK.Huffman.Tree (+ -- * Huffman decoding+ HTree(..)+ , eosInfo+ , toHTree+ , showTree+ , printTree+ , flatten+ ) where++import Control.Arrow (second)+import Data.List (partition)+import Network.HPACK.Huffman.Bit+import Network.HPACK.Huffman.Params++----------------------------------------------------------------++type EOSInfo = Maybe Int++-- | Type for Huffman decoding.+data HTree = Tip+ EOSInfo -- EOS info from 1+ {-# UNPACK #-} !Int -- Decoded value. Essentially Word8+ | Bin+ EOSInfo -- EOS info from 1+ {-# UNPACK #-} !Int -- Sequence no from 0+ HTree -- Left+ HTree -- Right+ deriving Show++eosInfo :: HTree -> EOSInfo+eosInfo (Tip mx _) = mx+eosInfo (Bin mx _ _ _) = mx++----------------------------------------------------------------++showTree :: HTree -> String+showTree = showTree' ""++showTree' :: String -> HTree -> String+showTree' _ (Tip _ i) = show i ++ "\n"+showTree' pref (Bin _ n l r) = "No " ++ show n ++ "\n"+ ++ pref ++ "+ " ++ showTree' pref' l+ ++ pref ++ "+ " ++ showTree' pref' r+ where+ pref' = " " ++ pref++printTree :: HTree -> IO ()+printTree = putStr . showTree++----------------------------------------------------------------++-- | Creating 'HTree'.+toHTree :: [Bits] -> HTree+toHTree bs = mark 1 eos $ snd $ build 0 $ zip [0..idxEos] bs+ where+ eos = bs !! idxEos++build :: Int -> [(Int,Bits)] -> (Int, HTree)+build !cnt0 [(v,[])] = (cnt0,Tip Nothing v)+build !cnt0 xs = let (cnt1,l) = build (cnt0 + 1) fs+ (cnt2,r) = build cnt1 ts+ in (cnt2, Bin Nothing cnt0 l r)+ where+ (fs',ts') = partition ((==) F . head . snd) xs+ fs = map (second tail) fs'+ ts = map (second tail) ts'++-- | Marking the EOS path+mark :: Int -> Bits -> HTree -> HTree+mark i [] (Tip Nothing v) = Tip (Just i) v+mark i (F:bs) (Bin Nothing n l r) = Bin (Just i) n (mark (i+1) bs l) r+mark i (T:bs) (Bin Nothing n l r) = Bin (Just i) n l (mark (i+1) bs r)+mark _ _ _ = error "mark"++----------------------------------------------------------------++flatten :: HTree -> [HTree]+flatten (Tip _ _) = []+flatten t@(Bin _ _ l r) = t : (flatten l ++ flatten r)
Network/HPACK/Table.hs view
@@ -3,7 +3,8 @@ module Network.HPACK.Table ( -- * Header table HeaderTable- , newHeaderTable+ , newHeaderTableForEncoding+ , newHeaderTableForDecoding , printHeaderTable -- * Insertion , insertEntry@@ -19,51 +20,207 @@ import Control.Applicative ((<$>)) import Control.Exception (throwIO)-import Data.Array.IO (readArray)+import Data.Array.IO (IOArray, newArray, readArray, writeArray)+import qualified Data.ByteString.Char8 as BS import Network.HPACK.Table.Entry-import Network.HPACK.Table.Header+import qualified Network.HPACK.Table.HashPSQ as HP import Network.HPACK.Table.Static import Network.HPACK.Types ---------------------------------------------------------------- -data HeaderCache = None | KeyOnly WhichTable Index | KeyValue WhichTable Index+-- | Type for header table.+data HeaderTable = HeaderTable {+ maxNumOfEntries :: !Int+ , offset :: !Index+ , numOfEntries :: !Int+ , circularTable :: !(IOArray Index Entry)+ , headerTableSize :: !Size+ , maxHeaderTableSize :: !Size+ , reverseIndex :: Maybe (HP.HashPSQ HIndex)+ } --- | Looking up the static table and the header table.-lookupTable :: Header -> HeaderTable -> IO HeaderCache-lookupTable h@(k,v) hdrtbl = do- miv <- toIndexValue k hdrtbl- case miv of- Just (i,val)- | val == v -> return $ KeyValue (whic i hdrtbl) i- | otherwise -> return $ KeyOnly (whic i hdrtbl) i- Nothing- | isColon h -> do- mi <- toStaticColonIndex h- case mi of- Just i -> return $ KeyValue InStaticTable (i + numOfEntries hdrtbl)- Nothing -> return $ None- | otherwise -> return $ None+adj :: Int -> Int -> Int+adj maxN x = (x + maxN) `mod` maxN -whic :: Int -> HeaderTable -> WhichTable-whic i hdrtbl- | i <= numOfEntries hdrtbl = InHeaderTable- | otherwise = InStaticTable+---------------------------------------------------------------- +-- | Printing 'HeaderTable'.+printHeaderTable :: HeaderTable -> IO ()+printHeaderTable (HeaderTable maxN off n tbl tblsiz _ rev) = do+ es <- mapM (readArray tbl . adj maxN) [beg .. end]+ let ts = zip [1..] es+ mapM_ printEntry ts+ putStrLn $ " Table size: " ++ show tblsiz+ print rev+ where+ beg = off + 1+ end = off + n++printEntry :: (Index,Entry) -> IO ()+printEntry (i,e) = do+ putStr "[ "+ putStr $ show i+ putStr "] (s = "+ putStr $ show $ entrySize e+ putStr ") "+ BS.putStr $ entryHeaderName e+ putStr ": "+ BS.putStrLn $ entryHeaderValue e+ ---------------------------------------------------------------- -- | Which table does `Index` refer to?-data WhichTable = InHeaderTable | InStaticTable deriving Eq+data WhichTable = InHeaderTable | InStaticTable deriving (Eq,Show) +data HeaderCache = None+ | KeyOnly WhichTable Index+ | KeyValue WhichTable Index deriving Show+ ---------------------------------------------------------------- +newtype HIndex = HIndex Int deriving (Eq, Ord, Show)++----------------------------------------------------------------++fromHIndexToIndex :: HeaderTable -> HIndex -> Index+fromHIndexToIndex hdrtbl (HIndex hidx) = idx -- fixme :: Checkme+ where+ maxN = maxNumOfEntries hdrtbl+ off = offset hdrtbl+ idx = adj maxN (maxN + hidx - off)++fromIndexToHIndex :: HeaderTable -> Index -> HIndex+fromIndexToHIndex hdrtbl idx = HIndex hidx+ where+ maxN = maxNumOfEntries hdrtbl+ off = offset hdrtbl+ hidx = adj maxN (off + idx)++fromSIndexToIndex :: HeaderTable -> SIndex -> Index+fromSIndexToIndex hdrtbl sidx = fromStaticIndex sidx + numOfEntries hdrtbl++fromIndexToSIndex :: HeaderTable -> Index -> SIndex+fromIndexToSIndex hdrtbl idx = toStaticIndex sidx+ where+ sidx = idx - numOfEntries hdrtbl++----------------------------------------------------------------++-- | Creating 'HeaderTable'.+-- The default maxHeaderTableSize is 4096 bytes,+-- an array has 128 entries, resulting 1024 bytes in 64bit machine+newHeaderTableForEncoding :: Size -> IO HeaderTable+newHeaderTableForEncoding maxsiz = newHeaderTable maxsiz (Just HP.empty)++-- | Creating 'HeaderTable'.+-- The default maxHeaderTableSize is 4096 bytes,+-- an array has 128 entries, resulting 1024 bytes in 64bit machine+newHeaderTableForDecoding :: Size -> IO HeaderTable+newHeaderTableForDecoding maxsiz = newHeaderTable maxsiz Nothing++newHeaderTable :: Size -> Maybe (HP.HashPSQ HIndex) -> IO HeaderTable+newHeaderTable maxsiz mhp = do+ tbl <- newArray (0,end) dummyEntry+ return HeaderTable {+ maxNumOfEntries = maxN+ , offset = end+ , numOfEntries = 0+ , circularTable = tbl+ , headerTableSize = 0+ , maxHeaderTableSize = maxsiz+ , reverseIndex = mhp+ }+ where+ maxN = maxNumbers maxsiz+ end = maxN - 1++----------------------------------------------------------------++-- | Inserting 'Entry' to 'HeaderTable'.+-- New 'HeaderTable' and a set of dropped OLD 'Index'+-- are returned.+insertEntry :: Entry -> HeaderTable -> IO (HeaderTable,[Index])+insertEntry e hdrtbl = do+ (hdrtbl', is, hs) <- insertOne e hdrtbl >>= adjustTableSize+ let hdrtbl'' = case reverseIndex hdrtbl' of+ Nothing -> hdrtbl'+ Just rev -> hdrtbl' { reverseIndex = Just (HP.deleteList hs rev) }+ return (hdrtbl'', is)++insertOne :: Entry -> HeaderTable -> IO HeaderTable+insertOne e hdrtbl@(HeaderTable maxN off n tbl tsize _ mrev) = do+ writeArray tbl i e+ return $ hdrtbl {+ offset = off'+ , numOfEntries = n + 1+ , headerTableSize = tsize'+ , reverseIndex = mrev'+ }+ where+ i = off+ tsize' = tsize + entrySize e+ off' = adj maxN (off - 1)+ mrev' = case mrev of+ Nothing -> Nothing+ Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev++adjustTableSize :: HeaderTable -> IO (HeaderTable, [Index], [Header])+adjustTableSize hdrtbl = adjust hdrtbl [] []++adjust :: HeaderTable -> [Index] -> [Header] -> IO (HeaderTable, [Index], [Header])+adjust hdrtbl is hs+ | tsize <= maxtsize = return (hdrtbl, is, hs)+ | otherwise = do+ (hdrtbl', i, h) <- removeOne hdrtbl+ adjust hdrtbl' (i:is) (h:hs)+ where+ tsize = headerTableSize hdrtbl+ maxtsize = maxHeaderTableSize hdrtbl++removeOne :: HeaderTable -> IO (HeaderTable,Index,Header)+removeOne hdrtbl@(HeaderTable maxN off n tbl tsize _ _) = do+ let i = adj maxN (off + n)+ e <- readArray tbl i+ writeArray tbl i dummyEntry -- let the entry GCed+ let tsize' = tsize - entrySize e+ h = entryHeader e+ hdrtbl' = hdrtbl {+ numOfEntries = n - 1+ , headerTableSize = tsize'+ }+ return (hdrtbl',n - 1, h)++----------------------------------------------------------------++lookupTable :: Header -> HeaderTable -> HeaderCache+lookupTable h hdrtbl = case mrev of+ Nothing -> None+ Just rev -> case HP.search h rev of+ HP.N -> case HP.search h staticHashPSQ of+ HP.N -> None+ HP.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex hdrtbl sidx)+ HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)+ HP.K hidx -> KeyOnly InHeaderTable (fromHIndexToIndex hdrtbl hidx)+ HP.KV hidx -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx)+ where+ mrev = reverseIndex hdrtbl++----------------------------------------------------------------++isIn :: Int -> HeaderTable -> Bool+isIn idx hdrtbl = idx <= numOfEntries hdrtbl+ -- | Which table does 'Index' belong to? which :: HeaderTable -> Index -> IO (WhichTable, Entry)-which (HeaderTable maxN off n tbl _ _) idx- | idx <= n = (InHeaderTable,) <$> readArray tbl pidx- | 1 <= stcidx && stcidx <= stcsiz = return (InStaticTable, toStaticEntry stcidx)- | otherwise = throwIO $ IndexOverrun idx+which hdrtbl idx+ | idx `isIn` hdrtbl = (InHeaderTable,) <$> toHeaderEntry hdrtbl hidx+ | isSIndexValid sidx = return (InStaticTable, toStaticEntry sidx)+ | otherwise = throwIO $ IndexOverrun idx where- stcsiz = staticTableSize- stcidx = idx - n- pidx = (off + idx + maxN) `mod` maxN+ hidx = fromIndexToHIndex hdrtbl idx+ sidx = fromIndexToSIndex hdrtbl idx++toHeaderEntry :: HeaderTable -> HIndex -> IO Entry+toHeaderEntry hdrtbl (HIndex hidx) = readArray (circularTable hdrtbl) hidx+
Network/HPACK/Table/Entry.hs view
@@ -13,6 +13,7 @@ , fromEntry -- * Getters , entrySize+ , entryHeader , entryHeaderName , entryHeaderValue -- * For initialization@@ -58,6 +59,10 @@ -- | Getting the size of 'Entry'. entrySize :: Entry -> Size entrySize = fst++-- | Getting 'Header'.+entryHeader :: Entry -> Header+entryHeader (_,h) = h -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName
+ Network/HPACK/Table/HashPSQ.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE BangPatterns #-}++module Network.HPACK.Table.HashPSQ (+ HashPSQ+ , empty+ , insert+ , delete+ , fromList+ , deleteList+ , Res(..)+ , search+ ) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.List (foldl')+import Data.PSQueue (PSQ, Binding(..))+import qualified Data.PSQueue as P+import Network.HPACK.Types++newtype HashPSQ p = HashPSQ (HashMap HeaderName (PSQ HeaderValue p)) deriving Show++empty :: HashPSQ p+empty = HashPSQ H.empty++insert :: Ord p => Header -> p -> HashPSQ p -> HashPSQ p+insert (k,v) p (HashPSQ m) = case H.lookup k m of+ Nothing -> let psq = P.singleton v p+ in HashPSQ $ H.insert k psq m+ Just psq -> let psq' = P.insert v p psq+ in HashPSQ $ H.adjust (const psq') k m++delete :: Ord p => Header -> HashPSQ p -> HashPSQ p+delete (k,v) hp@(HashPSQ m) = case H.lookup k m of+ Nothing -> hp -- Non-smart implementation makes duplicate keys.+ -- It is likely to happen to delete the same key+ -- in multiple times.+ Just psq -> case P.lookup v psq of+ Nothing -> hp -- see above+ _ -> delete' psq+ where+ delete' psq+ | P.null psq' = HashPSQ $ H.delete k m+ | otherwise = HashPSQ $ H.adjust (const psq') k m+ where+ psq' = P.delete v psq++fromList :: Ord p => [(p,Header)] -> HashPSQ p+fromList alst = hashpsq+ where+ ins !hp (!p,!h) = insert h p hp+ !hashpsq = foldl' ins empty alst++deleteList :: Ord p => [Header] -> HashPSQ p -> HashPSQ p+deleteList hs hp = foldl' (flip delete) hp hs++data Res p = N | K p | KV p++search :: Ord p => Header -> HashPSQ p -> Res p+search (k,v) (HashPSQ m) = case H.lookup k m of+ Nothing -> N+ Just psq -> case P.lookup v psq of+ Nothing -> case P.findMin psq of+ Nothing -> error "HashPSQ.lookup"+ Just (_ :-> p) -> K p+ Just p -> KV p
− Network/HPACK/Table/Header.hs
@@ -1,135 +0,0 @@-module Network.HPACK.Table.Header (- -- * Type- HeaderTable(..)- , newHeaderTable- , printHeaderTable- -- * Utilities- , insertEntry- , toIndexValue- ) where--import Data.Array.IO (IOArray, newArray, readArray, writeArray)-import qualified Data.ByteString.Char8 as BS-import Network.HPACK.Table.Entry---------------------------------------------------------------------- | Type for header table.-data HeaderTable = HeaderTable {- maxNumOfEntries :: Int- , offset :: Index- , numOfEntries :: Int- , circularTable :: !(IOArray Index Entry)- , headerTableSize :: Size- , maxHeaderTableSize :: Size- }---------------------------------------------------------------------- | Printing 'HeaderTable'.-printHeaderTable :: HeaderTable -> IO ()-printHeaderTable (HeaderTable maxN off n tbl tblsiz _) = do- es <- mapM (readArray tbl . adj maxN) [beg .. end]- let ts = zip [1..] es- mapM_ printEntry ts- putStrLn $ " Table size: " ++ show tblsiz- where- beg = off + 1- end = off + n--printEntry :: (Index,Entry) -> IO ()-printEntry (i,e) = do- putStr "[ "- putStr $ show i- putStr "] (s = "- putStr $ show $ entrySize e- putStr ") "- BS.putStr $ entryHeaderName e- putStr ": "- BS.putStrLn $ entryHeaderValue e---------------------------------------------------------------------- | Creating 'HeaderTable'.--- The default maxHeaderTableSize is 4096 bytes,--- an array has 128 entries, resulting 1024 bytes in 64bit machine-newHeaderTable :: Size -> IO HeaderTable-newHeaderTable maxsiz = do- tbl <- newArray (0,end) dummyEntry- return HeaderTable {- maxNumOfEntries = maxN- , offset = end- , numOfEntries = 0- , circularTable = tbl- , headerTableSize = 0- , maxHeaderTableSize = maxsiz- }- where- maxN = maxNumbers maxsiz- end = maxN - 1---------------------------------------------------------------------- | Inserting 'Entry' to 'HeaderTable'.--- New 'HeaderTable' and a set of dropped 'Index'--- are returned.-insertEntry :: Entry -> HeaderTable -> IO (HeaderTable,[Index])-insertEntry e hdrtbl = insertOne e hdrtbl >>= adjustTableSize--insertOne :: Entry -> HeaderTable -> IO HeaderTable-insertOne e hdrtbl@(HeaderTable maxN off n tbl tsize _) = do- writeArray tbl i e- return $ hdrtbl {- offset = off'- , numOfEntries = n + 1- , headerTableSize = tsize'- }- where- i = off- tsize' = tsize + entrySize e- off' = adj maxN (off - 1)--adjustTableSize :: HeaderTable -> IO (HeaderTable, [Index])-adjustTableSize hdrtbl = adjust hdrtbl []--adjust :: HeaderTable -> [Index] -> IO (HeaderTable, [Index])-adjust hdrtbl is- | tsize <= maxtsize = return (hdrtbl, is)- | otherwise = do- (hdrtbl', i) <- removeOne hdrtbl- adjust hdrtbl' (i:is)- where- tsize = headerTableSize hdrtbl- maxtsize = maxHeaderTableSize hdrtbl--removeOne :: HeaderTable -> IO (HeaderTable,Index)-removeOne hdrtbl@(HeaderTable maxN off n tbl tsize _) = do- let i = adj maxN (off + n)- e <- readArray tbl i- writeArray tbl i dummyEntry -- let the entry GCed- let tsize' = tsize - entrySize e- let hdrtbl' = hdrtbl {- numOfEntries = n - 1- , headerTableSize = tsize'- }- return (hdrtbl',n)--------------------------------------------------------------------toIndexValue :: HeaderName -> HeaderTable -> IO (Maybe (Index, HeaderValue))-toIndexValue k (HeaderTable maxN off n tbl _ _) = go 1- where- go i- | i > n = return Nothing- | otherwise = do- let idx = adj maxN (off + i)- e <- readArray tbl idx- if entryHeaderName e == k then- return $ Just (i, entryHeaderValue e)- else- go (i+1)--------------------------------------------------------------------adj :: Int -> Int -> Int-adj maxN x = (x + maxN) `mod` maxN
Network/HPACK/Table/Static.hs view
@@ -1,83 +1,55 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Table.Static (- staticTableSize- , toStaticEntry+ SIndex(..)+ , fromStaticIndex , toStaticIndex- , toStaticColonIndex- , isColon+ , isSIndexValid+ , toStaticEntry+ , staticHashPSQ ) where import Data.Array (Array, listArray, (!))-import Data.HashTable.IO (BasicHashTable)-import qualified Data.HashTable.IO as I import Network.HPACK.Table.Entry-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.ByteString.Char8 as H+import qualified Network.HPACK.Table.HashPSQ as HP ---------------------------------------------------------------- +newtype SIndex = SIndex Int deriving (Eq,Ord,Show)++fromStaticIndex :: SIndex -> Int+fromStaticIndex (SIndex sidx) = sidx++toStaticIndex :: Int -> SIndex+toStaticIndex = SIndex++isSIndexValid :: SIndex -> Bool+isSIndexValid (SIndex sidx) = 1 <= sidx && sidx <= staticTableSize++----------------------------------------------------------------+ -- | The size of static table. staticTableSize :: Size staticTableSize = 60 -- | Get 'Entry' from the static table. ----- >>> toStaticEntry 8+-- >>> toStaticEntry (SIndex 8) -- (42,(":status","200"))--- >>> toStaticEntry 49+-- >>> toStaticEntry (SIndex 49) -- (37,("range",""))-toStaticEntry :: Index -> Entry-toStaticEntry idx = staticTable ! idx+toStaticEntry :: SIndex -> Entry+toStaticEntry (SIndex sidx) = staticTable ! sidx -- | Pre-defined static table. staticTable :: Array Index Entry staticTable = listArray (1,60) $ map toEntry staticTableList --------------------------------------------------------------------- | Get 'Index' from the static table.------ >>> toStaticIndex ":status"--- Just 13--- >>> toStaticIndex "date"--- Just 32--- >>> toStaticIndex "user-agent"--- Just 57-toStaticIndex :: HeaderName -> IO (Maybe Index)-toStaticIndex k = I.lookup staticHashTable k--staticHashTable :: BasicHashTable HeaderName Index-staticHashTable = unsafePerformIO $ I.fromList alist- where- alist = zip (map fst staticTableList) [1 ..]---------------------------------------------------------------------- | Get 'Index' from the static table.--- Only colon headers.------ >>> toStaticColonIndex (":path","/index.html")--- Just 5--- >>> toStaticColonIndex (":status","200")--- Just 8-toStaticColonIndex :: Header -> IO (Maybe Index)-toStaticColonIndex h = I.lookup staticColonHashTable h--staticColonHashTable :: BasicHashTable Header Index-staticColonHashTable = unsafePerformIO $ I.fromList alist+staticHashPSQ :: HP.HashPSQ SIndex+staticHashPSQ = HP.fromList alist where- alist = zip staticColonHeaderList [1 ..]--------------------------------------------------------------------staticColonHeaderList :: [Header]--staticColonHeaderList = takeWhile isColon staticTableList---- | Checking if 'HeaderName' starts with colon.-isColon :: Header -> Bool-isColon h = H.head (fst h) == ':'+ is = map toStaticIndex [1..]+ alist = zip is staticTableList ----------------------------------------------------------------
Network/HPACK/Types.hs view
@@ -9,6 +9,10 @@ -- * Misc , ByteStream , Index+ -- * Encoding and decoding+ , CompressionAlgo(..)+ , EncodeStrategy(..)+ , defaultEncodeStrategy , DecodeError(..) ) where @@ -33,6 +37,27 @@ -- | Index for table. type Index = Int++-- | Compression algorithms for HPACK encoding.+data CompressionAlgo = Naive -- ^ No compression+ | Linear -- ^ Using indices only+ | Diff -- ^ Calculating difference++-- | Strategy for HPACK encoding.+data EncodeStrategy = EncodeStrategy {+ -- | Which compression algorithm is used.+ compressionAlgo :: CompressionAlgo+ -- | Whether or not to use Huffman encoding for strings.+ , useHuffman :: Bool+ }++-- | Default 'EncodeStrategy'. 'compressionAlgo' is 'Linear' and 'useHuffman' is 'True'.+defaultEncodeStrategy :: EncodeStrategy+defaultEncodeStrategy = EncodeStrategy {+ compressionAlgo = Linear+ , useHuffman = True+ }+ -- | Errors for decoder. data DecodeError = IndexOverrun Index -- ^ Index is out of range
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 0.1.1+Version: 0.1.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -16,14 +16,19 @@ GHC-Options: -Wall Exposed-Modules: Network.HPACK Other-Modules: Network.HPACK.Builder+ Network.HPACK.Builder.Word8 Network.HPACK.Context Network.HPACK.Context.HeaderSet Network.HPACK.Context.ReferenceSet Network.HPACK.Huffman Network.HPACK.Huffman.Bit- Network.HPACK.Huffman.Code+ Network.HPACK.Huffman.ByteString+ Network.HPACK.Huffman.Decode+ Network.HPACK.Huffman.Encode+ Network.HPACK.Huffman.Params Network.HPACK.Huffman.Request Network.HPACK.Huffman.Response+ Network.HPACK.Huffman.Tree Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode Network.HPACK.HeaderBlock.Encode@@ -34,15 +39,52 @@ Network.HPACK.HeaderBlock.To Network.HPACK.Table Network.HPACK.Table.Entry- Network.HPACK.Table.Header+ Network.HPACK.Table.HashPSQ Network.HPACK.Table.Static Network.HPACK.Types Build-Depends: base >= 4 && < 5+ , PSQueue , array , blaze-builder , bytestring- , hashtables+ , containers+ , unordered-containers +Executable hpack-encode+ Default-Language: Haskell2010+ HS-Source-Dirs: test-hpack, .+ GHC-Options: -Wall+ Main-Is: hpack-encode.hs+ Build-Depends: base >= 4 && < 5+ , PSQueue+ , aeson+ , aeson-pretty+ , array+ , blaze-builder+ , bytestring+ , containers+ , text+ , unordered-containers+ , vector+ , word8++Executable hpack-debug+ Default-Language: Haskell2010+ HS-Source-Dirs: test-hpack, .+ GHC-Options: -Wall+ Main-Is: hpack-debug.hs+ Build-Depends: base >= 4 && < 5+ , PSQueue+ , aeson+ , array+ , blaze-builder+ , bytestring+ , containers+ , text+ , unordered-containers+ , vector+ , word8+ Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010@@ -58,20 +100,22 @@ HS-Source-Dirs: test, . Ghc-Options: -Wall Main-Is: Spec.hs- Other-Modules: BitSpec- DecodeSpec+ Other-Modules: DecodeSpec+ HeaderBlock HeaderBlockSpec+ HexString HuffmanRequestSpec HuffmanResponseSpec IntegerSpec- HeaderBlock- HexString Build-Depends: base+ , PSQueue , array , blaze-builder , bytestring- , hashtables+ , containers , hspec >= 1.3+ , unordered-containers+ , word8 Test-Suite hpack Type: exitcode-stdio-1.0@@ -79,19 +123,24 @@ HS-Source-Dirs: test-hpack, . Ghc-Options: -Wall Main-Is: Spec.hs- Other-Modules: HPACKSpec+ Other-Modules: HPACK+ HPACKSpec+ HexString+ Types Build-Depends: base+ , PSQueue , aeson , aeson-pretty , array , blaze-builder , bytestring+ , containers , directory , filepath- , hashtables , text , unordered-containers , vector+ , word8 , hspec >= 1.3 Source-Repository head
+ test-hpack/HPACK.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++module HPACK (run+ , Result(..)+ , EncodeStrategy(..)+ , defaultEncodeStrategy+ , CompressionAlgo(..)+ ) where++import Control.Exception+import Control.Monad (when)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import Data.List (sort)+import Network.HPACK+import Network.HPACK.Context+import Network.HPACK.Context.HeaderSet+import Network.HPACK.HeaderBlock+import Network.HPACK.Huffman++import HexString+import Types++data Conf = Conf {+ debug :: Bool+ , enc :: HPACKEncoding+ , dec :: HPACKDecoding+ , hbk :: ByteStream -> Either DecodeError HeaderBlock+ }++data Result = Pass [ByteString] | Fail String deriving (Eq,Show)++run :: Bool -> EncodeStrategy -> Test -> IO Result+run _ _ (Test _ _ _ []) = return $ Pass []+run d stgy (Test _ reqOrRsp _ ccs@(c:_)) = do+ let siz = size c+ dctx <- newContextForDecoding siz+ ectx <- newContextForEncoding siz+ let conf+ | reqOrRsp == "request" = Conf {+ debug = d+ , enc = encodeRequestHeader stgy+ , dec = decodeRequestHeader+ , hbk = fromByteStream huffmanDecodeInRequest+ }+ | otherwise = Conf {+ debug = d+ , enc = encodeResponseHeader stgy+ , dec = decodeResponseHeader+ , hbk = fromByteStream huffmanDecodeInResponse+ }+ testLoop conf ccs dctx ectx []++testLoop :: Conf+ -> [Case]+ -> Context+ -> Context+ -> [ByteString]+ -> IO Result+testLoop _ [] _ _ hexs = return $ Pass $ reverse hexs+testLoop conf (c:cs) dctx ectx hexs = do+ res <- test conf c dctx ectx+ case res of+ Right (dctx', ectx', hex) -> testLoop conf cs dctx' ectx' (hex:hexs)+ Left e -> return $ Fail e++test :: Conf+ -> Case+ -> Context+ -> Context+ -> IO (Either String (Context, Context, ByteString))+test conf c dctx ectx = do+ -- context is destructive!!!+ when (debug conf) $ do+ putStrLn "--------------------------------"+ putStrLn "---- Input headerset"+ printHeaderSet $ sort hs+ putStrLn "---- Input context"+ printContext dctx+ putStrLn "---- Input Hex"+ B8.putStrLn hex+ putStrLn "---- Input header block"+ print hd+ x <- try $ dec conf dctx inp+ case x of+ Left e -> return $ Left $ show (e :: DecodeError)+ Right (dctx',hs') -> do+ -- This is for hpack-encoding only.+ (ectx',out) <- enc conf ectx hs+ let pass = sort hs == sort hs'+ hex' = toHexString out+ when (debug conf) $ do+ putStrLn "---- Output headerset"+ printHeaderSet $ sort hs'+ putStrLn "---- Output context"+ printContext dctx'+ putStrLn "--------------------------------"+ if pass then+ return $ Right (dctx', ectx', hex')+ else+ return $ Left $ "Headers are different in " ++ B8.unpack hex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs'+ where+ hex = wire c+ inp = fromHexString hex+ hs = headers c+ hd = hbk conf inp
test-hpack/HPACKSpec.hs view
@@ -21,7 +21,7 @@ subdirs1 <- filterM doesDirectoryExist subdirs0 concat <$> mapM getTestFiles' subdirs1 where- valid = map (testDir </>) . filter (not . isPrefixOf ".")+ valid = map (testDir </>) . filter ("raw-data" /=) . filter (not . isPrefixOf ".") getTestFiles' :: FilePath -> IO [FilePath] getTestFiles' subdir = do@@ -37,7 +37,7 @@ case etc of Left e -> return $ Just $ file ++ ": " ++ e Right tc -> do- res <- run tc+ res <- run False defaultEncodeStrategy tc case res of Pass _ -> return Nothing Fail e -> return $ Just $ file ++ ": " ++ e@@ -47,5 +47,6 @@ describe "decodeRequestHeader" $ do it "decodes headers in request" $ do files <- getTestFiles testDir- forM_ files $ \file ->+ forM_ files $ \file -> do+ putStrLn file test file `shouldReturn` Nothing
+ test-hpack/HexString.hs view
@@ -0,0 +1,53 @@+module HexString (fromHexString, toHexString) where++import Data.ByteString.Internal (ByteString(..), unsafeCreate)+import Data.Word8+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (peek, poke, peekByteOff, pokeByteOff)++fromHexString :: ByteString -> ByteString+fromHexString (PS fptr off len) = unsafeCreate size $ \dst ->+ withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0+ where+ size = len `div` 2+ go from to bytes+ | bytes == size = return ()+ | otherwise = do+ w1 <- peek from+ w2 <- peekByteOff from 1+ let w = hex2w (w1,w2)+ poke to w+ go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1)++hex2w :: (Word8, Word8) -> Word8+hex2w (w1,w2) = h2w w1 * 16 + h2w w2++h2w :: Word8 -> Word8+h2w w+ | isDigit w = w - _0+ | otherwise = w - _a + 10++toHexString :: ByteString -> ByteString+toHexString (PS fptr off len) = unsafeCreate size $ \dst ->+ withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0+ where+ size = len * 2+ go from to bytes+ | bytes == len = return ()+ | otherwise = do+ w <- peek from+ let (w1,w2) = w2hex w+ poke to w1+ pokeByteOff to 1 w2+ go (from `plusPtr` 1) (to `plusPtr` 2) (bytes + 1)++w2hex :: Word8 -> (Word8, Word8)+w2hex w = (w2h w1, w2h w2)+ where+ (w1,w2) = w `divMod` 16++w2h :: Word8 -> Word8+w2h w+ | w < 10 = w + _0+ | otherwise = w + _a - 10
+ test-hpack/Types.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Types (+ Test(..)+ , Case(..)+ , HeaderSet+ ) where++import Control.Applicative+import Control.Monad (mzero)+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector ((!))+import qualified Data.Vector as V+import Network.HPACK++{-+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy as BL++main :: IO ()+main = do+ bs <- BL.getContents+ let Right x = eitherDecode bs :: Either String Test+ BL.putStr $ encodePretty x+-}++data Test = Test {+ draft :: Int+ , context :: String+ , description :: String+ , cases :: [Case]+ } deriving Show++data Case = Case {+ size :: Int+ , wire :: ByteString+ , headers :: HeaderSet+ } deriving Show++instance FromJSON Test where+ parseJSON (Object o) = Test <$> o .: "draft"+ <*> o .: "context"+ <*> o .: "description"+ <*> o .: "cases"+ parseJSON _ = mzero++instance ToJSON Test where+ toJSON (Test n ctx desc cs) = object ["draft" .= n+ ,"context" .= ctx+ ,"description" .= desc+ ,"cases" .= cs+ ]++instance FromJSON Case where+ parseJSON (Object o) = Case <$> o .: "header_table_size"+ <*> (textToByteString <$> (o .: "wire"))+ <*> o .: "headers"+ parseJSON _ = mzero++instance ToJSON Case where+ toJSON (Case siz w hs) = object ["header_table_size" .= siz+ ,"wire" .= byteStringToText w+ ,"headers" .= hs+ ]++instance FromJSON HeaderSet where+ parseJSON (Array a) = mapM parseJSON $ V.toList a+ parseJSON _ = mzero++instance ToJSON HeaderSet where+ toJSON hs = toJSON $ map toJSON hs++instance FromJSON Header where+ parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old+ where+ toKey = toValue+ parseJSON (Object o) = pure (textToByteString k, toValue v) -- new+ where+ (k,v) = head $ H.toList o+ parseJSON _ = mzero++instance ToJSON Header where+ toJSON (k,v) = object [ byteStringToText k .= byteStringToText v ]++textToByteString :: Text -> ByteString+textToByteString = B8.pack . T.unpack++byteStringToText :: ByteString -> Text+byteStringToText = T.pack . B8.unpack++toValue :: Value -> ByteString+toValue (String s) = textToByteString s+toValue _ = error "toValue"
+ test-hpack/hpack-debug.hs view
@@ -0,0 +1,20 @@+module Main where++import Data.Aeson (eitherDecode)+import qualified Data.ByteString.Lazy as BL++import Types+import HPACK++main :: IO ()+main = do+ bs <- BL.getContents+ let etc = eitherDecode bs :: Either String Test+ res <- case etc of+ Left e -> return $ Just e+ Right tc -> do+ res <- run True defaultEncodeStrategy tc+ case res of+ Pass _ -> return Nothing+ Fail e -> return $ Just e+ print res
+ test-hpack/hpack-encode.hs view
@@ -0,0 +1,44 @@+module Main where++import Control.Monad (when)+import Data.Aeson+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as BL+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++import HPACK+import Types++main :: IO ()+main = do+ args <- getArgs+ when (length args /= 2) $ do+ hPutStrLn stderr "hpack-encode on/off naive|linear|diff"+ exitFailure+ let [arg1,arg2] = args+ huffman+ | arg1 == "on" = True+ | otherwise = False+ algo+ | arg2 == "naive" = Naive+ | arg2 == "linear" = Linear+ | otherwise = Diff+ stgy = EncodeStrategy algo huffman+ hpackEncode stgy++hpackEncode :: EncodeStrategy -> IO ()+hpackEncode stgy = do+ bs <- BL.getContents+ let Just tc = decode bs :: Maybe Test+ Pass hexs <- run False stgy tc+ let cs = cases tc+ cs' = zipWith update cs hexs+ tc' = tc {+ description = "Encoded by the http2 library in Haskell. First clear the reference set and encode all headers"+ , cases = cs'+ }+ BL.putStrLn $ encodePretty tc'+ where+ update c hex = c { wire = hex }
− test/BitSpec.hs
@@ -1,12 +0,0 @@-module BitSpec where--import Network.HPACK.Huffman.Bit-import Test.Hspec-import Test.Hspec.QuickCheck--spec :: Spec-spec = do- describe "toBits and fromBits" $ do- prop "duality" $ \n ->- let i = fromIntegral $ abs (n :: Int) `mod` 256- in fromBits (toBits i) == i
test/DecodeSpec.hs view
@@ -1,25 +1,29 @@ module DecodeSpec where +import Data.List (sort) import Network.HPACK.Context import Network.HPACK.HeaderBlock import Test.Hspec import HeaderBlock +shouldBeSameAs :: (Ord a, Show a) => [a] -> [a] -> Expectation+shouldBeSameAs xs ys = sort xs `shouldBe` sort ys+ spec :: Spec spec = do describe "fromHeaderBlock" $ do it "decodes HeaderSet in request" $ do- (c1,h1) <- newContext 4096 >>= flip fromHeaderBlock e31- h1 `shouldBe` e31h+ (c1,h1) <- newContextForDecoding 4096 >>= flip fromHeaderBlock e31+ h1 `shouldBeSameAs` e31h (c2,h2) <- fromHeaderBlock c1 e32- h2 `shouldBe` e32h+ h2 `shouldBeSameAs` e32h (_,h3) <- fromHeaderBlock c2 e33- h3 `shouldBe` e33h+ h3 `shouldBeSameAs` e33h it "decodes HeaderSet in response" $ do- (c1,h1) <- newContext 256 >>= flip fromHeaderBlock e51- h1 `shouldBe` e51h+ (c1,h1) <- newContextForDecoding 256 >>= flip fromHeaderBlock e51+ h1 `shouldBeSameAs` e51h (c2,h2) <- fromHeaderBlock c1 e52- h2 `shouldBe` e52h+ h2 `shouldBeSameAs` e52h (_,h3) <- fromHeaderBlock c2 e53- h3 `shouldBe` e53h+ h3 `shouldBeSameAs` e53h
test/HeaderBlock.hs view
@@ -2,7 +2,6 @@ module HeaderBlock where -import qualified Data.ByteString as BS import Network.HPACK.Context import Network.HPACK.HeaderBlock import Network.HPACK.Types@@ -27,7 +26,7 @@ ] e31b :: ByteStream-e31b = BS.pack $ fromHexString "828786048bdb6d883e68d1cb1225ba7f"+e31b = fromHexString "828786048bdb6d883e68d1cb1225ba7f" e32 :: HeaderBlock e32 = [@@ -42,7 +41,7 @@ ,(":authority","www.example.com")] e32b :: ByteStream-e32b = BS.pack $ fromHexString "1b8663654a1398ff"+e32b = fromHexString "1b8663654a1398ff" e33 :: HeaderBlock e33 = [@@ -63,7 +62,7 @@ ] e33b :: ByteStream-e33b = BS.pack $ fromHexString "80858c8b8400884eb08b749790fa7f894eb08b74979a17a8ff"+e33b = fromHexString "80858c8b8400884eb08b749790fa7f894eb08b74979a17a8ff" ---------------------------------------------------------------- @@ -83,7 +82,7 @@ ] e51b :: ByteStream-e51b = BS.pack $ fromHexString "0882409f1886c31b39bf387f2292a2fba20320f2ab303124018b490d3209e8773093e39e7864dd7afd3d3d248747db87284955f6ff"+e51b = fromHexString "0882409f1886c31b39bf387f2292a2fba20320f2ab303124018b490d3209e8773093e39e7864dd7afd3d3d248747db87284955f6ff" e52 :: HeaderBlock e52 = [@@ -99,7 +98,7 @@ ] e52b :: ByteStream-e52b = BS.pack $ fromHexString "848c"+e52b = fromHexString "848c" e53 :: HeaderBlock e53 = [@@ -124,4 +123,4 @@ ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")] e53b :: ByteStream-e53b = BS.pack $ fromHexString "8384840392a2fba20320f2ab303124018b490d3309e8771d84e1fbb30f848483833ab3df7dfb36d3d9e1fcfc3fafe7abfcfefcbfaf3edf2f977fd36ff7fd79f6f977fd3de16bfa46fe10d889447de1ce18e565f76c2f"+e53b = fromHexString "8384840392a2fba20320f2ab303124018b490d3309e8771d84e1fbb30f848483833ab3df7dfb36d3d9e1fcfc3fafe7abfcfefcbfaf3edf2f977fd36ff7fd79f6f977fd3de16bfa46fe10d889447de1ce18e565f76c2f"
test/HeaderBlockSpec.hs view
@@ -14,12 +14,12 @@ spec = do describe "toByteStream" $ do it "encodes HeaderBlock" $ do- toByteStream huffmanEncodeInRequest e31 `shouldBe` e31b- toByteStream huffmanEncodeInRequest e32 `shouldBe` e32b- toByteStream huffmanEncodeInRequest e33 `shouldBe` e33b- toByteStream huffmanEncodeInResponse e51 `shouldBe` e51b- toByteStream huffmanEncodeInResponse e52 `shouldBe` e52b- toByteStream huffmanEncodeInResponse e53 `shouldBe` e53b+ toByteStream huffmanEncodeInRequest True e31 `shouldBe` e31b+ toByteStream huffmanEncodeInRequest True e32 `shouldBe` e32b+ toByteStream huffmanEncodeInRequest True e33 `shouldBe` e33b+ toByteStream huffmanEncodeInResponse True e51 `shouldBe` e51b+ toByteStream huffmanEncodeInResponse True e52 `shouldBe` e52b+ toByteStream huffmanEncodeInResponse True e53 `shouldBe` e53b describe "fromByteStream" $ do it "encodes HeaderBlock" $ do@@ -35,9 +35,9 @@ val = BS.pack ('v':v) hb = [Literal Add (Lit key) val] fromByteStream huffmanDecodeInRequest- (toByteStream huffmanEncodeInRequest hb) `shouldBe` Right hb+ (toByteStream huffmanEncodeInRequest True hb) `shouldBe` Right hb prop "duality for response" $ \v -> do let val = BS.pack ('v':v) hb = [Literal Add (Idx 3) val] fromByteStream huffmanDecodeInResponse- (toByteStream huffmanEncodeInResponse hb) `shouldBe` Right hb+ (toByteStream huffmanEncodeInResponse True hb) `shouldBe` Right hb
test/HexString.hs view
@@ -1,17 +1,53 @@-module HexString where+module HexString (fromHexString, toHexString) where -import Numeric-import Text.Printf-import Data.Word (Word8)+import Data.ByteString.Internal (ByteString(..), unsafeCreate)+import Data.Word8+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (peek, poke, peekByteOff, pokeByteOff) -fromHexString :: String -> [Word8]-fromHexString = map fromHex . group2+fromHexString :: ByteString -> ByteString+fromHexString (PS fptr off len) = unsafeCreate size $ \dst ->+ withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0 where- fromHex = fst . head . readHex- group2 [] = []- group2 xs = ys : group2 zs- where- (ys,zs) = splitAt 2 xs+ size = len `div` 2+ go from to bytes+ | bytes == size = return ()+ | otherwise = do+ w1 <- peek from+ w2 <- peekByteOff from 1+ let w = hex2w (w1,w2)+ poke to w+ go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1) -toHexString :: [Word8] -> String-toHexString = concatMap (printf "%02x")+hex2w :: (Word8, Word8) -> Word8+hex2w (w1,w2) = h2w w1 * 16 + h2w w2++h2w :: Word8 -> Word8+h2w w+ | isDigit w = w - _0+ | otherwise = w - _a + 10++toHexString :: ByteString -> ByteString+toHexString (PS fptr off len) = unsafeCreate size $ \dst ->+ withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0+ where+ size = len * 2+ go from to bytes+ | bytes == len = return ()+ | otherwise = do+ w <- peek from+ let (w1,w2) = w2hex w+ poke to w1+ pokeByteOff to 1 w2+ go (from `plusPtr` 1) (to `plusPtr` 2) (bytes + 1)++w2hex :: Word8 -> (Word8, Word8)+w2hex w = (w2h w1, w2h w2)+ where+ (w1,w2) = w `divMod` 16++w2h :: Word8 -> Word8+w2h w+ | w < 10 = w + _0+ | otherwise = w + _a - 10
test/HuffmanRequestSpec.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ module HuffmanRequestSpec where -import Control.Applicative ((<$>))-import Data.Char+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Network.HPACK.Huffman.Request import Network.HPACK.Types import Test.Hspec@@ -9,24 +11,22 @@ import HexString -shouldBeEncoded :: String -> String -> Expectation+shouldBeEncoded :: ByteString -> ByteString -> Expectation shouldBeEncoded inp out = enc inp `shouldBe` out where- enc = toHexString . huffmanEncodeInRequest . toW- toW = map (fromIntegral . ord)+ enc = toHexString . huffmanEncodeInRequest -shouldBeDecoded :: String -> Either DecodeError String -> Expectation+shouldBeDecoded :: ByteString -> Either DecodeError ByteString -> Expectation shouldBeDecoded inp out = dec inp `shouldBe` out where- dec x = toS <$> huffmanDecodeInRequest (fromHexString x)- toS = map (chr . fromIntegral)+ dec x = huffmanDecodeInRequest (fromHexString x) spec :: Spec spec = do describe "huffmanEncodeInRequest and huffmanDecodeInRequest" $ do- prop "duality" $ \ns ->- let is = map ((`mod` 255) . abs) ns- in huffmanDecodeInRequest (huffmanEncodeInRequest is) == Right is+ prop "duality" $ \cs ->+ let bs = BS.pack cs+ in huffmanDecodeInRequest (huffmanEncodeInRequest bs) == Right bs describe "huffmanEncodeInRequest" $ do it "encodes in request" $ do "www.example.com" `shouldBeEncoded` "db6d883e68d1cb1225ba7f"
test/HuffmanResponseSpec.hs view
@@ -1,31 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+ module HuffmanResponseSpec where -import Control.Applicative ((<$>))-import Data.Char+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Network.HPACK.Huffman.Response import Test.Hspec import Test.Hspec.QuickCheck import HexString -shouldBeEncoded :: String -> String -> Expectation+shouldBeEncoded :: ByteString -> ByteString -> Expectation shouldBeEncoded inp out = enc inp `shouldBe` out where- enc = toHexString . huffmanEncodeInResponse . toW- toW = map (fromIntegral . ord)+ enc = toHexString . huffmanEncodeInResponse -shouldBeDecoded :: String -> String -> Expectation+shouldBeDecoded :: ByteString -> ByteString -> Expectation shouldBeDecoded inp out = dec inp `shouldBe` Right out where- dec x = toS <$> huffmanDecodeInResponse (fromHexString x)- toS = map (chr . fromIntegral)+ dec x = huffmanDecodeInResponse (fromHexString x) spec :: Spec spec = do describe "huffmanEncodeInResponse and huffmanDecodeInResponse" $ do- prop "duality" $ \ns ->- let is = map ((`mod` 255) . abs) ns- in huffmanDecodeInResponse (huffmanEncodeInResponse is) == Right is+ prop "duality" $ \cs ->+ let bs = BS.pack cs+ in huffmanDecodeInResponse (huffmanEncodeInResponse bs) == Right bs describe "huffmanEncodeInResponse" $ do it "encodes in response" $ do "private" `shouldBeEncoded` "c31b39bf387f"
test/IntegerSpec.hs view
@@ -3,10 +3,12 @@ import Network.HPACK.HeaderBlock.Integer import Test.Hspec import Test.Hspec.QuickCheck+import qualified Data.ByteString as BS dual :: Int -> Int -> Bool-dual n i = decode n (encode n x) == x+dual n i = decode n w (BS.pack ws) == x where+ w:ws = encode n x x = abs i spec :: Spec