content: {-# 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.Function (on)
  import Data.IORef
  import Data.List.NonEmpty (NonEmpty (..))
  import qualified Data.List.NonEmpty as NE
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as M
  import Network.HTTP.Semantics
  
  import Imports
  import Network.HPACK.Table.Entry
  import Network.HPACK.Table.Static
  import Network.HPACK.Types
  
  ----------------------------------------------------------------
  
  data RevIndex = RevIndex DynamicRevIndex OtherRevIdex
  
  type DynamicRevIndex = Array Int (IORef ValueMap)
  
  data KeyValue = KeyValue FieldName FieldValue deriving (Eq, 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 (Show)
  
  type ValueMap = Map FieldValue HIndex
  
  ----------------------------------------------------------------
  
  staticRevIndex :: StaticRevIndex
  staticRevIndex = A.array (minTokenIx, maxStaticTokenIx) $ map toEnt zs
    where
      toEnt (k, xs) = (tokenIx $ toToken $ foldedCase k, m)
        where
          m = case xs of
              ("", i) :| [] -> StaticEntry i Nothing
              (_, i) :| _ ->
                  let vs = M.fromList $ NE.toList xs
                   in StaticEntry i (Just vs)
      zs = map extract $ NE.groupBy ((==) `on` fst) lst
        where
          lst = zipWith (\(k, v) i -> (k, (v, i))) staticTableList $ map SIndex [1 ..]
  
          extract xs = (fst (NE.head xs), NE.map snd xs)
  
  {-# INLINE lookupStaticRevIndex #-}
  lookupStaticRevIndex
      :: Int -> FieldValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()
  lookupStaticRevIndex ix v fa' fbd' = case staticRevIndex `unsafeAt` ix of
      StaticEntry i Nothing -> fbd' i
      StaticEntry i (Just m) -> case M.lookup v m of
          Nothing -> fbd' i
          Just j -> fa' j
  
  ----------------------------------------------------------------
  
  newDynamicRevIndex :: IO DynamicRevIndex
  newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk' lst
    where
      mk' _ = newIORef M.empty
      lst = [minTokenIx .. maxStaticTokenIx]
  
  renewDynamicRevIndex :: DynamicRevIndex -> IO ()
  renewDynamicRevIndex drev = mapM_ clear [minTokenIx .. maxStaticTokenIx]
    where
      clear t = writeIORef (drev `unsafeAt` t) M.empty
  
  {-# INLINE lookupDynamicStaticRevIndex #-}
  lookupDynamicStaticRevIndex
      :: Int
      -> FieldValue
      -> DynamicRevIndex
      -> (HIndex -> IO ())
      -> (HIndex -> IO ())
      -> IO ()
  lookupDynamicStaticRevIndex ix v drev fa' fbd' = do
      let ref = drev `unsafeAt` ix
      m <- readIORef ref
      case M.lookup v m of
          Just i -> fa' i
          Nothing -> lookupStaticRevIndex ix v fa' fbd'
  
  {-# INLINE insertDynamicRevIndex #-}
  insertDynamicRevIndex
      :: Token -> FieldValue -> HIndex -> DynamicRevIndex -> IO ()
  insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i
    where
      ref = drev `unsafeAt` tokenIx t
  
  {-# INLINE deleteDynamicRevIndex #-}
  deleteDynamicRevIndex :: Token -> FieldValue -> DynamicRevIndex -> IO ()
  deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v
    where
      ref = drev `unsafeAt` tokenIx t
  
  ----------------------------------------------------------------
  
  newOtherRevIndex :: IO OtherRevIdex
  newOtherRevIndex = newIORef M.empty
  
  renewOtherRevIndex :: OtherRevIdex -> IO ()
  renewOtherRevIndex ref = writeIORef ref M.empty
  
  {-# INLINE lookupOtherRevIndex #-}
  lookupOtherRevIndex
      :: (FieldName, FieldValue) -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()
  lookupOtherRevIndex (k, v) ref fa' fc' = do
      oth <- readIORef ref
      maybe fc' fa' $ M.lookup (KeyValue k v) oth
  
  {-# INLINE insertOtherRevIndex #-}
  insertOtherRevIndex :: Token -> FieldValue -> HIndex -> OtherRevIdex -> IO ()
  insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i
    where
      k = tokenFoldedKey t
  
  {-# INLINE deleteOtherRevIndex #-}
  deleteOtherRevIndex :: Token -> FieldValue -> OtherRevIdex -> IO ()
  deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v)
    where
      k = tokenFoldedKey t
  
  ----------------------------------------------------------------
  
  newRevIndex :: IO RevIndex
  newRevIndex = RevIndex <$> newDynamicRevIndex <*> newOtherRevIndex
  
  renewRevIndex :: RevIndex -> IO ()
  renewRevIndex (RevIndex dyn oth) = do
      renewDynamicRevIndex dyn
      renewOtherRevIndex oth
  
  {-# INLINE lookupRevIndex #-}
  lookupRevIndex
      :: Token
      -> FieldValue
      -> (HIndex -> IO ())
      -> (FieldValue -> Entry -> HIndex -> IO ())
      -> (FieldName -> FieldValue -> Entry -> IO ())
      -> (FieldValue -> HIndex -> IO ())
      -> RevIndex
      -> IO ()
  lookupRevIndex t@Token{..} v fa fb fc fd (RevIndex dyn oth)
      | not (isStaticTokenIx tokenIx) = lookupOtherRevIndex (k, v) oth fa' fc'
      | shouldBeIndexed =
          lookupDynamicStaticRevIndex tokenIx v dyn fa' fb'
      -- path: is not indexed but ":path /" should be used, sigh.
      | otherwise = lookupStaticRevIndex tokenIx v fa' fd'
    where
      k = foldedCase tokenKey
      ent = toEntryToken t v
      fa' = fa
      fb' = fb v ent
      fc' = fc k v ent
      fd' = fd v
  
  {-# INLINE lookupRevIndex' #-}
  lookupRevIndex'
      :: Token
      -> FieldValue
      -> (HIndex -> IO ())
      -> (FieldValue -> HIndex -> IO ())
      -> (FieldName -> FieldValue -> IO ())
      -> IO ()
  lookupRevIndex' Token{..} v fa fd fe
      | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'
      | otherwise = fe'
    where
      k = foldedCase tokenKey
      fa' = fa
      fd' = fd v
      fe' = fe k v
  
  ----------------------------------------------------------------
  
  {-# INLINE insertRevIndex #-}
  insertRevIndex :: Entry -> HIndex -> RevIndex -> IO ()
  insertRevIndex (Entry _ t v) i (RevIndex dyn oth)
      | isStaticToken t = insertDynamicRevIndex t v i dyn
      | otherwise = insertOtherRevIndex t v i oth
  
  {-# INLINE deleteRevIndex #-}
  deleteRevIndex :: RevIndex -> Entry -> IO ()
  deleteRevIndex (RevIndex dyn oth) (Entry _ t v)
      | isStaticToken t = deleteDynamicRevIndex t v dyn
      | otherwise = deleteOtherRevIndex t v oth
  
  {-# INLINE deleteRevIndexList #-}
  deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
  deleteRevIndexList es rev = mapM_ (deleteRevIndex rev) es
  