-- | This is partial implementation of the priority of HTTP/2.
--
-- This implementation does support structured priority queue
-- but not support re-structuring. This means that it is assumed that
-- an entry created by a Priority frame is never closed. The entry
-- behaves an intermediate node, not a leaf.
--
-- This queue is fair for weight. Consider two weights: 201 and 101.
-- Repeating enqueue/dequeue probably produces
-- 201, 201, 101, 201, 201, 101, ...
--
-- Only one entry per stream should be enqueued.

module Network.HTTP2.Priority {-# DEPRECATED "Should be replaced with extensible priority" #-} (
  -- * Precedence
    Precedence
  , defaultPrecedence
  , toPrecedence
  -- * PriorityTree
  , PriorityTree
  , newPriorityTree
  -- * PriorityTree functions
  , 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

----------------------------------------------------------------

-- | Abstract data type for priority trees.
data PriorityTree a = PriorityTree (TVar (Glue a))
                                   (TNestedPriorityQueue a)

type Glue a = IntMap (TNestedPriorityQueue a, Precedence)

-- INVARIANT: Empty TNestedPriorityQueue is never enqueued in
-- another TNestedPriorityQueue.
type TNestedPriorityQueue a = TPriorityQueue (Element a)

data Element a = Child a
               | Parent (TNestedPriorityQueue a)


----------------------------------------------------------------

-- | Default precedence.
defaultPrecedence :: Precedence
defaultPrecedence :: Precedence
defaultPrecedence = Priority -> Precedence
toPrecedence Priority
defaultPriority

-- | Converting 'Priority' to 'Precedence'.
--   When an entry is enqueued at the first time,
--   this function should be used.
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

----------------------------------------------------------------

-- | Creating a new priority tree.
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

----------------------------------------------------------------

-- | Bringing up the structure of the priority tree.
--   This must be used for Priority frame.
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)

-- | Enqueuing an entry to the priority tree.
--   This must be used for Header frame.
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
          -- If not found, enqueuing it to the stream 0 queue.
          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


-- | Checking if the priority tree is empty.
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

-- | Checking if the priority tree is empty.
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

-- | Dequeuing an entry from the priority tree.
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

-- | Dequeuing an entry from the priority tree.
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

-- | Deleting the entry corresponding to 'StreamId'.
--   'delete' and 'enqueue' are used to change the priority of
--   a live stream.
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 -- fixme: this is error