-- | 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 :: forall a. IO (PriorityTree a)
newPriorityTree = forall a. TVar (Glue a) -> TNestedPriorityQueue a -> PriorityTree a
PriorityTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO forall a. IntMap a
Map.empty
                               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. STM a -> IO a
atomically 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 :: forall a. PriorityTree a -> StreamId -> Priority -> IO ()
prepare (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
_) StreamId
sid Priority
p = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    TNestedPriorityQueue a
q <- forall a. STM (TPriorityQueue a)
Q.new
    let pre :: Precedence
pre = Priority -> Precedence
toPrecedence Priority
p
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Glue a)
var forall a b. (a -> b) -> a -> b
$ 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 :: forall a. PriorityTree a -> StreamId -> Precedence -> a -> IO ()
enqueue (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
q0) StreamId
sid Precedence
p0 a
x = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    Glue a
m <- forall a. TVar a -> STM a
readTVar TVar (Glue a)
var
    let el :: Element a
el = 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 forall a. Eq a => a -> a -> Bool
== StreamId
0  = forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue a
q0 StreamId
sid Precedence
p Element a
el
      | Bool
otherwise = case 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 -> 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 <- forall a. TPriorityQueue a -> STM Bool
Q.isEmpty TNestedPriorityQueue a
q'
              forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue a
q' StreamId
sid Precedence
p Element a
el
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notQueued forall a b. (a -> b) -> a -> b
$ do
                  let el' :: Element a
el' = 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 :: forall a. PriorityTree a -> IO Bool
isEmpty = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PriorityTree a -> STM Bool
isEmptySTM

-- | Checking if the priority tree is empty.
isEmptySTM :: PriorityTree a -> STM Bool
isEmptySTM :: forall a. PriorityTree a -> STM Bool
isEmptySTM (PriorityTree TVar (Glue a)
_ TNestedPriorityQueue a
q0) = 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 :: forall a. PriorityTree a -> IO (StreamId, Precedence, a)
dequeue = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM

-- | Dequeuing an entry from the priority tree.
dequeueSTM :: PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM :: forall a. PriorityTree a -> STM (StreamId, Precedence, a)
dequeueSTM (PriorityTree TVar (Glue a)
_ TNestedPriorityQueue a
q0) = 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) <- forall a. TPriorityQueue a -> STM (StreamId, Precedence, a)
Q.dequeue TNestedPriorityQueue c
q
        case Element c
el of
            Child c
x   -> 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 <- forall a. TPriorityQueue a -> STM Bool
Q.isEmpty TNestedPriorityQueue c
q'
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty forall a b. (a -> b) -> a -> b
$ forall a. TPriorityQueue a -> StreamId -> Precedence -> a -> STM ()
Q.enqueue TNestedPriorityQueue c
q StreamId
sid Precedence
p Element c
el
                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 :: forall a. PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)
delete (PriorityTree TVar (Glue a)
var TNestedPriorityQueue a
q0) StreamId
sid Precedence
p
  | StreamId
pid forall a. Eq a => a -> a -> Bool
== StreamId
0  = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall {a}. TPriorityQueue (Element a) -> STM (Maybe a)
del TNestedPriorityQueue a
q0
  | Bool
otherwise = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Glue a
m <- forall a. TVar a -> STM a
readTVar TVar (Glue a)
var
        case forall a. StreamId -> IntMap a -> Maybe a
Map.lookup StreamId
pid Glue a
m of
            Maybe (TNestedPriorityQueue a, Precedence)
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (TNestedPriorityQueue a
q,Precedence
_) -> 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 <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just Element a
el -> case Element a
el of
                Child  a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
                Parent TPriorityQueue (Element a)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- fixme: this is error