diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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). diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Table/RevIndex.hs b/Network/HPACK/Table/RevIndex.hs --- a/Network/HPACK/Table/RevIndex.hs +++ b/Network/HPACK/Table/RevIndex.hs @@ -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 diff --git a/Network/HPACK/Table/Token.hs b/Network/HPACK/Table/Token.hs --- a/Network/HPACK/Table/Token.hs +++ b/Network/HPACK/Table/Token.hs @@ -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 diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 1.5.1 +Version: 1.5.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3