http2 0.9.1 → 1.0.0

raw patch · 27 files changed

+584/−230 lines, 27 filesdep +bytestring-builderdep +mersenne-randomdep +stmdep −blaze-builderdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring-builder, mersenne-random, stm

Dependencies removed: blaze-builder

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• Network/HPACK.hs +33/−6
• Network/HPACK/HeaderBlock.hs +1/−0
• Network/HPACK/HeaderBlock/Encode.hs +32/−17
• Network/HPACK/HeaderBlock/From.hs +3/−1
• Network/HPACK/Huffman/ByteString.hs +3/−2
• Network/HPACK/Huffman/Encode.hs +3/−1
• Network/HPACK/Table.hs +18/−16
• Network/HPACK/Table/DoubleHashMap.hs +69/−0
• Network/HPACK/Table/Dynamic.hs +8/−12
• Network/HPACK/Table/HashPSQ.hs +0/−66
• Network/HPACK/Table/Static.hs +3/−3
• Network/HTTP2.hs +13/−7
• Network/HTTP2/Decode.hs +14/−11
• Network/HTTP2/Encode.hs +20/−15
• Network/HTTP2/Internal.hs +0/−5
• Network/HTTP2/Priority.hs +120/−0
• Network/HTTP2/RandomSkewHeap.hs +67/−0
• Network/HTTP2/Types.hs +90/−47
• http2.cabal +15/−11
• test-frame/Case.hs +3/−1
• test-frame/JSON.hs +6/−3
• test-hpack/HPACKDecode.hs +3/−1
• test-hpack/HPACKSpec.hs +4/−0
• test-hpack/JSON.hs +3/−1
• test-hpack/hpack-stat.hs +3/−1
• test/HTTP2/FrameSpec.hs +3/−3
• test/HTTP2/PrioritySpec.hs +47/−0

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | HPACK: encoding and decoding a header list. module Network.HPACK (   -- * Encoding and decoding@@ -5,8 +7,12 @@   , HPACKDecoding   , encodeHeader   , decodeHeader+  -- * Encoding with builders+  , HPACKEncodingBuilder+  , encodeHeaderBuilder   -- * DynamicTable   , DynamicTable+  , defaultDynamicTableSize   , newDynamicTableForEncoding   , newDynamicTableForDecoding   -- * Strategy for encoding@@ -25,32 +31,53 @@   , Index   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Arrow (second) import Control.Exception (throwIO) import Data.ByteString (ByteString)-import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteString, fromByteString)+import Data.ByteString.Builder (Builder)+import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteString, fromByteString, toBuilder) import Network.HPACK.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding) import Network.HPACK.Types +-- | Default dynamic table size.+--   The value is 4,096 bytes: an array has 128 entries.+--+-- >>> defaultDynamicTableSize+-- 4096+defaultDynamicTableSize :: Int+defaultDynamicTableSize = 4096+ ---------------------------------------------------------------- --- | HPACK encoding, from 'HeaderList' to 'ByteString'.-type HPACKEncoding = DynamicTable -> HeaderList  -> IO (DynamicTable, ByteString)+-- | HPACK encoding from 'HeaderList' to 'ByteString'.+type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteString) --- | HPACK decoding, from 'ByteString' to 'HeaderList'.+-- | HPACK encoding from 'HeaderList' to 'Builder'.+type HPACKEncodingBuilder = DynamicTable -> HeaderList -> IO (DynamicTable, Builder)++-- | HPACK decoding from 'ByteString' to 'HeaderList'. type HPACKDecoding = DynamicTable -> ByteString -> IO (DynamicTable, HeaderList)  ---------------------------------------------------------------- --- | Converting 'HeaderList' for HTTP request to the low level format.+-- | Converting 'HeaderList' for HTTP header to the low level format. encodeHeader :: EncodeStrategy -> HPACKEncoding encodeHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs   where     algo = compressionAlgo stgy     toBS = toByteString (useHuffman stgy) --- | Converting the low level format for HTTP request to 'HeaderList'.+-- | Converting 'HeaderList' for HTTP header to bytestring builder.+encodeHeaderBuilder :: EncodeStrategy -> HPACKEncodingBuilder+encodeHeaderBuilder stgy ctx hs = second toBB <$> toHeaderBlock algo ctx hs+  where+    algo = compressionAlgo stgy+    toBB = toBuilder (useHuffman stgy)++-- | Converting the low level format for HTTP header to 'HeaderList'. --   'DecodeError' would be thrown. decodeHeader :: HPACKDecoding decodeHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb

@@ -5,6 +5,7 @@   , toByteString   , fromByteString   , fromByteStringDebug+  , toBuilder   -- * Header block from/to header list   , toHeaderBlock   , fromHeaderBlock

