{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HPACK.Table.RevIndex (
    RevIndex
  , newRevIndex
  , renewRevIndex
  , lookupRevIndex
  , lookupRevIndex'
  , insertRevIndex
  , deleteRevIndexList
  ) where

import Data.Array (Array)
import qualified Data.Array as A
import Data.Array.Base (unsafeAt)
import Data.CaseInsensitive (foldedCase)
import Data.Function (on)
import Data.IORef
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

import Imports
import Network.HPACK.Table.Entry
import Network.HPACK.Table.Static
import Network.HPACK.Token
import Network.HPACK.Types

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

data RevIndex = RevIndex DynamicRevIndex OtherRevIdex

type DynamicRevIndex = Array Int (IORef ValueMap)

data KeyValue = KeyValue HeaderName HeaderValue deriving (KeyValue -> KeyValue -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyValue -> KeyValue -> Bool
$c/= :: KeyValue -> KeyValue -> Bool
== :: KeyValue -> KeyValue -> Bool
$c== :: KeyValue -> KeyValue -> Bool
Eq, Eq KeyValue
KeyValue -> KeyValue -> Bool
KeyValue -> KeyValue -> Ordering
KeyValue -> KeyValue -> KeyValue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KeyValue -> KeyValue -> KeyValue
$cmin :: KeyValue -> KeyValue -> KeyValue
max :: KeyValue -> KeyValue -> KeyValue
$cmax :: KeyValue -> KeyValue -> KeyValue
>= :: KeyValue -> KeyValue -> Bool
$c>= :: KeyValue -> KeyValue -> Bool
> :: KeyValue -> KeyValue -> Bool
$c> :: KeyValue -> KeyValue -> Bool
<= :: KeyValue -> KeyValue -> Bool
$c<= :: KeyValue -> KeyValue -> Bool
< :: KeyValue -> KeyValue -> Bool
$c< :: KeyValue -> KeyValue -> Bool
compare :: KeyValue -> KeyValue -> Ordering
$ccompare :: KeyValue -> KeyValue -> Ordering
Ord)

-- We always create an index for a pair of an unknown header and its value
-- in Linear{H}.
type OtherRevIdex = IORef (Map KeyValue HIndex)

{-# SPECIALIZE INLINE M.lookup :: KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex #-}
{-# SPECIALIZE INLINE M.delete :: KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}
{-# SPECIALIZE INLINE M.insert :: KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}

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

type StaticRevIndex = Array Int StaticEntry

data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving Int -> StaticEntry -> ShowS
[StaticEntry] -> ShowS
StaticEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StaticEntry] -> ShowS
$cshowList :: [StaticEntry] -> ShowS
show :: StaticEntry -> String
$cshow :: StaticEntry -> String
showsPrec :: Int -> StaticEntry -> ShowS
$cshowsPrec :: Int -> StaticEntry -> ShowS
Show

type ValueMap = Map HeaderValue HIndex

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

staticRevIndex :: StaticRevIndex
staticRevIndex :: StaticRevIndex
staticRevIndex = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array (Int
minTokenIx,Int
maxStaticTokenIx) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (HeaderValue, [(HeaderValue, HIndex)]) -> (Int, StaticEntry)
toEnt [(HeaderValue, [(HeaderValue, HIndex)])]
zs
  where
    toEnt :: (HeaderValue, [(HeaderValue, HIndex)]) -> (Int, StaticEntry)
toEnt (HeaderValue
k, [(HeaderValue, HIndex)]
xs) = (Token -> Int
tokenIx (HeaderValue -> Token
toToken HeaderValue
k), StaticEntry
m)
      where
        m :: StaticEntry
m = case [(HeaderValue, HIndex)]
xs of
            []  -> forall a. HasCallStack => String -> a
error String
"staticRevIndex"
            [(HeaderValue
"",HIndex
i)] -> HIndex -> Maybe ValueMap -> StaticEntry
StaticEntry HIndex
i forall a. Maybe a
Nothing
            (HeaderValue
_,HIndex
i):[(HeaderValue, HIndex)]
_  -> let vs :: ValueMap
vs = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(HeaderValue, HIndex)]
xs
                        in HIndex -> Maybe ValueMap -> StaticEntry
StaticEntry HIndex
i (forall a. a -> Maybe a
Just ValueMap
vs)
    zs :: [(HeaderValue, [(HeaderValue, HIndex)])]
zs = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. [(a, b)] -> (a, [b])
extract forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(HeaderValue, (HeaderValue, HIndex))]
lst
      where
        lst :: [(HeaderValue, (HeaderValue, HIndex))]
lst = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(HeaderValue
k,HeaderValue
v) HIndex
i -> (HeaderValue
k,(HeaderValue
v,HIndex
i))) [(HeaderValue, HeaderValue)]
staticTableList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> HIndex
SIndex [Int
1..]
        extract :: [(a, b)] -> (a, [b])
