module Network.HPACK.HeaderBlock.To (
toHeaderBlock
) where
import Network.HPACK.Builder
import Network.HPACK.HeaderBlock.HeaderField
import Network.HPACK.Table
import Network.HPACK.Types
type Ctx = (DynamicTable, Builder HeaderField)
type Step = Ctx -> Header -> IO Ctx
toHeaderBlock :: CompressionAlgo
-> DynamicTable
-> HeaderList
-> IO (DynamicTable, HeaderBlock)
toHeaderBlock Naive !hdrtbl hs = encodeLoop naiveStep hs (hdrtbl,empty)
toHeaderBlock Static !hdrtbl hs = encodeLoop staticStep hs (hdrtbl,empty)
toHeaderBlock Linear !hdrtbl hs = encodeLoop linearStep hs (hdrtbl,empty)
encodeFinal :: Ctx -> IO (DynamicTable, HeaderBlock)
encodeFinal (!hdrtbl, !builder) = return (hdrtbl, run builder)
encodeLoop :: Step
-> HeaderList
-> Ctx
-> IO (DynamicTable, HeaderBlock)
encodeLoop step (h:hs) !hdrtbl = step hdrtbl h >>= encodeLoop step hs
encodeLoop _ [] !hdrtbl = encodeFinal hdrtbl
naiveStep :: Step
naiveStep (!hdrtbl,!builder) (k,v) = do
let builder' = builder << Literal NotAdd (Lit k) v
return (hdrtbl, builder')
staticStep :: Step
staticStep (!hdrtbl,!builder) h@(k,v) = return (hdrtbl, builder')
where
b = case lookupTable h hdrtbl of
None -> Literal NotAdd (Lit k) v
KeyOnly InStaticTable i -> Literal NotAdd (Idx i) v
KeyOnly InDynamicTable _ -> Literal NotAdd (Lit k) v
KeyValue InStaticTable i -> Literal NotAdd (Idx i) v
KeyValue InDynamicTable _ -> Literal NotAdd (Lit k) v
builder' = builder << b
linearStep :: Step
linearStep cb@(!hdrtbl,!builder) h = smartStep linear cb h
where
linear i = return (hdrtbl,builder << Indexed i)
smartStep :: (Index -> IO Ctx) -> Step
smartStep func cb@(!hdrtbl,!builder) h@(k,_) = do
let cache = lookupTable h hdrtbl
case cache of
None -> check cb h (Lit k)
KeyOnly InStaticTable i -> check cb h (Idx i)
KeyOnly InDynamicTable i -> check cb h (Idx i)
KeyValue InStaticTable i -> return (hdrtbl, builder << Indexed i)
KeyValue InDynamicTable i -> func i
check :: Ctx -> Header -> Naming -> IO Ctx
check (hdrtbl,builder) h@(k,v) x
| k `elem` headersNotToIndex = do
let builder' = builder << Literal NotAdd x v
return (hdrtbl, builder')
| otherwise = do
let e = toEntry h
hdrtbl' <- insertEntry e hdrtbl
let builder' = builder << Literal Add x v
return (hdrtbl', builder')
headersNotToIndex :: [HeaderName]
headersNotToIndex = [
":path"
, "content-length"
, "location"
, "etag"
, "set-cookie"
]