@@ -1,14 +1,22 @@+{-# LANGUAGE CPP #-}+ module Network.HPACK.HeaderBlock.Encode (     toByteString+  , toBuilder   ) where -import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as BB import Data.Bits (setBit) import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Lazy as BL import Data.List (foldl')-import Data.Monoid ((<>), mempty)+#if __GLASGOW_HASKELL__ < 709+import Data.Monoid (mempty)+#endif+import Data.Monoid ((<>)) import Data.Word (Word8) import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I@@ -18,8 +26,12 @@  -- | Converting 'HeaderBlock' to the low level format. toByteString :: Bool -> HeaderBlock -> ByteString-toByteString huff hbs = BB.toByteString $ foldl' (<>) mempty $ map toBB hbs+toByteString huff hbs = BL.toStrict $ BB.toLazyByteString $ toBuilder huff hbs++toBuilder :: Bool -> [HeaderField] -> Builder+toBuilder huff hbs = foldl' op mempty hbs   where+    b `op` x = b <> toBB x     toBB = fromHeaderField huff  fromHeaderField :: Bool -> HeaderField -> Builder@@ -34,14 +46,17 @@  ---------------------------------------------------------------- +word8s :: [Word8] -> Builder+word8s = P.primMapListFixed P.word8+ change :: Int -> Builder-change i = BB.fromWord8s (w':ws)+change i = word8s (w':ws)   where     (w:ws) = I.encode 5 i     w' = set001 w  index :: Int -> Builder-index i = BB.fromWord8s (w':ws)+index i = word8s (w':ws)   where     (w:ws) = I.encode 7 i     w' = set1 w@@ -51,31 +66,31 @@ indexedName huff n set idx v = pre <> vlen <> val   where     (p:ps) = I.encode n idx-    pre = BB.fromWord8s $ set p : ps+    pre = word8s $ set p : ps     value = S.encode huff v     valueLen = BS.length value     vlen-      | huff      = BB.fromWord8s $ setH $ I.encode 7 valueLen-      | otherwise = BB.fromWord8s $ I.encode 7 valueLen-    val = BB.fromByteString value+      | huff      = word8s $ setH $ I.encode 7 valueLen+      | otherwise = word8s $ I.encode 7 valueLen+    val = BB.byteString value  -- Using Huffman encoding newName :: Bool -> Setter -> HeaderName -> HeaderValue -> Builder newName huff set k v = pre <> klen <> key <> vlen <> val   where-    pre = BB.fromWord8 $ set 0+    pre = BB.word8 $ set 0     key0 = S.encode huff k     keyLen = BS.length key0     value = S.encode huff v     valueLen = BS.length value     klen-      | huff      = BB.fromWord8s $ setH $ I.encode 7 keyLen-      | otherwise = BB.fromWord8s $ I.encode 7 keyLen+      | huff      = word8s $ setH $ I.encode 7 keyLen+      | otherwise = word8s $ I.encode 7 keyLen     vlen-      | huff      = BB.fromWord8s $ setH $ I.encode 7 valueLen-      | otherwise = BB.fromWord8s $ I.encode 7 valueLen-    key = BB.fromByteString key0-    val = BB.fromByteString value+      | huff      = word8s $ setH $ I.encode 7 valueLen+      | otherwise = word8s $ I.encode 7 valueLen+    key = BB.byteString key0+    val = BB.byteString value  ---------------------------------------------------------------- 

@@ -1,11 +1,13 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, CPP #-}  module Network.HPACK.HeaderBlock.From (     fromHeaderBlock   , decodeStep   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Network.HPACK.Builder import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table

@@ -7,12 +7,13 @@  import Control.Monad (void) import Data.Bits ((.&.), shiftR)-import Data.ByteString.Internal (ByteString(..), inlinePerformIO)+import Data.ByteString.Internal (ByteString(..)) import Data.Word (Word8) import Foreign.C.Types (CSize(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek)+import System.IO.Unsafe (unsafeDupablePerformIO)  -- $setup -- >>> import qualified Data.ByteString as BS@@ -26,7 +27,7 @@ -- [3,4,15,3,10,11]  unpack4bits :: ByteString -> [Word8]-unpack4bits (PS fptr off len) = inlinePerformIO $+unpack4bits (PS fptr off len) = unsafeDupablePerformIO $   withForeignPtr fptr $ \ptr -> do     let lim = ptr `plusPtr` (off - 1)         end = ptr `plusPtr` (off + len - 1)

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, CPP #-}  module Network.HPACK.Huffman.Encode (   -- * Huffman encoding@@ -6,7 +6,9 @@   , encode   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Monad (when) import Data.Array import Data.Bits ((.|.))

@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, RecordWildCards #-}+{-# LANGUAGE TupleSections, RecordWildCards, CPP #-}  module Network.HPACK.Table (   -- * dynamic table@@ -20,11 +20,13 @@   , which   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Exception (throwIO) import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry-import qualified Network.HPACK.Table.HashPSQ as HP+import qualified Network.HPACK.Table.DoubleHashMap as DHM import Network.HPACK.Table.Static import Network.HPACK.Types @@ -45,21 +47,21 @@ lookupTable :: Header -> DynamicTable -> HeaderCache lookupTable h hdrtbl = case reverseIndex hdrtbl of     Nothing            -> None-    Just rev -> case HP.search h rev of-        HP.N       -> case mstatic of-            HP.N       -> None-            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  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 InDynamicTable (fromHIndexToIndex hdrtbl hidx)-            HP.K  _    -> KeyValue InDynamicTable (fromHIndexToIndex hdrtbl hidx)-            HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)+    Just rev -> case DHM.search h rev of+        DHM.N       -> case mstatic of+            DHM.N       -> None+            DHM.K  sidx -> KeyOnly  InStaticTable (fromSIndexToIndex hdrtbl sidx)+            DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)+        DHM.K hidx  -> case mstatic of+            DHM.N       -> KeyOnly  InDynamicTable (fromHIndexToIndex hdrtbl hidx)+            DHM.K  sidx -> KeyOnly  InStaticTable (fromSIndexToIndex hdrtbl sidx)+            DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)+        DHM.KV hidx -> case mstatic of+            DHM.N       -> KeyValue InDynamicTable (fromHIndexToIndex hdrtbl hidx)+            DHM.K  _    -> KeyValue InDynamicTable (fromHIndexToIndex hdrtbl hidx)+            DHM.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)   where-    mstatic = HP.search h staticHashPSQ+    mstatic = DHM.search h staticHashPSQ  ---------------------------------------------------------------- 

@@ -0,0 +1,69 @@+{-# LANGUAGE BangPatterns #-}++module Network.HPACK.Table.DoubleHashMap (+    DoubleHashMap+  , empty+  , insert+  , delete+  , fromList+  , deleteList+  , Res(..)+  , search+  ) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.List (foldl')+import Network.HPACK.Types++newtype DoubleHashMap a =+    DoubleHashMap (HashMap HeaderName (HashMap HeaderValue a)) deriving Show++empty :: DoubleHashMap a+empty = DoubleHashMap H.empty++insert :: Ord a => Header -> a -> DoubleHashMap a -> DoubleHashMap a+insert (k,v) p (DoubleHashMap m) = case H.lookup k m of+    Nothing    -> let inner = H.singleton v p+                  in DoubleHashMap $ H.insert k inner m+    Just inner -> let inner' = H.insert v p inner+                  in DoubleHashMap $ H.adjust (const inner') k m++delete :: Ord a => Header -> DoubleHashMap a -> DoubleHashMap a+delete (k,v) dhm@(DoubleHashMap outer) = case H.lookup k outer of+    Nothing  -> dhm -- Non-smart implementation makes duplicate keys.+                    -- It is likely to happen to delete the same key+                    -- in multiple times.+    Just inner -> case H.lookup v inner of+        Nothing -> dhm -- see above+        _       -> delete' inner+  where+    delete' inner+      | H.null inner' = DoubleHashMap $ H.delete k outer+      | otherwise     = DoubleHashMap $ H.adjust (const inner') k outer+      where+        inner' = H.delete v inner++fromList :: Ord a => [(a,Header)] -> DoubleHashMap a+fromList alist = hashinner+  where+    ins !hp (!a,!dhm) = insert dhm a hp+    !hashinner = foldl' ins empty alist++deleteList :: Ord a => [Header] -> DoubleHashMap a -> DoubleHashMap a+deleteList hs hp = foldl' (flip delete) hp hs++data Res a = N | K a | KV a++search :: Ord a => Header -> DoubleHashMap a -> Res a+search (k,v) (DoubleHashMap outer) = case H.lookup k outer of+    Nothing  -> N+    Just inner -> case H.lookup v inner of+        Nothing -> case top inner of+            Nothing -> error "DoubleHashMap.search"+            Just a  -> K a+        Just a -> KV a++-- | Take an arbitrary entry. O(1) thanks to lazy evaluation.+top :: HashMap k v -> Maybe v+top = H.foldr (\v _ -> Just v) Nothing

@@ -18,7 +18,7 @@ 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 qualified Network.HPACK.Table.DoubleHashMap as DHM import Network.HPACK.Table.Static import Control.Monad (forM) @@ -61,7 +61,7 @@   -- | Header to the index in Dynamic Table for encoder.   --   Static Table is not included.   --   Nothing for decoder.-  , reverseIndex :: Maybe (HP.HashPSQ HIndex)+  , reverseIndex :: Maybe (DHM.DoubleHashMap HIndex)   }  adj :: Int -> Int -> Int@@ -123,18 +123,14 @@ ----------------------------------------------------------------  -- | 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)+newDynamicTableForEncoding maxsiz = newDynamicTable maxsiz (Just DHM.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 :: Size -> Maybe (DHM.DoubleHashMap HIndex) -> IO DynamicTable newDynamicTable maxsiz mhp = do     tbl <- newArray (0,end) dummyEntry     return DynamicTable {@@ -157,7 +153,7 @@   where     mhp = case reverseIndex oldhdrtbl of         Nothing -> Nothing-        _       -> Just HP.empty+        _       -> Just DHM.empty renewDynamicTable _ oldhdrtbl = return oldhdrtbl  copyTable :: DynamicTable -> DynamicTable -> IO DynamicTable@@ -191,7 +187,7 @@     (hdrtbl', hs) <- insertFront e hdrtbl >>= adjustTableSize     let hdrtbl'' = case reverseIndex hdrtbl' of             Nothing  -> hdrtbl'-            Just rev -> hdrtbl' { reverseIndex = Just (HP.deleteList hs rev) }+            Just rev -> hdrtbl' { reverseIndex = Just (DHM.deleteList hs rev) }     return hdrtbl''  insertFront :: Entry -> DynamicTable -> IO DynamicTable@@ -209,7 +205,7 @@     offset' = adj maxNumOfEntries (offset - 1)     reverseIndex' = case reverseIndex of         Nothing  -> Nothing-        Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev+        Just rev -> Just $ DHM.insert (entryHeader e) (HIndex i) rev  adjustTableSize :: DynamicTable -> IO (DynamicTable, [Header]) adjustTableSize hdrtbl = adjust hdrtbl []@@ -236,7 +232,7 @@     headerTableSize' = headerTableSize + entrySize e     reverseIndex' = case reverseIndex of         Nothing  -> Nothing-        Just rev -> Just $ HP.insert (entryHeader e) (HIndex i) rev+        Just rev -> Just $ DHM.insert (entryHeader e) (HIndex i) rev  ---------------------------------------------------------------- 

@@ -1,66 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Network.HPACK.Table.HashPSQ (-    HashPSQ-  , empty-  , insert-  , delete-  , fromList-  , deleteList-  , Res(..)-  , search-  ) where--import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import Data.List (foldl')-import Data.PSQueue (PSQ, Binding(..))-import qualified Data.PSQueue as P-import Network.HPACK.Types--newtype HashPSQ p = HashPSQ (HashMap HeaderName (PSQ HeaderValue p)) deriving Show--empty :: HashPSQ p-empty = HashPSQ H.empty--insert :: Ord p => Header -> p -> HashPSQ p -> HashPSQ p-insert (k,v) p (HashPSQ m) = case H.lookup k m of-    Nothing  -> let psq = P.singleton v p-                in HashPSQ $ H.insert k psq m-    Just psq -> let psq' = P.insert v p psq-                in HashPSQ $ H.adjust (const psq') k m--delete :: Ord p => Header -> HashPSQ p -> HashPSQ p-delete (k,v) hp@(HashPSQ m) = case H.lookup k m of-    Nothing  -> hp -- Non-smart implementation makes duplicate keys.-                   -- It is likely to happen to delete the same key-                   -- in multiple times.-    Just psq -> case P.lookup v psq of-        Nothing -> hp -- see above-        _       -> delete' psq-  where-    delete' psq-      | P.null psq' = HashPSQ $ H.delete k m-      | otherwise   = HashPSQ $ H.adjust (const psq') k m-      where-        psq' = P.delete v psq--fromList :: Ord p => [(p,Header)] -> HashPSQ p-fromList alst = hashpsq-  where-    ins !hp (!p,!h) = insert h p hp-    !hashpsq = foldl' ins empty alst--deleteList :: Ord p => [Header] -> HashPSQ p -> HashPSQ p-deleteList hs hp = foldl' (flip delete) hp hs--data Res p = N | K p | KV p--search :: Ord p => Header -> HashPSQ p -> Res p-search (k,v) (HashPSQ m) = case H.lookup k m of-    Nothing  -> N-    Just psq -> case P.lookup v psq of-        Nothing -> case P.findMin psq of-            Nothing        -> error "HashPSQ.lookup"-            Just (_ :-> p) -> K p-        Just p -> KV p

@@ -12,7 +12,7 @@  import Data.Array (Array, listArray, (!)) import Network.HPACK.Table.Entry-import qualified Network.HPACK.Table.HashPSQ as HP+import qualified Network.HPACK.Table.DoubleHashMap as DHM  ---------------------------------------------------------------- @@ -48,8 +48,8 @@ staticTable :: Array Index Entry staticTable = listArray (1,staticTableSize) $ map toEntry staticTableList -staticHashPSQ :: HP.HashPSQ SIndex-staticHashPSQ = HP.fromList alist+staticHashPSQ :: DHM.DoubleHashMap SIndex+staticHashPSQ = DHM.fromList alist   where     is = map toStaticIndex [1..]     alist = zip is staticTableList

@@ -11,6 +11,7 @@   , encodeFrame   , encodeFrameChunks   , encodeFrameHeader+  , encodeFrameHeaderBuf   , encodeFramePayload   , EncodeInfo(..)   , encodeInfo@@ -25,21 +26,19 @@   -- * Types   , HeaderBlockFragment   , Padding+  , Weight   , Priority(..)-  , PromisedStreamId-  , LastStreamId-  , StreamDependency-  , WindowSizeIncrement+  , defaultPriority+  , highestPriority   -- * Stream identifier-  , StreamIdentifier-  , fromStreamIdentifier-  , toStreamIdentifier+  , StreamId   , isControl   , isRequest   , isResponse   -- * Stream identifier related   , testExclusive   , setExclusive+  , clearExclusive   -- * Flags   , FrameFlags   , defaultFlags@@ -64,6 +63,13 @@   , Settings(..)   , defaultSettings   , updateSettings+  -- * Window+  , WindowSize+  , defaultInitialWindowSize+  , maxWindowSize+  , isWindowOverflow+  -- * Misc+  , recommendedConcurrency   -- * Error code   , ErrorCode   , ErrorCodeId(..)

@@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections, BangPatterns, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE CPP #-}  module Network.HTTP2.Decode (   -- * Decoding@@ -20,16 +21,19 @@   , decodeContinuationFrame   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Data.Array (Array, listArray, (!)) import Data.Bits (clearBit, shiftL, (.|.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString(..), inlinePerformIO)+import Data.ByteString.Internal (ByteString(..)) import Data.Word import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek)+import System.IO.Unsafe (unsafeDupablePerformIO)  import Network.HTTP2.Types @@ -53,7 +57,7 @@ -- | Decoding an HTTP/2 frame header. --   Must supply 9 bytes. decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)-decodeFrameHeader (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do     let p = ptr +. off     l0 <- fromIntegral <$> peek p     l1 <- fromIntegral <$> peek (p +. 1)@@ -63,7 +67,7 @@     w32 <- word32' (p +. 5)     let !len = (l0 `shiftL` 16) .|. (l1 `shiftL` 8) .|. l2         !sid = streamIdentifier w32-    return $ (typ, FrameHeader len flg sid)+    return (typ, FrameHeader len flg sid)  (+.) :: Ptr Word8 -> Int -> Ptr Word8 (+.) = plusPtr@@ -72,8 +76,7 @@  -- | Checking a frame header and reporting an error if any. ----- >>> let stid = toStreamIdentifier 0--- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 stid))+-- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0)) -- Left (ConnectionError ProtocolError "cannot used in control stream") checkFrameHeader :: Settings                  -> (FrameTypeId, FrameHeader)@@ -178,7 +181,7 @@ decodeSettingsFrame FrameHeader{..} (PS fptr off _) = Right $ SettingsFrame alist   where     num = payloadLength `div` 6-    alist = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+    alist = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do         let p = ptr +. off         settings num p id     settings 0 _ builder = return $ builder []@@ -215,7 +218,7 @@   | wsi == 0  = Left $ ConnectionError ProtocolError "window update must not be 0"   | otherwise = Right $ WindowUpdateFrame wsi   where-    !wsi = word32 bs `clearBit` 31+    !wsi = fromIntegral (word32 bs `clearBit` 31)  decodeContinuationFrame :: FramePayloadDecoder decodeContinuationFrame _ bs = Right $ ContinuationFrame bs@@ -248,11 +251,11 @@   where     padded = testPadded flags -streamIdentifier :: Word32 -> StreamIdentifier-streamIdentifier w32 = toStreamIdentifier (fromIntegral w32)+streamIdentifier :: Word32 -> StreamId+streamIdentifier w32 = clearExclusive $ fromIntegral w32  priority :: ByteString -> Priority-priority (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+priority (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do     let p = ptr +. off     w32 <- word32' p     let !streamdId = streamIdentifier w32@@ -265,7 +268,7 @@ intFromWord8 = fromIntegral  word32 :: ByteString -> Word32-word32 (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+word32 (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do     let p = ptr +. off     word32' p {-# INLINE word32 #-}

@@ -4,6 +4,7 @@     encodeFrame   , encodeFrameChunks   , encodeFrameHeader+  , encodeFrameHeaderBuf   , encodeFramePayload   , EncodeInfo(..)   , encodeInfo@@ -27,7 +28,7 @@     -- | Flags to be set in a frame header       encodeFlags    :: FrameFlags     -- | Stream id to be set in a frame header-    , encodeStreamId :: StreamIdentifier+    , encodeStreamId :: StreamId     -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set.     , encodePadding  :: Maybe Padding     } deriving (Show,Read)@@ -37,11 +38,11 @@ -- | A smart builder of 'EncodeInfo'. -- -- >>> encodeInfo setAck 0--- EncodeInfo {encodeFlags = 1, encodeStreamId = StreamIdentifier 0, encodePadding = Nothing}+-- EncodeInfo {encodeFlags = 1, encodeStreamId = 0, encodePadding = Nothing} encodeInfo :: (FrameFlags -> FrameFlags)            -> Int -- ^ stream identifier            -> EncodeInfo-encodeInfo set stid = EncodeInfo (set defaultFlags) (toStreamIdentifier stid) Nothing+encodeInfo set sid = EncodeInfo (set defaultFlags) sid Nothing  ---------------------------------------------------------------- @@ -66,14 +67,19 @@ -- | Encoding an HTTP/2 frame header. --   The frame header must be completed. encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString-encodeFrameHeader ftid FrameHeader{..} = unsafeCreate frameHeaderLength $ \ptr -> do+encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr++-- | Writing an encoded HTTP/2 frame header to the buffer.+--   The length of the buffer must be larger than or equal to 9 bytes.+encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO ()+encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do     poke24 ptr payloadLength     poke8 ptr 3 typ     poke8 ptr 4 flags     poke32 (ptr `plusPtr` 5) sid   where     typ = fromFrameTypeId ftid-    sid = fromIntegral $ fromStreamIdentifier streamId+    sid = fromIntegral streamId  -- | Encoding an HTTP/2 frame payload. --   This returns a complete frame header and chunks of payload.@@ -132,10 +138,9 @@ buildPriority Priority{..} = builder   where     builder = (priority :)-    stream = fromStreamIdentifier streamDependency     estream-      | exclusive = setExclusive stream-      | otherwise = stream+      | exclusive = setExclusive streamDependency+      | otherwise = streamDependency     priority = unsafeCreate 5 $ \ptr -> do         poke32 ptr $ fromIntegral estream         poke8 ptr 4 $ fromIntegral $ weight - 1@@ -188,11 +193,11 @@     len = length alist * 6     header = FrameHeader len encodeFlags encodeStreamId -buildFramePayloadPushPromise :: EncodeInfo -> StreamIdentifier -> HeaderBlockFragment -> (FrameHeader, Builder)-buildFramePayloadPushPromise einfo stid hdr = buildPadding einfo builder len+buildFramePayloadPushPromise :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len   where     builder = (b4 :) . (hdr :)-    b4 = bytestring4 $ fromIntegral $ fromStreamIdentifier stid+    b4 = bytestring4 $ fromIntegral sid     len = 4 + BS.length hdr  buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder)@@ -201,23 +206,23 @@     builder = (odata :)     header = FrameHeader 8 encodeFlags encodeStreamId -buildFramePayloadGoAway :: EncodeInfo -> LastStreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)+buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder) buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder)   where     builder = (b8 :) . (debug :)     len0 = 8     b8 = unsafeCreate len0 $ \ptr -> do-        poke32 ptr $ fromIntegral $ fromStreamIdentifier sid+        poke32 ptr $ fromIntegral sid         poke32 (ptr `plusPtr` 4) $ fromErrorCodeId e     len = len0 + BS.length debug     header = FrameHeader len encodeFlags encodeStreamId -buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSizeIncrement -> (FrameHeader, Builder)+buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSize -> (FrameHeader, Builder) buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder)   where     -- fixme: reserve bit     builder = (b4 :)-    b4 = bytestring4 size+    b4 = bytestring4 $ fromIntegral size     header = FrameHeader 4 encodeFlags encodeStreamId  buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder)

