http2 1.5.1 → 1.5.2
raw patch · 5 files changed
+198/−150 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +8/−0
- Network/HPACK/HeaderBlock/Encode.hs +86/−58
- Network/HPACK/Table/RevIndex.hs +41/−37
- Network/HPACK/Table/Token.hs +62/−54
- http2.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,11 @@+## 1.5.2++* Minor optimization for HPACK.++## 1.5.1++* Adding a missing file for testing.+ ## 1.5.0 * New API for HPACK. HPACK is much faster than 1.4.x (roughly x3.2).
Network/HPACK/HeaderBlock/Encode.hs view
@@ -8,11 +8,13 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Control.Exception (bracket, try, throwIO)+import Control.Exception (bracket, throwIO)+import qualified Control.Exception as E import Control.Monad (when) import Data.Bits (setBit) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString, create, memcpy)+import Data.IORef import Data.Word (Word8) import Foreign.Marshal.Alloc import Foreign.Ptr (minusPtr)@@ -76,75 +78,101 @@ -> 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+ let fa = indexedHeaderField dyntbl wbuf useHuffman+ fb = literalHeaderFieldWithIncrementalIndexingIndexedName dyntbl wbuf useHuffman+ fc = literalHeaderFieldWithIncrementalIndexingNewName dyntbl wbuf useHuffman+ fd = literalHeaderFieldWithoutIndexingIndexedName dyntbl wbuf useHuffman+ fe = literalHeaderFieldWithoutIndexingNewName dyntbl wbuf useHuffman+ fe' = literalHeaderFieldWithoutIndexingNewName' dyntbl wbuf useHuffman+ rev = getRevIndex dyntbl+ step0 = case compressionAlgo of+ Naive -> naiveStep fe'+ Static -> staticStep rev fa fd fe+ Linear -> linearStep rev fa fb fc fd+ ref1 <- currentOffset wbuf >>= newIORef+ ref2 <- newIORef hs0+ loop wbuf ref1 ref2 step0 hs0 `E.catch` \BufferOverrun -> return ()+ end <- readIORef ref1+ let !len = end `minusPtr` buf+ hs <- readIORef ref2+ return (hs, len) 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)+ loop wbuf ref1 ref2 step hsx = go hsx+ where+ go [] = return ()+ go (h:hs) = do+ _ <- step h+ currentOffset wbuf >>= writeIORef ref1+ writeIORef ref2 hs+ go hs ---------------------------------------------------------------- -naiveStep :: Bool -> DynamicTable -> WorkingBuffer -> Header -> IO ()-naiveStep huff _dyntbl wbuf (k,v) = newName wbuf huff set0000 k v+naiveStep :: FE' -> Header -> IO ()+naiveStep fe (k,v) = fe k v ---------------------------------------------------------------- -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+staticStep :: RevIndex -> FA -> FD -> FE -> Header -> IO ()+staticStep rev fa fd fe h = lookupRevIndex h fa fd fe fd rev ---------------------------------------------------------------- -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+linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Header -> IO ()+linearStep rev fa fb fc fd h = lookupRevIndex h fa fb fc fd rev++----------------------------------------------------------------++type FA = HIndex -> IO ()+type FB = HeaderValue -> Entry -> HIndex -> IO ()+type FC = HeaderName -> HeaderValue -> Entry -> IO ()+type FD = HeaderValue -> Entry -> HIndex -> IO ()+type FE = HeaderName -> HeaderValue -> Entry -> IO ()+type FE' = HeaderName -> HeaderValue -> IO ()++-- 6.1. Indexed Header Field Representation+-- Indexed Header Field+indexedHeaderField+ :: DynamicTable -> WorkingBuffer -> Bool -> FA+indexedHeaderField dyntbl wbuf _ hidx =+ fromHIndexToIndex dyntbl hidx >>= index wbuf++-- 6.2.1. Literal Header Field with Incremental Indexing+-- Literal Header Field with Incremental Indexing -- Indexed Name+literalHeaderFieldWithIncrementalIndexingIndexedName+ :: DynamicTable -> WorkingBuffer -> Bool -> FB+literalHeaderFieldWithIncrementalIndexingIndexedName dyntbl wbuf huff v ent hidx = do+ fromHIndexToIndex dyntbl hidx >>= indexedName wbuf huff 6 set01 v+ insertEntry ent dyntbl++-- 6.2.1. Literal Header Field with Incremental Indexing+-- Literal Header Field with Incremental Indexing -- New Name+literalHeaderFieldWithIncrementalIndexingNewName+ :: DynamicTable -> WorkingBuffer -> Bool -> FC+literalHeaderFieldWithIncrementalIndexingNewName dyntbl wbuf huff k v ent = do+ newName wbuf huff set01 k v+ insertEntry ent dyntbl++-- 6.2.2. Literal Header Field without Indexing+-- Literal Header Field without Indexing -- Indexed Name+literalHeaderFieldWithoutIndexingIndexedName+ :: DynamicTable -> WorkingBuffer -> Bool -> FB+literalHeaderFieldWithoutIndexingIndexedName dyntbl wbuf huff v _ hidx =+ fromHIndexToIndex dyntbl hidx >>= indexedName wbuf huff 4 set0000 v++-- 6.2.2. Literal Header Field without Indexing+-- Literal Header Field without Indexing -- New Name+literalHeaderFieldWithoutIndexingNewName+ :: DynamicTable -> WorkingBuffer -> Bool -> FE+literalHeaderFieldWithoutIndexingNewName _ wbuf huff k v _ =+ newName wbuf huff set0000 k v++literalHeaderFieldWithoutIndexingNewName'+ :: DynamicTable -> WorkingBuffer -> Bool -> HeaderName -> HeaderValue -> IO ()+literalHeaderFieldWithoutIndexingNewName' _ wbuf huff k v =+ newName wbuf huff set0000 k v ----------------------------------------------------------------
Network/HPACK/Table/RevIndex.hs view
@@ -2,7 +2,6 @@ module Network.HPACK.Table.RevIndex ( RevIndex- , RevResult(..) , newRevIndex , renewRevIndex , lookupRevIndex@@ -33,11 +32,7 @@ ---------------------------------------------------------------- -data RevResult = N | K HIndex | KV HIndex--------------------------------------------------------------------data RevIndex = RevIndex DynamicRevIndex OtherRevIdex+data RevIndex = RevIndex !DynamicRevIndex !OtherRevIdex type DynamicRevIndex = Array Token (IORef ValueMap) @@ -79,12 +74,9 @@ extract xs = (fst (head xs), map snd xs) {-# 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+lookupStaticRevIndex :: Token -> (HIndex -> IO ()) -> IO ()+lookupStaticRevIndex t fd' = case staticRevIndex ! t of+ StaticEntry i _ -> fd' i ---------------------------------------------------------------- @@ -99,14 +91,21 @@ where clear t = writeIORef (drev ! t) M.empty -{-# INLINE lookupDynamicRevIndex #-}-lookupDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO RevResult-lookupDynamicRevIndex t v drev = do+{-# INLINE lookupDynamicStaticRevIndex #-}+lookupDynamicStaticRevIndex :: Token -> HeaderValue -> DynamicRevIndex+ -> (HIndex -> IO ())+ -> (HIndex -> IO ())+ -> IO ()+lookupDynamicStaticRevIndex t v drev fa' fbd' = do let ref = drev ! t m <- readIORef ref- return $! case M.lookup v m of- Nothing -> N- Just i -> KV i+ case M.lookup v m of+ Just i -> fa' i+ Nothing -> case staticRevIndex ! t of+ StaticEntry i Nothing -> fbd' i+ StaticEntry i (Just m') -> case M.lookup v m' of+ Nothing -> fbd' i+ Just j -> fa' j {-# INLINE insertDynamicRevIndex #-} insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()@@ -129,12 +128,12 @@ renewOtherRevIndex ref = writeIORef ref M.empty {-# INLINE lookupOtherRevIndex #-}-lookupOtherRevIndex :: HeaderName -> HeaderValue -> OtherRevIdex -> IO RevResult-lookupOtherRevIndex k v ref = do+lookupOtherRevIndex :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()+lookupOtherRevIndex h ref fa' fc' = do oth <- readIORef ref- return $! case M.lookup (k,v) oth of- Nothing -> N- Just i -> KV i+ case M.lookup h oth of+ Just i -> fa' i+ Nothing -> fc' {-# INLINE insertOtherRevIndex #-} insertOtherRevIndex :: HeaderName -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()@@ -155,18 +154,23 @@ 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)+lookupRevIndex :: Header+ -> (HIndex -> IO ())+ -> (HeaderValue -> Entry -> HIndex -> IO ())+ -> (HeaderName -> HeaderValue -> Entry -> IO ())+ -> (HeaderValue -> Entry -> HIndex -> IO ())+ -> RevIndex+ -> IO ()+lookupRevIndex h@(k,v) fa fb fc fd (RevIndex dyn oth)+ | t == TOTHER = lookupOtherRevIndex h oth fa' fc'+ | shouldBeIndexed t = lookupDynamicStaticRevIndex t v dyn fa' fb'+ | otherwise = lookupStaticRevIndex t fd' where- get- | t == TOTHER = lookupOtherRevIndex k v oth- | otherwise = do- mx <- lookupDynamicRevIndex t v dyn- return $! case mx of- N -> lookupStaticRevIndex t v- _ -> mx+ ent@(Entry _ t _) = toEntryToken h+ fa' = fa+ fb' = fb v ent+ fc' = fc k v ent+ fd' = fd v ent ---------------------------------------------------------------- @@ -200,13 +204,13 @@ 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+ mapM_ (toFalse 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+ toFalse :: IOA.IOUArray Int Bool -> Int -> IO ()+ toFalse arr i = IOA.writeArray arr i False {-# INLINE shouldBeIndexed #-} shouldBeIndexed :: Token -> Bool
Network/HPACK/Table/Token.hs view
@@ -2,9 +2,12 @@ module Network.HPACK.Table.Token where -import Data.Ix-import Data.ByteString (ByteString) import qualified Data.ByteString as B+import Data.ByteString.Internal (ByteString(..), memcmp)+import Data.Ix+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (plusPtr)+import System.IO.Unsafe (unsafeDupablePerformIO) -- $setup -- >>> :set -XOverloadedStrings@@ -175,94 +178,99 @@ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 110 -> if bs === "access-control-allow-origin" then TAccessControlAllowOrigin else TOTHER _ -> TOTHER _ -> TOTHER where len = B.length bs lst = B.last bs+ PS fp1 off1 siz === PS fp2 off2 _ = unsafeDupablePerformIO $+ withForeignPtr fp1 $ \p1 ->+ withForeignPtr fp2 $ \p2 -> do+ i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz+ return $! i == 0
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 1.5.1+Version: 1.5.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3