http2 1.4.3 → 1.4.4

raw patch · 4 files changed

+90/−15 lines, 4 filesdep ~basedep ~bytestringdep ~containers

Dependency ranges changed: base, bytestring, containers

Files

• ChangeLog.md +4/−0
• Network/HPACK/Table/RevIndex.hs +17/−11
• bench-hpack/Main.hs +53/−0
• http2.cabal +16/−4

@@ -1,3 +1,7 @@+## 1.4.4++* Fixing a bug of reverse index.+ ## 1.4.3  * Priority benchmark is now external information versions.

@@ -1,7 +1,9 @@+{-# LANGUAGE BangPatterns #-}+ module Network.HPACK.Table.RevIndex where -import Data.Map (Map)-import qualified Data.Map as M+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M import Network.HPACK.Types import Network.HPACK.Table.Static @@ -14,27 +16,31 @@ newtype Outer = Outer (Map HeaderName Inner) deriving Show  defaultRevIndex :: Outer-defaultRevIndex = Outer $ foldr op M.empty lst+defaultRevIndex = Outer $! foldr op M.empty lst   where     lst = zip staticTableList $ map SIndex [1..]     op ((k,v),i) m = M.alter f k m       where-        f Nothing              = Just $ Inner [(v,i)]    []-        f (Just (Inner ss ds)) = Just $ Inner ((v,i):ss) ds+        f Nothing              = Just $! Inner [(v,i)]    []+        f (Just (Inner ss ds)) = let ss' = (v,i):ss+                                 in Just $! Inner ss' ds  insertDynamic :: Header -> DIndex -> Outer -> Outer-insertDynamic (k,v) didx (Outer rev) = Outer $ M.alter f k rev+insertDynamic (k,v) didx (Outer rev) = Outer $! M.alter f k rev   where-    f Nothing              = Just $ Inner [] [(v,didx)]-    f (Just (Inner ss ds)) = Just $ Inner ss ((v,didx):ds)+    f Nothing              = Just $! Inner [] [(v,didx)]+    f (Just (Inner ss ds)) = let ds' = (v,didx):ds+                             in Just $! Inner ss ds'  deleteDynamic :: Header -> Map HeaderName Inner -> Map HeaderName Inner deleteDynamic (k,v) rev = M.alter f k rev   where     f Nothing              = Nothing     f (Just (Inner ss ds)) = case filter (\(a,_) -> a /= v) ds of-        []  -> Nothing-        ds' -> Just $ Inner ss ds'+        []  -> case ss of+            [] -> Nothing+            _  -> Just $! Inner ss []+        ds' -> Just $! Inner ss ds'  deleteDynamicList :: [Header] -> Outer -> Outer-deleteDynamicList hs (Outer rev) = Outer $ foldr deleteDynamic rev hs+deleteDynamicList hs (Outer rev) = Outer $! foldr deleteDynamic rev hs

@@ -0,0 +1,53 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import Control.Exception+import Criterion.Main+import Network.HPACK+import Data.ByteString (ByteString)++main :: IO ()+main = do+    hdrs <- read <$> readFile "bench-hpack/headers.hs"+    hpacks <- prepare hdrs+    _ <- evaluate hpacks+    defaultMain [+        bgroup "HPACK encoding" [+              bench "Pure" $ nfIO (enc hdrs)+            ]+      , bgroup "HPACK decoding" [+              bench "Pure" $ nfIO (dec hpacks)+            ]+      ]++----------------------------------------------------------------+prepare :: [HeaderList] -> IO [ByteString]+prepare hdrs = do+    tbl <- newDynamicTableForEncoding defaultDynamicTableSize+    go tbl hdrs id+  where+    go _    []     b = return (b [])+    go !tbl (h:hs) b = do+        (tbl', frag) <- encodeHeader defaultEncodeStrategy tbl h+        go tbl' hs (b . (frag :))++enc :: [HeaderList] -> IO ()+enc hdrs = do+    tbl <- newDynamicTableForEncoding defaultDynamicTableSize+    go tbl hdrs+  where+    go _    []     = return ()+    go !tbl (h:hs) = do+        (tbl', !_) <- encodeHeader defaultEncodeStrategy tbl h+        go tbl' hs++dec :: [ByteString] -> IO ()+dec hpacks = do+    tbl <- newDynamicTableForDecoding defaultDynamicTableSize+    go tbl hpacks+  where+    go _    []     = return ()+    go !tbl (f:fs) = do+        (tbl', !_) <- decodeHeader tbl f+        go tbl' fs

@@ -1,5 +1,5 @@ Name:                   http2-Version:                1.4.3+Version:                1.4.4 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -120,7 +120,6 @@                       , containers                       , hex                       , hspec >= 1.3-                      , mwc-random                       , psqueues                       , stm                       , unordered-containers@@ -261,7 +260,7 @@                       , text                       , unordered-containers -Benchmark criterion+Benchmark priority   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   Hs-Source-Dirs:       bench-priority, .@@ -274,7 +273,6 @@                         RandomSkewHeap                         RingOfQueues                         RingOfQueuesSTM-   Build-Depends:        base                       , array                       , containers@@ -284,4 +282,18 @@                       , mwc-random                       , psqueues                       , random+                      , stm++Benchmark header-compression+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  Hs-Source-Dirs:       bench-hpack, .+  Ghc-Options:          -Wall+  Main-Is:              Main.hs+  Build-Depends:        base+                      , array+                      , bytestring+                      , containers+                      , criterion+                      , hashtables                       , stm