@@ -1,5 +0,0 @@-module Network.HTTP2.Internal (-    StreamIdentifier(..)-  ) where--import Network.HTTP2.Types

@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}++-- | This is partial implementation of the priority of HTTP/2.+--+-- This implementation does support structured priority queue+-- but not support re-structuring. This means that it is assumed that+-- an entry created by a Priority frame is never closed. The entry+-- behaves an intermediate node, not a leaf.+--+-- This queue is fair for weight. Consider two weights: 201 and 101.+-- Repeating enqueue/dequeue probably produces+-- 201, 201, 101, 201, 201, 101, ... based on randomness.+--+-- Only one entry per stream should be enqueue.+-- If multiple entries for a stream are inserted, the ordering+-- is not preserved because of the randomness.++module Network.HTTP2.Priority (+    PriorityTree+  , newPriorityTree+  , prepare+  , enqueue+  , dequeue+  ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Control.Concurrent.STM+import Control.Monad (when, unless)+import qualified Data.IntMap.Strict as Map+import Data.IntMap.Strict (IntMap)+import Network.HTTP2.RandomSkewHeap (Heap)+import qualified Network.HTTP2.RandomSkewHeap as Heap+import Network.HTTP2.Types++----------------------------------------------------------------++type Struct a = (PriorityQueue a, Priority)+-- | Abstract data type for priority trees.+data PriorityTree a = PriorityTree (TVar (IntMap (Struct a)))+                                   (PriorityQueue a)+-- INVARIANT: Empty PriorityQueue is never enqueued in+-- another PriorityQueue.+type PriorityQueue a = TPQueue (Element a)+data Element a = Child a+               | Parent (PriorityQueue a)++-- | Creating a new priority tree.+newPriorityTree :: IO (PriorityTree a)+newPriorityTree = PriorityTree <$> newTVarIO Map.empty <*> atomically newTPQueue++newPriorityQueue :: STM (PriorityQueue a)+newPriorityQueue = TPQueue <$> newTVar Heap.empty++----------------------------------------------------------------++-- | Bringing up the structure of the priority tree.+--   This must be used for Priority frame.+prepare :: PriorityTree a -> StreamId -> Priority -> IO ()+prepare (PriorityTree var _) sid p = atomically $ do+    q <- newPriorityQueue+    modifyTVar' var $ Map.insert sid (q, p)++-- | Enqueuing an element to the priority tree.+--   This must be used for Header frame.+enqueue :: PriorityTree a -> a -> Priority -> IO ()+enqueue (PriorityTree var q0) a p0 = atomically $ do+    m <- readTVar var+    loop m (Child a) p0+  where+    loop m el p+      | pid == 0  = writeTPQueue q0 el p+      | otherwise = case Map.lookup pid m of+          Nothing -> writeTPQueue q0 el defaultPriority -- error case: checkme+          Just (q', p') -> do+              notQueued <- isTPQueueEmpty q'+              writeTPQueue q' el p+              when notQueued $ loop m (Parent q') p'+      where+        pid = streamDependency p++-- | Dequeuing an element from the priority tree.+dequeue :: PriorityTree a -> IO (a, Priority)+dequeue (PriorityTree _ q0) = atomically (loop q0)+  where+    loop q = do+        (el, w) <- readTPQueue q+        case el of+            Child  a      -> return (a, w)+            p@(Parent q') -> do+                r <- loop q'+                empty <- isTPQueueEmpty q'+                unless empty $ writeTPQueue q p w+                return r++----------------------------------------------------------------+--+-- The following code is originally written by Fumiaki Kinoshita+--++newtype TPQueue a = TPQueue (TVar (Heap (a,Priority)))++newTPQueue :: STM (TPQueue a)+newTPQueue = TPQueue <$> newTVar Heap.empty++readTPQueue :: TPQueue a -> STM (a, Priority)+readTPQueue (TPQueue th) = do+  h <- readTVar th+  case Heap.uncons h of+    Nothing -> retry+    Just (ap, _, h') -> do+      writeTVar th h'+      return ap++writeTPQueue :: TPQueue a -> a -> Priority -> STM ()+writeTPQueue (TPQueue th) a p = modifyTVar' th $ Heap.insert (a,p) (weight p)++isTPQueueEmpty :: TPQueue a -> STM Bool+isTPQueueEmpty (TPQueue th) = Heap.isEmpty <$> readTVar th

@@ -0,0 +1,67 @@+{-# LANGUAGE BangPatterns #-}++-- This data structure is based on skew heap.+--+-- If we take weight as priority, a typical heap (priority queue)+-- is not fair enough. Consider two weight 201 for A and 101 for B.+-- A typical heap would generate A(201), A(200), A(199), A(198), ....,+-- and finaly A(101), B(101), A(100), B(100).+-- What we want is A, A, B, A, A, B...+--+-- So, we introduce randomness to Skew Heap.+--+-- In the random binary tree,+-- an element is selected as the root with probability of+-- 1 / (n + 1) where n is the size of the original tree.+-- In the random skew heap, an element is selected as the root+-- with the probability of weight / total_weight.+--+-- Since this data structure uses random numbers, APIs should be+-- essentially impure. But since this is used with STM,+-- APIs are made to be pure with unsafePerformIO.++module Network.HTTP2.RandomSkewHeap (+    Heap+  , empty+  , isEmpty+  , singleton+  , insert+  , uncons+  ) where++import Network.HTTP2.Types (Weight)+import System.IO.Unsafe (unsafePerformIO)+import System.Random.Mersenne (randomIO)++data Heap a = Leaf | Node Weight -- total+                          a Weight !(Heap a) !(Heap a) deriving Show++empty :: Heap a+empty = Leaf++isEmpty :: Heap a -> Bool+isEmpty Leaf = True+isEmpty _    = False++singleton :: a -> Weight -> Heap a+singleton a w = Node w a w Leaf Leaf++insert :: a -> Weight -> Heap a -> Heap a+insert a w t = merge (singleton a w) t++merge :: Heap t -> Heap t -> Heap t+merge t Leaf = t+merge Leaf t = t+merge l@(Node tw1 a1 w1 l1 r1) r@(Node tw2 a2 w2 l2 r2)+  | g < w1    = Node tw a1 w1 r1 $ merge l1 r+  | otherwise = Node tw a2 w2 r2 $ merge l2 l+  where+    tw = tw1 + tw2+    g = unsafePerformIO randomIO `mod` tw+{-# NOINLINE merge #-}++uncons :: Heap a -> Maybe (a, Weight, Heap a)+uncons Leaf             = Nothing+uncons (Node _ a w l r) = Just (a, w, t)+  where+    !t = merge l r

@@ -38,17 +38,13 @@   , framePayloadToFrameTypeId   , isPaddingDefined   -- * Stream identifier-  , StreamIdentifier(..)-  , fromStreamIdentifier-  , toStreamIdentifier+  , StreamId   , isControl   , isRequest   , isResponse-  , PromisedStreamId-  , LastStreamId-  , StreamDependency   , testExclusive   , setExclusive+  , clearExclusive   -- * Flags   , FrameFlags   , defaultFlags@@ -62,10 +58,19 @@   , setEndHeader   , setPadded   , setPriority+  -- * Window+  , WindowSize+  , defaultInitialWindowSize+  , maxWindowSize+  , isWindowOverflow+  -- * Misc+  , recommendedConcurrency   -- * Types-  , WindowSizeIncrement   , HeaderBlockFragment+  , Weight   , Priority(..)+  , defaultPriority+  , highestPriority   , Padding   ) where @@ -159,7 +164,7 @@  -- | The connection error or the stream error. data HTTP2Error = ConnectionError ErrorCodeId ByteString-                | StreamError ErrorCodeId StreamIdentifier+                | StreamError ErrorCodeId StreamId                 deriving (Eq, Show, Typeable, Read)  instance E.Exception HTTP2Error@@ -243,7 +248,7 @@     headerTableSize :: Int   , enablePush :: Bool   , maxConcurrentStreams :: Maybe Int-  , initialWindowSize :: Int+  , initialWindowSize :: WindowSize   , maxFrameSize :: Int   , maxHeaderBlockSize :: Maybe Int   } deriving (Show)@@ -257,7 +262,7 @@     headerTableSize = 4096   , enablePush = True   , maxConcurrentStreams = Nothing-  , initialWindowSize = 65535+  , initialWindowSize = defaultInitialWindowSize   , maxFrameSize = 16384   , maxHeaderBlockSize = Nothing   }@@ -277,14 +282,65 @@     update (SettingsMaxFrameSize,x)         def = def { maxFrameSize = x }     update (SettingsMaxHeaderBlockSize,x)   def = def { maxHeaderBlockSize = Just x } +type WindowSize = Int++-- | The default initial window size.+--+-- >>> defaultInitialWindowSize+-- 65535+defaultInitialWindowSize :: WindowSize+defaultInitialWindowSize = 65535++-- | The maximum window size.+--+-- >>> maxWindowSize+-- 2147483647+maxWindowSize :: WindowSize+maxWindowSize = 2147483647++-- | Checking if a window size exceeds the maximum window size.+--+-- >>> isWindowOverflow 10+-- False+-- >>> isWindowOverflow maxWindowSize+-- False+-- >>> isWindowOverflow (maxWindowSize + 1)+-- True+isWindowOverflow :: WindowSize -> Bool+isWindowOverflow w = testBit w 31+++-- | Default concurrency.+--+-- >>> recommendedConcurrency+-- 100+recommendedConcurrency :: Int+recommendedConcurrency = 100+ ---------------------------------------------------------------- +type Weight = Int+ data Priority = Priority {     exclusive :: Bool-  , streamDependency :: StreamIdentifier-  , weight :: Int+  , streamDependency :: StreamId+  , weight :: Weight   } deriving (Show, Read, Eq) +-- | Default priority which depends on stream 0.+--+-- >>> defaultPriority+-- Priority {exclusive = False, streamDependency = 0, weight = 16}+defaultPriority :: Priority+defaultPriority = Priority False 0 16++-- | Highest priority which depends on stream 0.+--+-- >>> highestPriority+-- Priority {exclusive = False, streamDependency = 0, weight = 256}+highestPriority :: Priority+highestPriority = Priority False 0 256+ ----------------------------------------------------------------  type FrameType = Word8@@ -433,48 +489,33 @@  ---------------------------------------------------------------- -newtype StreamIdentifier = StreamIdentifier Int deriving (Show, Read, Eq)-type StreamDependency    = StreamIdentifier-type LastStreamId        = StreamIdentifier-type PromisedStreamId    = StreamIdentifier---- |--- >>> toStreamIdentifier 0--- StreamIdentifier 0-toStreamIdentifier :: Int -> StreamIdentifier-toStreamIdentifier n = StreamIdentifier (n `clearBit` 31)---- |--- >>> fromStreamIdentifier (toStreamIdentifier 0)--- 0-fromStreamIdentifier :: StreamIdentifier -> Int-fromStreamIdentifier (StreamIdentifier n) = n+type StreamId = Int  -- |--- >>> isControl $ toStreamIdentifier 0+-- >>> isControl 0 -- True--- >>> isControl $ toStreamIdentifier 1+-- >>> isControl 1 -- False-isControl :: StreamIdentifier -> Bool-isControl (StreamIdentifier 0) = True-isControl _                    = False+isControl :: StreamId -> Bool+isControl 0 = True+isControl _ = False  -- |--- >>> isRequest $ toStreamIdentifier 0+-- >>> isRequest 0 -- False--- >>> isRequest $ toStreamIdentifier 1+-- >>> isRequest 1 -- True-isRequest :: StreamIdentifier -> Bool-isRequest (StreamIdentifier n) = odd n+isRequest :: StreamId -> Bool+isRequest = odd  -- |--- >>> isResponse $ toStreamIdentifier 0+-- >>> isResponse 0 -- False--- >>> isResponse $ toStreamIdentifier 2+-- >>> isResponse 2 -- True-isResponse :: StreamIdentifier -> Bool-isResponse (StreamIdentifier 0) = False-isResponse (StreamIdentifier n) = even n+isResponse :: StreamId -> Bool+isResponse 0 = False+isResponse n = even n  testExclusive :: Int -> Bool testExclusive n = n `testBit` 31@@ -482,9 +523,11 @@ setExclusive :: Int -> Int setExclusive n = n `setBit` 31 +clearExclusive :: Int -> Int+clearExclusive n = n `clearBit` 31+ ---------------------------------------------------------------- -type WindowSizeIncrement = Word32 type HeaderBlockFragment = ByteString type Padding = ByteString @@ -500,7 +543,7 @@ data FrameHeader = FrameHeader     { payloadLength :: Int     , flags         :: FrameFlags-    , streamId      :: StreamIdentifier+    , streamId      :: StreamId     } deriving (Show, Read, Eq)  -- | The data type for HTTP/2 frame payloads.@@ -510,10 +553,10 @@   | PriorityFrame Priority   | RSTStreamFrame ErrorCodeId   | SettingsFrame SettingsList-  | PushPromiseFrame PromisedStreamId HeaderBlockFragment+  | PushPromiseFrame StreamId HeaderBlockFragment   | PingFrame ByteString-  | GoAwayFrame LastStreamId ErrorCodeId ByteString-  | WindowUpdateFrame WindowSizeIncrement+  | GoAwayFrame StreamId ErrorCodeId ByteString+  | WindowUpdateFrame WindowSize   | ContinuationFrame HeaderBlockFragment   | UnknownFrame FrameType ByteString   deriving (Show, Read, Eq)

