module Network.HPACK.Table.RevIndex (
RevIndex
, newRevIndex
, renewRevIndex
, lookupRevIndex
, insertRevIndex
, deleteRevIndexList
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>), (<*>))
#endif
import Data.Array (Array, (!))
import qualified Data.Array as A
import qualified Data.Array.IO as IOA
import Data.Array.Unboxed (UArray)
import qualified Data.Array.Unboxed as U
import qualified Data.Array.Unsafe as Unsafe
import Data.Function (on)
import Data.IORef
import Data.List (groupBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Network.HPACK.Table.Entry
import Network.HPACK.Table.Static
import Network.HPACK.Table.Token
import Network.HPACK.Types
import System.IO.Unsafe
data RevIndex = RevIndex !DynamicRevIndex !OtherRevIdex
type DynamicRevIndex = Array Token (IORef ValueMap)
type OtherRevIdex = IORef (Map (HeaderName,HeaderValue) HIndex)
type StaticRevIndex = Array Token StaticEntry
data StaticEntry = StaticEntry !HIndex !(Maybe ValueMap)
type ValueMap = Map HeaderValue HIndex
beg :: Token
beg = minBound
end :: Token
end = toEnum (fromEnum (maxBound :: Token) 1)
staticRevIndex :: StaticRevIndex
staticRevIndex = A.array (minBound, end) $ map toEnt zs
where
toEnt (k,xs) = (toToken k, m)
where
m = case xs of
[] -> error "staticRevIndex"
[(_,i)] -> StaticEntry i Nothing
(_,i):_ -> let !vs = M.fromList xs
in StaticEntry i (Just vs)
zs = map extract $ groupBy ((==) `on` fst) lst
where
lst = zipWith (\(k,v) i -> (k,(v,i))) staticTableList $ map SIndex [1..]
extract xs = (fst (head xs), map snd xs)
lookupStaticRevIndex :: Token -> (HIndex -> IO ()) -> IO ()
lookupStaticRevIndex t fd' = case staticRevIndex ! t of
StaticEntry i _ -> fd' i
newDynamicRevIndex :: IO DynamicRevIndex
newDynamicRevIndex = A.listArray (beg,end) <$> mapM mk lst
where
mk _ = newIORef M.empty
lst = [beg..end]
renewDynamicRevIndex :: DynamicRevIndex -> IO ()
renewDynamicRevIndex drev = mapM_ clear [beg..end]
where
clear t = writeIORef (drev ! t) M.empty
lookupDynamicStaticRevIndex :: Token -> HeaderValue -> DynamicRevIndex
-> (HIndex -> IO ())
-> (HIndex -> IO ())
-> IO ()
lookupDynamicStaticRevIndex t v drev fa' fbd' = do
let ref = drev ! t
m <- readIORef ref
case M.lookup v m of
Just i -> fa' i
Nothing -> case staticRevIndex ! t of
StaticEntry i Nothing -> fbd' i
StaticEntry i (Just m') -> case M.lookup v m' of
Nothing -> fbd' i
Just j -> fa' j
insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()
insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i
where
ref = drev ! t
deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO ()
deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v
where
ref = drev ! t
newOtherRevIndex :: IO OtherRevIdex
newOtherRevIndex = newIORef M.empty
renewOtherRevIndex :: OtherRevIdex -> IO ()
renewOtherRevIndex ref = writeIORef ref M.empty
lookupOtherRevIndex :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()
lookupOtherRevIndex h ref fa' fc' = do
oth <- readIORef ref
case M.lookup h oth of
Just i -> fa' i
Nothing -> fc'
insertOtherRevIndex :: HeaderName -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()
insertOtherRevIndex k v i ref = modifyIORef' ref $ M.insert (k,v) i
deleteOtherRevIndex :: HeaderName -> HeaderValue -> OtherRevIdex -> IO ()
deleteOtherRevIndex k v ref = modifyIORef' ref $ M.delete (k,v)
newRevIndex :: IO RevIndex
newRevIndex = RevIndex <$> newDynamicRevIndex <*> newOtherRevIndex
renewRevIndex :: RevIndex -> IO ()
renewRevIndex (RevIndex dyn oth) = do
renewDynamicRevIndex dyn
renewOtherRevIndex oth
lookupRevIndex :: Header
-> (HIndex -> IO ())
-> (HeaderValue -> Entry -> HIndex -> IO ())
-> (HeaderName -> HeaderValue -> Entry -> IO ())
-> (HeaderValue -> Entry -> HIndex -> IO ())
-> RevIndex
-> IO ()
lookupRevIndex h@(k,v) fa fb fc fd (RevIndex dyn oth)
| t == TOTHER = lookupOtherRevIndex h oth fa' fc'
| shouldBeIndexed t = lookupDynamicStaticRevIndex t v dyn fa' fb'
| otherwise = lookupStaticRevIndex t fd'
where
ent@(Entry _ t _) = toEntryToken h
fa' = fa
fb' = fb v ent
fc' = fc k v ent
fd' = fd v ent
insertRevIndex :: Entry -> HIndex -> RevIndex -> IO ()
insertRevIndex (Entry _ t (k,v)) i (RevIndex dyn oth)
| t == TOTHER = insertOtherRevIndex k v i oth
| otherwise = insertDynamicRevIndex t v i dyn
deleteRevIndex :: RevIndex -> Entry -> IO ()
deleteRevIndex (RevIndex dyn oth) (Entry _ t (k,v))
| t == TOTHER = deleteOtherRevIndex k v oth
| otherwise = deleteDynamicRevIndex t v dyn
deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
deleteRevIndexList es rev = mapM_ (deleteRevIndex rev) es
headersNotToIndex :: [HeaderName]
headersNotToIndex = [
":path"
, "content-length"
, "location"
, "etag"
, "set-cookie"
]
indexedOrNot :: UArray Int Bool
indexedOrNot = unsafePerformIO $ do
arr <- IOA.newArray (ib,ie) True :: IO (IOA.IOUArray Int Bool)
mapM_ (toFalse arr) $ map (fromEnum . toToken) headersNotToIndex
Unsafe.unsafeFreeze arr
where
ib = fromEnum (minBound :: Token)
ie = fromEnum (maxBound :: Token)
toFalse :: IOA.IOUArray Int Bool -> Int -> IO ()
toFalse arr i = IOA.writeArray arr i False
shouldBeIndexed :: Token -> Bool
shouldBeIndexed t = indexedOrNot U.! fromEnum t