http2 1.2.0 → 1.3.0
raw patch · 10 files changed
+169/−137 lines, 10 files
Files
- ChangeLog.md +7/−0
- Network/HPACK/Table.hs +1/−1
- Network/HPACK/Table/Static.hs +3/−3
- Network/HTTP2.hs +0/−1
- Network/HTTP2/Priority.hs +41/−36
- Network/HTTP2/Priority/PSQ.hs +62/−34
- Network/HTTP2/Priority/Queue.hs +10/−16
- Network/HTTP2/Types.hs +0/−5
- http2.cabal +2/−1
- test/HTTP2/PrioritySpec.hs +43/−40
+ ChangeLog.md view
@@ -0,0 +1,7 @@+## 1.3.0++* APIs `Network.HTTP2.Priority` are changed again. `Precedence` is introduced.++## 1.2.0++* APIs of `Network.HTTP2.Priority` are changed. `delete` is provided. Internal data structure is changed from random skew heap to priority search queue.
Network/HPACK/Table.hs view
@@ -66,7 +66,7 @@ DHM.K _ -> KeyValue InDynamicTable (fromHIndexToIndex dyntbl hidx) DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex dyntbl sidx) where- mstatic = DHM.search h staticHashPSQ+ mstatic = DHM.search h staticHashMap ----------------------------------------------------------------
Network/HPACK/Table/Static.hs view
@@ -6,7 +6,7 @@ , toStaticIndex , isSIndexValid , toStaticEntry- , staticHashPSQ+ , staticHashMap , staticTableSize -- fixme ) where @@ -48,8 +48,8 @@ staticTable :: Array Index Entry staticTable = listArray (1,staticTableSize) $ map toEntry staticTableList -staticHashPSQ :: DHM.DoubleHashMap SIndex-staticHashPSQ = DHM.fromList alist+staticHashMap :: DHM.DoubleHashMap SIndex+staticHashMap = DHM.fromList alist where is = map toStaticIndex [1..] alist = zip is staticTableList
Network/HTTP2.hs view
@@ -30,7 +30,6 @@ , Weight , defaultPriority , highestPriority- , controlPriority -- * Stream identifier , StreamId , isControl
Network/HTTP2/Priority.hs view
@@ -15,15 +15,19 @@ -- Only one entry per stream should be enqueued. module Network.HTTP2.Priority (+ -- * Precedence+ Precedence+ , defaultPrecedence+ , toPrecedence -- * PriorityTree- PriorityTree+ , PriorityTree , newPriorityTree -- * PriorityTree functions , prepare , enqueue+ , enqueueControl , dequeue , delete- , clear ) where #if __GLASGOW_HASKELL__ < 709@@ -33,7 +37,7 @@ import Control.Monad (when, unless) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as Map-import Network.HTTP2.Priority.Queue (TPriorityQueue)+import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence) import qualified Network.HTTP2.Priority.Queue as Q import Network.HTTP2.Types @@ -42,9 +46,9 @@ -- | Abstract data type for priority trees. data PriorityTree a = PriorityTree (TVar (Glue a)) (TNestedPriorityQueue a)- (TQueue (StreamId, a))+ (TQueue (StreamId, Precedence, a)) -type Glue a = IntMap (TNestedPriorityQueue a, Priority)+type Glue a = IntMap (TNestedPriorityQueue a, Precedence) -- INVARIANT: Empty TNestedPriorityQueue is never enqueued in -- another TNestedPriorityQueue.@@ -53,8 +57,21 @@ data Element a = Child a | Parent (TNestedPriorityQueue a) + ---------------------------------------------------------------- +-- | Default precedence.+defaultPrecedence :: Precedence+defaultPrecedence = toPrecedence defaultPriority++-- | Converting 'Priority' to 'Precedence'.+-- When an entry is enqueued at the first time,+-- this function should be used.+toPrecedence :: Priority -> Precedence+toPrecedence (Priority _ dep w) = Q.Precedence 0 w dep++----------------------------------------------------------------+ -- | Creating a new priority tree. newPriorityTree :: IO (PriorityTree a) newPriorityTree = PriorityTree <$> newTVarIO Map.empty@@ -68,36 +85,38 @@ prepare :: PriorityTree a -> StreamId -> Priority -> IO () prepare (PriorityTree var _ _) sid p = atomically $ do q <- Q.new- modifyTVar' var $ Map.insert sid (q, p)+ let pre = toPrecedence p+ modifyTVar' var $ Map.insert sid (q, pre) -- | Enqueuing an entry to the priority tree. -- This must be used for Header frame.--- If 'controlPriority' is specified,--- it is treated as a control frame and top-queued.-enqueue :: PriorityTree a -> StreamId -> Priority -> a -> IO ()-enqueue (PriorityTree _ _ cq) sid p0 x- | p0 == controlPriority = atomically $ writeTQueue cq (sid,x)+enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO () enqueue (PriorityTree var q0 _) sid p0 x = atomically $ do m <- readTVar var let !el = Child x loop m el p0 where loop m el p- | pid == 0 = Q.enqueue q0 sid w el+ | pid == 0 = Q.enqueue q0 sid p el | otherwise = case Map.lookup pid m of- Nothing -> Q.enqueue q0 sid w el -- error case: checkme+ -- If not found, enqueuing it to the stream 0 queue.+ Nothing -> Q.enqueue q0 sid p el Just (q', p') -> do notQueued <- Q.isEmpty q'- Q.enqueue q' sid w el+ Q.enqueue q' sid p el when notQueued $ do let !el' = Parent q' loop m el' p' where- pid = streamDependency p- w = weight p+ pid = Q.dependency p +-- | Putting an entry to the top of the priority tree.+enqueueControl :: PriorityTree a -> StreamId -> a -> IO ()+enqueueControl (PriorityTree _ _ cq) sid x =+ atomically $ writeTQueue cq (sid,defaultPrecedence,x)+ -- | Dequeuing an entry from the priority tree.-dequeue :: PriorityTree a -> IO (StreamId, a)+dequeue :: PriorityTree a -> IO (StreamId, Precedence, a) dequeue (PriorityTree _ q0 cq) = atomically $ do mx <- tryReadTQueue cq case mx of@@ -105,19 +124,19 @@ Nothing -> loop q0 where loop q = do- (sid,w,el) <- Q.dequeue q+ (sid,p,el) <- Q.dequeue q case el of- Child x -> return $! (sid, x)+ Child x -> return $! (sid, p, x) Parent q' -> do entr <- loop q' empty <- Q.isEmpty q'- unless empty $ Q.enqueue q sid w el+ unless empty $ Q.enqueue q sid p el return entr -- | Deleting the entry corresponding to 'StreamId'. -- 'delete' and 'enqueue' are used to change the priority of -- a live stream.-delete :: PriorityTree a -> StreamId -> Priority -> IO (Maybe a)+delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a) delete (PriorityTree var q0 _) sid p | pid == 0 = atomically $ del q0 | otherwise = atomically $ do@@ -126,7 +145,7 @@ Nothing -> return Nothing Just (q,_) -> del q where- pid = streamDependency p+ pid = Q.dependency p del q = do mel <- Q.delete sid q case mel of@@ -134,17 +153,3 @@ Just el -> case el of Child x -> return $ Just x Parent _ -> return Nothing -- fixme: this is error---- | Clearing the internal state for 'StreamId' from 'PriorityTree'.--- When a stream is closed, this function MUST be called--- to prevent memory leak.-clear :: PriorityTree a -> StreamId -> Priority -> IO ()-clear (PriorityTree var q0 _) sid p- | pid == 0 = atomically $ Q.clear sid q0- | otherwise = atomically $ do- m <- readTVar var- case Map.lookup pid m of- Nothing -> return ()- Just (q,_) -> Q.clear sid q- where- pid = streamDependency p
Network/HTTP2/Priority/PSQ.hs view
@@ -3,21 +3,21 @@ {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Priority.PSQ (- PriorityQueue+ Key+ , Precedence(..)+ , newPrecedence+ , PriorityQueue , empty , isEmpty , enqueue , dequeue , delete- , clear ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.Array (Array, listArray, (!))-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as P import Data.Word (Word64)@@ -27,13 +27,34 @@ type Key = Int type Weight = Int type Deficit = Word64-type Heap a = IntPSQ Deficit (Weight, a) +-- | Internal representation of priority in priority queues.+-- The precedence of a dequeued entry should be specified+-- to 'enqueue' when the entry is enqueued again.+data Precedence = Precedence {+ deficit :: {-# UNPACK #-} !Deficit+ , weight :: {-# UNPACK #-} !Weight+ -- stream dependency, used by the upper layer+ , dependency :: {-# UNPACK #-} !Key+ } deriving Show++-- | For test only+newPrecedence :: Weight -> Precedence+newPrecedence w = Precedence 0 w 0++instance Eq Precedence where+ Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2++instance Ord Precedence where+ Precedence d1 _ _ < Precedence d2 _ _ = d1 < d2+ Precedence d1 _ _ <= Precedence d2 _ _ = d1 <= d2++type Heap a = IntPSQ Precedence a+ -- FIXME: The base (Word64) would be overflowed. -- In that case, the heap must be re-constructed. data PriorityQueue a = PriorityQueue { baseDeficit :: {-# UNPACK #-} !Deficit- , deficitMap :: IntMap Deficit , queue :: Heap a } @@ -54,46 +75,53 @@ weightToDeficit :: Weight -> Deficit weightToDeficit w = deficitTable ! w +deficitLimit :: Deficit+deficitLimit = 10000000000000000000 -- more than 2^63 and less than 2^63 + 2^62+ ---------------------------------------------------------------- empty :: PriorityQueue a-empty = PriorityQueue 0 I.empty P.empty+empty = PriorityQueue 0 P.empty isEmpty :: PriorityQueue a -> Bool isEmpty PriorityQueue{..} = P.null queue -enqueue :: Key -> Weight -> a -> PriorityQueue a -> PriorityQueue a-enqueue k w x PriorityQueue{..} =- PriorityQueue baseDeficit deficitMap' queue'+enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a+enqueue k p v PriorityQueue{..}+ | deficit' < deficitLimit = fastPath+ | otherwise = slowPath where- !d = weightToDeficit w- !forNew = baseDeficit + d- f _ _ old = old + d- (!mold, !deficitMap') = I.insertLookupWithKey f k forNew deficitMap- !deficit' = case mold of- Nothing -> forNew- Just old -> old + d- !queue' = P.insert k deficit' (w,x) queue+ !d = weightToDeficit (weight p)+ !b = if deficit p == 0 then baseDeficit else deficit p+ !deficit' = b + d+ fastPath = PriorityQueue baseDeficit queue'+ where+ !p' = p { deficit = deficit' }+ !queue' = P.insert k p' v queue+ slowPath = PriorityQueue 0 queue''+ where+ adjust (x,y,z) = (x,y',z)+ where+ !d' = deficit y - baseDeficit+ !y' = y { deficit = d' }+ !queue' = P.fromList $ map adjust $ P.toList queue+ !deficit'' = deficit' - baseDeficit+ !p'' = p { deficit = deficit'' }+ !queue'' = P.insert k p'' v queue' -dequeue :: PriorityQueue a -> Maybe (Key, Weight, a, PriorityQueue a)+dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a) dequeue PriorityQueue{..} = case P.minView queue of Nothing -> Nothing- Just (k, deficit, (w,x), queue')- | P.null queue' -> Just (k, w, x, empty)- | otherwise -> Just (k, w, x, PriorityQueue deficit deficitMap queue')+ Just (k, p, v, queue')+ | P.null queue' -> Just (k, p, v, empty)+ | otherwise -> let !base = deficit p+ in Just (k, p, v, PriorityQueue base queue') delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a) delete k PriorityQueue{..} = case P.findMin queue' of- Nothing -> (mx, empty)- Just (_,deficit,_) -> let !deficitMap' = I.delete k deficitMap- in (mx, PriorityQueue deficit deficitMap' queue')- where- (!mx,!queue') = P.alter f k queue- f Nothing = (Nothing, Nothing)- f (Just (_, (_,x))) = (Just x, Nothing)--clear :: Key -> PriorityQueue a -> PriorityQueue a-clear k PriorityQueue{..} = PriorityQueue baseDeficit deficitMap' queue'+ Nothing -> (mv, empty)+ Just (_,p,_) -> (mv, PriorityQueue (deficit p) queue') where- !deficitMap' = I.delete k deficitMap- !queue' = P.delete k queue -- just in case+ (!mv,!queue') = P.alter f k queue+ f Nothing = (Nothing, Nothing)+ f (Just (_,v)) = (Just v, Nothing)
Network/HTTP2/Priority/Queue.hs view
@@ -1,27 +1,24 @@ {-# LANGUAGE CPP #-} module Network.HTTP2.Priority.Queue (- TPriorityQueue+ Precedence(..)+ , TPriorityQueue , new , isEmpty , enqueue , dequeue , delete- , clear ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Concurrent.STM-import Network.HTTP2.Priority.PSQ (PriorityQueue)+import Network.HTTP2.Priority.PSQ (PriorityQueue, Key, Precedence(..)) import qualified Network.HTTP2.Priority.PSQ as Q ---------------------------------------------------------------- -type Key = Int-type Weight = Int- newtype TPriorityQueue a = TPriorityQueue (TVar (PriorityQueue a)) new :: STM (TPriorityQueue a)@@ -30,24 +27,21 @@ isEmpty :: TPriorityQueue a -> STM Bool isEmpty (TPriorityQueue th) = Q.isEmpty <$> readTVar th -enqueue :: TPriorityQueue a -> Key -> Weight -> a -> STM ()-enqueue (TPriorityQueue th) k w x = modifyTVar' th $ Q.enqueue k w x+enqueue :: TPriorityQueue a -> Key -> Precedence -> a -> STM ()+enqueue (TPriorityQueue th) k p v = modifyTVar' th $ Q.enqueue k p v -dequeue :: TPriorityQueue a -> STM (Key, Weight, a)+dequeue :: TPriorityQueue a -> STM (Key, Precedence, a) dequeue (TPriorityQueue th) = do h <- readTVar th case Q.dequeue h of Nothing -> retry- Just (k, w, x, h') -> do+ Just (k, p, v, h') -> do writeTVar th h'- return (k, w, x)+ return (k, p, v) delete :: Key -> TPriorityQueue a -> STM (Maybe a) delete k (TPriorityQueue th) = do q <- readTVar th- let (mx, q') = Q.delete k q+ let (mv, q') = Q.delete k q writeTVar th q'- return mx--clear :: Key -> TPriorityQueue a -> STM ()-clear k (TPriorityQueue th) = modifyTVar' th $ \q -> Q.clear k q+ return mv
Network/HTTP2/Types.hs view
@@ -71,7 +71,6 @@ , Priority(..) , defaultPriority , highestPriority- , controlPriority , Padding ) where @@ -348,10 +347,6 @@ -- Priority {exclusive = False, streamDependency = 0, weight = 256} highestPriority :: Priority highestPriority = Priority False 0 256---- | Priority for control frames to be top-queued.-controlPriority :: Priority-controlPriority = Priority False 0 (-1) ----------------------------------------------------------------
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 1.2.0+Version: 1.3.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -10,6 +10,7 @@ Category: Network Cabal-Version: >= 1.10 Build-Type: Simple+Extra-Source-Files: ChangeLog.md ----------------------------------------------------------------
test/HTTP2/PrioritySpec.hs view
@@ -15,9 +15,9 @@ it "enqueue and dequeue frames from Firefox properly" $ firefox describe "base priority queue" $ do it "queues entries based on weight" $ do- let q = P.enqueue 5 1 5 $- P.enqueue 3 101 3 $- P.enqueue 1 201 1 P.empty+ let q = P.enqueue 5 (P.newPrecedence 1) 5 $+ P.enqueue 3 (P.newPrecedence 101) 3 $+ P.enqueue 1 (P.newPrecedence 201) 1 P.empty xs = enqdeq q 1000 map length (group (sort xs)) `shouldBe` [664,333,3] @@ -29,50 +29,53 @@ prepare pt 7 (pri 0 1) prepare pt 9 (pri 7 1) prepare pt 11 (pri 3 1)- enQ pt 13 (pri 11 32)- dequeue pt `shouldReturn` (13,13)- enQ pt 15 (pri 3 32)- enQ pt 17 (pri 3 32)- enQ pt 19 (pri 3 32)- enQ pt 21 (pri 3 32)- enQ pt 23 (pri 3 32)- enQ pt 25 (pri 3 32)- enQ pt 27 (pri 11 22)- enQ pt 29 (pri 11 22)- enQ pt 31 (pri 11 22)- enQ pt 33 (pri 5 32)- enQ pt 35 (pri 5 32)- enQ pt 37 (pri 5 32)- dequeue pt `shouldReturn` (15,15)- clear pt 15 (pri 3 32)- clear pt 15 (pri 3 32)- dequeue pt `shouldReturn` (33,33)- dequeue pt `shouldReturn` (17,17)- clear pt 17 (pri 3 32)- clear pt 17 (pri 3 32)- delete pt 17 (pri 3 32) `shouldReturn` Nothing- delete pt 31 (pri 11 22) `shouldReturn` Just 31- dequeue pt `shouldReturn` (19,19)- dequeue pt `shouldReturn` (35,35)- dequeue pt `shouldReturn` (21,21)- dequeue pt `shouldReturn` (23,23)- dequeue pt `shouldReturn` (37,37)- dequeue pt `shouldReturn` (25,25)- dequeue pt `shouldReturn` (27,27)- dequeue pt `shouldReturn` (29,29)- enQ pt 39 (pri 3 32)- dequeue pt `shouldReturn` (39,39)+ enQ pt 13 (pre 11 32)+ deQ pt `shouldReturn` 13+ enQ pt 15 (pre 3 32)+ enQ pt 17 (pre 3 32)+ enQ pt 19 (pre 3 32)+ enQ pt 21 (pre 3 32)+ enQ pt 23 (pre 3 32)+ enQ pt 25 (pre 3 32)+ enQ pt 27 (pre 11 22)+ enQ pt 29 (pre 11 22)+ enQ pt 31 (pre 11 22)+ enQ pt 33 (pre 5 32)+ enQ pt 35 (pre 5 32)+ enQ pt 37 (pre 5 32)+ deQ pt `shouldReturn` 15+ deQ pt `shouldReturn` 33+ deQ pt `shouldReturn` 17+ delete pt 17 (pre 3 32) `shouldReturn` Nothing+ delete pt 31 (pre 11 22) `shouldReturn` Just 31+ deQ pt `shouldReturn` 19+ deQ pt `shouldReturn` 35+ deQ pt `shouldReturn` 21+ deQ pt `shouldReturn` 23+ deQ pt `shouldReturn` 37+ deQ pt `shouldReturn` 25+ deQ pt `shouldReturn` 27+ deQ pt `shouldReturn` 29+ enQ pt 39 (pre 3 32)+ deQ pt `shouldReturn` 39 -enQ :: PriorityTree Int -> StreamId -> Priority -> IO ()+enQ :: PriorityTree Int -> StreamId -> Precedence -> IO () enQ pt sid p = enqueue pt sid p sid +deQ :: PriorityTree Int+ -> IO StreamId+deQ pt = (\(x,_,_) -> x) <$> dequeue pt+ pri :: StreamId -> Weight -> Priority pri dep w = Priority False dep w +pre :: StreamId -> Weight -> Precedence+pre dep w = toPrecedence $ pri dep w+ enqdeq :: P.PriorityQueue Int -> Int -> [Int] enqdeq pq num = loop pq num [] where- loop _ 0 xs = xs- loop !q !n xs = case P.dequeue q of+ loop _ 0 ks = ks+ loop !q !n ks = case P.dequeue q of Nothing -> error "enqdeq"- Just (k,w,x,q') -> loop (P.enqueue k w x q') (n - 1) (x:xs)+ Just (k,p,v,q') -> loop (P.enqueue k p v q') (n - 1) (k:ks)