@@ -1,5 +1,5 @@ Name:                   http2-Version:                0.9.1+Version:                1.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -28,7 +28,7 @@   GHC-Options:          -Wall   Exposed-Modules:      Network.HPACK                         Network.HTTP2-                        Network.HTTP2.Internal+                        Network.HTTP2.Priority   Other-Modules:        Network.HPACK.Builder                         Network.HPACK.Builder.Word8                         Network.HPACK.Huffman@@ -48,20 +48,22 @@                         Network.HPACK.HeaderBlock.String                         Network.HPACK.HeaderBlock.To                         Network.HPACK.Table+                        Network.HPACK.Table.DoubleHashMap                         Network.HPACK.Table.Dynamic                         Network.HPACK.Table.Entry-                        Network.HPACK.Table.HashPSQ                         Network.HPACK.Table.Static                         Network.HPACK.Types                         Network.HTTP2.Decode                         Network.HTTP2.Encode+                        Network.HTTP2.RandomSkewHeap                         Network.HTTP2.Types   Build-Depends:        base >= 4 && < 5-                      , PSQueue                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers+                      , mersenne-random+                      , stm                       , unordered-containers  ----------------------------------------------------------------@@ -87,14 +89,16 @@                         HPACK.HuffmanSpec                         HPACK.IntegerSpec                         HTTP2.FrameSpec+                        HTTP2.PrioritySpec   Build-Depends:        base >= 4 && < 5-                      , PSQueue                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers                       , hex                       , hspec >= 1.3+                      , mersenne-random+                      , stm                       , unordered-containers                       , word8 @@ -112,8 +116,8 @@                       , aeson                       , aeson-pretty                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers                       , directory                       , filepath@@ -162,8 +166,8 @@                       , aeson                       , aeson-pretty                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers                       , hex                       , text@@ -184,8 +188,8 @@                       , PSQueue                       , aeson                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers                       , hex                       , text@@ -207,8 +211,8 @@                       , aeson                       , aeson-pretty                       , array-                      , blaze-builder                       , bytestring+                      , bytestring-builder                       , containers                       , directory                       , filepath

