module Network.HTTP2.Priority {-# DEPRECATED "Should be replaced with extensible priority" #-} (
Precedence
, defaultPrecedence
, toPrecedence
, PriorityTree
, newPriorityTree
, prepare
, enqueue
, dequeue
, dequeueSTM
, isEmpty
, isEmptySTM
, delete
) where
import Control.Concurrent.STM
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as Map
import Imports hiding (delete, empty)
import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence)
import qualified Network.HTTP2.Priority.Queue as Q
import Network.HTTP2.Frame.Types
data PriorityTree a = PriorityTree (TVar (Glue a))
(TNestedPriorityQueue 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 :: Precedence
defaultPrecedence = Priority -> Precedence
toPrecedence Priority
defaultPriority
toPrecedence :: Priority -> Precedence
toPrecedence :: Priority -> Precedence
toPrecedence (Priority Bool
_ StreamId
dep StreamId
w) = Deficit -> StreamId -> StreamId -> Precedence
Q.Precedence Deficit
0 StreamId
w StreamId
dep
newPriorityTree :: IO (PriorityTree a)
newPriorityTree :: IO (PriorityTree a)
newPriorityTree = TVar (Glue a) -> TNestedPriorityQueue a -> PriorityTree a
forall a. TVar (Glue a) -> TNestedPriorityQueue a -> PriorityTree a
PriorityTree (TVar (Glue a) -> TNestedPriorityQueue a -> PriorityTree a)
-> IO (TVar (Glue a))
-> IO (TNestedPriorityQueue a -> PriorityTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Glue a -> IO (TVar (Glue a))
forall a. a -> IO (TVar a)
newTVarIO Glue a
forall a. IntMap a
Map.empty
IO (TNestedPriorityQueue a -> PriorityTree a)
-> IO (TNestedPriorityQueue a) -> IO (PriorityTree a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM (TNestedPriorityQueue a) -> IO (TNestedPriorityQueue a)
forall a. STM a -> IO a
atomically STM (TNestedPriorityQueue a)
forall a. STM (TPriorityQueue a)
Q.new
prepare :: PriorityTree a -> StreamId -> Priority -> IO ()
prepare :: PriorityTree a -> StreamId -> Priority -> IO ()
prepare (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
_) StreamId
sid Priority
p = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TNestedPriorityQueue a
q <- STM (TNestedPriorityQueue a)
forall a. STM (TPriorityQueue a)
Q.new
let pre :: Precedence
pre = Priority -> Precedence
toPrecedence Priority
p
TVar (Glue a) -> (Glue a -> Glue a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Glue a)
var ((Glue a -> Glue a) -> STM ()) -> (Glue a -> Glue a) -> STM ()
forall a b. (a -> b) -> a -> b
$ StreamId
-> (TNestedPriorityQueue a, Precedence) -> Glue a -> Glue a
forall a. StreamId -> a -> IntMap a -> IntMap a
Map.insert StreamId
sid (TNestedPriorityQueue a
q, Precedence
pre)
enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO ()
enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO ()
enqueue (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
q0) StreamId
sid Precedence
p0 a
x = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Glue a
m <- TVar (Glue a) -> STM (Glue a)
forall a. TVar a -> STM a
readTVar TVar (Glue a)
var
let el :: Element a
el = a -> Element a
forall a. a -> Element a
Child a
x
Glue a -> Element a -> Precedence -> STM ()
loop Glue a
m Element a
el Precedence
p0
where
loop :: Glue a -> Element a -> Precedence -> STM ()
loop Glue a
m Element a
el Precedence
p
| StreamId
pid StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
0 = TNestedPriorityQueue a
-> StreamId -> Precedence -> Element a -> STM ()
forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue a
q0 StreamId
sid Precedence
p Element a
el
| Bool
otherwise = case StreamId -> Glue a -> Maybe (TNestedPriorityQueue a, Precedence)
forall a. StreamId -> IntMap a -> Maybe a
Map.lookup StreamId
pid Glue a
m of
Maybe (TNestedPriorityQueue a, Precedence)
Nothing -> TNestedPriorityQueue a
-> StreamId -> Precedence -> Element a -> STM ()
forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue a
q0 StreamId
sid Precedence
p Element a
el
Just (TNestedPriorityQueue a
q', Precedence
p') -> do
Bool
notQueued <- TNestedPriorityQueue a -> STM Bool
forall a. TPriorityQueue a -> STM Bool
Q.isEmpty TNestedPriorityQueue a
q'
TNestedPriorityQueue a
-> StreamId -> Precedence -> Element a -> STM ()
forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue a
q' StreamId
sid Precedence
p Element a
el
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notQueued (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
let el' :: Element a
el' = TNestedPriorityQueue a -> Element a
forall a. TNestedPriorityQueue a -> Element a
Parent TNestedPriorityQueue a
q'
Glue a -> Element a -> Precedence -> STM ()
loop Glue a
m Element a
el' Precedence
p'
where
pid :: StreamId
pid = Precedence -> StreamId
Q.dependency Precedence
p
isEmpty :: PriorityTree a -> IO Bool
isEmpty :: PriorityTree a -> IO Bool
isEmpty = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool)
-> (PriorityTree a -> STM Bool) -> PriorityTree a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PriorityTree a -> STM Bool
forall a. PriorityTree a -> STM Bool
isEmptySTM
isEmptySTM :: PriorityTree a -> STM Bool
isEmptySTM :: PriorityTree a -> STM Bool
isEmptySTM (PriorityTree TVar (Glue a)
_ TNestedPriorityQueue a
q0) = TNestedPriorityQueue a -> STM Bool
forall a. TPriorityQueue a -> STM Bool
Q.isEmpty TNestedPriorityQueue a
q0
dequeue :: PriorityTree a -> IO (StreamId, Precedence, a)
dequeue :: PriorityTree a -> IO (StreamId, Precedence, a)
dequeue = STM (StreamId, Precedence, a) -> IO (StreamId, Precedence, a)
forall a. STM a -> IO a
atomically (STM (StreamId, Precedence, a) -> IO (StreamId, Precedence, a))
-> (PriorityTree a -> STM (StreamId, Precedence, a))
-> PriorityTree a
-> IO (StreamId, Precedence, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PriorityTree a -> STM (StreamId, Precedence, a)
forall a. PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM
dequeueSTM :: PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM :: PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM (PriorityTree TVar (Glue a)
_ TNestedPriorityQueue a
q0) = TNestedPriorityQueue a -> STM (StreamId, Precedence, a)
forall c. TNestedPriorityQueue c -> STM (StreamId, Precedence, c)
loop TNestedPriorityQueue a
q0
where
loop :: TNestedPriorityQueue c -> STM (StreamId, Precedence, c)
loop TNestedPriorityQueue c
q = do
(StreamId
sid,Precedence
p,Element c
el) <- TNestedPriorityQueue c -> STM (StreamId, Precedence, Element c)
forall a. TPriorityQueue a -> STM (StreamId, Precedence, a)
Q.dequeue TNestedPriorityQueue c
q
case Element c
el of
Child c
x -> (StreamId, Precedence, c) -> STM (StreamId, Precedence, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamId
sid, Precedence
p, c
x)
Parent TNestedPriorityQueue c
q' -> do
(StreamId, Precedence, c)
entr <- TNestedPriorityQueue c -> STM (StreamId, Precedence, c)
loop TNestedPriorityQueue c
q'
Bool
empty <- TNestedPriorityQueue c -> STM Bool
forall a. TPriorityQueue a -> STM Bool
Q.isEmpty TNestedPriorityQueue c
q'
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TNestedPriorityQueue c
-> StreamId -> Precedence -> Element c -> STM ()
forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue c
q StreamId
sid Precedence
p Element c
el
(StreamId, Precedence, c) -> STM (StreamId, Precedence, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamId, Precedence, c)
entr
delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)
delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)
delete (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
q0) StreamId
sid Precedence
p
| StreamId
pid StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
0 = STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ TNestedPriorityQueue a -> STM (Maybe a)
forall a. TPriorityQueue (Element a) -> STM (Maybe a)
del TNestedPriorityQueue a
q0
| Bool
otherwise = STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
Glue a
m <- TVar (Glue a) -> STM (Glue a)
forall a. TVar a -> STM a
readTVar TVar (Glue a)
var
case StreamId -> Glue a -> Maybe (TNestedPriorityQueue a, Precedence)
forall a. StreamId -> IntMap a -> Maybe a
Map.lookup StreamId
pid Glue a
m of
Maybe (TNestedPriorityQueue a, Precedence)
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just (TNestedPriorityQueue a
q,Precedence
_) -> TNestedPriorityQueue a -> STM (Maybe a)
forall a. TPriorityQueue (Element a) -> STM (Maybe a)
del TNestedPriorityQueue a
q
where
pid :: StreamId
pid = Precedence -> StreamId
Q.dependency Precedence
p
del :: TPriorityQueue (Element a) -> STM (Maybe a)
del TPriorityQueue (Element a)
q = do
Maybe (Element a)
mel <- StreamId -> TPriorityQueue (Element a) -> STM (Maybe (Element a))
forall a. StreamId -> TPriorityQueue a -> STM (Maybe a)
Q.delete StreamId
sid TPriorityQueue (Element a)
q
case Maybe (Element a)
mel of
Maybe (Element a)
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just Element a
el -> case Element a
el of
Child a
x -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM (Maybe a)) -> Maybe a -> STM (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
Parent TPriorityQueue (Element a)
_ -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing