diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -5,10 +5,10 @@ , HPACKDecoding , encodeHeader , decodeHeader - -- * Contenxt - , Context - , newContextForEncoding - , newContextForDecoding + -- * DynamicTable + , DynamicTable + , newDynamicTableForEncoding + , newDynamicTableForDecoding -- * Strategy for encoding , CompressionAlgo(..) , EncodeStrategy(..) @@ -29,18 +29,17 @@ import Control.Applicative ((<$>)) import Control.Arrow (second) import Control.Exception (throwIO) -import Network.HPACK.Context (Context, newContextForEncoding, newContextForDecoding, HeaderList) import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteStream, fromByteStream) -import Network.HPACK.Table (Size) +import Network.HPACK.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding) import Network.HPACK.Types ---------------------------------------------------------------- -- | HPACK encoding, from 'HeaderList' to 'ByteStream'. -type HPACKEncoding = Context -> HeaderList -> IO (Context, ByteStream) +type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteStream) -- | HPACK decoding, from 'ByteStream' to 'HeaderList'. -type HPACKDecoding = Context -> ByteStream -> IO (Context, HeaderList) +type HPACKDecoding = DynamicTable -> ByteStream -> IO (DynamicTable, HeaderList) ---------------------------------------------------------------- diff --git a/Network/HPACK/Context.hs b/Network/HPACK/Context.hs deleted file mode 100644 --- a/Network/HPACK/Context.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Network.HPACK.Context ( - -- * Types - HeaderList -- re-exporting - , Context - , DecodeError(..) - -- * Context - , newContextForEncoding - , newContextForDecoding - , changeContextForDecoding - , printContext - , isContextTableEmpty - -- * Processing - , newEntryForEncoding - , newEntryForDecoding - -- * Auxiliary functions - , getEntry - -- * Table - , whichTable - , lookupHeader - ) where - -import Control.Applicative ((<$>)) -import Network.HPACK.Context.HeaderList -import Network.HPACK.Table -import Network.HPACK.Types - ----------------------------------------------------------------- - --- | Context for HPACK encoding/decoding. --- This is destructive! -data Context = Context { - headerTable :: !HeaderTable -- ^ A cache of headers - } - --- | Printing 'Context' -printContext :: Context -> IO () -printContext (Context hdrtbl) = do - putStrLn "<<
>>" - printHeaderTable hdrtbl - putStr "\n" - ----------------------------------------------------------------- - --- | Creating a new 'Context'. --- The first argument is the size of a header table. -newContextForEncoding :: Size -> IO Context -newContextForEncoding maxsiz = Context <$> newHeaderTableForEncoding maxsiz - --- | Creating a new 'Context'. --- The first argument is the size of a header table. -newContextForDecoding :: Size -> IO Context -newContextForDecoding maxsiz = Context <$> newHeaderTableForDecoding maxsiz - --- | Changing the size of Header Table in 'Context'. -changeContextForDecoding :: Context -> Size -> IO Context -changeContextForDecoding ctx@(Context hdrtbl) siz - | shouldRenew hdrtbl siz = Context <$> renewHeaderTable siz hdrtbl - | otherwise = return ctx - ----------------------------------------------------------------- - -isContextTableEmpty :: Context -> Bool -isContextTableEmpty (Context hdrtbl) = isHeaderTableEmpty hdrtbl - ----------------------------------------------------------------- - --- | The header field is inserted at the beginning of the header table. --- A reference to the new entry is added to the reference set. -newEntryForEncoding :: Context -> Entry -> IO Context -newEntryForEncoding (Context hdrtbl) e = Context <$> insertEntry e hdrtbl - --- | The header field is inserted at the beginning of the header table. --- A reference to the new entry is added to the reference set. -newEntryForDecoding :: Context -> Entry -> IO Context -newEntryForDecoding (Context hdrtbl) e = Context <$> insertEntry e hdrtbl - ----------------------------------------------------------------- - --- | Which table does 'Index' refer to? -whichTable :: Index -> Context -> IO (WhichTable, Entry) -whichTable idx ctx = which hdrtbl idx - where - hdrtbl = headerTable ctx - --- | Which table contains 'Header'? -lookupHeader :: Header -> Context -> HeaderCache -lookupHeader h ctx = lookupTable h (headerTable ctx) - ----------------------------------------------------------------- - --- | Getting 'Entry' by 'Index'. -getEntry :: Index -> Context -> IO Entry -getEntry idx ctx = snd <$> whichTable idx ctx diff --git a/Network/HPACK/Context/HeaderList.hs b/Network/HPACK/Context/HeaderList.hs deleted file mode 100644 --- a/Network/HPACK/Context/HeaderList.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.HPACK.Context.HeaderList where - -import qualified Data.ByteString.Char8 as BS -import Network.HPACK.Table - --- | Header list. -type HeaderList = [Header] - --- | Printing 'HeaderList'. -printHeaderList :: HeaderList -> IO () -printHeaderList hs = mapM_ printHeader hs - where - printHeader (k,v) = do - BS.putStr k - putStr ": " - BS.putStr v - putStr "\n" diff --git a/Network/HPACK/HeaderBlock/From.hs b/Network/HPACK/HeaderBlock/From.hs --- a/Network/HPACK/HeaderBlock/From.hs +++ b/Network/HPACK/HeaderBlock/From.hs @@ -7,66 +7,65 @@ import Control.Applicative ((<$>)) import Network.HPACK.Builder -import Network.HPACK.Context import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table +import Network.HPACK.Types ---------------------------------------------------------------- -type Ctx = (Context, Builder Header) +type Ctx = (DynamicTable, Builder Header) type Step = Ctx -> HeaderField -> IO Ctx -- | Decoding 'HeaderBlock' to 'HeaderList'. -fromHeaderBlock :: Context +fromHeaderBlock :: DynamicTable -> HeaderBlock - -> IO (Context, HeaderList) -fromHeaderBlock !ctx rs = decodeLoop rs (ctx,empty) + -> IO (DynamicTable, HeaderList) +fromHeaderBlock !hdrtbl rs = decodeLoop rs (hdrtbl,empty) ---------------------------------------------------------------- -decodeLoop :: HeaderBlock -> Ctx -> IO (Context, HeaderList) -decodeLoop (r:rs) !ctx = decodeStep ctx r >>= decodeLoop rs -decodeLoop [] !ctx = decodeFinal ctx +decodeLoop :: HeaderBlock -> Ctx -> IO (DynamicTable, HeaderList) +decodeLoop (r:rs) !hdrtbl = decodeStep hdrtbl r >>= decodeLoop rs +decodeLoop [] !hdrtbl = decodeFinal hdrtbl ---------------------------------------------------------------- -- | Decoding step for one 'HeaderField'. Exporting for the -- test purpose. decodeStep :: Step -decodeStep (!ctx,!builder) (ChangeTableSize siz) = do - ctx' <- changeContextForDecoding ctx siz - return (ctx',builder) -decodeStep (!ctx,!builder) (Indexed idx) = do - w <- whichTable idx ctx +decodeStep (!hdrtbl,!builder) (ChangeTableSize siz) = do + hdrtbl' <- renewDynamicTable siz hdrtbl + return (hdrtbl',builder) +decodeStep (!hdrtbl,!builder) (Indexed idx) = do + w <- which hdrtbl idx case w of (InStaticTable, e) -> do let b = builder << fromEntry e - return (ctx,b) - (InHeaderTable, e) -> do - let c = ctx - b = builder << fromEntry e - return (c,b) -decodeStep (!ctx,!builder) (Literal NotAdd naming v) = do - k <- fromNaming naming ctx + return (hdrtbl,b) + (InDynamicTable, e) -> do + let b = builder << fromEntry e + return (hdrtbl,b) +decodeStep (!hdrtbl,!builder) (Literal NotAdd naming v) = do + k <- fromNaming naming hdrtbl let b = builder << (k,v) - return (ctx, b) -decodeStep (!ctx,!builder) (Literal Never naming v) = do - k <- fromNaming naming ctx + return (hdrtbl, b) +decodeStep (!hdrtbl,!builder) (Literal Never naming v) = do + k <- fromNaming naming hdrtbl let b = builder << (k,v) - return (ctx, b) -decodeStep (!ctx,!builder) (Literal Add naming v) = do - k <- fromNaming naming ctx + return (hdrtbl, b) +decodeStep (!hdrtbl,!builder) (Literal Add naming v) = do + k <- fromNaming naming hdrtbl let h = (k,v) e = toEntry (k,v) b = builder << h - c <- newEntryForDecoding ctx e - return (c,b) + hdrtbl' <- insertEntry e hdrtbl + return (hdrtbl',b) -decodeFinal :: Ctx -> IO (Context, HeaderList) -decodeFinal (!ctx, !builder) = return (ctx, run builder) +decodeFinal :: Ctx -> IO (DynamicTable, HeaderList) +decodeFinal (!hdrtbl, !builder) = return (hdrtbl, run builder) ---------------------------------------------------------------- -fromNaming :: Naming -> Context -> IO HeaderName +fromNaming :: Naming -> DynamicTable -> IO HeaderName fromNaming (Lit k) _ = return k -fromNaming (Idx idx) ctx = entryHeaderName <$> getEntry idx ctx +fromNaming (Idx idx) hdrtbl = entryHeaderName . snd <$> which hdrtbl idx diff --git a/Network/HPACK/HeaderBlock/To.hs b/Network/HPACK/HeaderBlock/To.hs --- a/Network/HPACK/HeaderBlock/To.hs +++ b/Network/HPACK/HeaderBlock/To.hs @@ -5,53 +5,52 @@ ) where import Network.HPACK.Builder -import Network.HPACK.Context import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table import Network.HPACK.Types -type Ctx = (Context, Builder HeaderField) +type Ctx = (DynamicTable, Builder HeaderField) type Step = Ctx -> Header -> IO Ctx -- | Encoding 'HeaderList' to 'HeaderBlock'. toHeaderBlock :: CompressionAlgo - -> Context + -> DynamicTable -> HeaderList - -> IO (Context, HeaderBlock) -toHeaderBlock Naive !ctx hs = encodeLoop naiveStep hs (ctx,empty) -toHeaderBlock Static !ctx hs = encodeLoop staticStep hs (ctx,empty) -toHeaderBlock Linear !ctx hs = encodeLoop linearStep hs (ctx,empty) + -> 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 (Context, HeaderBlock) -encodeFinal (!ctx, !builder) = return (ctx, run builder) +encodeFinal :: Ctx -> IO (DynamicTable, HeaderBlock) +encodeFinal (!hdrtbl, !builder) = return (hdrtbl, run builder) encodeLoop :: Step -> HeaderList -> Ctx - -> IO (Context, HeaderBlock) -encodeLoop step (h:hs) !ctx = step ctx h >>= encodeLoop step hs -encodeLoop _ [] !ctx = encodeFinal ctx + -> IO (DynamicTable, HeaderBlock) +encodeLoop step (h:hs) !hdrtbl = step hdrtbl h >>= encodeLoop step hs +encodeLoop _ [] !hdrtbl = encodeFinal hdrtbl ---------------------------------------------------------------- naiveStep :: Step -naiveStep (!ctx,!builder) (k,v) = do +naiveStep (!hdrtbl,!builder) (k,v) = do let builder' = builder << Literal NotAdd (Lit k) v - return (ctx, builder') + return (hdrtbl, builder') ---------------------------------------------------------------- staticStep :: Step -staticStep (!ctx,!builder) h@(k,v) = return (ctx, builder') +staticStep (!hdrtbl,!builder) h@(k,v) = return (hdrtbl, builder') where - b = case lookupHeader h ctx of + b = case lookupTable h hdrtbl of None -> Literal NotAdd (Lit k) v KeyOnly InStaticTable i -> Literal NotAdd (Idx i) v - KeyOnly InHeaderTable _ -> Literal NotAdd (Lit k) v + KeyOnly InDynamicTable _ -> Literal NotAdd (Lit k) v KeyValue InStaticTable i -> Literal NotAdd (Idx i) v - KeyValue InHeaderTable _ -> Literal NotAdd (Lit k) v + KeyValue InDynamicTable _ -> Literal NotAdd (Lit k) v builder' = builder << b ---------------------------------------------------------------- @@ -59,32 +58,32 @@ -- by 'Index 0' and uses indexing as much as possible. linearStep :: Step -linearStep cb@(!ctx,!builder) h = smartStep linear cb h +linearStep cb@(!hdrtbl,!builder) h = smartStep linear cb h where - linear i = return (ctx,builder << Indexed i) + linear i = return (hdrtbl,builder << Indexed i) ---------------------------------------------------------------- smartStep :: (Index -> IO Ctx) -> Step -smartStep func cb@(!ctx,!builder) h@(k,_) = do - let cache = lookupHeader h ctx +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 InHeaderTable i -> check cb h (Idx i) - KeyValue InStaticTable i -> return (ctx, builder << Indexed i) - KeyValue InHeaderTable i -> func i + 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 (ctx,builder) h@(k,v) x +check (hdrtbl,builder) h@(k,v) x | k `elem` headersNotToIndex = do let builder' = builder << Literal NotAdd x v - return (ctx, builder') + return (hdrtbl, builder') | otherwise = do let e = toEntry h - ctx' <- newEntryForEncoding ctx e + hdrtbl' <- insertEntry e hdrtbl let builder' = builder << Literal Add x v - return (ctx', builder') + return (hdrtbl', builder') headersNotToIndex :: [HeaderName] headersNotToIndex = [ diff --git a/Network/HPACK/Table.hs b/Network/HPACK/Table.hs --- a/Network/HPACK/Table.hs +++ b/Network/HPACK/Table.hs @@ -1,14 +1,13 @@ {-# LANGUAGE TupleSections, RecordWildCards #-} module Network.HPACK.Table ( - -- * Header table - HeaderTable - , newHeaderTableForEncoding - , newHeaderTableForDecoding - , shouldRenew - , renewHeaderTable - , printHeaderTable - , isHeaderTableEmpty + -- * dynamic table + DynamicTable + , newDynamicTableForEncoding + , newDynamicTableForDecoding + , renewDynamicTable + , printDynamicTable + , isDynamicTableEmpty -- * Insertion , insertEntry -- * Header to index @@ -23,93 +22,16 @@ import Control.Applicative ((<$>)) import Control.Exception (throwIO) -import Data.Array.IO (IOArray, newArray, readArray, writeArray) -import qualified Data.ByteString.Char8 as BS +import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry import qualified Network.HPACK.Table.HashPSQ as HP import Network.HPACK.Table.Static import Network.HPACK.Types -import Control.Monad (forM) ---------------------------------------------------------------- -type Table = IOArray Index Entry - -{- - offset - v - +-+-+-+-+-+-+-+-+ - | | | |z|y|x| | | - +-+-+-+-+-+-+-+-+ - 1 2 3 (numOfEntries = 3) - -After insertion: - - offset - v - +-+-+-+-+-+-+-+-+ - | | |w|z|y|x| | | - +-+-+-+-+-+-+-+-+ - 1 2 3 4 (numOfEntries = 4) --} - --- | Type for header table. -data HeaderTable = HeaderTable { - -- | An array - circularTable :: !Table - -- | Start point - , offset :: !Index - -- | The current number of entries - , numOfEntries :: !Int - -- | The size of the array - , maxNumOfEntries :: !Int - -- | The current header table size (defined in HPACK) - , headerTableSize :: !Size - -- | The max header table size (defined in HPACK) - , maxHeaderTableSize :: !Size - -- | Header to the index in Header Table for encoder. - -- Static Table is not included. - -- Nothing for decoder. - , reverseIndex :: Maybe (HP.HashPSQ HIndex) - } - -adj :: Int -> Int -> Int -adj maxN x = (x + maxN) `mod` maxN - ----------------------------------------------------------------- - --- | Printing 'HeaderTable'. -printHeaderTable :: HeaderTable -> IO () -printHeaderTable HeaderTable{..} = do - es <- mapM (readArray circularTable . adj maxNumOfEntries) [beg .. end] - let ts = zip [1..] es - mapM_ printEntry ts - putStrLn $ " Table size: " ++ show headerTableSize ++ "/" ++ show maxHeaderTableSize - print reverseIndex - where - beg = offset + 1 - end = offset + numOfEntries - -printEntry :: (Index,Entry) -> IO () -printEntry (i,e) = do - putStr "[ " - putStr $ show i - putStr "] (s = " - putStr $ show $ entrySize e - putStr ") " - BS.putStr $ entryHeaderName e - putStr ": " - BS.putStrLn $ entryHeaderValue e - ----------------------------------------------------------------- - -isHeaderTableEmpty :: HeaderTable -> Bool -isHeaderTableEmpty hdrtbl = numOfEntries hdrtbl == 0 - ----------------------------------------------------------------- - -- | Which table does `Index` refer to? -data WhichTable = InHeaderTable | InStaticTable deriving (Eq,Show) +data WhichTable = InDynamicTable | InStaticTable deriving (Eq,Show) -- | Is header key-value stored in the tables? data HeaderCache = None @@ -118,164 +40,9 @@ ---------------------------------------------------------------- --- Physical array index for Header Table. -newtype HIndex = HIndex Int deriving (Eq, Ord, Show) - ----------------------------------------------------------------- - -fromHIndexToIndex :: HeaderTable -> HIndex -> Index -fromHIndexToIndex HeaderTable{..} (HIndex hidx) = idx - where - idx = adj maxNumOfEntries (hidx - offset) + staticTableSize - -fromIndexToHIndex :: HeaderTable -> Index -> HIndex -fromIndexToHIndex HeaderTable{..} idx = HIndex hidx - where - hidx = adj maxNumOfEntries (idx + offset - staticTableSize) - -fromSIndexToIndex :: HeaderTable -> SIndex -> Index -fromSIndexToIndex _ sidx = fromStaticIndex sidx - -fromIndexToSIndex :: HeaderTable -> Index -> SIndex -fromIndexToSIndex _ idx = toStaticIndex idx - ----------------------------------------------------------------- - --- | Creating 'HeaderTable'. --- The default maxHeaderTableSize is 4096 bytes, --- an array has 128 entries, resulting 1024 bytes in 64bit machine -newHeaderTableForEncoding :: Size -> IO HeaderTable -newHeaderTableForEncoding maxsiz = newHeaderTable maxsiz (Just HP.empty) - --- | Creating 'HeaderTable'. --- The default maxHeaderTableSize is 4096 bytes, --- an array has 128 entries, resulting 1024 bytes in 64bit machine -newHeaderTableForDecoding :: Size -> IO HeaderTable -newHeaderTableForDecoding maxsiz = newHeaderTable maxsiz Nothing - -newHeaderTable :: Size -> Maybe (HP.HashPSQ HIndex) -> IO HeaderTable -newHeaderTable maxsiz mhp = do - tbl <- newArray (0,end) dummyEntry - return HeaderTable { - maxNumOfEntries = maxN - , offset = end - , numOfEntries = 0 - , circularTable = tbl - , headerTableSize = 0 - , maxHeaderTableSize = maxsiz - , reverseIndex = mhp - } - where - maxN = maxNumbers maxsiz - end = maxN - 1 - --- | Renewing 'HeaderTable' with necessary entries copied. -renewHeaderTable :: Size -> HeaderTable -> IO HeaderTable -renewHeaderTable maxsiz oldhdrtbl = - newHeaderTable maxsiz mhp >>= copyTable oldhdrtbl - where - mhp = case reverseIndex oldhdrtbl of - Nothing -> Nothing - _ -> Just HP.empty - -copyTable :: HeaderTable -> HeaderTable -> IO HeaderTable -copyTable oldhdrtbl newhdrtbl = getEntries oldhdrtbl >>= copyEntries newhdrtbl - -getEntries :: HeaderTable -> IO [Entry] -getEntries HeaderTable{..} = forM [1 .. numOfEntries] readTable - where - readTable i = readArray circularTable $ adj maxNumOfEntries (offset + i) - -copyEntries :: HeaderTable -> [Entry] -> IO HeaderTable -copyEntries hdrtbl [] = return hdrtbl -copyEntries hdrtbl@HeaderTable{..} (e:es) - | headerTableSize + entrySize e <= maxHeaderTableSize = do - hdrtbl' <- insertEnd e hdrtbl - copyEntries hdrtbl' es - | otherwise = return hdrtbl - --- | Is the size of 'HeaderTable' really changed? -shouldRenew :: HeaderTable -> Size -> Bool -shouldRenew HeaderTable{..} maxsiz = maxHeaderTableSize /= maxsiz - ----------------------------------------------------------------- - --- | Inserting 'Entry' to 'HeaderTable'. --- New 'HeaderTable', the largest new 'Index' --- and a set of dropped OLD 'Index' --- are returned. -insertEntry :: Entry -> HeaderTable -> IO HeaderTable -insertEntry e hdrtbl = do - (hdrtbl', hs) <- insertFront e hdrtbl >>= adjustTableSize - let hdrtbl'' = case reverseIndex hdrtbl' of - Nothing -> hdrtbl' - Just rev -> hdrtbl' { reverseIndex = Just (HP.deleteList hs rev) } - return hdrtbl'' - -insertFront :: Entry -> HeaderTable -> IO HeaderTable -insertFront e hdrtbl@HeaderTable{..} = do - writeArray circularTable i e - return $ hdrtbl { - offset = offset' - , numOfEntries = numOfEntries + 1 - , headerTableSize = headerTableSize' - , reverseIndex = reverseIndex' - } - where - i = offset - headerTableSize' = headerTableSize + entrySize e - offset' = adj maxNumOfEntries (offset - 1) - reverseIndex' = case reverseIndex of - Nothing -> Nothing - Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev - -adjustTableSize :: HeaderTable -> IO (HeaderTable, [Header]) -adjustTableSize hdrtbl = adjust hdrtbl [] - -adjust :: HeaderTable -> [Header] -> IO (HeaderTable, [Header]) -adjust hdrtbl@HeaderTable{..} hs - | headerTableSize <= maxHeaderTableSize = return (hdrtbl, hs) - | otherwise = do - (hdrtbl', h) <- removeEnd hdrtbl - adjust hdrtbl' (h:hs) - ----------------------------------------------------------------- - -insertEnd :: Entry -> HeaderTable -> IO HeaderTable -insertEnd e hdrtbl@HeaderTable{..} = do - writeArray circularTable i e - return $ hdrtbl { - numOfEntries = numOfEntries + 1 - , headerTableSize = headerTableSize' - , reverseIndex = reverseIndex' - } - where - i = adj maxNumOfEntries (offset + numOfEntries + 1) - headerTableSize' = headerTableSize + entrySize e - reverseIndex' = case reverseIndex of - Nothing -> Nothing - Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev - ----------------------------------------------------------------- - -removeEnd :: HeaderTable -> IO (HeaderTable,Header) -removeEnd hdrtbl@HeaderTable{..} = do - let i = adj maxNumOfEntries (offset + numOfEntries) - e <- readArray circularTable i - writeArray circularTable i dummyEntry -- let the entry GCed - let tsize = headerTableSize - entrySize e - h = entryHeader e - hdrtbl' = hdrtbl { - numOfEntries = numOfEntries - 1 - , headerTableSize = tsize - } - return (hdrtbl', h) - ----------------------------------------------------------------- - -- | Resolving an index from a header. --- Static table is prefer to header table. -lookupTable :: Header -> HeaderTable -> HeaderCache +-- Static table is prefer to dynamic table. +lookupTable :: Header -> DynamicTable -> HeaderCache lookupTable h hdrtbl = case reverseIndex hdrtbl of Nothing -> None Just rev -> case HP.search h rev of @@ -284,30 +51,27 @@ HP.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.K hidx -> case mstatic of - HP.N -> KeyOnly InHeaderTable (fromHIndexToIndex hdrtbl hidx) + HP.N -> KeyOnly InDynamicTable (fromHIndexToIndex hdrtbl hidx) HP.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.KV hidx -> case mstatic of - HP.N -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx) - HP.K _ -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx) + HP.N -> KeyValue InDynamicTable (fromHIndexToIndex hdrtbl hidx) + HP.K _ -> KeyValue InDynamicTable (fromHIndexToIndex hdrtbl hidx) HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx) where mstatic = HP.search h staticHashPSQ ---------------------------------------------------------------- -isIn :: Int -> HeaderTable -> Bool -isIn idx HeaderTable{..} = idx > staticTableSize +isIn :: Int -> DynamicTable -> Bool +isIn idx DynamicTable{..} = idx > staticTableSize -- | Which table does 'Index' belong to? -which :: HeaderTable -> Index -> IO (WhichTable, Entry) +which :: DynamicTable -> Index -> IO (WhichTable, Entry) which hdrtbl idx - | idx `isIn` hdrtbl = (InHeaderTable,) <$> toHeaderEntry hdrtbl hidx + | idx `isIn` hdrtbl = (InDynamicTable,) <$> toHeaderEntry hdrtbl hidx | isSIndexValid sidx = return (InStaticTable, toStaticEntry sidx) | otherwise = throwIO $ IndexOverrun idx where hidx = fromIndexToHIndex hdrtbl idx sidx = fromIndexToSIndex hdrtbl idx - -toHeaderEntry :: HeaderTable -> HIndex -> IO Entry -toHeaderEntry HeaderTable{..} (HIndex hidx) = readArray circularTable hidx diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Network/HPACK/Table/Dynamic.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE TupleSections, RecordWildCards #-} + +module Network.HPACK.Table.Dynamic ( + DynamicTable(..) + , newDynamicTableForEncoding + , newDynamicTableForDecoding + , renewDynamicTable + , printDynamicTable + , isDynamicTableEmpty + , insertEntry + , toHeaderEntry + , fromHIndexToIndex + , fromIndexToHIndex + , fromSIndexToIndex + , fromIndexToSIndex + ) where + +import Data.Array.IO (IOArray, newArray, readArray, writeArray) +import qualified Data.ByteString.Char8 as BS +import Network.HPACK.Table.Entry +import qualified Network.HPACK.Table.HashPSQ as HP +import Network.HPACK.Table.Static +import Control.Monad (forM) + +---------------------------------------------------------------- + +type Table = IOArray Index Entry + +{- + offset + v + +-+-+-+-+-+-+-+-+ + | | | |z|y|x| | | + +-+-+-+-+-+-+-+-+ + 1 2 3 (numOfEntries = 3) + +After insertion: + + offset + v + +-+-+-+-+-+-+-+-+ + | | |w|z|y|x| | | + +-+-+-+-+-+-+-+-+ + 1 2 3 4 (numOfEntries = 4) +-} + +-- | Type for dynamic table. +data DynamicTable = DynamicTable { + -- | An array + circularTable :: !Table + -- | Start point + , offset :: !Index + -- | The current number of entries + , numOfEntries :: !Int + -- | The size of the array + , maxNumOfEntries :: !Int + -- | The current dynamic table size (defined in HPACK) + , headerTableSize :: !Size + -- | The max dynamic table size (defined in HPACK) + , maxDynamicTableSize :: !Size + -- | Header to the index in Dynamic Table for encoder. + -- Static Table is not included. + -- Nothing for decoder. + , reverseIndex :: Maybe (HP.HashPSQ HIndex) + } + +adj :: Int -> Int -> Int +adj maxN x = (x + maxN) `mod` maxN + +---------------------------------------------------------------- + +-- | Printing 'DynamicTable'. +printDynamicTable :: DynamicTable -> IO () +printDynamicTable DynamicTable{..} = do + es <- mapM (readArray circularTable . adj maxNumOfEntries) [beg .. end] + let ts = zip [1..] es + mapM_ printEntry ts + putStrLn $ " Table size: " ++ show headerTableSize ++ "/" ++ show maxDynamicTableSize + print reverseIndex + where + beg = offset + 1 + end = offset + numOfEntries + +printEntry :: (Index,Entry) -> IO () +printEntry (i,e) = do + putStr "[ " + putStr $ show i + putStr "] (s = " + putStr $ show $ entrySize e + putStr ") " + BS.putStr $ entryHeaderName e + putStr ": " + BS.putStrLn $ entryHeaderValue e + +---------------------------------------------------------------- + +isDynamicTableEmpty :: DynamicTable -> Bool +isDynamicTableEmpty hdrtbl = numOfEntries hdrtbl == 0 + +---------------------------------------------------------------- + +-- Physical array index for Dynamic Table. +newtype HIndex = HIndex Int deriving (Eq, Ord, Show) + +---------------------------------------------------------------- + +fromHIndexToIndex :: DynamicTable -> HIndex -> Index +fromHIndexToIndex DynamicTable{..} (HIndex hidx) = idx + where + idx = adj maxNumOfEntries (hidx - offset) + staticTableSize + +fromIndexToHIndex :: DynamicTable -> Index -> HIndex +fromIndexToHIndex DynamicTable{..} idx = HIndex hidx + where + hidx = adj maxNumOfEntries (idx + offset - staticTableSize) + +fromSIndexToIndex :: DynamicTable -> SIndex -> Index +fromSIndexToIndex _ sidx = fromStaticIndex sidx + +fromIndexToSIndex :: DynamicTable -> Index -> SIndex +fromIndexToSIndex _ idx = toStaticIndex idx + +---------------------------------------------------------------- + +-- | Creating 'DynamicTable'. +-- The default maxDynamicTableSize is 4096 bytes, +-- an array has 128 entries, resulting 1024 bytes in 64bit machine +newDynamicTableForEncoding :: Size -> IO DynamicTable +newDynamicTableForEncoding maxsiz = newDynamicTable maxsiz (Just HP.empty) + +-- | Creating 'DynamicTable'. +-- The default maxDynamicTableSize is 4096 bytes, +-- an array has 128 entries, resulting 1024 bytes in 64bit machine +newDynamicTableForDecoding :: Size -> IO DynamicTable +newDynamicTableForDecoding maxsiz = newDynamicTable maxsiz Nothing + +newDynamicTable :: Size -> Maybe (HP.HashPSQ HIndex) -> IO DynamicTable +newDynamicTable maxsiz mhp = do + tbl <- newArray (0,end) dummyEntry + return DynamicTable { + maxNumOfEntries = maxN + , offset = end + , numOfEntries = 0 + , circularTable = tbl + , headerTableSize = 0 + , maxDynamicTableSize = maxsiz + , reverseIndex = mhp + } + where + maxN = maxNumbers maxsiz + end = maxN - 1 + +-- | Renewing 'DynamicTable' with necessary entries copied. +renewDynamicTable :: Size -> DynamicTable -> IO DynamicTable +renewDynamicTable maxsiz oldhdrtbl | shouldRenew oldhdrtbl maxsiz = + newDynamicTable maxsiz mhp >>= copyTable oldhdrtbl + where + mhp = case reverseIndex oldhdrtbl of + Nothing -> Nothing + _ -> Just HP.empty +renewDynamicTable _ oldhdrtbl = return oldhdrtbl + +copyTable :: DynamicTable -> DynamicTable -> IO DynamicTable +copyTable oldhdrtbl newhdrtbl = getEntries oldhdrtbl >>= copyEntries newhdrtbl + +getEntries :: DynamicTable -> IO [Entry] +getEntries DynamicTable{..} = forM [1 .. numOfEntries] readTable + where + readTable i = readArray circularTable $ adj maxNumOfEntries (offset + i) + +copyEntries :: DynamicTable -> [Entry] -> IO DynamicTable +copyEntries hdrtbl [] = return hdrtbl +copyEntries hdrtbl@DynamicTable{..} (e:es) + | headerTableSize + entrySize e <= maxDynamicTableSize = do + hdrtbl' <- insertEnd e hdrtbl + copyEntries hdrtbl' es + | otherwise = return hdrtbl + +-- | Is the size of 'DynamicTable' really changed? +shouldRenew :: DynamicTable -> Size -> Bool +shouldRenew DynamicTable{..} maxsiz = maxDynamicTableSize /= maxsiz + +---------------------------------------------------------------- + +-- | Inserting 'Entry' to 'DynamicTable'. +-- New 'DynamicTable', the largest new 'Index' +-- and a set of dropped OLD 'Index' +-- are returned. +insertEntry :: Entry -> DynamicTable -> IO DynamicTable +insertEntry e hdrtbl = do + (hdrtbl', hs) <- insertFront e hdrtbl >>= adjustTableSize + let hdrtbl'' = case reverseIndex hdrtbl' of + Nothing -> hdrtbl' + Just rev -> hdrtbl' { reverseIndex = Just (HP.deleteList hs rev) } + return hdrtbl'' + +insertFront :: Entry -> DynamicTable -> IO DynamicTable +insertFront e hdrtbl@DynamicTable{..} = do + writeArray circularTable i e + return $ hdrtbl { + offset = offset' + , numOfEntries = numOfEntries + 1 + , headerTableSize = headerTableSize' + , reverseIndex = reverseIndex' + } + where + i = offset + headerTableSize' = headerTableSize + entrySize e + offset' = adj maxNumOfEntries (offset - 1) + reverseIndex' = case reverseIndex of + Nothing -> Nothing + Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev + +adjustTableSize :: DynamicTable -> IO (DynamicTable, [Header]) +adjustTableSize hdrtbl = adjust hdrtbl [] + +adjust :: DynamicTable -> [Header] -> IO (DynamicTable, [Header]) +adjust hdrtbl@DynamicTable{..} hs + | headerTableSize <= maxDynamicTableSize = return (hdrtbl, hs) + | otherwise = do + (hdrtbl', h) <- removeEnd hdrtbl + adjust hdrtbl' (h:hs) + +---------------------------------------------------------------- + +insertEnd :: Entry -> DynamicTable -> IO DynamicTable +insertEnd e hdrtbl@DynamicTable{..} = do + writeArray circularTable i e + return $ hdrtbl { + numOfEntries = numOfEntries + 1 + , headerTableSize = headerTableSize' + , reverseIndex = reverseIndex' + } + where + i = adj maxNumOfEntries (offset + numOfEntries + 1) + headerTableSize' = headerTableSize + entrySize e + reverseIndex' = case reverseIndex of + Nothing -> Nothing + Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev + +---------------------------------------------------------------- + +removeEnd :: DynamicTable -> IO (DynamicTable,Header) +removeEnd hdrtbl@DynamicTable{..} = do + let i = adj maxNumOfEntries (offset + numOfEntries) + e <- readArray circularTable i + writeArray circularTable i dummyEntry -- let the entry GCed + let tsize = headerTableSize - entrySize e + h = entryHeader e + hdrtbl' = hdrtbl { + numOfEntries = numOfEntries - 1 + , headerTableSize = tsize + } + return (hdrtbl', h) + +---------------------------------------------------------------- + +toHeaderEntry :: DynamicTable -> HIndex -> IO Entry +toHeaderEntry DynamicTable{..} (HIndex hidx) = readArray circularTable hidx diff --git a/Network/HPACK/Table/Entry.hs b/Network/HPACK/Table/Entry.hs --- a/Network/HPACK/Table/Entry.hs +++ b/Network/HPACK/Table/Entry.hs @@ -74,10 +74,10 @@ ---------------------------------------------------------------- --- | Dummy 'Entry' to initialize a header table. +-- | Dummy 'Entry' to initialize a dynamic table. dummyEntry :: Entry dummyEntry = (0,("dummy","dummy")) --- | How many entries can be stored in a header table? +-- | How many entries can be stored in a dynamic table? maxNumbers :: Size -> Int maxNumbers siz = siz `div` headerSizeMagicNumber diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -6,6 +6,7 @@ , HeaderValue , HeaderStuff , Header + , HeaderList -- * Misc , ByteStream , Index @@ -28,6 +29,9 @@ -- | Header. type Header = (HeaderName, HeaderValue) + +-- | Header list. +type HeaderList = [Header] -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs --- a/Network/HTTP2.hs +++ b/Network/HTTP2.hs @@ -1,11 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.HTTP2 ( - -- * Decoding and Encoding - decodeFrame + -- * Magic + connectionPreface + , connectionPrefaceLength + -- * Encoding and decoding , EncodeInfo(..) + , encodeInfo , encodeFrame + , decodeFrame , module Network.HTTP2.Types ) where +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Network.HTTP2.Decode import Network.HTTP2.Encode import Network.HTTP2.Types + +-- | "PRI * HTTP/2.0\\r\\n\\r\\nSM\\r\\n\\r\\n" +connectionPreface :: ByteString +connectionPreface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" + +-- | Length of the preface +connectionPrefaceLength :: Int +connectionPrefaceLength = BS.length connectionPreface diff --git a/Network/HTTP2/Decode.hs b/Network/HTTP2/Decode.hs --- a/Network/HTTP2/Decode.hs +++ b/Network/HTTP2/Decode.hs @@ -82,9 +82,7 @@ doesExceed :: Settings -> PayloadLength -> Bool doesExceed settings len = len > maxLength where - maxLength = case settings ! SettingsMaxFrameSize of - Just x -> fromIntegral x - Nothing -> maxPayloadLength + maxLength = maxFrameSize settings zeroFrameTypes :: [FrameTypeId] zeroFrameTypes = [ @@ -110,9 +108,7 @@ | typ == FramePushPromise && not pushEnabled = True | otherwise = False where - pushEnabled = case settings ! SettingsEnablePush of - Nothing -> True - Just x -> x /= 0 + pushEnabled = establishPush settings ---------------------------------------------------------------- @@ -168,7 +164,7 @@ where num = payloadLength `div` 6 isNotValid = payloadLength `mod` 6 /= 0 - settings 0 builder = return $ toSettings $ builder [] + settings 0 builder = return $ builder [] settings n builder = do rawSetting <- BI.anyWord16be let msettings = toSettingsKeyId rawSetting @@ -176,8 +172,8 @@ case msettings of Nothing -> settings n' builder -- ignoring unknown one (Section 6.5.2) Just k -> do - v <- BI.anyWord32be - settings n' (((k,v):) . builder) + v <- fromIntegral <$> BI.anyWord32be + settings n' (builder. ((k,v):)) parsePushPromiseFrame :: FramePayloadParser parsePushPromiseFrame header = parseWithPadding header $ \len -> @@ -231,13 +227,13 @@ padded = testPadded flags streamIdentifier :: B.Parser StreamIdentifier -streamIdentifier = toStreamIdentifier <$> BI.anyWord32be +streamIdentifier = toStreamIdentifier . fromIntegral <$> BI.anyWord32be streamIdentifier' :: B.Parser (StreamIdentifier, Bool) streamIdentifier' = do - w32 <- BI.anyWord32be - let !streamdId = toStreamIdentifier w32 - !exclusive = testExclusive w32 + n <- fromIntegral <$> BI.anyWord32be + let !streamdId = toStreamIdentifier n + !exclusive = testExclusive n return (streamdId, exclusive) priority :: B.Parser Priority diff --git a/Network/HTTP2/Encode.hs b/Network/HTTP2/Encode.hs --- a/Network/HTTP2/Encode.hs +++ b/Network/HTTP2/Encode.hs @@ -8,16 +8,15 @@ , buildFrameHeader , buildFramePayload , EncodeInfo(..) + , encodeInfo ) where import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB -import Data.Array (assocs) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Data.Maybe (isJust) import Data.Monoid ((<>), mempty) import Network.HTTP2.Types @@ -36,6 +35,12 @@ ---------------------------------------------------------------- +-- | A smart builder of 'EncodeInfo'. +encodeInfo :: (FrameFlags -> FrameFlags) -> Int -> EncodeInfo +encodeInfo set stid = EncodeInfo (set defaultFlags) (toStreamIdentifier stid) Nothing + +---------------------------------------------------------------- + -- | Encoding an HTTP/2 frame to byte stream. encodeFrame :: EncodeInfo -> FramePayload -> ByteString encodeFrame einfo payload = run $ buildFrame einfo payload @@ -71,7 +76,7 @@ len = len1 <> len2 typ = BB.fromWord8 ftyp flg = BB.fromWord8 flags - sid = BB.fromWord32be $ fromStreamIdentifier streamId + sid = BB.fromWord32be . fromIntegral $ fromStreamIdentifier streamId ---------------------------------------------------------------- @@ -125,12 +130,12 @@ estream | exclusive = setExclusive stream | otherwise = stream - bstream = BB.fromWord32be estream + bstream = BB.fromWord32be $ fromIntegral estream bweight = BB.fromWord8 $ fromIntegral $ weight - 1 -- fixme: clear 31th bit? buildStream :: StreamIdentifier -> Builder -buildStream = BB.fromWord32be . fromStreamIdentifier +buildStream = BB.fromWord32be . fromIntegral . fromStreamIdentifier buildErrorCodeId :: ErrorCodeId -> Builder buildErrorCodeId = BB.fromWord32be . fromErrorCodeId @@ -169,15 +174,13 @@ builder = buildErrorCodeId e header = FrameHeader 4 encodeFlags encodeStreamId -buildFramePayloadSettings :: EncodeInfo -> Settings -> (FrameHeader, Builder) -buildFramePayloadSettings EncodeInfo{..} settings = (header, builder) +buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder) +buildFramePayloadSettings EncodeInfo{..} alist = (header, builder) where - alist = assocs settings builder = foldr op mempty alist - (_, Nothing) `op` x = x - (key, Just val) `op` x = BB.fromWord16be (fromSettingsKeyId key) - <> BB.fromWord32be val <> x - len = length (filter (isJust . snd) alist) * 6 + (key, val) `op` x = BB.fromWord16be (fromSettingsKeyId key) + <> BB.fromWord32be (fromIntegral val) <> x + len = length alist * 6 header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadPushPromise :: EncodeInfo -> StreamIdentifier -> HeaderBlockFragment -> (FrameHeader, Builder) diff --git a/Network/HTTP2/Types.hs b/Network/HTTP2/Types.hs --- a/Network/HTTP2/Types.hs +++ b/Network/HTTP2/Types.hs @@ -5,10 +5,10 @@ , SettingsValue , fromSettingsKeyId , toSettingsKeyId - , Settings + , Settings(..) + , SettingsList , defaultSettings - , toSettings - , fromSettings + , updateSettings -- * Error code , ErrorCode , ErrorCodeId(..) @@ -57,13 +57,9 @@ , Padding ) where -import Control.Arrow (second) -import Control.Monad (forM_) -import Data.Array (Array, Ix, listArray, assocs) -import Data.Array.ST (newArray, writeArray, runSTArray) +import Data.Array (Ix) import Data.Bits (setBit, testBit, clearBit) import Data.ByteString (ByteString) -import Data.Maybe (fromJust, isJust) import Data.Word (Word8, Word16, Word32) ---------------------------------------------------------------- @@ -83,6 +79,7 @@ | ConnectError | EnhanceYourCalm | InadequateSecurity + | HTTP11Required -- our extensions | UnknownErrorCode ErrorCode | UnknownError String @@ -108,6 +105,7 @@ fromErrorCodeId ConnectError = 0xa fromErrorCodeId EnhanceYourCalm = 0xb fromErrorCodeId InadequateSecurity = 0xc +fromErrorCodeId HTTP11Required = 0xd fromErrorCodeId (UnknownErrorCode w) = w fromErrorCodeId _ = 255 -- never reached @@ -117,8 +115,8 @@ -- NoError -- >>> toErrorCodeId 0xc -- InadequateSecurity --- >>> toErrorCodeId 0xd --- UnknownErrorCode 13 +-- >>> toErrorCodeId 0xe +-- UnknownErrorCode 14 toErrorCodeId :: ErrorCode -> ErrorCodeId toErrorCodeId 0x0 = NoError toErrorCodeId 0x1 = ProtocolError @@ -133,21 +131,22 @@ toErrorCodeId 0xa = ConnectError toErrorCodeId 0xb = EnhanceYourCalm toErrorCodeId 0xc = InadequateSecurity +toErrorCodeId 0xd = HTTP11Required toErrorCodeId w = UnknownErrorCode w ---------------------------------------------------------------- -type SettingsKey = Word16 -type SettingsValue = Word32 - data SettingsKeyId = SettingsHeaderTableSize - | SettingsEnablePush - | SettingsMaxConcurrentStreams - | SettingsInitialWindowSize - | SettingsMaxFrameSize -- this means payload size - | SettingsMaxHeaderBlockSize - deriving (Show, Read, Eq, Ord, Enum, Bounded, Ix) + | SettingsEnablePush + | SettingsMaxConcurrentStreams + | SettingsInitialWindowSize + | SettingsMaxFrameSize -- this means payload size + | SettingsMaxHeaderBlockSize + deriving (Show, Read, Eq, Ord, Enum, Bounded) +type SettingsKey = Word16 +type SettingsValue = Int -- Word32 + -- | -- -- >>> fromSettingsKeyId SettingsHeaderTableSize @@ -182,26 +181,44 @@ ---------------------------------------------------------------- -type Settings = Array SettingsKeyId (Maybe SettingsValue) +data Settings = Settings { + headerTableSize :: Int + , establishPush :: Bool + , maxConcurrentStreams :: Int + , initialWindowSize :: Int + , maxFrameSize :: Int + , maxHeaderBlockSize :: Maybe Int + } deriving (Show) --- | Default settings. All values are 'Nothing'. +type SettingsList = [(SettingsKeyId,SettingsValue)] + +-- | The default settings. defaultSettings :: Settings -defaultSettings = listArray settingsRange [Nothing|_<-xs] - where - xs = [minBound :: SettingsKeyId .. maxBound :: SettingsKeyId] +defaultSettings = Settings { + headerTableSize = 4096 + , establishPush = True + , maxConcurrentStreams = 100 + , initialWindowSize = 65535 + , maxFrameSize = 16384 + , maxHeaderBlockSize = Nothing + } --- | +-- | Updating settings. -- --- >>> toSettings [(SettingsHeaderTableSize,10),(SettingsInitialWindowSize,20),(SettingsHeaderTableSize,30)] --- array (SettingsHeaderTableSize,SettingsMaxHeaderBlockSize) [(SettingsHeaderTableSize,Just 30),(SettingsEnablePush,Nothing),(SettingsMaxConcurrentStreams,Nothing),(SettingsInitialWindowSize,Just 20),(SettingsMaxFrameSize,Nothing),(SettingsMaxHeaderBlockSize,Nothing)] -toSettings :: [(SettingsKeyId,SettingsValue)] -> Settings -toSettings kvs = runSTArray $ do - arr <- newArray settingsRange Nothing - forM_ kvs $ \(k,v) -> writeArray arr k (Just v) - return arr +-- >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)] +-- Settings {headerTableSize = 4096, establishPush = False, maxConcurrentStreams = 100, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200} +updateSettings :: Settings -> SettingsList -> Settings +updateSettings settings kvs = foldr update settings kvs + where + update (SettingsHeaderTableSize,x) def = def { headerTableSize = x } + -- fixme: x should be 0 or 1 + update (SettingsEnablePush,x) def = def { establishPush = x > 0 } + update (SettingsMaxConcurrentStreams,x) def = def { maxConcurrentStreams = x } + update (SettingsInitialWindowSize,x) def = def { initialWindowSize = x } + update (SettingsMaxFrameSize,x) def = def { maxFrameSize = x } + update (SettingsMaxHeaderBlockSize,x) def = def { maxHeaderBlockSize = Just x } -settingsRange :: (SettingsKeyId, SettingsKeyId) -settingsRange = (minBound, maxBound) +---------------------------------------------------------------- data Priority = Priority { exclusive :: Bool @@ -209,12 +226,6 @@ , weight :: Int } deriving (Show, Read, Eq) --- | --- >>> fromSettings $ toSettings [(SettingsHeaderTableSize,10),(SettingsInitialWindowSize,20),(SettingsHeaderTableSize,30)] --- [(SettingsHeaderTableSize,30),(SettingsInitialWindowSize,20)] -fromSettings :: Settings -> [(SettingsKeyId,SettingsValue)] -fromSettings = map (second fromJust) . filter (isJust.snd) . assocs - ---------------------------------------------------------------- type FrameType = Word8 @@ -337,22 +348,22 @@ ---------------------------------------------------------------- -newtype StreamIdentifier = StreamIdentifier Word32 deriving (Show, Read, Eq) +newtype StreamIdentifier = StreamIdentifier Int deriving (Show, Read, Eq) type StreamDependency = StreamIdentifier type LastStreamId = StreamIdentifier type PromisedStreamId = StreamIdentifier -toStreamIdentifier :: Word32 -> StreamIdentifier -toStreamIdentifier w = StreamIdentifier (w `clearBit` 31) +toStreamIdentifier :: Int -> StreamIdentifier +toStreamIdentifier n = StreamIdentifier (n `clearBit` 31) -fromStreamIdentifier :: StreamIdentifier -> Word32 -fromStreamIdentifier (StreamIdentifier w32) = w32 +fromStreamIdentifier :: StreamIdentifier -> Int +fromStreamIdentifier (StreamIdentifier n) = n -testExclusive :: Word32 -> Bool -testExclusive w = w `testBit` 31 +testExclusive :: Int -> Bool +testExclusive n = n `testBit` 31 -setExclusive :: Word32 -> Word32 -setExclusive w = w `setBit` 31 +setExclusive :: Int -> Int +setExclusive n = n `setBit` 31 streamIdentifierForSeetings :: StreamIdentifier streamIdentifierForSeetings = StreamIdentifier 0 @@ -382,7 +393,7 @@ | HeadersFrame (Maybe Priority) HeaderBlockFragment | PriorityFrame Priority | RSTStreamFrame ErrorCodeId - | SettingsFrame Settings + | SettingsFrame SettingsList | PushPromiseFrame PromisedStreamId HeaderBlockFragment | PingFrame ByteString | GoAwayFrame LastStreamId ErrorCodeId ByteString diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,12 +1,12 @@ Name: http2 -Version: 0.6.0 +Version: 0.7.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE -Synopsis: HTTP/2.0 library including HPACK -Description: HTTP/2.0 library including HPACK. - Currently HTTP/2 14 framing and HPACK 09 is supported. +Synopsis: HTTP/2.0 library including frames and HPACK +Description: HTTP/2.0 library including frames and HPACK + Currently HTTP/2 16 framing and HPACK 10 is supported. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple @@ -30,8 +30,6 @@ Network.HTTP2 Other-Modules: Network.HPACK.Builder Network.HPACK.Builder.Word8 - Network.HPACK.Context - Network.HPACK.Context.HeaderList Network.HPACK.Huffman Network.HPACK.Huffman.Bit Network.HPACK.Huffman.ByteString @@ -49,6 +47,7 @@ Network.HPACK.HeaderBlock.String Network.HPACK.HeaderBlock.To Network.HPACK.Table + Network.HPACK.Table.Dynamic Network.HPACK.Table.Entry Network.HPACK.Table.HashPSQ Network.HPACK.Table.Static diff --git a/test-frame/Case.hs b/test-frame/Case.hs --- a/test-frame/Case.hs +++ b/test-frame/Case.hs @@ -45,8 +45,8 @@ where -- fromJust is unsafe frm = case decodeFrame defaultSettings $ fromJust $ unhex wire_hex of - Left e -> error $ show e - Right r -> r + Left e -> error $ show e + Right (r,_) -> r wireToCase CaseWire { wire_error = Just e, ..} = Case { draft = 14 , description = wire_description diff --git a/test-frame/JSON.hs b/test-frame/JSON.hs --- a/test-frame/JSON.hs +++ b/test-frame/JSON.hs @@ -82,11 +82,11 @@ instance FromJSON ErrorCodeId where parseJSON e = toErrorCodeId <$> parseJSON e -instance ToJSON Settings where - toJSON settings = toJSON $ map (first fromSettingsKeyId) (fromSettings settings) +instance ToJSON SettingsList where + toJSON settings = toJSON $ map (first fromSettingsKeyId) settings -instance FromJSON Settings where - parseJSON x = toSettings . map (first (fromJust . toSettingsKeyId)) <$> parseJSON x +instance FromJSON SettingsList where + parseJSON x = map (first (fromJust . toSettingsKeyId)) <$> parseJSON x instance ToJSON ByteString where toJSON bs = toJSON $ byteStringToText bs diff --git a/test-hpack/HPACKDecode.hs b/test-hpack/HPACKDecode.hs --- a/test-hpack/HPACKDecode.hs +++ b/test-hpack/HPACKDecode.hs @@ -15,9 +15,8 @@ import Data.Hex import Data.List (sort) import Network.HPACK -import Network.HPACK.Context -import Network.HPACK.Context.HeaderList import Network.HPACK.HeaderBlock +import Network.HPACK.Table import JSON @@ -31,47 +30,47 @@ run _ (Test _ _ []) = return $ Pass run d (Test _ _ ccs@(c:_)) = do let siz = maybe 4096 id $ size c - dctx <- newContextForDecoding siz + dhdrtbl <- newDynamicTableForDecoding siz let conf = Conf { debug = d } - testLoop conf ccs dctx + testLoop conf ccs dhdrtbl testLoop :: Conf -> [Case] - -> Context + -> DynamicTable -> IO Result testLoop _ [] _ = return $ Pass -testLoop conf (c:cs) dctx = do - res <- test conf c dctx +testLoop conf (c:cs) dhdrtbl = do + res <- test conf c dhdrtbl case res of - Right dctx' -> testLoop conf cs dctx' + Right dhdrtbl' -> testLoop conf cs dhdrtbl' Left e -> return $ Fail e test :: Conf -> Case - -> Context - -> IO (Either String Context) -test conf c dctx = do + -> DynamicTable + -> IO (Either String DynamicTable) +test conf c dhdrtbl = do -- context is destructive!!! when (debug conf) $ do putStrLn "--------------------------------" - putStrLn "---- Input headerlist" + putStrLn "---- Input header list" printHeaderList $ sort hs - putStrLn "---- Input context" - printContext dctx + putStrLn "---- Input header table" + printDynamicTable dhdrtbl putStrLn "---- Input Hex" B8.putStrLn wirehex putStrLn "---- Input header block" print bshd' - dctx0 <- case size c of - Nothing -> return dctx - Just siz -> changeContextForDecoding dctx siz - x <- try $ decodeHeader dctx0 inp + dhdrtbl0 <- case size c of + Nothing -> return dhdrtbl + Just siz -> renewDynamicTable siz dhdrtbl + x <- try $ decodeHeader dhdrtbl0 inp case x of Left e -> return $ Left $ show (e :: DecodeError) - Right (dctx',hs') -> do + Right (dhdrtbl',hs') -> do let pass = sort hs == sort hs' if pass then - return $ Right (dctx') + return $ Right (dhdrtbl') else return $ Left $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs' where @@ -81,3 +80,13 @@ bshd = fromByteStreamDebug inp hd = map snd <$> bshd bshd' = map (\(x,y)->(hex x,y)) <$> bshd + +-- | Printing 'HeaderList'. +printHeaderList :: HeaderList -> IO () +printHeaderList hs = mapM_ printHeader hs + where + printHeader (k,v) = do + B8.putStr k + putStr ": " + B8.putStr v + putStr "\n" diff --git a/test-hpack/HPACKEncode.hs b/test-hpack/HPACKEncode.hs --- a/test-hpack/HPACKEncode.hs +++ b/test-hpack/HPACKEncode.hs @@ -11,7 +11,7 @@ import Data.ByteString (ByteString) import Data.Hex import Network.HPACK -import Network.HPACK.Context +import Network.HPACK.Table import JSON @@ -24,31 +24,31 @@ run _ _ (Test _ _ []) = return [] run d stgy (Test _ _ ccs@(c:_)) = do let siz = maybe 4096 id $ size c - ectx <- newContextForEncoding siz + ehdrtbl <- newHeaderTableForEncoding siz let conf = Conf { debug = d, enc = encodeHeader stgy } - testLoop conf ccs ectx [] + testLoop conf ccs ehdrtbl [] testLoop :: Conf -> [Case] - -> Context + -> HeaderTable -> [ByteString] -> IO [ByteString] testLoop _ [] _ hexs = return $ reverse hexs -testLoop conf (c:cs) ectx hxs = do - (ectx',hx) <- test conf c ectx - testLoop conf cs ectx' (hx:hxs) +testLoop conf (c:cs) ehdrtbl hxs = do + (ehdrtbl',hx) <- test conf c ehdrtbl + testLoop conf cs ehdrtbl' (hx:hxs) test :: Conf -> Case - -> Context - -> IO (Context, ByteString) -test conf c ectx = do - (ectx',out) <- enc conf ectx hs + -> HeaderTable + -> IO (HeaderTable, ByteString) +test conf c ehdrtbl = do + (ehdrtbl',out) <- enc conf ehdrtbl hs let hex' = hex out when (debug conf) $ do putStrLn "---- Output context" - printContext ectx' + printHeaderTable ehdrtbl' putStrLn "--------------------------------" - return (ectx', hex') + return (ehdrtbl', hex') where hs = headers c diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -2,8 +2,9 @@ module HPACK.DecodeSpec where -import Network.HPACK.Context import Network.HPACK.HeaderBlock +import Network.HPACK.Table +import Network.HPACK.Types import Test.Hspec import HPACK.HeaderBlock @@ -12,23 +13,23 @@ spec = do describe "fromHeaderBlock" $ do it "decodes HeaderList in request" $ do - (c1,h1) <- newContextForDecoding 4096 >>= flip fromHeaderBlock d41 + (c1,h1) <- newDynamicTableForDecoding 4096 >>= flip fromHeaderBlock d41 h1 `shouldBe` d41h (c2,h2) <- fromHeaderBlock c1 d42 h2 `shouldBe` d42h (_,h3) <- fromHeaderBlock c2 d43 h3 `shouldBe` d43h it "decodes HeaderList in response" $ do - (c1,h1) <- newContextForDecoding 256 >>= flip fromHeaderBlock d61 + (c1,h1) <- newDynamicTableForDecoding 256 >>= flip fromHeaderBlock d61 h1 `shouldBe` d61h (c2,h2) <- fromHeaderBlock c1 d62 h2 `shouldBe` d62h (_,h3) <- fromHeaderBlock c2 d63 h3 `shouldBe` d63h - it "decodes HeaderList even if an entry is larger than HeaderTable" $ do - (c1,h1) <- newContextForDecoding 64 >>= flip fromHeaderBlock hb1 + it "decodes HeaderList even if an entry is larger than DynamicTable" $ do + (c1,h1) <- newDynamicTableForDecoding 64 >>= flip fromHeaderBlock hb1 h1 `shouldBe` hl1 - isContextTableEmpty c1 `shouldBe` True + isDynamicTableEmpty c1 `shouldBe` True hb1 :: HeaderBlock hb1 = [Literal Add (Lit "custom-key") "custom-value" diff --git a/test/HPACK/HeaderBlock.hs b/test/HPACK/HeaderBlock.hs --- a/test/HPACK/HeaderBlock.hs +++ b/test/HPACK/HeaderBlock.hs @@ -4,7 +4,6 @@ import Data.Hex import Data.Maybe (fromJust) -import Network.HPACK.Context import Network.HPACK.HeaderBlock import Network.HPACK.Types