diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/Network/HPACK/Table.hs b/Network/HPACK/Table.hs --- a/Network/HPACK/Table.hs +++ b/Network/HPACK/Table.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Table/Static.hs b/Network/HPACK/Table/Static.hs --- a/Network/HPACK/Table/Static.hs +++ b/Network/HPACK/Table/Static.hs @@ -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 diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs --- a/Network/HTTP2.hs +++ b/Network/HTTP2.hs @@ -30,7 +30,6 @@ , Weight , defaultPriority , highestPriority - , controlPriority -- * Stream identifier , StreamId , isControl diff --git a/Network/HTTP2/Priority.hs b/Network/HTTP2/Priority.hs --- a/Network/HTTP2/Priority.hs +++ b/Network/HTTP2/Priority.hs @@ -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 diff --git a/Network/HTTP2/Priority/PSQ.hs b/Network/HTTP2/Priority/PSQ.hs --- a/Network/HTTP2/Priority/PSQ.hs +++ b/Network/HTTP2/Priority/PSQ.hs @@ -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) diff --git a/Network/HTTP2/Priority/Queue.hs b/Network/HTTP2/Priority/Queue.hs --- a/Network/HTTP2/Priority/Queue.hs +++ b/Network/HTTP2/Priority/Queue.hs @@ -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 diff --git a/Network/HTTP2/Types.hs b/Network/HTTP2/Types.hs --- a/Network/HTTP2/Types.hs +++ b/Network/HTTP2/Types.hs @@ -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) ---------------------------------------------------------------- diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 1.2.0 +Version: 1.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -10,6 +10,7 @@ Category: Network Cabal-Version: >= 1.10 Build-Type: Simple +Extra-Source-Files: ChangeLog.md ---------------------------------------------------------------- diff --git a/test/HTTP2/PrioritySpec.hs b/test/HTTP2/PrioritySpec.hs --- a/test/HTTP2/PrioritySpec.hs +++ b/test/HTTP2/PrioritySpec.hs @@ -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)