@@ -1,8 +1,10 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-}  module Case where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Data.ByteString (ByteString) import Data.Hex import Data.Maybe (fromJust)

@@ -1,10 +1,12 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module JSON where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>))+#endif import Control.Arrow (first) import Control.Monad (mzero) import Data.Aeson@@ -18,7 +20,6 @@ import qualified Data.Text as T  import Network.HTTP2-import Network.HTTP2.Internal  ---------------------------------------------------------------- @@ -57,11 +58,13 @@  ---------------------------------------------------------------- +{- instance ToJSON StreamIdentifier where     toJSON (StreamIdentifier s) = toJSON s  instance FromJSON StreamIdentifier where     parseJSON x = StreamIdentifier <$> parseJSON x+-}  instance ToJSON ErrorCodeId where     toJSON e = toJSON $ fromErrorCodeId e@@ -133,7 +136,7 @@         "length" .= payloadLength frameHeader       , "type" .= fromFrameTypeId (framePayloadToFrameTypeId framePayload)       , "flags" .= flags frameHeader-      , "stream_identifier" .= fromStreamIdentifier (streamId frameHeader)+      , "stream_identifier" .= streamId frameHeader       , "frame_payload" .= (toJSON framePayload +++ padObj)       ]       where

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-}  module HPACKDecode (     run@@ -8,7 +8,9 @@   , CompressionAlgo(..)   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Exception import Control.Monad (when) import qualified Data.ByteString.Char8 as B8

@@ -1,6 +1,10 @@+{-# LANGUAGE CPP #-}+ module HPACKSpec where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Monad (forM_, filterM) import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module JSON (@@ -7,7 +7,9 @@   , HeaderList   ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative+#endif import Control.Monad (mzero) import Data.Aeson import Data.ByteString (ByteString)

@@ -1,8 +1,10 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, CPP #-}  module Main where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative+#endif import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BL

@@ -16,7 +16,7 @@             let header = FrameHeader {                     payloadLength = 500                   , flags = defaultFlags-                  , streamId = StreamIdentifier 10+                  , streamId = 10                   }                 wire = encodeFrameHeader FramePriority header                 fibHeader = decodeFrameHeader wire@@ -26,7 +26,7 @@         it "encode/decodes frames properly" $ do             let einfo = EncodeInfo {                     encodeFlags = defaultFlags-                  , encodeStreamId = StreamIdentifier 2+                  , encodeStreamId = 2                   , encodePadding = Nothing                   }                 payload = DataFrame "Hello, world!"@@ -37,7 +37,7 @@         it "encode/decodes padded frames properly" $ do             let einfo = EncodeInfo {                     encodeFlags = defaultFlags-                  , encodeStreamId = StreamIdentifier 2+                  , encodeStreamId = 2                   , encodePadding = Just "padding!"                   }                 payload = DataFrame "Hello, world!"

@@ -0,0 +1,47 @@+module HTTP2.PrioritySpec where++import Test.Hspec++import Control.Monad (void)+import Network.HTTP2.Priority+import Network.HTTP2.Types++spec :: Spec+spec = do+    describe "enqueue & dequeue" $ do+        it "enqueue and dequeue frames from Firefox properly" $ do+            pt <- newPriorityTree :: IO (PriorityTree Int)+            prepare pt 3 $ Priority False 0 201+            prepare pt 5 $ Priority False 0 101+            prepare pt 7 $ Priority False 0 1+            prepare pt 9 $ Priority False 7 1+            prepare pt 11 $ Priority False 3 1+            enqueue pt 13 $ Priority False 11 32+            (sid13,_) <- dequeue pt+            sid13 `shouldBe` 13+            enqueue pt 15 $ Priority False 3 32+            enqueue pt 17 $ Priority False 3 32+            enqueue pt 19 $ Priority False 3 32+            enqueue pt 21 $ Priority False 3 32+            enqueue pt 23 $ Priority False 3 32+            enqueue pt 25 $ Priority False 3 32+            enqueue pt 27 $ Priority False 11 22+            enqueue pt 29 $ Priority False 11 22+            enqueue pt 31 $ Priority False 11 22+            enqueue pt 33 $ Priority False 5 32+            enqueue pt 35 $ Priority False 5 32+            enqueue pt 37 $ Priority False 5 32+            -- Currently, just checking no errors.+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+            void $ dequeue pt+