packages feed

http2 0.6.0 → 0.7.0

raw patch · 20 files changed

+514/−568 lines, 20 files

Files

Network/HPACK.hs view
@@ -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)  ----------------------------------------------------------------
− Network/HPACK/Context.hs 
@@ -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 "<<<Header table>>>"-    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
− Network/HPACK/Context/HeaderList.hs 
@@ -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"
Network/HPACK/HeaderBlock/From.hs view
@@ -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
Network/HPACK/HeaderBlock/To.hs view
@@ -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 = [
Network/HPACK/Table.hs view
@@ -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
+ Network/HPACK/Table/Dynamic.hs view
@@ -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
Network/HPACK/Table/Entry.hs view
@@ -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
Network/HPACK/Types.hs view
@@ -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
Network/HTTP2.hs view
@@ -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
Network/HTTP2/Decode.hs view
@@ -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
Network/HTTP2/Encode.hs view
@@ -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)
Network/HTTP2/Types.hs view
@@ -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
http2.cabal view
@@ -1,12 +1,12 @@ Name:                   http2-Version:                0.6.0+Version:                0.7.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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
test-frame/Case.hs view
@@ -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
test-frame/JSON.hs view
@@ -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
test-hpack/HPACKDecode.hs view
@@ -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"
test-hpack/HPACKEncode.hs view
@@ -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
test/HPACK/DecodeSpec.hs view
@@ -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"
test/HPACK/HeaderBlock.hs view
@@ -4,7 +4,6 @@  import Data.Hex import Data.Maybe (fromJust)-import Network.HPACK.Context import Network.HPACK.HeaderBlock import Network.HPACK.Types