module Network.HTTP2.Priority (
Precedence
, defaultPrecedence
, toPrecedence
, PriorityTree
, newPriorityTree
, prepare
, enqueue
, enqueueControl
, dequeue
, delete
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Concurrent.STM
import Control.Monad (when, unless)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as Map
import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence)
import qualified Network.HTTP2.Priority.Queue as Q
import Network.HTTP2.Types
data PriorityTree a = PriorityTree (TVar (Glue a))
(TNestedPriorityQueue a)
(TQueue (StreamId, Precedence, a))
type Glue a = IntMap (TNestedPriorityQueue a, Precedence)
type TNestedPriorityQueue a = TPriorityQueue (Element a)
data Element a = Child a
| Parent (TNestedPriorityQueue a)
defaultPrecedence :: Precedence
defaultPrecedence = toPrecedence defaultPriority
toPrecedence :: Priority -> Precedence
toPrecedence (Priority _ dep w) = Q.Precedence 0 w dep
newPriorityTree :: IO (PriorityTree a)
newPriorityTree = PriorityTree <$> newTVarIO Map.empty
<*> atomically Q.new
<*> newTQueueIO
prepare :: PriorityTree a -> StreamId -> Priority -> IO ()
prepare (PriorityTree var _ _) sid p = atomically $ do
q <- Q.new
let pre = toPrecedence p
modifyTVar' var $ Map.insert sid (q, pre)
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 p el
| otherwise = case Map.lookup pid m of
Nothing -> Q.enqueue q0 sid p el
Just (q', p') -> do
notQueued <- Q.isEmpty q'
Q.enqueue q' sid p el
when notQueued $ do
let !el' = Parent q'
loop m el' p'
where
pid = Q.dependency p
enqueueControl :: PriorityTree a -> StreamId -> a -> IO ()
enqueueControl (PriorityTree _ _ cq) sid x =
atomically $ writeTQueue cq (sid,defaultPrecedence,x)
dequeue :: PriorityTree a -> IO (StreamId, Precedence, a)
dequeue (PriorityTree _ q0 cq) = atomically $ do
mx <- tryReadTQueue cq
case mx of
Just x -> return x
Nothing -> loop q0
where
loop q = do
(sid,p,el) <- Q.dequeue q
case el of
Child x -> return $! (sid, p, x)
Parent q' -> do
entr <- loop q'
empty <- Q.isEmpty q'
unless empty $ Q.enqueue q sid p el
return entr
delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)
delete (PriorityTree var q0 _) sid p
| pid == 0 = atomically $ del q0
| otherwise = atomically $ do
m <- readTVar var
case Map.lookup pid m of
Nothing -> return Nothing
Just (q,_) -> del q
where
pid = Q.dependency p
del q = do
mel <- Q.delete sid q
case mel of
Nothing -> return Nothing
Just el -> case el of
Child x -> return $ Just x
Parent _ -> return Nothing