extract [(a, b)]
xs = (forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(a, b)]
xs), forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
xs)

{-# INLINE lookupStaticRevIndex #-}
lookupStaticRevIndex :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex :: Int
-> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex Int
ix HeaderValue
v HIndex -> IO ()
fa' HIndex -> IO ()
fbd' = case StaticRevIndex
staticRevIndex forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
ix of
    StaticEntry HIndex
i Maybe ValueMap
Nothing  -> HIndex -> IO ()
fbd' HIndex
i
    StaticEntry HIndex
i (Just ValueMap
m) -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HeaderValue
v ValueMap
m of
            Maybe HIndex
Nothing -> HIndex -> IO ()
fbd' HIndex
i
            Just HIndex
j  -> HIndex -> IO ()
fa' HIndex
j


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

newDynamicRevIndex :: IO DynamicRevIndex
newDynamicRevIndex :: IO DynamicRevIndex
newDynamicRevIndex = forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
minTokenIx,Int
maxStaticTokenIx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {p} {k} {a}. p -> IO (IORef (Map k a))
mk [Int]
lst
  where
    mk :: p -> IO (IORef (Map k a))
mk p
_ = forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty
    lst :: [Int]
lst = [Int
minTokenIx..Int
maxStaticTokenIx]

renewDynamicRevIndex :: DynamicRevIndex -> IO ()
renewDynamicRevIndex :: DynamicRevIndex -> IO ()
renewDynamicRevIndex DynamicRevIndex
drev = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
clear [Int
minTokenIx..Int
maxStaticTokenIx]
  where
    clear :: Int -> IO ()
clear Int
t = forall a. IORef a -> a -> IO ()
writeIORef (DynamicRevIndex
drev forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
t) forall k a. Map k a
M.empty

{-# INLINE lookupDynamicStaticRevIndex #-}
lookupDynamicStaticRevIndex :: Int -> HeaderValue -> DynamicRevIndex
                            -> (HIndex -> IO ())
                            -> (HIndex -> IO ())
                            -> IO ()
lookupDynamicStaticRevIndex :: Int
-> HeaderValue
-> DynamicRevIndex
-> (HIndex -> IO ())
-> (HIndex -> IO ())
-> IO ()
lookupDynamicStaticRevIndex Int
ix HeaderValue
v DynamicRevIndex
drev HIndex -> IO ()
fa' HIndex -> IO ()
fbd' = do
    let ref :: IORef ValueMap
ref = DynamicRevIndex
drev forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
ix
    ValueMap
m <- forall a. IORef a -> IO a
readIORef IORef ValueMap
ref
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HeaderValue
v ValueMap
m of
        Just HIndex
i  -> HIndex -> IO ()
fa' HIndex
i
        Maybe HIndex
Nothing -> Int
-> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex Int
ix HeaderValue
v HIndex -> IO ()
fa' HIndex -> IO ()
fbd'

{-# INLINE insertDynamicRevIndex #-}
insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()
insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()
insertDynamicRevIndex Token
t HeaderValue
v HIndex
i DynamicRevIndex
drev = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ValueMap
ref forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert HeaderValue
v HIndex
i
  where
    ref :: IORef ValueMap
ref = DynamicRevIndex
drev forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Token -> Int
tokenIx Token
t

{-# INLINE deleteDynamicRevIndex #-}
deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO ()
deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO ()
deleteDynamicRevIndex Token
t HeaderValue
v DynamicRevIndex
drev = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ValueMap
ref forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete HeaderValue
v
  where
    ref :: IORef ValueMap
ref = DynamicRevIndex
drev forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Token -> Int
tokenIx Token
t

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

newOtherRevIndex :: IO OtherRevIdex
newOtherRevIndex :: IO OtherRevIdex
newOtherRevIndex = forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty

renewOtherRevIndex :: OtherRevIdex -> IO ()
renewOtherRevIndex :: OtherRevIdex -> IO ()
renewOtherRevIndex OtherRevIdex
ref = forall a. IORef a -> a -> IO ()
writeIORef OtherRevIdex
ref forall k a. Map k a
M.empty

{-# INLINE lookupOtherRevIndex #-}
lookupOtherRevIndex :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()
lookupOtherRevIndex :: (HeaderValue, HeaderValue)
-> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()
lookupOtherRevIndex (HeaderValue
k,HeaderValue
v) OtherRevIdex
ref HIndex -> IO ()
fa' IO ()
fc' = do
      Map KeyValue HIndex
oth <- forall a. IORef a -> IO a
readIORef OtherRevIdex
ref
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
fc' HIndex -> IO ()
fa' forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (HeaderValue -> HeaderValue -> KeyValue
KeyValue HeaderValue
k HeaderValue
v) Map KeyValue HIndex
oth

{-# INLINE insertOtherRevIndex #-}
insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()
insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()
insertOtherRevIndex Token
t HeaderValue
v HIndex
i OtherRevIdex
ref = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' OtherRevIdex
ref forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (HeaderValue -> HeaderValue -> KeyValue
KeyValue HeaderValue
k HeaderValue
v) HIndex
i
  where
    k :: HeaderValue
k = Token -> HeaderValue
tokenFoldedKey Token
t

{-# INLINE deleteOtherRevIndex #-}
deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO ()
deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO ()
deleteOtherRevIndex Token
t HeaderValue
v OtherRevIdex
ref = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' OtherRevIdex
ref forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete (HeaderValue -> HeaderValue -> KeyValue
KeyValue HeaderValue
k HeaderValue
v)
  where
    k :: HeaderValue
k = Token -> HeaderValue
tokenFoldedKey Token
t

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

newRevIndex :: IO RevIndex
newRevIndex :: IO RevIndex
newRevIndex = DynamicRevIndex -> OtherRevIdex -> RevIndex
RevIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO DynamicRevIndex
newDynamicRevIndex forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO OtherRevIdex
newOtherRevIndex

renewRevIndex :: RevIndex -> IO ()
renewRevIndex :: RevIndex -> IO ()
renewRevIndex (RevIndex DynamicRevIndex
dyn OtherRevIdex
oth) = do
    DynamicRevIndex -> IO ()
renewDynamicRevIndex DynamicRevIndex
dyn
    OtherRevIdex -> IO ()
renewOtherRevIndex OtherRevIdex
oth

{-# INLINE lookupRevIndex #-}
lookupRevIndex :: Token
               -> HeaderValue
               -> (HIndex -> IO ())
               -> (HeaderValue -> Entry -> HIndex -> IO ())
               -> (HeaderName -> HeaderValue -> Entry -> IO ())
               -> (HeaderValue -> HIndex -> IO ())
               -> RevIndex
               -> IO ()
lookupRevIndex :: Token
-> HeaderValue
-> (HIndex -> IO ())
-> (HeaderValue -> Entry -> HIndex -> IO ())
-> (HeaderValue -> HeaderValue -> Entry -> IO ())
-> (HeaderValue -> HIndex -> IO ())
-> RevIndex
-> IO ()
lookupRevIndex t :: Token
t@Token{Bool
Int
CI HeaderValue
tokenKey :: Token -> CI HeaderValue
isPseudo :: Token -> Bool
shouldBeIndexed :: Token -> Bool
tokenKey :: CI HeaderValue
isPseudo :: Bool
shouldBeIndexed :: Bool
tokenIx :: Int
tokenIx :: Token -> Int
..} HeaderValue
v HIndex -> IO ()
fa HeaderValue -> Entry -> HIndex -> IO ()
fb HeaderValue -> HeaderValue -> Entry -> IO ()
fc HeaderValue -> HIndex -> IO ()
fd (RevIndex DynamicRevIndex
dyn OtherRevIdex
oth)
  | Bool -> Bool
not (Int -> Bool
isStaticTokenIx Int
tokenIx) = (HeaderValue, HeaderValue)
-> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()
lookupOtherRevIndex (HeaderValue
k,HeaderValue
v) OtherRevIdex
oth HIndex -> IO ()
fa' IO ()
fc'
  | Bool
shouldBeIndexed               = Int
-> HeaderValue
-> DynamicRevIndex
-> (HIndex -> IO ())
-> (HIndex -> IO ())
-> IO ()
lookupDynamicStaticRevIndex Int
tokenIx HeaderValue
v DynamicRevIndex
dyn HIndex -> IO ()
fa' HIndex -> IO ()
fb'
  -- path: is not indexed but ":path /" should be used, sigh.
  | Bool
otherwise                     = Int
-> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex Int
tokenIx HeaderValue
v HIndex -> IO ()
fa' HIndex -> IO ()
fd'
  where
    k :: HeaderValue
k = forall s. CI s -> s
foldedCase CI HeaderValue
tokenKey
    ent :: Entry
ent = Token -> HeaderValue -> Entry
toEntryToken Token
t HeaderValue
v
    fa' :: HIndex -> IO ()
fa' = HIndex -> IO ()
fa
    fb' :: HIndex -> IO ()
fb' = HeaderValue -> Entry -> HIndex -> IO ()
fb HeaderValue
v Entry
ent
    fc' :: IO ()
fc' = HeaderValue -> HeaderValue -> Entry -> IO ()
fc HeaderValue
k HeaderValue
v Entry
ent
    fd' :: HIndex -> IO ()
fd' = HeaderValue -> HIndex -> IO ()
fd HeaderValue
v

{-# INLINE lookupRevIndex' #-}
lookupRevIndex' :: Token
                -> HeaderValue
                -> (HIndex -> IO ())
                -> (HeaderValue -> HIndex -> IO ())
                -> (HeaderName -> HeaderValue -> IO ())
                -> IO ()
lookupRevIndex' :: Token
-> HeaderValue
-> (HIndex -> IO ())
-> (HeaderValue -> HIndex -> IO ())
-> (HeaderValue -> HeaderValue -> IO ())
-> IO ()
lookupRevIndex' Token{Bool
Int
CI HeaderValue
tokenKey :: CI HeaderValue
isPseudo :: Bool
shouldBeIndexed :: Bool
tokenIx :: Int
tokenKey :: Token -> CI HeaderValue
isPseudo :: Token -> Bool
shouldBeIndexed :: Token -> Bool
tokenIx :: Token -> Int
..} HeaderValue
v HIndex -> IO ()
fa HeaderValue -> HIndex -> IO ()
fd HeaderValue -> HeaderValue -> IO ()
fe
  | Int -> Bool
isStaticTokenIx Int
tokenIx = Int
-> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex Int
tokenIx HeaderValue
v HIndex -> IO ()
fa' HIndex -> IO ()
fd'
  | Bool
otherwise               = IO ()
fe'
  where
    k :: HeaderValue
k = forall s. CI s -> s
foldedCase CI HeaderValue
tokenKey
    fa' :: HIndex -> IO ()
fa' = HIndex -> IO ()
fa
    fd' :: HIndex -> IO ()
fd' = HeaderValue -> HIndex -> IO ()
fd HeaderValue
v
    fe' :: IO ()
fe' = HeaderValue -> HeaderValue -> IO ()
fe HeaderValue
k HeaderValue
v

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

{-# INLINE insertRevIndex #-}
insertRevIndex :: Entry -> HIndex -> RevIndex -> IO ()
insertRevIndex :: Entry -> HIndex -> RevIndex -> IO ()
insertRevIndex (Entry Int
_ Token
t HeaderValue
v) HIndex
i (RevIndex DynamicRevIndex
dyn OtherRevIdex
oth)
  | Token -> Bool
isStaticToken Token
t = Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()
insertDynamicRevIndex Token
t HeaderValue
v HIndex
i DynamicRevIndex
dyn
  | Bool
otherwise       = Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()
insertOtherRevIndex   Token
t HeaderValue
v HIndex
i OtherRevIdex
oth

{-# INLINE deleteRevIndex #-}
deleteRevIndex :: RevIndex -> Entry -> IO ()
deleteRevIndex :: RevIndex -> Entry -> IO ()
deleteRevIndex (RevIndex DynamicRevIndex
dyn OtherRevIdex
oth) (Entry Int
_ Token
t HeaderValue
v)
  | Token -> Bool
isStaticToken Token
t = Token -> HeaderValue -> DynamicRevIndex -> IO ()
deleteDynamicRevIndex Token
t HeaderValue
v DynamicRevIndex
dyn
  | Bool
otherwise       = Token -> HeaderValue -> OtherRevIdex -> IO ()
deleteOtherRevIndex   Token
t HeaderValue
v OtherRevIdex
oth

{-# INLINE deleteRevIndexList #-}
deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
deleteRevIndexList [Entry]
es RevIndex
rev = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RevIndex -> Entry -> IO ()
deleteRevIndex RevIndex
rev) [Entry]
es