http2 1.6.5 → 2.0.0
raw patch · 45 files changed
+2398/−391 lines, 45 filesdep +gaugedep +http-typesdep +networkdep −criteriondep ~network-byte-order
Dependencies added: gauge, http-types, network, time-manager
Dependencies removed: criterion
Dependency ranges changed: network-byte-order
Files
- ChangeLog.md +14/−0
- Imports.hs +27/−0
- Network/HPACK.hs +1/−0
- Network/HPACK/Buffer.hs +0/−195
- Network/HPACK/HeaderBlock.hs +1/−0
- Network/HPACK/HeaderBlock/Decode.hs +32/−32
- Network/HPACK/HeaderBlock/Encode.hs +26/−30
- Network/HPACK/HeaderBlock/Integer.hs +12/−16
- Network/HPACK/Huffman/Bit.hs +1/−2
- Network/HPACK/Huffman/ByteString.hs +2/−4
- Network/HPACK/Huffman/Decode.hs +10/−10
- Network/HPACK/Huffman/Encode.hs +13/−19
- Network/HPACK/Huffman/Table.hs +1/−1
- Network/HPACK/Huffman/Tree.hs +2/−1
- Network/HPACK/Table.hs +1/−4
- Network/HPACK/Table/Dynamic.hs +4/−6
- Network/HPACK/Table/RevIndex.hs +3/−5
- Network/HPACK/Types.hs +5/−16
- Network/HTTP2.hs +2/−1
- Network/HTTP2/Decode.hs +1/−8
- Network/HTTP2/Encode.hs +2/−2
- Network/HTTP2/Priority.hs +2/−5
- Network/HTTP2/Priority/PSQ.hs +1/−6
- Network/HTTP2/Priority/Queue.hs +0/−5
- Network/HTTP2/Server.hs +156/−0
- Network/HTTP2/Server/API.hs +131/−0
- Network/HTTP2/Server/Config.hs +27/−0
- Network/HTTP2/Server/Context.hs +111/−0
- Network/HTTP2/Server/EncodeFrame.hs +34/−0
- Network/HTTP2/Server/File.hs +16/−0
- Network/HTTP2/Server/HPACK.hs +124/−0
- Network/HTTP2/Server/Manager.hs +113/−0
- Network/HTTP2/Server/Queue.hs +37/−0
- Network/HTTP2/Server/ReadN.hs +35/−0
- Network/HTTP2/Server/Receiver.hs +432/−0
- Network/HTTP2/Server/Run.hs +58/−0
- Network/HTTP2/Server/Sender.hs +457/−0
- Network/HTTP2/Server/Stream.hs +74/−0
- Network/HTTP2/Server/Types.hs +112/−0
- Network/HTTP2/Server/Worker.hs +213/−0
- Network/HTTP2/Types.hs +2/−5
- bench-hpack/Main.hs +1/−1
- bench-priority/Main.hs +1/−1
- http2.cabal +94/−11
- test/HPACK/EncodeSpec.hs +7/−5
ChangeLog.md view
@@ -1,3 +1,17 @@+## 2.0.0++* Providing Network.HTTP.Server.++## 1.6.5++* Deny shrink of dynamic table to zero size+ [#17](https://github.com/kazu-yamamoto/http2/pull/17)++## 1.6.4++* checkFrameHeader for FrameHeaders.+ [#15](https://github.com/kazu-yamamoto/http2/pull/15)+ ## 1.6.3 * Fixing two bugs of HPACK pointed out by h2spec v2.
+ Imports.hs view
@@ -0,0 +1,27 @@+module Imports (+ ByteString(..)+ , module Control.Applicative+ , module Control.Monad+ , module Data.Bits+ , module Data.List+ , module Data.Foldable+ , module Data.Int+ , module Data.Monoid+ , module Data.Ord+ , module Data.Word+ , module Data.Maybe+ , module Numeric+ ) where++import Control.Applicative+import Control.Monad+import Data.Bits hiding (Bits)+import Data.ByteString.Internal (ByteString(..))+import Data.Foldable+import Data.Int+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Word+import Numeric
Network/HPACK.hs view
@@ -33,6 +33,7 @@ , TokenHeader -- * Value table , ValueTable+ , HeaderTable , getHeaderValue , toHeaderTable -- * Basic types
− Network/HPACK/Buffer.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE BangPatterns, RecordWildCards, CPP #-}--module Network.HPACK.Buffer (- Buffer- , BufferSize- , WorkingBuffer(..)- , newWorkingBuffer- , wind- , readWord8- , writeWord8- , shiftLastN- , returnLength- , toByteString- , copyByteString- , withTemporaryBuffer- , currentOffset- , ReadBuffer- , withReadBuffer- , hasOneByte- , hasMoreBytes- , rewindOneByte- , getByte- , getByte'- , extractByteString- ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif-import Control.Exception (bracket, throwIO)-import Data.ByteString.Internal (ByteString(..), create, memcpy)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Alloc-import Foreign.Ptr (plusPtr, minusPtr)-import Foreign.Storable (peek, poke)-import Network.HPACK.Types (Buffer, BufferSize, BufferOverrun(..))--------------------------------------------------------------------data WorkingBuffer = WorkingBuffer {- start :: !Buffer- , limit :: !Buffer- , offset :: !(IORef Buffer)- }--newWorkingBuffer :: Buffer -> BufferSize -> IO WorkingBuffer-newWorkingBuffer buf siz = WorkingBuffer buf (buf `plusPtr` siz) <$> newIORef buf--{-# INLINE wind #-}-wind :: WorkingBuffer -> Int -> IO ()-wind WorkingBuffer{..} n = do- ptr <- readIORef offset- let !ptr' = ptr `plusPtr` n- writeIORef offset ptr'--{-# INLINE readWord8 #-}-readWord8 :: WorkingBuffer -> IO Word8-readWord8 WorkingBuffer{..} = readIORef offset >>= peek--{-# INLINE writeWord8 #-}-writeWord8 :: WorkingBuffer -> Word8 -> IO ()-writeWord8 WorkingBuffer{..} w = do- ptr <- readIORef offset- if ptr >= limit then- throwIO BufferOverrun- else do- poke ptr w- let !ptr' = ptr `plusPtr` 1- writeIORef offset ptr'--{-# INLINE shiftLastN #-}-shiftLastN :: WorkingBuffer -> Int -> Int -> IO ()-shiftLastN WorkingBuffer{..} 0 _ = return ()-shiftLastN WorkingBuffer{..} i len = do- ptr <- readIORef offset- let !ptr' = ptr `plusPtr` i- if ptr' >= limit then- throwIO BufferOverrun- else if i < 0 then do- let !src = ptr `plusPtr` negate len- !dst = src `plusPtr` i- shiftLeft dst src len- writeIORef offset ptr'- else do- let !src = ptr `plusPtr` (-1)- !dst = ptr' `plusPtr` (-1)- shiftRight dst src len- writeIORef offset ptr'- where- -- memcpy cannot be used for overlapped areas.- shiftLeft :: Buffer -> Buffer -> Int -> IO ()- shiftLeft _ _ 0 = return ()- shiftLeft !dst !src n = do- peek src >>= poke dst- shiftLeft (dst `plusPtr` 1) (src `plusPtr` 1) (n - 1)- shiftRight :: Buffer -> Buffer -> Int -> IO ()- shiftRight _ _ 0 = return ()- shiftRight !dst !src n = do- peek src >>= poke dst- shiftRight (dst `plusPtr` (-1)) (src `plusPtr` (-1)) (n - 1)--{-# INLINE copyByteString #-}-copyByteString :: WorkingBuffer -> ByteString -> IO ()-copyByteString WorkingBuffer{..} (PS fptr off len) = withForeignPtr fptr $ \ptr -> do- let src = ptr `plusPtr` off- dst <- readIORef offset- let !dst' = dst `plusPtr` len- if dst' >= limit then- throwIO BufferOverrun- else do- memcpy dst src len- writeIORef offset dst'--toByteString :: WorkingBuffer -> IO ByteString-toByteString WorkingBuffer{..} = do- ptr <- readIORef offset- let !len = ptr `minusPtr` start- create len $ \p -> memcpy p start len--{-# INLINE returnLength #-}-returnLength :: WorkingBuffer -> IO () -> IO Int-returnLength WorkingBuffer{..} body = do- beg <- readIORef offset- body- end <- readIORef offset- return $ end `minusPtr` beg--withTemporaryBuffer :: Int -> (WorkingBuffer -> IO ()) -> IO ByteString-withTemporaryBuffer siz action = bracket (mallocBytes siz) free $ \buf -> do- wbuf <- newWorkingBuffer buf 4096- action wbuf- toByteString wbuf--currentOffset :: WorkingBuffer -> IO Buffer-currentOffset WorkingBuffer{..} = readIORef offset--------------------------------------------------------------------data ReadBuffer = ReadBuffer {- beg :: !Buffer- , end :: !Buffer- , cur :: !(IORef Buffer)- }--withReadBuffer :: ByteString -> (ReadBuffer -> IO a) -> IO a-withReadBuffer (PS fp off len) action = withForeignPtr fp $ \ptr -> do- let !bg = ptr `plusPtr` off- !ed = bg `plusPtr` len- nsrc <- ReadBuffer bg ed <$> newIORef bg- action nsrc--{-# INLINE hasOneByte #-}-hasOneByte :: ReadBuffer -> IO Bool-hasOneByte ReadBuffer{..} = do- ptr <- readIORef cur- return $! ptr < end--{-# INLINE hasMoreBytes #-}-hasMoreBytes :: ReadBuffer -> Int -> IO Bool-hasMoreBytes ReadBuffer{..} n = do- ptr <- readIORef cur- return $! (end `minusPtr` ptr) >= n--{-# INLINE rewindOneByte #-}-rewindOneByte :: ReadBuffer -> IO ()-rewindOneByte ReadBuffer{..} = modifyIORef' cur (`plusPtr` (-1))--{-# INLINE getByte #-}-getByte :: ReadBuffer -> IO Word8-getByte ReadBuffer{..} = do- ptr <- readIORef cur- w <- peek ptr- writeIORef cur $! ptr `plusPtr` 1- return w--{-# INLINE getByte' #-}-getByte' :: ReadBuffer -> IO Int-getByte' ReadBuffer{..} = do- ptr <- readIORef cur- if ptr < end then do- w <- peek ptr- writeIORef cur $! ptr `plusPtr` 1- let !i = fromIntegral w- return i- else- return (-1)--extractByteString :: ReadBuffer -> Int -> IO ByteString-extractByteString ReadBuffer{..} len = do- src <- readIORef cur- bs <- create len $ \dst -> memcpy dst src len- writeIORef cur $! src `plusPtr` len- return bs
Network/HPACK/HeaderBlock.hs view
@@ -2,6 +2,7 @@ decodeHeader , decodeTokenHeader , ValueTable+ , HeaderTable , toHeaderTable , getHeaderValue , encodeHeader
Network/HPACK/HeaderBlock/Decode.hs view
@@ -1,31 +1,26 @@-{-# LANGUAGE BangPatterns, CPP, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Decode ( decodeHeader , decodeTokenHeader , ValueTable+ , HeaderTable , toHeaderTable , getHeaderValue ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Exception (throwIO)-import Control.Monad (unless, when)-import Data.Maybe (isJust) import Data.Array (Array) import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite) import qualified Data.Array.IO as IOA import qualified Data.Array.Unsafe as Unsafe-import Data.Bits (testBit, clearBit, (.&.))-import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.Char (isUpper) import Data.CaseInsensitive (CI(..))-import Data.Word (Word8)-import Network.HPACK.Buffer+import Network.ByteOrder++import Imports hiding (empty) import Network.HPACK.Builder import qualified Network.HPACK.HeaderBlock.Integer as I import Network.HPACK.Huffman@@ -33,7 +28,9 @@ import Network.HPACK.Token import Network.HPACK.Types --- | An array for 'HeaderValue'.+-- | An array to get 'HeaderValue' quickly.+-- 'getHeaderValue' should be used.+-- Internally, the key is 'Token' 'ix'. type ValueTable = Array Int (Maybe HeaderValue) -- | Accessing 'HeaderValue' with 'Token'.@@ -69,7 +66,7 @@ -- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeTokenHeader :: DynamicTable -> ByteString -- ^ An HPACK format- -> IO (TokenHeaderList, ValueTable)+ -> IO HeaderTable decodeTokenHeader dyntbl inp = decodeHPACK dyntbl inp decodeSophisticated decodeHPACK :: DynamicTable@@ -79,14 +76,14 @@ decodeHPACK dyntbl inp dec = withReadBuffer inp chkChange where chkChange rbuf = do- more <- hasOneByte rbuf- if more then do- w <- getByte rbuf+ leftover <- remainingSize rbuf+ if leftover >= 1 then do+ w <- read8 rbuf if isTableSizeUpdate w then do tableSizeUpdate dyntbl w rbuf chkChange rbuf else do- rewindOneByte rbuf+ ff rbuf (-1) dec dyntbl rbuf else throwIO HeaderBlockTruncated@@ -95,9 +92,9 @@ decodeSimple dyntbl rbuf = go empty where go builder = do- more <- hasOneByte rbuf- if more then do- w <- getByte rbuf+ leftover <- remainingSize rbuf+ if leftover >= 1 then do+ w <- read8 rbuf !tv <- toTokenHeader dyntbl w rbuf let builder' = builder << tv go builder'@@ -107,7 +104,7 @@ return kvs decodeSophisticated :: DynamicTable -> ReadBuffer- -> IO (TokenHeaderList, ValueTable)+ -> IO HeaderTable decodeSophisticated dyntbl rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing@@ -119,9 +116,9 @@ pseudoNormal arr = pseudo where pseudo = do- more <- hasOneByte rbuf- if more then do- w <- getByte rbuf+ leftover <- remainingSize rbuf+ if leftover >= 1 then do+ w <- read8 rbuf tv@(!Token{..},!v) <- toTokenHeader dyntbl w rbuf if isPseudo then do mx <- unsafeRead arr ix@@ -140,9 +137,9 @@ else return [] normal !builder !cookie = do- more <- hasOneByte rbuf- if more then do- w <- getByte rbuf+ leftover <- remainingSize rbuf+ if leftover >= 1 then do+ w <- read8 rbuf tv@(Token{..},!v) <- toTokenHeader dyntbl w rbuf when isPseudo $ throwIO IllegalHeaderName when (isMaxTokenIx ix && B8.any isUpper (original tokenKey)) $@@ -231,9 +228,9 @@ headerStuff :: DynamicTable -> ReadBuffer -> IO HeaderStuff headerStuff dyntbl rbuf = do- more <- hasOneByte rbuf- if more then do- w <- getByte rbuf+ leftover <- remainingSize rbuf+ if leftover >= 1 then do+ w <- read8 rbuf let !p = dropHuffman w !huff = isHuffman w !len <- I.decode 7 p rbuf@@ -273,8 +270,8 @@ decodeString :: Bool -> HuffmanDecoding -> ReadBuffer -> Int -> IO HeaderStuff decodeString huff hufdec rbuf len = do- more <- hasMoreBytes rbuf len- if more then+ leftover <- remainingSize rbuf+ if leftover >= len then if huff then hufdec rbuf len else@@ -285,9 +282,12 @@ ---------------------------------------------------------------- +-- | A pair of token list and value table.+type HeaderTable = (TokenHeaderList, ValueTable)+ -- | Converting a header list of the http-types style to -- 'TokenHeaderList' and 'ValueTable'.-toHeaderTable :: [(CI HeaderName,HeaderValue)] -> IO (TokenHeaderList, ValueTable)+toHeaderTable :: [(CI HeaderName,HeaderValue)] -> IO HeaderTable toHeaderTable kvs = do arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing !tvs <- conv arr
Network/HPACK/HeaderBlock/Encode.hs view
@@ -1,24 +1,20 @@-{-# LANGUAGE CPP, BangPatterns, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Encode ( encodeHeader , encodeTokenHeader ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Exception (bracket, throwIO) import qualified Control.Exception as E-import Control.Monad (when)-import Data.Bits (setBit) import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString, create, memcpy)+import Data.ByteString.Internal (create, memcpy) import Data.IORef-import Data.Word (Word8)-import Foreign.Marshal.Alloc+import Foreign.Marshal.Alloc (mallocBytes, free) import Foreign.Ptr (minusPtr)-import Network.HPACK.Buffer+import Network.ByteOrder++import Imports import qualified Network.HPACK.HeaderBlock.Integer as I import qualified Network.HPACK.Huffman as Huffman import Network.HPACK.Table@@ -27,7 +23,7 @@ ---------------------------------------------------------------- -changeTableSize :: DynamicTable -> WorkingBuffer -> IO ()+changeTableSize :: DynamicTable -> WriteBuffer -> IO () changeTableSize dyntbl wbuf = do msiz <- needChangeTableSize dyntbl case msiz of@@ -94,7 +90,7 @@ -> TokenHeaderList -> IO (TokenHeaderList, Int) -- ^ Leftover, filled length encodeTokenHeader buf siz EncodeStrategy{..} first dyntbl hs0 = do- wbuf <- newWorkingBuffer buf siz+ wbuf <- newWriteBuffer buf siz when first $ changeTableSize dyntbl wbuf let fa = indexedHeaderField dyntbl wbuf useHuffman fb = literalHeaderFieldWithIncrementalIndexingIndexedName dyntbl wbuf useHuffman@@ -150,14 +146,14 @@ -- 6.1. Indexed Header Field Representation -- Indexed Header Field indexedHeaderField- :: DynamicTable -> WorkingBuffer -> Bool -> FA+ :: DynamicTable -> WriteBuffer -> Bool -> FA indexedHeaderField dyntbl wbuf _ hidx = fromHIndexToIndex dyntbl hidx >>= index wbuf -- 6.2.1. Literal Header Field with Incremental Indexing -- Literal Header Field with Incremental Indexing -- Indexed Name literalHeaderFieldWithIncrementalIndexingIndexedName- :: DynamicTable -> WorkingBuffer -> Bool -> FB+ :: DynamicTable -> WriteBuffer -> Bool -> FB literalHeaderFieldWithIncrementalIndexingIndexedName dyntbl wbuf huff v ent hidx = do fromHIndexToIndex dyntbl hidx >>= indexedName wbuf huff 6 set01 v insertEntry ent dyntbl@@ -165,7 +161,7 @@ -- 6.2.1. Literal Header Field with Incremental Indexing -- Literal Header Field with Incremental Indexing -- New Name literalHeaderFieldWithIncrementalIndexingNewName- :: DynamicTable -> WorkingBuffer -> Bool -> FC+ :: DynamicTable -> WriteBuffer -> Bool -> FC literalHeaderFieldWithIncrementalIndexingNewName dyntbl wbuf huff k v ent = do newName wbuf huff set01 k v insertEntry ent dyntbl@@ -173,44 +169,44 @@ -- 6.2.2. Literal Header Field without Indexing -- Literal Header Field without Indexing -- Indexed Name literalHeaderFieldWithoutIndexingIndexedName- :: DynamicTable -> WorkingBuffer -> Bool -> FD+ :: DynamicTable -> WriteBuffer -> Bool -> FD literalHeaderFieldWithoutIndexingIndexedName dyntbl wbuf huff v hidx = fromHIndexToIndex dyntbl hidx >>= indexedName wbuf huff 4 set0000 v -- 6.2.2. Literal Header Field without Indexing -- Literal Header Field without Indexing -- New Name literalHeaderFieldWithoutIndexingNewName- :: DynamicTable -> WorkingBuffer -> Bool -> FE+ :: DynamicTable -> WriteBuffer -> Bool -> FE literalHeaderFieldWithoutIndexingNewName _ wbuf huff k v = newName wbuf huff set0000 k v literalHeaderFieldWithoutIndexingNewName'- :: DynamicTable -> WorkingBuffer -> Bool -> HeaderName -> HeaderValue -> IO ()+ :: DynamicTable -> WriteBuffer -> Bool -> HeaderName -> HeaderValue -> IO () literalHeaderFieldWithoutIndexingNewName' _ wbuf huff k v = newName wbuf huff set0000 k v ---------------------------------------------------------------- {-# INLINE change #-}-change :: WorkingBuffer -> Int -> IO ()+change :: WriteBuffer -> Int -> IO () change wbuf i = I.encode wbuf set001 5 i {-# INLINE index #-}-index :: WorkingBuffer -> Int -> IO ()+index :: WriteBuffer -> Int -> IO () index wbuf i = I.encode wbuf set1 7 i -- Using Huffman encoding {-# INLINE indexedName #-}-indexedName :: WorkingBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()+indexedName :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO () indexedName wbuf huff n set v idx = do I.encode wbuf set n idx encodeString huff v wbuf -- Using Huffman encoding {-# INLINE newName #-}-newName :: WorkingBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO ()+newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO () newName wbuf huff set k v = do- writeWord8 wbuf $ set 0+ write8 wbuf $ set 0 encodeString huff k wbuf encodeString huff v wbuf @@ -230,7 +226,7 @@ ---------------------------------------------------------------- {-# INLINE encodeString #-}-encodeString :: Bool -> ByteString -> WorkingBuffer -> IO ()+encodeString :: Bool -> ByteString -> WriteBuffer -> IO () encodeString False bs wbuf = do let !len = BS.length bs I.encode wbuf id 7 len@@ -239,23 +235,23 @@ let !origLen = BS.length bs !expectedLen = (origLen `div` 10) * 8 -- 80%: decided by examples !expectedIntLen = integerLength expectedLen- wind wbuf expectedIntLen+ ff wbuf expectedIntLen len <- Huffman.encode wbuf bs let !intLen = integerLength len if origLen < len then do- wind wbuf (negate (expectedIntLen + len))+ ff wbuf (negate (expectedIntLen + len)) I.encode wbuf id 7 origLen copyByteString wbuf bs else if intLen == expectedIntLen then do- wind wbuf (negate (expectedIntLen + len))+ ff wbuf (negate (expectedIntLen + len)) I.encode wbuf setH 7 len- wind wbuf len+ ff wbuf len else do let !gap = intLen - expectedIntLen shiftLastN wbuf gap len- wind wbuf (negate (intLen + len))+ ff wbuf (negate (intLen + len)) I.encode wbuf setH 7 len- wind wbuf len+ ff wbuf len -- For 7+: -- 1 byte: 0 - 126
Network/HPACK/HeaderBlock/Integer.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}+{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Integer ( encode@@ -7,16 +7,12 @@ , decodeInteger ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt)-import Data.Bits ((.&.), shiftR, testBit)-import Data.ByteString (ByteString)-import Data.Word (Word8)-import Network.HPACK.Buffer+import Network.ByteOrder +import Imports+ -- $setup -- >>> import qualified Data.ByteString as BS @@ -37,25 +33,25 @@ -} encodeInteger :: Int -> Int -> IO ByteString-encodeInteger n i = withTemporaryBuffer 4096 $ \wbuf -> encode wbuf id n i+encodeInteger n i = withWriteBuffer 4096 $ \wbuf -> encode wbuf id n i --- Using writeWord8 is faster than using internals directly.+-- Using write8 is faster than using internals directly. {-# INLINABLE encode #-}-encode :: WorkingBuffer -> (Word8 -> Word8) -> Int -> Int -> IO ()+encode :: WriteBuffer -> (Word8 -> Word8) -> Int -> Int -> IO () encode wbuf set n i- | i < p = writeWord8 wbuf $ set $ fromIntegral i+ | i < p = write8 wbuf $ set $ fromIntegral i | otherwise = do- writeWord8 wbuf $ set $ fromIntegral p+ write8 wbuf $ set $ fromIntegral p encode' (i - p) where !p = powerArray `unsafeAt` (n - 1) encode' :: Int -> IO () encode' j- | j < 128 = writeWord8 wbuf $ fromIntegral j+ | j < 128 = write8 wbuf $ fromIntegral j | otherwise = do let !q = j `shiftR` 7 !r = j .&. 0x7f- writeWord8 wbuf $ fromIntegral (r + 128)+ write8 wbuf $ fromIntegral (r + 128) encode' q ----------------------------------------------------------------@@ -95,7 +91,7 @@ !i = fromIntegral w decode' :: Int -> Int -> IO Int decode' m j = do- !b <- fromIntegral <$> getByte rbuf+ !b <- readInt8 rbuf let !j' = j + (b .&. 0x7f) * 2 ^ m !m' = m + 7 !cont = b `testBit` 7
Network/HPACK/Huffman/Bit.hs view
@@ -5,8 +5,7 @@ , fromBits ) where -import Data.Word (Word8)-import Data.List (foldl')+import Imports -- | Data type for Bit. data B = F -- ^ Zero
Network/HPACK/Huffman/ByteString.hs view
@@ -5,15 +5,13 @@ , copy ) where -import Control.Monad (void)-import Data.Bits ((.&.), shiftR)-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)++import Imports -- $setup -- >>> import qualified Data.ByteString as BS
Network/HPACK/Huffman/Decode.hs view
@@ -11,9 +11,8 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString(..))-import Data.Word (Word8)-import Network.HPACK.Buffer+import Network.ByteOrder+ import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table@@ -47,11 +46,11 @@ -- | Huffman decoding. decode :: Buffer -> BufferSize -> HuffmanDecoding decode buf siz rbuf len = do- wbuf <- newWorkingBuffer buf siz+ wbuf <- newWriteBuffer buf siz dec wbuf rbuf len toByteString wbuf -dec :: WorkingBuffer -> ReadBuffer -> Int -> IO ()+dec :: WriteBuffer -> ReadBuffer -> Int -> IO () dec wbuf rbuf len = go len (way256 `unsafeAt` 0) where go 0 way0 = case way0 of@@ -60,26 +59,27 @@ | i <= 8 -> return () | otherwise -> throwIO TooLongEos go !n !way0 = do- w <- getByte rbuf+ w <- read8 rbuf way <- doit way0 w go (n - 1) way doit !way !w = case next way w of EndOfString -> throwIO EosInTheMiddle Forward n -> return $ way256 `unsafeAt` fromIntegral n GoBack n v -> do- writeWord8 wbuf v+ write8 wbuf v return $ way256 `unsafeAt` fromIntegral n GoBack2 n v1 v2 -> do- writeWord8 wbuf v1- writeWord8 wbuf v2+ write8 wbuf v1+ write8 wbuf v2 return $ way256 `unsafeAt` fromIntegral n decodeHuffman :: ByteString -> IO ByteString-decodeHuffman bs = withTemporaryBuffer 4096 $ \wbuf ->+decodeHuffman bs = withWriteBuffer 4096 $ \wbuf -> withReadBuffer bs $ \rbuf -> dec wbuf rbuf (BS.length bs) ---------------------------------------------------------------- +{-# NOINLINE way256 #-} way256 :: Way256 way256 = construct $ toHTree huffmanTable
Network/HPACK/Huffman/Encode.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}+{-# LANGUAGE BangPatterns, RecordWildCards #-} module Network.HPACK.Huffman.Encode ( -- * Huffman encoding@@ -7,24 +7,18 @@ , encodeHuffman ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Exception (throwIO)-import Control.Monad (when, void) import Data.Array.Base (unsafeAt) import Data.Array.IArray (listArray) import Data.Array.Unboxed (UArray)-import Data.Bits ((.|.), shiftR, shiftL)-import Data.ByteString (ByteString) import Data.IORef-import Data.Word (Word8, Word64) import Foreign.Ptr (plusPtr, minusPtr) import Foreign.Storable (poke)-import Network.HPACK.Buffer+import Network.ByteOrder hiding (copy)++import Imports import Network.HPACK.Huffman.Params (idxEos) import Network.HPACK.Huffman.Table-import Network.HPACK.Types (BufferOverrun(..)) ---------------------------------------------------------------- @@ -37,7 +31,7 @@ ---------------------------------------------------------------- -- | Huffman encoding.-type HuffmanEncoding = WorkingBuffer -> ByteString -> IO Int+type HuffmanEncoding = WriteBuffer -> ByteString -> IO Int -- | Huffman encoding. encode :: HuffmanEncoding@@ -51,8 +45,8 @@ shiftForWrite :: Int shiftForWrite = 32 -enc :: WorkingBuffer -> ReadBuffer -> IO Int-enc WorkingBuffer{..} rbuf = do+enc :: WriteBuffer -> ReadBuffer -> IO Int+enc WriteBuffer{..} rbuf = do beg <- readIORef offset end <- go (beg,0,initialOffset) writeIORef offset end@@ -60,9 +54,9 @@ return len where go (dst,encoded,off) = do- !i <- getByte' rbuf+ !i <- readInt8 rbuf if i >= 0 then- copy dst (bond i) >>= go+ cpy dst (bond i) >>= go else if off == initialOffset then return dst else do@@ -84,15 +78,15 @@ poke p w8 let !p' = p `plusPtr` 1 return p'- {-# INLINE copy #-}- copy p (w,o)+ {-# INLINE cpy #-}+ cpy p (w,o) | o > shiftForWrite = return (p,w,o) | otherwise = do p' <- write p w let !w' = w `shiftL` 8 !o' = o + 8- copy p' (w',o')+ cpy p' (w',o') encodeHuffman :: ByteString -> IO ByteString-encodeHuffman bs = withTemporaryBuffer 4096 $ \wbuf ->+encodeHuffman bs = withWriteBuffer 4096 $ \wbuf -> void $ encode wbuf bs
Network/HPACK/Huffman/Table.hs view
@@ -1,6 +1,6 @@ module Network.HPACK.Huffman.Table where -import Data.Word (Word64)+import Imports import Network.HPACK.Huffman.Bit huffmanTable :: [Bits]
Network/HPACK/Huffman/Tree.hs view
@@ -11,7 +11,8 @@ ) where import Control.Arrow (second)-import Data.List (partition)++import Imports import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.Params
Network/HPACK/Table.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, CPP #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK hide #-} module Network.HPACK.Table (@@ -30,9 +30,6 @@ , fromHIndexToIndex ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry import Network.HPACK.Table.RevIndex
Network/HPACK/Table/Dynamic.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TupleSections, RecordWildCards, FlexibleContexts #-}-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns #-} module Network.HPACK.Table.Dynamic ( DynamicTable(..)@@ -25,16 +25,14 @@ , getRevIndex ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<*>))-#endif import Control.Exception (bracket, throwIO)-import Control.Monad (forM, when, (>=>)) import Data.Array.Base (unsafeRead, unsafeWrite) import Data.Array.IO (IOArray, newArray) import qualified Data.ByteString.Char8 as BS import Data.IORef-import Foreign.Marshal.Alloc+import Foreign.Marshal.Alloc (mallocBytes, free)++import Imports import Network.HPACK.Huffman import Network.HPACK.Table.Entry import Network.HPACK.Table.RevIndex
Network/HPACK/Table/RevIndex.hs view
@@ -10,18 +10,16 @@ , deleteRevIndexList ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<*>))-#endif import Data.Array (Array) import qualified Data.Array as A import Data.Array.Base (unsafeAt)-import Data.Function (on) import Data.CaseInsensitive (foldedCase)+import Data.Function (on) import Data.IORef-import Data.List (groupBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M++import Imports import Network.HPACK.Table.Entry import Network.HPACK.Table.Static import Network.HPACK.Token
Network/HPACK/Types.hs view
@@ -24,10 +24,10 @@ ) where import Control.Exception as E-import Data.ByteString (ByteString) import Data.Typeable-import Data.Word (Word8)-import Foreign.Ptr (Ptr)+import Network.ByteOrder (Buffer, BufferSize, BufferOverrun(..))++import Imports import Network.HPACK.Token (Token) ----------------------------------------------------------------@@ -47,8 +47,10 @@ -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString +-- | TokenBased header. type TokenHeader = (Token, HeaderValue) +-- | TokenBased header list. type TokenHeaderList = [TokenHeader] ----------------------------------------------------------------@@ -100,16 +102,3 @@ deriving (Eq,Show,Typeable) instance Exception DecodeError---------------------------------------------------------------------- | Buffer type.-type Buffer = Ptr Word8---- | The size of buffer.-type BufferSize = Int--data BufferOverrun = BufferOverrun -- ^ The buffer size is not enough- deriving (Eq,Show,Typeable)--instance Exception BufferOverrun
Network/HTTP2.hs view
@@ -84,8 +84,9 @@ , recommendedConcurrency ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as BS++import Imports import Network.HTTP2.Decode import Network.HTTP2.Encode import Network.HTTP2.Types
Network/HTTP2/Decode.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TupleSections, BangPatterns, RecordWildCards, OverloadedStrings #-}-{-# LANGUAGE CPP #-} module Network.HTTP2.Decode ( -- * Decoding@@ -21,20 +20,14 @@ , decodeContinuationFrame ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Data.Array (Array, listArray, (!))-import Data.Bits (clearBit)-import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString(..))-import Data.Word import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import qualified Network.ByteOrder as N import System.IO.Unsafe (unsafeDupablePerformIO) +import Imports import Network.HTTP2.Types ----------------------------------------------------------------
Network/HTTP2/Encode.hs view
@@ -11,11 +11,11 @@ ) where import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString, unsafeCreate)-import Data.Word (Word8)+import Data.ByteString.Internal (unsafeCreate) import Foreign.Ptr (Ptr, plusPtr) import qualified Network.ByteOrder as N +import Imports import Network.HTTP2.Types ----------------------------------------------------------------
Network/HTTP2/Priority.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -- | This is partial implementation of the priority of HTTP/2.@@ -32,13 +31,11 @@ , delete ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Control.Concurrent.STM-import Control.Monad (when, unless) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as Map++import Imports hiding (delete, empty) import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence) import qualified Network.HTTP2.Priority.Queue as Q import Network.HTTP2.Types
Network/HTTP2/Priority/PSQ.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Priority.PSQ (@@ -14,10 +13,6 @@ , delete ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-import Data.Word (Word)-#endif import Data.Array (Array, listArray, (!)) import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as P@@ -30,7 +25,7 @@ -- | Internal representation of priority in priority queues. -- The precedence of a dequeued entry should be specified--- to 'enqueue' when the entry is enqueued again.+-- to enqueue when the entry is enqueued again. data Precedence = Precedence { deficit :: {-# UNPACK #-} !Deficit , weight :: {-# UNPACK #-} !Weight
Network/HTTP2/Priority/Queue.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Network.HTTP2.Priority.Queue ( Precedence(..) , TPriorityQueue@@ -10,9 +8,6 @@ , delete ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Concurrent.STM import Network.HTTP2.Priority.PSQ (PriorityQueue, Key, Precedence(..)) import qualified Network.HTTP2.Priority.PSQ as Q
+ Network/HTTP2/Server.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | HTTP\/2 server library.+--+-- Example:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > module Main (main) where+-- >+-- > import Control.Concurrent (forkFinally)+-- > import qualified Control.Exception as E+-- > import Control.Monad (forever, void)+-- > import Data.ByteString.Builder (byteString)+-- > import Network.HTTP.Types (ok200)+-- > import Network.HTTP2.Server+-- > import Network.Socket+-- >+-- > main :: IO ()+-- > main = withSocketsDo $ do+-- > addr <- resolve "80"+-- > E.bracket (open addr) close loop+-- > where+-- > server _req _ctl sendResponse = sendResponse response []+-- > where+-- > response = responseBuilder ok200 [("Content-Type", "text/plain")] (byteString "Hello, world!\n")+-- > loop sock = forever $ do+-- > (s, _peer) <- accept sock+-- > (config, cleanup) <- makeSimpleConfig s 4096+-- > void $ forkFinally (run config server) (\_ -> close s >> cleanup)+-- > resolve port = do+-- > let hints = defaultHints {+-- > addrFlags = [AI_PASSIVE]+-- > , addrSocketType = Stream+-- > }+-- > addr:_ <- getAddrInfo (Just hints) Nothing (Just port)+-- > return addr+-- > open addr = do+-- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+-- > setSocketOption sock ReuseAddr 1+-- > withFdSocket sock $ setCloseOnExecIfNeeded+-- > bind sock (addrAddress addr)+-- > listen sock 10+-- > return sock++module Network.HTTP2.Server (+ -- * Runner+ run+ -- * Runner arguments+ , Config(..)+ , makeSimpleConfig+ -- * HTTP/2 server+ , Server+ -- * Request+ , Request+ , requestHeaders+ , requestBodySize+ , getRequestBodyChunk+ , getRequestTrailers+ -- * Aux+ , Aux+ , auxTimeHandle+ -- * Response+ , Response+ -- ** Creating response+ , responseNoBody+ , responseFile+ , responseStreaming+ , responseBuilder+ -- ** Accessing response+ , responseStatus+ , responseBodySize+ -- ** Trailers maker+ , TrailersMaker+ , NextTrailersMaker(..)+ , defaultTrailersMaker+ , setResponseTrailersMaker+ -- * Push promise+ , PushPromise+ , pushPromise+ , promiseRequestPath+ , promiseResponse+ , promiseWeight+ -- * Types+ , FileSpec(..)+ , FileOffset+ , ByteCount+ -- * RecvN+ , defaultReadN+ -- * Position read for files+ , PositionReadMaker+ , PositionRead+ , Sentinel(..)+ , defaultPositionReadMaker+ ) where++import Data.IORef (readIORef)+import Data.ByteString.Builder (Builder)+import qualified Network.HTTP.Types as H++import Imports+import Network.HPACK+import Network.HTTP2.Server.API+import Network.HTTP2.Server.Config (makeSimpleConfig)+import Network.HTTP2.Server.File (defaultPositionReadMaker)+import Network.HTTP2.Server.ReadN (defaultReadN)+import Network.HTTP2.Server.Run (run)+import Network.HTTP2.Types++----------------------------------------------------------------++-- | Reading a chunk of the request body.+-- An empty 'ByteString' returned when finished.+getRequestBodyChunk :: Request -> IO ByteString+getRequestBodyChunk = requestBody++-- | Reading request trailers.+-- This function must be called after 'getRequestBodyChunk'+-- returns an empty.+getRequestTrailers :: Request -> IO (Maybe HeaderTable)+getRequestTrailers = readIORef . requestTrailers_++-- |Creating response without body.+responseNoBody :: H.Status -> H.ResponseHeaders -> Response+responseNoBody st hdr = Response st hdr RspNoBody defaultTrailersMaker++-- |Creating response with file.+responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response+responseFile st hdr fileSpec = Response st hdr (RspFile fileSpec) defaultTrailersMaker++-- |Creating response with builder.+responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response+responseBuilder st hdr builder = Response st hdr (RspBuilder builder) defaultTrailersMaker+-- |Creating response with streaming.+responseStreaming :: H.Status -> H.ResponseHeaders+ -> ((Builder -> IO ()) -> IO () -> IO ())+ -> Response+responseStreaming st hdr strmbdy = Response st hdr (RspStreaming strmbdy) defaultTrailersMaker++-- | Getter for response body size. This value is available for file body.+responseBodySize :: Response -> Maybe Int+responseBodySize (Response _ _ (RspFile (FileSpec _ _ len)) _) = Just (fromIntegral len)+responseBodySize _ = Nothing++-- | Setting 'TrailersMaker' to 'Response'.+setResponseTrailersMaker :: Response -> TrailersMaker -> Response+setResponseTrailersMaker rsp tm = rsp { responseTrailers = tm }++-- | TrailersMake to create no trailers.+defaultTrailersMaker :: TrailersMaker+defaultTrailersMaker Nothing = return $ Trailers []+defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker++-- | Creating push promise.+pushPromise :: ByteString -> Response -> Weight -> PushPromise+pushPromise path rsp w = PushPromise path rsp w
+ Network/HTTP2/Server/API.hs view
@@ -0,0 +1,131 @@+module Network.HTTP2.Server.API where++import Data.ByteString.Builder (Builder)+import Data.IORef (IORef)+import qualified Network.HTTP.Types as H+import qualified System.TimeManager as T++import Imports+import Network.HPACK+import Network.HTTP2++-- | HTTP/2 server configuration.+data Config = Config {+ confWriteBuffer :: Buffer+ , confBufferSize :: BufferSize+ , confSendAll :: ByteString -> IO ()+ , confReadN :: Int -> IO ByteString+ , confPositionReadMaker :: PositionReadMaker+ }++----------------------------------------------------------------++-- | HTTP\/2 server takes a HTTP request, should+-- generate a HTTP response and push promises, then+-- should give them to the sending function.+-- The sending function would throw exceptions so that+-- they can be logged.+type Server = Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()++-- | HTTP request.+data Request = Request {+ requestHeaders :: HeaderTable -- ^ Accessor for request headers.+ , requestBodySize :: Maybe Int -- ^ Accessor for body length specified in content-length:.+ , requestBody :: IO ByteString -- ^ Accessor for body.+ , requestTrailers_ :: IORef (Maybe HeaderTable)+ }++-- | Additional information.+data Aux = Aux {+ -- | Time handle for the worker processing this request and response.+ auxTimeHandle :: T.Handle+ }++-- | HTTP response.+data Response = Response {+ responseStatus :: H.Status -- ^ Accessor for response status.+ , responseHeaders :: H.ResponseHeaders -- ^ Accessor for response header.+ , responseBody :: ResponseBody -- ^ Accessor for response body.+ , responseTrailers :: TrailersMaker -- ^ Accessor for response trailers maker.+ }++-- | HTTP response body.+data ResponseBody = RspNoBody+ -- | Streaming body takes a write action and a flush action.+ | RspStreaming ((Builder -> IO ()) -> IO () -> IO ())+ | RspBuilder Builder+ | RspFile FileSpec++-- | Trailers maker. A chunks of the response body is passed+-- with 'Just'. The maker should update internal state+-- with the 'ByteString' and return the next trailers maker.+-- When response body reaches its end,+-- 'Nothing' is passed and the maker should generate+-- trailers. An example:+--+-- > {-# LANGUAGE BangPatterns #-}+-- > import Data.ByteString (ByteString)+-- > import qualified Data.ByteString.Char8 as C8+-- > import Crypto.Hash (Context, SHA1) -- cryptonite+-- > import qualified Crypto.Hash as CH+-- >+-- > -- Strictness is important for Context.+-- > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker+-- > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]+-- > where+-- > !sha1 = C8.pack $ show $ CH.hashFinalize ctx+-- > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'+-- > where+-- > !ctx' = CH.hashUpdate ctx bs+--+-- Usage example:+--+-- > let h2rsp = responseFile ...+-- > maker = trailersMaker (CH.hashInit :: Context SHA1)+-- > h2rsp' = setResponseTrailersMaker h2rsp maker+--+type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker++-- | Either the next trailers maker or final trailers.+data NextTrailersMaker = NextTrailersMaker !TrailersMaker+ | Trailers H.ResponseHeaders++-- | HTTP/2 push promise or sever push.+-- Pseudo REQUEST headers in push promise is automatically generated.+-- Then, a server push is sent according to 'promiseResponse'.+data PushPromise = PushPromise {+ -- | Accessor for a URL path in a push promise (a virtual request from a server).+ -- E.g. \"\/style\/default.css\".+ promiseRequestPath :: ByteString+ -- | Accessor for response actually pushed from a server.+ , promiseResponse :: Response+ -- | Accessor for response weight.+ , promiseWeight :: Weight+ }++----------------------------------------------------------------++-- | File specification.+data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)++-- | Offset for file.+type FileOffset = Int64+-- | How many bytes to read+type ByteCount = Int64++----------------------------------------------------------------++-- | Position read for files.+type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount++-- | Manipulating a file resource.+data Sentinel =+ -- | Closing a file resource. Its refresher is automatiaclly generated by+ -- the internal timer.+ Closer (IO ())+ -- | Refreshing a file resource while reading.+ -- Closing the file must be done by its own timer or something.+ | Refresher (IO ())++-- | Making a position read and its closer.+type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel)
+ Network/HTTP2/Server/Config.hs view
@@ -0,0 +1,27 @@+module Network.HTTP2.Server.Config where++import Data.IORef+import Foreign.Marshal.Alloc (mallocBytes, free)+import Network.Socket+import Network.Socket.ByteString (sendAll)++import Network.HPACK+import Network.HTTP2.Server.API+import Network.HTTP2.Server.File+import Network.HTTP2.Server.ReadN++-- | Making configuration whose IO is not efficient.+-- A write buffer is allocated internally.+-- That should be deallocated by the returned action.+makeSimpleConfig :: Socket -> BufferSize -> IO (Config, IO ())+makeSimpleConfig s bufsiz = do+ buf <- mallocBytes bufsiz+ ref <- newIORef Nothing+ let config = Config {+ confWriteBuffer = buf+ , confBufferSize = bufsiz+ , confSendAll = sendAll s+ , confReadN = defaultReadN s ref+ , confPositionReadMaker = defaultPositionReadMaker+ }+ return (config, free buf)
+ Network/HTTP2/Server/Context.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++module Network.HTTP2.Server.Context where++import Control.Concurrent.STM+import Data.IORef++import Imports+import Network.HPACK+import Network.HTTP2+import Network.HTTP2.Priority+import Network.HTTP2.Server.Stream+import Network.HTTP2.Server.Types++----------------------------------------------------------------++-- | The context for HTTP/2 connection.+data Context = Context {+ -- HTTP/2 settings received from a browser+ http2settings :: !(IORef Settings)+ , firstSettings :: !(IORef Bool)+ , streamTable :: !StreamTable+ , concurrency :: !(IORef Int)+ , priorityTreeSize :: !(IORef Int)+ -- | RFC 7540 says "Other frames (from any stream) MUST NOT+ -- occur between the HEADERS frame and any CONTINUATION+ -- frames that might follow". This field is used to implement+ -- this requirement.+ , continued :: !(IORef (Maybe StreamId))+ , clientStreamId :: !(IORef StreamId)+ , serverStreamId :: !(IORef StreamId)+ , inputQ :: !(TQueue Input)+ , outputQ :: !(PriorityTree Output)+ , controlQ :: !(TQueue Control)+ , encodeDynamicTable :: !DynamicTable+ , decodeDynamicTable :: !DynamicTable+ -- the connection window for data from a server to a browser.+ , connectionWindow :: !(TVar WindowSize)+ }++----------------------------------------------------------------++newContext :: IO Context+newContext = Context <$> newIORef defaultSettings+ <*> newIORef False+ <*> newStreamTable+ <*> newIORef 0+ <*> newIORef 0+ <*> newIORef Nothing+ <*> newIORef 0+ <*> newIORef 0+ <*> newTQueueIO+ <*> newPriorityTree+ <*> newTQueueIO+ <*> newDynamicTableForEncoding defaultDynamicTableSize+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096+ <*> newTVarIO defaultInitialWindowSize++clearContext :: Context -> IO ()+clearContext _ctx = return ()++----------------------------------------------------------------++newPushStream :: Context -> WindowSize -> Precedence -> IO Stream+newPushStream Context{serverStreamId} win pre = do+ sid <- atomicModifyIORef' serverStreamId inc2+ Stream sid <$> newIORef Reserved+ <*> newTVarIO win+ <*> newIORef pre+ where+ inc2 x = let !x' = x + 2 in (x', x')++----------------------------------------------------------------++{-# INLINE setStreamState #-}+setStreamState :: Context -> Stream -> StreamState -> IO ()+setStreamState _ Stream{streamState} val = writeIORef streamState val++opened :: Context -> Stream -> IO ()+opened ctx@Context{concurrency} strm = do+ atomicModifyIORef' concurrency (\x -> (x+1,()))+ setStreamState ctx strm (Open JustOpened)++halfClosedRemote :: Context -> Stream -> IO ()+halfClosedRemote ctx stream@Stream{streamState} = do+ !closingCode <- atomicModifyIORef streamState closeHalf+ traverse_ (closed ctx stream) closingCode+ where+ closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)+ closeHalf x@(Closed _) = (x, Nothing)+ closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)+ closeHalf _ = (HalfClosedRemote, Nothing)++halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()+halfClosedLocal ctx stream@Stream{streamState} cc = do+ shouldFinalize <- atomicModifyIORef streamState closeHalf+ when shouldFinalize $+ closed ctx stream cc+ where+ closeHalf :: StreamState -> (StreamState, Bool)+ closeHalf x@(Closed _) = (x, False)+ closeHalf HalfClosedRemote = (Closed cc, True)+ closeHalf _ = (HalfClosedLocal cc, False)++closed :: Context -> Stream -> ClosedCode -> IO ()+closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do+ remove streamTable streamNumber+ -- TODO: prevent double-counting+ atomicModifyIORef' concurrency (\x -> (x-1,()))+ setStreamState ctx strm (Closed cc) -- anyway
+ Network/HTTP2/Server/EncodeFrame.hs view
@@ -0,0 +1,34 @@+module Network.HTTP2.Server.EncodeFrame where++import Network.HTTP2++import Imports++----------------------------------------------------------------++goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString+goawayFrame sid etype debugmsg = encodeFrame einfo frame+ where+ einfo = encodeInfo id 0+ frame = GoAwayFrame sid etype debugmsg++resetFrame :: ErrorCodeId -> StreamId -> ByteString+resetFrame etype sid = encodeFrame einfo frame+ where+ einfo = encodeInfo id sid+ frame = RSTStreamFrame etype++settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist+ where+ einfo = encodeInfo func 0++pingFrame :: ByteString -> ByteString+pingFrame bs = encodeFrame einfo $ PingFrame bs+ where+ einfo = encodeInfo setAck 0++windowUpdateFrame :: StreamId -> WindowSize -> ByteString+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz+ where+ einfo = encodeInfo id sid
+ Network/HTTP2/Server/File.hs view
@@ -0,0 +1,16 @@+module Network.HTTP2.Server.File where++import System.IO++import Network.HTTP2.Server.API++-- | Position read based on 'Handle'.+defaultPositionReadMaker :: PositionReadMaker+defaultPositionReadMaker file = do+ hdl <- openBinaryFile file ReadMode+ return (pread hdl, Closer $ hClose hdl)+ where+ pread :: Handle -> PositionRead+ pread hdl off bytes buf = do+ hSeek hdl AbsoluteSeek $ fromIntegral off+ fromIntegral <$> (hGetBufSome hdl buf $ fromIntegral bytes)
+ Network/HTTP2/Server/HPACK.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Server.HPACK (+ hpackEncodeHeader+ , hpackEncodeHeaderLoop+ , hpackDecodeHeader+ , hpackDecodeTrailer+ , just+ , fixHeaders+ ) where++import qualified Control.Exception as E+import Data.ByteString.Internal (unsafeCreate)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (poke)+import Network.ByteOrder+import qualified Network.HTTP.Types as H++import Imports+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP2+import Network.HTTP2.Server.Context++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++fixHeaders :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders+fixHeaders st hdr = (":status", packStatus st) : deleteUnnecessaryHeaders hdr++packStatus :: H.Status -> ByteString+packStatus status = unsafeCreate 3 $ \p -> do+ poke p (toW8 r2)+ poke (p `plusPtr` 1) (toW8 r1)+ poke (p `plusPtr` 2) (toW8 r0)+ where+ toW8 :: Int -> Word8+ toW8 n = 48 + fromIntegral n+ !s = fromIntegral $ H.statusCode status+ (!q0,!r0) = s `divMod` 10+ (!q1,!r1) = q0 `divMod` 10+ !r2 = q1 `mod` 10++deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders+deleteUnnecessaryHeaders hdr = filter del hdr+ where+ del (k,_) = k `notElem` headersToBeRemoved++headersToBeRemoved :: [H.HeaderName]+headersToBeRemoved = [ H.hConnection+ , "Transfer-Encoding"+ -- Keep-Alive+ -- Proxy-Connection+ -- Upgrade+ ]++----------------------------------------------------------------++strategy :: EncodeStrategy+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }++-- Set-Cookie: contains only one cookie value.+-- So, we don't need to split it.+hpackEncodeHeader :: Context -> Buffer -> BufferSize+ -> TokenHeaderList+ -> IO (TokenHeaderList, Int)+hpackEncodeHeader Context{..} buf siz ths =+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths++hpackEncodeHeaderLoop :: Context -> Buffer -> BufferSize+ -> TokenHeaderList+ -> IO (TokenHeaderList, Int)+hpackEncodeHeaderLoop Context{..} buf siz hs =+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs++----------------------------------------------------------------++hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderTable+hpackDecodeHeader hdrblk ctx = do+ tbl@(_,vt) <- hpackDecodeTrailer hdrblk ctx+ if checkRequestHeader vt then+ return tbl+ else+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"++hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable+hpackDecodeTrailer hdrblk Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl+ where+ handl IllegalHeaderName =+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"+ handl _ =+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"++{-# INLINE checkRequestHeader #-}+checkRequestHeader :: ValueTable -> Bool+checkRequestHeader reqvt+ | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme+ | isJust mStatus = False+ | isNothing mMethod = False+ | isNothing mScheme = False+ | isNothing mPath = False+ | mPath == Just "" = False+ | isJust mConnection = False+ | just mTE (/= "trailers") = False+ | otherwise = True+ where+ mStatus = getHeaderValue tokenStatus reqvt+ mScheme = getHeaderValue tokenScheme reqvt+ mPath = getHeaderValue tokenPath reqvt+ mMethod = getHeaderValue tokenMethod reqvt+ mConnection = getHeaderValue tokenConnection reqvt+ mTE = getHeaderValue tokenTE reqvt++{-# INLINE just #-}+just :: Maybe a -> (a -> Bool) -> Bool+just Nothing _ = False+just (Just x) p+ | p x = True+ | otherwise = False
+ Network/HTTP2/Server/Manager.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE BangPatterns #-}++-- | A thread pool manager.+-- The manager has responsibility to spawn and kill+-- worker threads.+module Network.HTTP2.Server.Manager (+ Manager+ , Action+ , start+ , setAction+ , stop+ , spawnAction+ , addMyId+ , deleteMyId+ , timeoutKillThread+ , timeoutClose+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as E+import Data.Foldable+import Data.IORef+import Data.Set (Set)+import qualified Data.Set as Set+import qualified System.TimeManager as T++import Imports++----------------------------------------------------------------++type Action = IO ()++noAction :: Action+noAction = return ()++data Command = Stop | Spawn | Add ThreadId | Delete ThreadId++data Manager = Manager (TQueue Command) (IORef Action) T.Manager++-- | Starting a thread pool manager.+-- Its action is initially set to 'return ()' and should be set+-- by 'setAction'. This allows that the action can include+-- the manager itself.+start :: IO Manager+start = do+ q <- newTQueueIO+ ref <- newIORef noAction+ timmgr <- T.initialize $ 30 * 1000000 -- fixme+ void $ forkIO $ go q Set.empty ref timmgr+ return $ Manager q ref timmgr+ where+ go q !tset0 ref timmgr = do+ x <- atomically $ readTQueue q+ case x of+ Stop -> kill tset0 >> T.killManager timmgr+ Spawn -> next tset0+ Add newtid -> let !tset = add newtid tset0+ in go q tset ref timmgr+ Delete oldtid -> let !tset = del oldtid tset0+ in go q tset ref timmgr+ where+ next tset = do+ action <- readIORef ref+ newtid <- forkIO action+ let !tset' = add newtid tset+ go q tset' ref timmgr++setAction :: Manager -> Action -> IO ()+setAction (Manager _ ref _) action = writeIORef ref action++stop :: Manager -> IO ()+stop (Manager q _ _) = atomically $ writeTQueue q Stop++spawnAction :: Manager -> IO ()+spawnAction (Manager q _ _) = atomically $ writeTQueue q Spawn++addMyId :: Manager -> IO ()+addMyId (Manager q _ _) = do+ tid <- myThreadId+ atomically $ writeTQueue q $ Add tid++deleteMyId :: Manager -> IO ()+deleteMyId (Manager q _ _) = do+ tid <- myThreadId+ atomically $ writeTQueue q $ Delete tid++----------------------------------------------------------------++add :: ThreadId -> Set ThreadId -> Set ThreadId+add tid set = set'+ where+ !set' = Set.insert tid set++del :: ThreadId -> Set ThreadId -> Set ThreadId+del tid set = set'+ where+ !set' = Set.delete tid set++kill :: Set ThreadId -> IO ()+kill set = traverse_ killThread set++timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()+timeoutKillThread (Manager _ _ tmgr) action = E.bracket register T.cancel action+ where+ register = T.registerKillThread tmgr noAction++-- | Registering closer for a resource and+-- returning a timer refresher.+timeoutClose :: Manager -> IO () -> IO (IO ())+timeoutClose (Manager _ _ tmgr) closer = do+ th <- T.register tmgr closer+ return $ T.tickle th
+ Network/HTTP2/Server/Queue.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Server.Queue where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Exception (bracket)+import Data.IORef++import Imports+import Network.HTTP2.Priority+import Network.HTTP2.Server.Manager+import Network.HTTP2.Server.Types++{-# INLINE forkAndEnqueueWhenReady #-}+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()+forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->+ void . forkIO $ do+ wait+ enqueueOutput outQ out+ where+ setup = addMyId mgr+ teardown _ = deleteMyId mgr++{-# INLINE enqueueOutput #-}+enqueueOutput :: PriorityTree Output -> Output -> IO ()+enqueueOutput outQ out = do+ let Stream{..} = outputStream out+ pre <- readIORef streamPrecedence+ enqueue outQ streamNumber pre out++{-# INLINE enqueueControl #-}+enqueueControl :: TQueue Control -> Control -> IO ()+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl++----------------------------------------------------------------
+ Network/HTTP2/Server/ReadN.hs view
@@ -0,0 +1,35 @@+module Network.HTTP2.Server.ReadN where++import qualified Data.ByteString as B+import Data.IORef+import Network.Socket+import qualified Network.Socket.ByteString as N++-- | Naive implementation for readN.+defaultReadN :: Socket -> IORef (Maybe B.ByteString) -> Int -> IO B.ByteString+defaultReadN s ref n = do+ mbs <- readIORef ref+ writeIORef ref Nothing+ case mbs of+ Nothing -> do+ bs <- N.recv s n+ if B.length bs == n then+ return bs+ else+ loop bs+ Just bs+ | B.length bs == n -> return bs+ | B.length bs > n -> do+ let (bs0, bs1) = B.splitAt n bs+ writeIORef ref (Just bs1)+ return bs0+ | otherwise -> loop bs+ where+ loop bs = do+ let n' = n - B.length bs+ bs1 <- N.recv s n'+ let bs2 = bs `B.append` bs1+ if B.length bs2 == n then+ return bs2+ else+ loop bs2
+ Network/HTTP2/Server/Receiver.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}++module Network.HTTP2.Server.Receiver (frameReceiver) where++import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as E+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.IORef+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP2+import Network.HTTP2.Priority (toPrecedence, delete, prepare)++import Imports hiding (delete, insert)+import Network.HTTP2.Server.API+import Network.HTTP2.Server.EncodeFrame+import Network.HTTP2.Server.HPACK+import Network.HTTP2.Server.Types+import Network.HTTP2.Server.Context+import Network.HTTP2.Server.Stream+import Network.HTTP2.Server.Queue++----------------------------------------------------------------++-- | Type for input streaming.+data Source = Source !(IORef ByteString) !(IO ByteString)++mkSource :: IO ByteString -> IO Source+mkSource func = do+ ref <- newIORef BS.empty+ return $! Source ref func++readSource :: Source -> IO ByteString+readSource (Source ref func) = do+ bs <- readIORef ref+ if BS.null bs+ then func+ else do+ writeIORef ref BS.empty+ return bs++frameReceiver :: Context -> (BufferSize -> IO ByteString) -> IO ()+frameReceiver ctx recvN = loop 0 `E.catch` sendGoaway+ where+ Context{ http2settings+ , streamTable+ , concurrency+ , continued+ , clientStreamId+ , inputQ+ , controlQ+ } = ctx+ sendGoaway e+ | Just (ConnectionError err msg) <- E.fromException e = do+ csid <- readIORef clientStreamId+ let !frame = goawayFrame csid err msg+ enqueueControl controlQ $ CGoaway frame+ | otherwise = return ()++ sendReset err sid = do+ let !frame = resetFrame err sid+ enqueueControl controlQ $ CFrame frame++ loop :: Int -> IO ()+ loop !n+ | n == 6 = do+ yield+ loop 0+ | otherwise = do+ hd <- recvN frameHeaderLength+ if BS.null hd then+ enqueueControl controlQ CFinish+ else do+ cont <- processStreamGuardingError $ decodeFrameHeader hd+ when cont $ loop (n + 1)++ processStreamGuardingError (fid, FrameHeader{streamId})+ | isResponse streamId &&+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"+ processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do+ mx <- readIORef continued+ case mx of+ Nothing -> do+ -- ignoring unknown frame+ consume payloadLength+ return True+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"+ processStreamGuardingError (FramePushPromise, _) =+ E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"+ processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do+ settings <- readIORef http2settings+ case checkFrameHeader settings typhdr of+ Left h2err -> case h2err of+ StreamError err sid -> do+ sendReset err sid+ consume payloadLength+ return True+ connErr -> E.throwIO connErr+ Right _ -> do+ ex <- E.try $ controlOrStream ftyp header+ case ex of+ Left (StreamError err sid) -> do+ sendReset err sid+ return True+ Left connErr -> E.throw connErr+ Right cont -> return cont++ controlOrStream ftyp header@FrameHeader{streamId, payloadLength}+ | isControl streamId = do+ pl <- recvN payloadLength+ control ftyp header pl ctx+ | otherwise = do+ checkContinued+ !mstrm <- getStream+ pl <- recvN payloadLength+ case mstrm of+ Nothing -> do+ -- for h2spec only+ when (ftyp == FramePriority) $ do+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl+ checkPriority newpri streamId+ return True -- just ignore this frame+ Just strm@Stream{streamPrecedence} -> do+ state <- readStreamState strm+ state' <- stream ftyp header pl ctx state strm+ case state' of+ Open (NoBody tbl@(_,reqvt) pri) -> do+ resetContinued+ let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ when (just mcl (/= (0 :: Int))) $+ E.throwIO $ StreamError ProtocolError streamId+ writeIORef streamPrecedence $ toPrecedence pri+ halfClosedRemote ctx strm+ tlr <- newIORef Nothing+ atomically $ writeTQueue inputQ $ Input strm $ Request tbl (Just 0) (return "") tlr+ Open (HasBody tbl@(_,reqvt) pri) -> do+ resetContinued+ q <- newTQueueIO+ let !mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ writeIORef streamPrecedence $ toPrecedence pri+ bodyLength <- newIORef 0+ tlr <- newIORef Nothing+ setStreamState ctx strm $ Open (Body q mcl bodyLength tlr)+ readQ <- newReadBody q+ bodySource <- mkSource readQ+ atomically $ writeTQueue inputQ $ Input strm $ Request tbl mcl (readSource bodySource) tlr+ s@(Open Continued{}) -> do+ setContinued+ setStreamState ctx strm s+ HalfClosedRemote -> do+ resetContinued+ halfClosedRemote ctx strm+ s -> do -- Idle, Open Body, Closed+ resetContinued+ setStreamState ctx strm s+ return True+ where+ setContinued = writeIORef continued (Just streamId)+ resetContinued = writeIORef continued Nothing+ checkContinued = do+ mx <- readIORef continued+ case mx of+ Nothing -> return ()+ Just sid+ | sid == streamId && ftyp == FrameContinuation -> return ()+ | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"+ getStream = do+ mstrm0 <- search streamTable streamId+ case mstrm0 of+ js@(Just strm0) -> do+ when (ftyp == FrameHeaders) $ do+ st <- readStreamState strm0+ when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"+ -- Priority made an idele stream+ when (isIdle st) $ opened ctx strm0+ return js+ Nothing+ | isResponse streamId -> return Nothing+ | otherwise -> do+ csid <- readIORef clientStreamId+ if streamId <= csid then -- consider the stream closed+ if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then+ return Nothing -- will be ignored+ else+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"+ else do -- consider the stream idle+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $+ E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)+ when (ftyp == FrameHeaders) $ do+ writeIORef clientStreamId streamId+ cnt <- readIORef concurrency+ -- Checking the limitation of concurrency+ when (cnt >= maxConcurrency) $+ E.throwIO $ StreamError RefusedStream streamId+ ws <- initialWindowSize <$> readIORef http2settings+ newstrm <- newStream streamId (fromIntegral ws)+ when (ftyp == FrameHeaders) $ opened ctx newstrm+ insert streamTable streamId newstrm+ return $ Just newstrm++ consume = void . recvN++maxConcurrency :: Int+maxConcurrency = recommendedConcurrency++initialFrame :: ByteString+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]++----------------------------------------------------------------++control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool+control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs+ traverse_ E.throwIO $ checkSettingsList alist+ -- HTTP/2 Setting from a browser+ unless (testAck flags) $ do+ oldws <- initialWindowSize <$> readIORef http2settings+ modifyIORef' http2settings $ \old -> updateSettings old alist+ newws <- initialWindowSize <$> readIORef http2settings+ let diff = newws - oldws+ when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable+ let !frame = settingsFrame setAck []+ sent <- readIORef firstSettings+ let !setframe+ | sent = CSettings frame alist+ | otherwise = CSettings0 initialFrame frame alist+ unless sent $ writeIORef firstSettings True+ enqueueControl controlQ setframe+ return True++control FramePing FrameHeader{flags} bs Context{controlQ} =+ if testAck flags then+ return True -- just ignore+ else do+ let !frame = pingFrame bs+ enqueueControl controlQ $ CFrame frame+ return True++control FrameGoAway _ _ Context{controlQ} = do+ enqueueControl controlQ CFinish+ return False++control FrameWindowUpdate header bs Context{connectionWindow} = do+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs+ !w <- atomically $ do+ w0 <- readTVar connectionWindow+ let !w1 = w0 + n+ writeTVar connectionWindow w1+ return w1+ when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"+ return True++control _ _ _ _ =+ -- must not reach here+ return False++----------------------------------------------------------------++{-# INLINE guardIt #-}+guardIt :: Either HTTP2Error a -> IO a+guardIt x = case x of+ Left err -> E.throwIO err+ Right frame -> return frame+++{-# INLINE checkPriority #-}+checkPriority :: Priority -> StreamId -> IO ()+checkPriority p me+ | dep == me = E.throwIO $ StreamError ProtocolError me+ | otherwise = return ()+ where+ dep = streamDependency p++stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState+stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs+ pri <- case mp of+ Nothing -> return defaultPriority+ Just p -> do+ checkPriority p streamNumber+ return p+ let !endOfStream = testEndStream flags+ !endOfHeader = testEndHeader flags+ if endOfHeader then do+ tbl <- hpackDecodeHeader frag ctx -- fixme+ return $ if endOfStream then+ Open (NoBody tbl pri)+ else+ Open (HasBody tbl pri)+ else do+ let !siz = BS.length frag+ return $ Open $ Continued [frag] siz 1 endOfStream pri++stream FrameHeaders header@FrameHeader{flags} bs ctx (Open (Body q _ _ tlr)) _ = do+ HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs+ let !endOfStream = testEndStream flags+ if endOfStream then do+ tbl <- hpackDecodeTrailer frag ctx+ writeIORef tlr (Just tbl)+ atomically $ writeTQueue q ""+ return HalfClosedRemote+ else+ -- we don't support continuation here.+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"++-- ignore data-frame except for flow-control when we're done locally+stream FrameData+ FrameHeader{flags,payloadLength}+ _bs+ Context{controlQ} s@(HalfClosedLocal _)+ Stream{streamNumber} = do+ let !endOfStream = testEndStream flags+ when (payloadLength /= 0) $ do+ let !frame1 = windowUpdateFrame 0 payloadLength+ !frame2 = windowUpdateFrame streamNumber payloadLength+ !frame = frame1 `BS.append` frame2+ enqueueControl controlQ $ CFrame frame+ if endOfStream then do+ return HalfClosedRemote+ else+ return s++stream FrameData+ header@FrameHeader{flags,payloadLength,streamId}+ bs+ Context{controlQ} s@(Open (Body q mcl bodyLength _))+ Stream{streamNumber} = do+ DataFrame body <- guardIt $ decodeDataFrame header bs+ let !endOfStream = testEndStream flags+ len0 <- readIORef bodyLength+ let !len = len0 + payloadLength+ writeIORef bodyLength len+ when (payloadLength /= 0) $ do+ let !frame1 = windowUpdateFrame 0 payloadLength+ !frame2 = windowUpdateFrame streamNumber payloadLength+ !frame = frame1 `BS.append` frame2+ enqueueControl controlQ $ CFrame frame+ atomically $ writeTQueue q body+ if endOfStream then do+ case mcl of+ Nothing -> return ()+ Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId+ -- no trailers+ atomically $ writeTQueue q ""+ return HalfClosedRemote+ else+ return s++stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do+ let !endOfHeader = testEndHeader flags+ !rfrags' = frag : rfrags+ !siz' = siz + BS.length frag+ !n' = n + 1+ when (siz' > 51200) $ -- fixme: hard coding: 50K+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"+ when (n' > 10) $ -- fixme: hard coding+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"+ if endOfHeader then do+ let !hdrblk = BS.concat $ reverse rfrags'+ tbl <- hpackDecodeHeader hdrblk ctx+ return $ if endOfStream then+ Open (NoBody tbl pri)+ else+ Open (HasBody tbl pri)+ else+ return $ Open $ Continued rfrags' siz' n' endOfStream pri++stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs+ !w <- atomically $ do+ w0 <- readTVar streamWindow+ let !w1 = w0 + n+ writeTVar streamWindow w1+ return w1+ when (isWindowOverflow w) $+ E.throwIO $ StreamError FlowControlError streamId+ return s++stream FrameRSTStream header bs ctx _ strm = do+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs+ let !cc = Reset e+ closed ctx strm cc+ return $ Closed cc -- will be written to streamState again++stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs+ checkPriority newpri streamNumber+ oldpre <- readIORef streamPrecedence+ let !newpre = toPrecedence newpri+ writeIORef streamPrecedence newpre+ if isIdle s then do+ n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))+ -- fixme hard coding+ when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"+ prepare outputQ streamNumber newpri+ else do+ mout <- delete outputQ streamNumber oldpre+ traverse_ (enqueueOutput outputQ) mout+ return s++-- this ordering is important+stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"+stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"+-- Ignore frames to streams we have just reset, per section 5.1.+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId++----------------------------------------------------------------++{-# INLINE newReadBody #-}+newReadBody :: TQueue ByteString -> IO (IO ByteString)+newReadBody q = do+ ref <- newIORef False+ return $ readBody q ref++{-# INLINE readBody #-}+readBody :: TQueue ByteString -> IORef Bool -> IO ByteString+readBody q ref = do+ eof <- readIORef ref+ if eof then+ return ""+ else do+ bs <- atomically $ readTQueue q+ when (bs == "") $ writeIORef ref True+ return bs
+ Network/HTTP2/Server/Run.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Server.Run where++import Control.Concurrent (forkIO, killThread)+import qualified Control.Exception as E++import Imports+import Network.HTTP2+import Network.HTTP2.Server.API+import Network.HTTP2.Server.EncodeFrame+import Network.HTTP2.Server.Manager+import Network.HTTP2.Server.Receiver+import Network.HTTP2.Server.Sender+import Network.HTTP2.Server.Worker+import Network.HTTP2.Server.Context++----------------------------------------------------------------++-- | Running HTTP/2 server.+run :: Config -> Server -> IO ()+run conf@Config{..} server = do+ ok <- checkPreface+ when ok $ do+ ctx <- newContext+ -- Workers, worker manager and timer manager+ mgr <- start+ setAction mgr $ worker ctx mgr server+ -- The number of workers is 3.+ -- This was carefully chosen based on a lot of benchmarks.+ -- If it is 1, we cannot avoid head-of-line blocking.+ -- If it is large, huge memory is consumed and many+ -- context switches happen.+ replicateM_ 3 $ spawnAction mgr+ -- Receiver+ tid <- forkIO $ frameReceiver ctx confReadN+ -- Sender+ -- frameSender is the main thread because it ensures to send+ -- a goway frame.+ frameSender ctx conf mgr `E.finally` do+ clearContext ctx+ stop mgr+ killThread tid+ where+ checkPreface = do+ preface <- confReadN connectionPrefaceLength+ if connectionPreface /= preface then do+ goaway conf ProtocolError "Preface mismatch"+ return False+ else+ return True++-- connClose must not be called here since Run:fork calls it+goaway :: Config -> ErrorCodeId -> ByteString -> IO ()+goaway Config{..} etype debugmsg = confSendAll bytestream+ where+ bytestream = goawayFrame 0 etype debugmsg
+ Network/HTTP2/Server/Sender.hs view
@@ -0,0 +1,457 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Server.Sender (frameSender) where++import Control.Concurrent.STM+import qualified Control.Exception as E+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder.Extra as B+import Data.IORef+import Foreign.Ptr (plusPtr)+import Network.ByteOrder++import Imports+import Network.HPACK (setLimitForEncoding, toHeaderTable)+import Network.HTTP2+import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)+import Network.HTTP2.Server.API+import Network.HTTP2.Server.EncodeFrame+import Network.HTTP2.Server.HPACK+import Network.HTTP2.Server.Manager hiding (start)+import Network.HTTP2.Server.Types+import Network.HTTP2.Server.Queue+import Network.HTTP2.Server.Context+import Network.HTTP2.Server.Stream++----------------------------------------------------------------++data Leftover = LZero+ | LOne B.BufferWriter+ | LTwo ByteString B.BufferWriter++----------------------------------------------------------------++{-# INLINE getStreamWindowSize #-}+getStreamWindowSize :: Stream -> IO WindowSize+getStreamWindowSize Stream{streamWindow} = readTVarIO streamWindow++{-# INLINE waitStreamWindowSize #-}+waitStreamWindowSize :: Stream -> IO ()+waitStreamWindowSize Stream{streamWindow} = atomically $ do+ w <- readTVar streamWindow+ check (w > 0)++{-# INLINE waitStreaming #-}+waitStreaming :: TBQueue a -> IO ()+waitStreaming tbq = atomically $ do+ isEmpty <- isEmptyTBQueue tbq+ check (not isEmpty)++data Switch = C Control+ | O (StreamId,Precedence,Output)+ | Flush++frameSender :: Context -> Config -> Manager -> IO ()+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}+ conf@Config{..}+ mgr = loop 0 `E.catch` ignore+ where+ dequeue off = do+ isEmpty <- isEmptyTQueue controlQ+ if isEmpty then do+ w <- readTVar connectionWindow+ check (w > 0)+ emp <- isEmptySTM outputQ+ if emp then+ if off /= 0 then return Flush else retry+ else+ O <$> dequeueSTM outputQ+ else+ C <$> readTQueue controlQ++ loop off = do+ x <- atomically $ dequeue off+ case x of+ C ctl -> do+ when (off /= 0) $ flushN off+ off' <- control ctl off+ when (off' >= 0) $ loop off'+ O (_,pre,out) -> do+ let strm = outputStream out+ writeIORef (streamPrecedence strm) pre+ off' <- outputOrEnqueueAgain out off+ case off' of+ 0 -> loop 0+ _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding+ | otherwise -> loop off'+ Flush -> flushN off >> loop 0++ control CFinish _ = return (-1)+ control (CGoaway frame) _ = confSendAll frame >> return (-1)+ control (CFrame frame) _ = confSendAll frame >> return 0+ control (CSettings frame alist) _ = do+ confSendAll frame+ setLimit alist+ return 0+ control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case+ let !buf = confWriteBuffer `plusPtr` off+ !off' = off + BS.length frame1 + BS.length frame2+ buf' <- copy buf frame1+ void $ copy buf' frame2+ setLimit alist+ return off'++ {-# INLINE setLimit #-}+ setLimit alist = case lookup SettingsHeaderTableSize alist of+ Nothing -> return ()+ Just siz -> setLimitForEncoding siz encodeDynamicTable++ output out@(Output strm (Response _ _ _ _) (ONext curr tlrmkr) _ sentinel) off0 lim = do+ -- Data frame payload+ let !buf = confWriteBuffer `plusPtr` off0+ !siz = confBufferSize - off0+ !payloadOff = off0 + frameHeaderLength+ Next datPayloadLen mnext <- curr buf siz lim+ NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen+ fillDataHeaderEnqueueNext strm off0 datPayloadLen mnext tlrmkr' sentinel out++ output out@(Output strm (Response st hdr body tlrmkr) ORspn mtbq sentinel) off0 lim = do+ -- Header frame and Continuation frame+ let !sid = streamNumber strm+ !endOfStream = case body of+ RspNoBody -> True+ _ -> False+ (ths,_) <- toHeaderTable $ fixHeaders st hdr+ kvlen <- headerContinue sid ths endOfStream off0+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen+ case body of+ RspNoBody -> do+ halfClosedLocal ctx strm Finished+ return off+ RspFile (FileSpec path fileoff bytecount) -> do+ -- Data frame payload+ let payloadOff = off + frameHeaderLength+ Next datPayloadLen mnext <-+ fillFileBodyGetNext conf payloadOff lim path fileoff bytecount mgr confPositionReadMaker+ NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen+ fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out+ RspBuilder builder -> do+ -- Data frame payload+ let payloadOff = off + frameHeaderLength+ Next datPayloadLen mnext <-+ fillBuilderBodyGetNext conf payloadOff lim builder+ NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen+ fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out+ RspStreaming _ -> do+ let payloadOff = off + frameHeaderLength+ Next datPayloadLen mnext <-+ fillStreamBodyGetNext conf payloadOff lim (fromJust mtbq) strm+ NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen+ fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out++ output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do+ -- Creating a push promise header+ -- Frame id should be associated stream id from the client.+ let !sid = streamNumber strm+ len <- pushPromise pid sid ths off0+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len+ output out{outputType=ORspn} off lim++ output _ _ _ = undefined -- never reach++ outputOrEnqueueAgain :: Output -> Int -> IO Int+ outputOrEnqueueAgain out@(Output strm _ otyp _ _) off = E.handle resetStream $ do+ state <- readStreamState strm+ if isHalfClosedLocal state then+ return off+ else case otyp of+ OWait wait -> do+ -- Checking if all push are done.+ forkAndEnqueueWhenReady wait outputQ out{outputType=ORspn} mgr+ return off+ _ -> case mtbq of+ Just tbq -> checkStreaming tbq+ _ -> checkStreamWindowSize+ where+ mtbq = outputStrmQ out+ checkStreaming tbq = do+ isEmpty <- atomically $ isEmptyTBQueue tbq+ if isEmpty then do+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr+ return off+ else+ checkStreamWindowSize+ checkStreamWindowSize = do+ sws <- getStreamWindowSize strm+ if sws == 0 then do+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr+ return off+ else do+ cws <- readTVarIO connectionWindow -- not 0+ let !lim = min cws sws+ output out off lim+ resetStream e = do+ closed ctx strm (ResetByMe e)+ let !rst = resetFrame InternalError $ streamNumber strm+ enqueueControl controlQ $ CFrame rst+ return off++ {-# INLINE flushN #-}+ -- Flush the connection buffer to the socket, where the first 'n' bytes of+ -- the buffer are filled.+ flushN :: Int -> IO ()+ flushN n = bufferIO confWriteBuffer n confSendAll++ headerContinue sid ths endOfStream off = do+ let !offkv = off + frameHeaderLength+ let !bufkv = confWriteBuffer `plusPtr` offkv+ !limkv = confBufferSize - offkv+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths+ let flag0 = case hs of+ [] -> setEndHeader defaultFlags+ _ -> defaultFlags+ flag = if endOfStream then setEndStream flag0 else flag0+ let buf = confWriteBuffer `plusPtr` off+ fillFrameHeader FrameHeaders kvlen sid flag buf+ continue sid kvlen hs++ !bufHeaderPayload = confWriteBuffer `plusPtr` frameHeaderLength+ !headerPayloadLim = confBufferSize - frameHeaderLength++ continue _ kvlen [] = return kvlen+ continue sid kvlen ths = do+ flushN $ kvlen + frameHeaderLength+ -- Now off is 0+ (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths+ when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"+ let flag = case ths' of+ [] -> setEndHeader defaultFlags+ _ -> defaultFlags+ fillFrameHeader FrameContinuation kvlen' sid flag confWriteBuffer+ continue sid kvlen' ths'++ {-# INLINE sendHeadersIfNecessary #-}+ -- Send headers if there is not room for a 1-byte data frame, and return+ -- the offset of the next frame's first header byte.+ sendHeadersIfNecessary off+ -- True if the connection buffer has room for a 1-byte data frame.+ | off + frameHeaderLength < confBufferSize = return off+ | otherwise = do+ flushN off+ return 0++ fillDataHeaderEnqueueNext strm@Stream{streamWindow,streamNumber}+ off datPayloadLen Nothing tlrmkr tell _ = do+ let !buf = confWriteBuffer `plusPtr` off+ !off' = off + frameHeaderLength + datPayloadLen+ (mtrailers, flag) <- do+ Trailers !trailers <- tlrmkr Nothing+ if null trailers then+ return (Nothing, setEndStream defaultFlags)+ else+ return (Just trailers, defaultFlags)+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf+ off'' <- handleTrailers mtrailers off'+ void tell+ halfClosedLocal ctx strm Finished+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)+ return off''+ where+ handleTrailers Nothing off0 = return off0+ handleTrailers (Just trailers) off0 = do+ (ths,_) <- toHeaderTable trailers+ kvlen <- headerContinue streamNumber ths True off0+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen++ fillDataHeaderEnqueueNext Stream{streamWindow,streamNumber}+ off datPayloadLen (Just next) tlrmkr _ out = do+ let !buf = confWriteBuffer `plusPtr` off+ !off' = off + frameHeaderLength + datPayloadLen+ flag = defaultFlags+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)+ let !out' = out { outputType = ONext next tlrmkr }+ enqueueOutput outputQ out'+ return off'++ pushPromise pid sid ths off = do+ let !offsid = off + frameHeaderLength+ !bufsid = confWriteBuffer `plusPtr` offsid+ poke32 (fromIntegral sid) bufsid 0+ let !offkv = offsid + 4+ !bufkv = confWriteBuffer `plusPtr` offkv+ !limkv = confBufferSize - offkv+ (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths+ let !flag = setEndHeader defaultFlags -- No EndStream flag+ !buf = confWriteBuffer `plusPtr` off+ !len = kvlen + 4+ fillFrameHeader FramePushPromise len pid flag buf+ return len++ {-# INLINE fillFrameHeader #-}+ fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf+ where+ hinfo = FrameHeader len flag sid++ runTrailersMaker tlrmkr off siz = do+ let datBuf = confWriteBuffer `plusPtr` off+ bufferIO datBuf siz $ \bs -> tlrmkr (Just bs)++ {-# INLINE ignore #-}+ ignore :: E.SomeException -> IO ()+ ignore _ = return ()++----------------------------------------------------------------++fillBuilderBodyGetNext :: Config -> Int -> WindowSize -> Builder -> IO Next+fillBuilderBodyGetNext Config{confWriteBuffer,confBufferSize}+ off lim bb = do+ let datBuf = confWriteBuffer `plusPtr` off+ room = min (confBufferSize - off) lim+ (len, signal) <- B.runBuilder bb datBuf room+ return $ nextForBuilder len signal++fillFileBodyGetNext :: Config -> Int -> WindowSize -> FilePath -> FileOffset -> ByteCount -> Manager -> PositionReadMaker -> IO Next+fillFileBodyGetNext Config{confWriteBuffer,confBufferSize}+ off lim path start bytecount mgr prmaker = do+ let datBuf = confWriteBuffer `plusPtr` off+ room = min (confBufferSize - off) lim+ (pread, sentinel) <- prmaker path+ refresh <- case sentinel of+ Closer closer -> timeoutClose mgr closer+ Refresher refresher -> return refresher+ len <- pread start (mini room bytecount) datBuf+ let len' = fromIntegral len+ return $ nextForFile len' pread (start + len) (bytecount - len) refresh++----------------------------------------------------------------++fillStreamBodyGetNext :: Config -> Int -> WindowSize -> TBQueue RspStreaming -> Stream -> IO Next+fillStreamBodyGetNext Config{confWriteBuffer,confBufferSize}+ off lim sq strm = do+ let datBuf = confWriteBuffer `plusPtr` off+ room = min (confBufferSize - off) lim+ (leftover, cont, len) <- runStreamBuilder datBuf room sq+ return $ nextForStream sq strm leftover cont len++----------------------------------------------------------------++fillBufBuilder :: Leftover -> DynaNext+fillBufBuilder leftover buf0 siz0 lim = do+ let payloadBuf = buf0 `plusPtr` frameHeaderLength+ room = min (siz0 - frameHeaderLength) lim+ case leftover of+ LZero -> error "fillBufBuilder: LZero"+ LOne writer -> do+ (len, signal) <- writer payloadBuf room+ getNext len signal+ LTwo bs writer+ | BS.length bs <= room -> do+ buf1 <- copy payloadBuf bs+ let len1 = BS.length bs+ (len2, signal) <- writer buf1 (room - len1)+ getNext (len1 + len2) signal+ | otherwise -> do+ let (bs1,bs2) = BS.splitAt room bs+ void $ copy payloadBuf bs1+ getNext room (B.Chunk bs2 writer)+ where+ getNext l s = return $ nextForBuilder l s++nextForBuilder :: BytesFilled -> B.Next -> Next+nextForBuilder len B.Done+ = Next len Nothing+nextForBuilder len (B.More _ writer)+ = Next len $ Just (fillBufBuilder (LOne writer))+nextForBuilder len (B.Chunk bs writer)+ = Next len $ Just (fillBufBuilder (LTwo bs writer))++----------------------------------------------------------------++runStreamBuilder :: Buffer -> BufferSize -> TBQueue RspStreaming+ -> IO (Leftover, Bool, BytesFilled)+runStreamBuilder buf0 room0 sq = loop buf0 room0 0+ where+ loop !buf !room !total = do+ mbuilder <- atomically $ tryReadTBQueue sq+ case mbuilder of+ Nothing -> return (LZero, True, total)+ Just (RSBuilder builder) -> do+ (len, signal) <- B.runBuilder builder buf room+ let !total' = total + len+ case signal of+ B.Done -> loop (buf `plusPtr` len) (room - len) total'+ B.More _ writer -> return (LOne writer, True, total')+ B.Chunk bs writer -> return (LTwo bs writer, True, total')+ Just RSFlush -> return (LZero, True, total)+ Just RSFinish -> return (LZero, False, total)++fillBufStream :: Leftover -> TBQueue RspStreaming -> Stream -> DynaNext+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do+ let payloadBuf = buf0 `plusPtr` frameHeaderLength+ room0 = min (siz0 - frameHeaderLength) lim0+ case leftover0 of+ LZero -> do+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq+ getNext leftover cont len+ LOne writer -> write writer payloadBuf room0 0+ LTwo bs writer+ | BS.length bs <= room0 -> do+ buf1 <- copy payloadBuf bs+ let len = BS.length bs+ write writer buf1 (room0 - len) len+ | otherwise -> do+ let (bs1,bs2) = BS.splitAt room0 bs+ void $ copy payloadBuf bs1+ getNext (LTwo bs2 writer) True room0+ where+ getNext l b r = return $ nextForStream sq strm l b r+ write writer1 buf room sofar = do+ (len, signal) <- writer1 buf room+ case signal of+ B.Done -> do+ (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq+ let !total = sofar + len + extra+ getNext leftover cont total+ B.More _ writer -> do+ let !total = sofar + len+ getNext (LOne writer) True total+ B.Chunk bs writer -> do+ let !total = sofar + len+ getNext (LTwo bs writer) True total++nextForStream :: TBQueue RspStreaming -> Stream+ -> Leftover -> Bool -> BytesFilled+ -> Next+nextForStream _ _ _ False len = Next len Nothing+nextForStream sq strm leftOrZero True len =+ Next len $ Just (fillBufStream leftOrZero sq strm)++----------------------------------------------------------------++fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext+fillBufFile pread start bytes refresh buf siz lim = do+ let payloadBuf = buf `plusPtr` frameHeaderLength+ room = min (siz - frameHeaderLength) lim+ len <- pread start (mini room bytes) payloadBuf+ refresh+ let len' = fromIntegral len+ return $ nextForFile len' pread (start + len) (bytes - len) refresh++nextForFile :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next+nextForFile 0 _ _ _ _ = Next 0 Nothing+nextForFile len _ _ 0 _ = Next len Nothing+nextForFile len pread start bytes refresh =+ Next len $ Just (fillBufFile pread start bytes refresh)++{-# INLINE mini #-}+mini :: Int -> Int64 -> Int64+mini i n+ | fromIntegral i < n = fromIntegral i+ | otherwise = n
+ Network/HTTP2/Server/Stream.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++module Network.HTTP2.Server.Stream where++import Control.Concurrent.STM+import Data.IORef+import qualified Data.IntMap.Strict as M++import Imports+import Network.HTTP2+import Network.HTTP2.Priority+import Network.HTTP2.Server.Types++----------------------------------------------------------------++isIdle :: StreamState -> Bool+isIdle Idle = True+isIdle _ = False++isOpen :: StreamState -> Bool+isOpen Open{} = True+isOpen _ = False++isHalfClosedRemote :: StreamState -> Bool+isHalfClosedRemote HalfClosedRemote = True+isHalfClosedRemote (Closed _) = True+isHalfClosedRemote _ = False++isHalfClosedLocal :: StreamState -> Bool+isHalfClosedLocal (HalfClosedLocal _) = True+isHalfClosedLocal (Closed _) = True+isHalfClosedLocal _ = False++isClosed :: StreamState -> Bool+isClosed Closed{} = True+isClosed _ = False++----------------------------------------------------------------++newStream :: StreamId -> WindowSize -> IO Stream+newStream sid win = Stream sid <$> newIORef Idle+ <*> newTVarIO win+ <*> newIORef defaultPrecedence++----------------------------------------------------------------++{-# INLINE readStreamState #-}+readStreamState :: Stream -> IO StreamState+readStreamState Stream{streamState} = readIORef streamState++----------------------------------------------------------------++newStreamTable :: IO StreamTable+newStreamTable = StreamTable <$> newIORef M.empty++insert :: StreamTable -> M.Key -> Stream -> IO ()+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->+ let !m' = M.insert k v m+ in (m', ())++remove :: StreamTable -> M.Key -> IO ()+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->+ let !m' = M.delete k m+ in (m', ())++search :: StreamTable -> M.Key -> IO (Maybe Stream)+search (StreamTable ref) k = M.lookup k <$> readIORef ref++updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()+updateAllStreamWindow adst (StreamTable ref) = do+ strms <- M.elems <$> readIORef ref+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst+
+ Network/HTTP2/Server/Types.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP2.Server.Types where++import Control.Concurrent.STM+import Control.Exception (SomeException)+import Data.ByteString.Builder (Builder)+import Data.IORef+import Data.IntMap.Strict (IntMap)++import Imports+import Network.HPACK+import Network.HTTP2+import Network.HTTP2.Priority+import Network.HTTP2.Server.API++----------------------------------------------------------------++data OpenState =+ JustOpened+ | Continued [HeaderBlockFragment]+ !Int -- Total size+ !Int -- The number of continuation frames+ !Bool -- End of stream+ !Priority+ | NoBody HeaderTable !Priority+ | HasBody HeaderTable !Priority+ | Body !(TQueue ByteString)+ !(Maybe Int) -- received Content-Length+ -- compared the body length for error checking+ !(IORef Int) -- actual body length+ !(IORef (Maybe HeaderTable)) -- trailers++data ClosedCode = Finished+ | Killed+ | Reset !ErrorCodeId+ | ResetByMe SomeException+ deriving Show++----------------------------------------------------------------++data StreamState =+ Idle+ | Open !OpenState+ | HalfClosedRemote+ | HalfClosedLocal !ClosedCode+ | Closed !ClosedCode+ | Reserved++instance Show StreamState where+ show Idle = "Idle"+ show Open{} = "Open"+ show HalfClosedRemote = "HalfClosedRemote"+ show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e+ show (Closed e) = "Closed: " ++ show e+ show Reserved = "Reserved"++----------------------------------------------------------------++data Stream = Stream {+ streamNumber :: !StreamId+ , streamState :: !(IORef StreamState)+ , streamWindow :: !(TVar WindowSize)+ , streamPrecedence :: !(IORef Precedence)+ }++instance Show Stream where+ show s = show (streamNumber s)++----------------------------------------------------------------++newtype StreamTable = StreamTable (IORef (IntMap Stream))++----------------------------------------------------------------++data Input = Input Stream Request++data Output = Output {+ outputStream :: Stream+ , outputResponse :: Response+ , outputType :: OutputType+ , outputStrmQ :: Maybe (TBQueue RspStreaming)+ , outputSentinel :: IO ()+ }++data OutputType = ORspn+ | OWait (IO ())+ | OPush !TokenHeaderList !StreamId -- associated stream id from client+ | ONext !DynaNext !TrailersMaker++----------------------------------------------------------------++type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next++type BytesFilled = Int++data Next = Next !BytesFilled (Maybe DynaNext)++----------------------------------------------------------------++data Control = CFinish+ | CGoaway !ByteString+ | CFrame !ByteString+ | CSettings !ByteString !SettingsList+ | CSettings0 !ByteString !ByteString !SettingsList++----------------------------------------------------------------++data RspStreaming = RSFinish+ | RSFlush+ | RSBuilder Builder
+ Network/HTTP2/Server/Worker.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Server.Worker (+ worker+ ) where++import Control.Concurrent.STM+import Control.Exception (SomeException(..), AsyncException(..))+import qualified Control.Exception as E+import Data.IORef+import qualified Network.HTTP.Types as H+import qualified System.TimeManager as T++import Imports hiding (insert)+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP2+import Network.HTTP2.Priority+import Network.HTTP2.Server.API+import Network.HTTP2.Server.Context+import Network.HTTP2.Server.EncodeFrame+import Network.HTTP2.Server.Manager+import Network.HTTP2.Server.Queue+import Network.HTTP2.Server.Stream+import Network.HTTP2.Server.Types++----------------------------------------------------------------++pushStream :: Context+ -> Stream -- parent stream+ -> ValueTable -- request+ -> [PushPromise]+ -> IO OutputType+pushStream _ _ _ [] = return ORspn+pushStream ctx@Context{..} pstrm reqvt pps0+ | len == 0 = return ORspn+ | otherwise = do+ pushable <- enablePush <$> readIORef http2settings+ if pushable then do+ tvar <- newTVarIO 0+ lim <- push tvar pps0 0+ if lim == 0 then+ return ORspn+ else+ return $ OWait (waiter lim tvar)+ else+ return ORspn+ where+ !pid = streamNumber pstrm+ !len = length pps0+ increment tvar = atomically $ modifyTVar' tvar (+1)+ waiter lim tvar = atomically $ do+ n <- readTVar tvar+ check (n >= lim)+ push _ [] !n = return (n :: Int)+ push tvar (pp:pps) !n = do+ ws <- initialWindowSize <$> readIORef http2settings+ let !w = promiseWeight pp+ !pri = defaultPriority { weight = w }+ !pre = toPrecedence pri+ newstrm <- newPushStream ctx ws pre+ let !sid = streamNumber newstrm+ insert streamTable sid newstrm+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt+ -- fixme: this value can be Nothing+ !auth = fromJust (getHeaderValue tokenHost reqvt+ <|> getHeaderValue tokenAuthority reqvt)+ !path = promiseRequestPath pp+ !promiseRequest = [(tokenMethod, H.methodGet)+ ,(tokenScheme, scheme)+ ,(tokenAuthority, auth)+ ,(tokenPath, path)]+ !ot = OPush promiseRequest pid+ !rsp = promiseResponse pp+ !out = Output newstrm rsp ot Nothing $ increment tvar+ enqueueOutput outputQ out+ push tvar pps (n + 1)++-- | This function is passed to workers.+-- They also pass 'Response's from a server to this function.+-- This function enqueues commands for the HTTP/2 sender.+response :: Context -> Manager -> T.Handle -> ThreadContinue -> Stream -> Request -> Response -> [PushPromise] -> IO ()+response ctx@Context{..} mgr th tconf strm req rsp pps = case responseBody rsp of+ RspNoBody -> do+ setThreadContinue tconf True+ enqueueOutput outputQ $ Output strm rsp ORspn Nothing (return ())+ RspBuilder _ -> do+ otyp <- pushStream ctx strm reqvt pps+ setThreadContinue tconf True+ enqueueOutput outputQ $ Output strm rsp otyp Nothing (return ())+ RspFile _ -> do+ otyp <- pushStream ctx strm reqvt pps+ setThreadContinue tconf True+ enqueueOutput outputQ $ Output strm rsp otyp Nothing (return ())+ RspStreaming strmbdy -> do+ otyp <- pushStream ctx strm reqvt pps+ -- We must not exit this WAI application.+ -- If the application exits, streaming would be also closed.+ -- So, this work occupies this thread.+ --+ -- We need to increase the number of workers.+ spawnAction mgr+ -- After this work, this thread stops to decease+ -- the number of workers.+ setThreadContinue tconf False+ -- Since streaming body is loop, we cannot control it.+ -- So, let's serialize 'Builder' with a designated queue.+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10+ enqueueOutput outputQ $ Output strm rsp otyp (Just tbq) (return ())+ let push b = do+ T.pause th+ atomically $ writeTBQueue tbq (RSBuilder b)+ T.resume th+ flush = atomically $ writeTBQueue tbq RSFlush+ strmbdy push flush+ atomically $ writeTBQueue tbq RSFinish+ deleteMyId mgr+ where+ (_,reqvt) = requestHeaders req++worker :: Context -> Manager -> Server -> Action+worker ctx@Context{inputQ,controlQ} mgr server = do+ sinfo <- newStreamInfo+ tcont <- newThreadContinue+ timeoutKillThread mgr $ go sinfo tcont+ where+ go sinfo tcont th = do+ setThreadContinue tcont True+ ex <- E.try $ do+ T.pause th+ Input strm req <- atomically $ readTQueue inputQ+ let req' = pauseRequestBody req th+ setStreamInfo sinfo strm+ T.resume th+ T.tickle th+ let aux = Aux th+ server req aux $ response ctx mgr th tcont strm req'+ cont1 <- case ex of+ Right () -> return True+ Left e@(SomeException _)+ -- killed by the local worker manager+ | Just ThreadKilled <- E.fromException e -> return False+ -- killed by the local timeout manager+ | Just T.TimeoutThread <- E.fromException e -> do+ cleanup sinfo+ return True+ | otherwise -> do+ cleanup sinfo+ return True+ cont2 <- getThreadContinue tcont+ clearStreamInfo sinfo+ when (cont1 && cont2) $ go sinfo tcont th+ pauseRequestBody req th = req { requestBody = readBody' }+ where+ !readBody = requestBody req+ !readBody' = do+ T.pause th+ bs <- readBody+ T.resume th+ return bs+ cleanup sinfo = do+ minp <- getStreamInfo sinfo+ case minp of+ Nothing -> return ()+ Just strm -> do+ closed ctx strm Killed+ let !frame = resetFrame InternalError (streamNumber strm)+ enqueueControl controlQ $ CFrame frame++----------------------------------------------------------------++-- A reference is shared by a responder and its worker.+-- The reference refers a value of this type as a return value.+-- If 'True', the worker continue to serve requests.+-- Otherwise, the worker get finished.+newtype ThreadContinue = ThreadContinue (IORef Bool)++{-# INLINE newThreadContinue #-}+newThreadContinue :: IO ThreadContinue+newThreadContinue = ThreadContinue <$> newIORef True++{-# INLINE setThreadContinue #-}+setThreadContinue :: ThreadContinue -> Bool -> IO ()+setThreadContinue (ThreadContinue ref) x = writeIORef ref x++{-# INLINE getThreadContinue #-}+getThreadContinue :: ThreadContinue -> IO Bool+getThreadContinue (ThreadContinue ref) = readIORef ref++----------------------------------------------------------------++-- | The type for cleaning up.+newtype StreamInfo = StreamInfo (IORef (Maybe Stream))++{-# INLINE newStreamInfo #-}+newStreamInfo :: IO StreamInfo+newStreamInfo = StreamInfo <$> newIORef Nothing++{-# INLINE clearStreamInfo #-}+clearStreamInfo :: StreamInfo -> IO ()+clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing++{-# INLINE setStreamInfo #-}+setStreamInfo :: StreamInfo -> Stream -> IO ()+setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp++{-# INLINE getStreamInfo #-}+getStreamInfo :: StreamInfo -> IO (Maybe Stream)+getStreamInfo (StreamInfo ref) = readIORef ref
Network/HTTP2/Types.hs view
@@ -75,12 +75,9 @@ ) where import qualified Control.Exception as E-import Data.Bits (setBit, testBit, clearBit)-import Data.ByteString (ByteString)-import Data.List (foldl')-import Data.Maybe (mapMaybe) import Data.Typeable-import Data.Word (Word8, Word16, Word32)++import Imports ----------------------------------------------------------------
bench-hpack/Main.hs view
@@ -3,7 +3,7 @@ module Main where import Control.Exception-import Criterion.Main+import Gauge.Main import Network.HPACK import Data.ByteString (ByteString)
bench-priority/Main.hs view
@@ -3,7 +3,7 @@ module Main where import Control.Concurrent.STM-import Criterion.Main+import Gauge.Main import Data.List (foldl') import System.Random.MWC
http2.cabal view
@@ -1,11 +1,11 @@ Name: http2-Version: 1.6.5+Version: 2.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3 License-File: LICENSE-Synopsis: HTTP/2 library including frames, priority queues and HPACK-Description: HTTP/2 library including frames, priority queues and HPACK.+Synopsis: HTTP/2 library+Description: HTTP/2 library including frames, priority queues, HPACK and server. Homepage: https://github.com/kazu-yamamoto/http2 Category: Network Cabal-Version: >= 1.10@@ -55,7 +55,8 @@ Network.HPACK.Token Network.HTTP2 Network.HTTP2.Priority- Other-Modules: Network.HPACK.Buffer+ Network.HTTP2.Server+ Other-Modules: Imports Network.HPACK.Builder Network.HPACK.Huffman Network.HPACK.Huffman.Bit@@ -78,15 +79,35 @@ Network.HTTP2.Encode Network.HTTP2.Priority.PSQ Network.HTTP2.Priority.Queue+ Network.HTTP2.Server.API+ Network.HTTP2.Server.Config+ Network.HTTP2.Server.Context+ Network.HTTP2.Server.EncodeFrame+ Network.HTTP2.Server.File+ Network.HTTP2.Server.HPACK+ Network.HTTP2.Server.Manager+ Network.HTTP2.Server.Queue+ Network.HTTP2.Server.ReadN+ Network.HTTP2.Server.Receiver+ Network.HTTP2.Server.Run+ Network.HTTP2.Server.Sender+ Network.HTTP2.Server.Stream+ Network.HTTP2.Server.Types+ Network.HTTP2.Server.Worker Network.HTTP2.Types Build-Depends: base >= 4.8 && < 5 , array , bytestring >= 0.10 , case-insensitive , containers >= 0.5+ , http-types+ , network , network-byte-order , psqueues , stm+ , time-manager+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData ---------------------------------------------------------------- @@ -98,6 +119,8 @@ Main-Is: doctests.hs Build-Depends: base >= 4 && < 5 , doctest >= 0.9.3+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Test-Suite spec Type: exitcode-stdio-1.0@@ -112,8 +135,8 @@ HPACK.IntegerSpec HTTP2.FrameSpec HTTP2.PrioritySpec+ Imports Network.HPACK- Network.HPACK.Buffer Network.HPACK.Builder Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode@@ -133,11 +156,27 @@ Network.HPACK.Table.Static Network.HPACK.Token Network.HPACK.Types+ Network.HTTP2 Network.HTTP2.Decode Network.HTTP2.Encode Network.HTTP2.Priority Network.HTTP2.Priority.PSQ Network.HTTP2.Priority.Queue+ Network.HTTP2.Server.API+ Network.HTTP2.Server.Config+ Network.HTTP2.Server.Context+ Network.HTTP2.Server.EncodeFrame+ Network.HTTP2.Server.File+ Network.HTTP2.Server.HPACK+ Network.HTTP2.Server.Manager+ Network.HTTP2.Server.Queue+ Network.HTTP2.Server.ReadN+ Network.HTTP2.Server.Receiver+ Network.HTTP2.Server.Run+ Network.HTTP2.Server.Sender+ Network.HTTP2.Server.Stream+ Network.HTTP2.Server.Types+ Network.HTTP2.Server.Worker Network.HTTP2.Types Build-Depends: base >= 4 && < 5 , array@@ -146,10 +185,14 @@ , case-insensitive , containers , hspec >= 1.3+ , http-types+ , network , network-byte-order , psqueues , stm- , word8+ , time-manager+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Test-Suite hpack Type: exitcode-stdio-1.0@@ -160,8 +203,8 @@ Other-Modules: HPACKDecode HPACKSpec JSON+ Imports Network.HPACK- Network.HPACK.Buffer Network.HPACK.Builder Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode@@ -181,6 +224,28 @@ Network.HPACK.Table.Static Network.HPACK.Token Network.HPACK.Types+ Network.HTTP2+ Network.HTTP2.Decode+ Network.HTTP2.Encode+ Network.HTTP2.Priority+ Network.HTTP2.Priority.PSQ+ Network.HTTP2.Priority.Queue+ Network.HTTP2.Server.API+ Network.HTTP2.Server.Config+ Network.HTTP2.Server.Context+ Network.HTTP2.Server.EncodeFrame+ Network.HTTP2.Server.File+ Network.HTTP2.Server.HPACK+ Network.HTTP2.Server.Manager+ Network.HTTP2.Server.Queue+ Network.HTTP2.Server.ReadN+ Network.HTTP2.Server.Receiver+ Network.HTTP2.Server.Run+ Network.HTTP2.Server.Sender+ Network.HTTP2.Server.Stream+ Network.HTTP2.Server.Types+ Network.HTTP2.Server.Worker+ Network.HTTP2.Types Build-Depends: base >= 4 && < 5 , aeson , aeson-pretty@@ -192,11 +257,17 @@ , directory , filepath , hspec >= 1.3+ , http-types+ , network , network-byte-order+ , psqueues+ , stm , text+ , time-manager , unordered-containers , vector- , word8+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Test-Suite frame Type: exitcode-stdio-1.0@@ -220,6 +291,8 @@ , network-byte-order , text , unordered-containers+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData ---------------------------------------------------------------- @@ -273,6 +346,8 @@ , unordered-containers , vector , word8+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Executable hpack-stat Default-Language: Haskell2010@@ -299,6 +374,8 @@ , unordered-containers , vector , word8+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Executable frame-encode Default-Language: Haskell2010@@ -319,11 +396,13 @@ , http2 , text , unordered-containers+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData Benchmark priority Type: exitcode-stdio-1.0 Default-Language: Haskell2010- Hs-Source-Dirs: bench-priority+ Hs-Source-Dirs: bench-priority, . Ghc-Options: -Wall Main-Is: Main.hs Other-Modules: BinaryHeap@@ -333,11 +412,12 @@ RandomSkewHeap RingOfQueues RingOfQueuesSTM+ Network.HTTP2.Priority.PSQ Build-Depends: base , array , case-insensitive , containers- , criterion+ , gauge , heaps , mwc-random , network-byte-order@@ -355,6 +435,9 @@ , bytestring , case-insensitive , containers- , criterion+ , gauge , network-byte-order , stm+ , http2+ if impl(ghc >= 8)+ Default-Extensions: Strict StrictData
test/HPACK/EncodeSpec.hs view
@@ -22,7 +22,7 @@ it "works for StaticH" $ run EncodeStrategy {compressionAlgo = Static, useHuffman = True} [] it "works for Linear" $- run EncodeStrategy {compressionAlgo = Linear, useHuffman = False} linearLens+ run EncodeStrategy {compressionAlgo = Linear, useHuffman = False} [] -- linearLens it "works for LinearH" $ run EncodeStrategy {compressionAlgo = Linear, useHuffman = True} [] @@ -40,11 +40,11 @@ putStrLn $ "encodeHeader: " ++ show e print h E.throwIO e- let lens' = case lens of+ lens' <- case lens of l:ls- | BS.length bs == l -> ls- | otherwise -> error $ show h ++ "\nshould be " ++ show l- [] -> []+ | BS.length bs == l -> return ls+ | otherwise -> error $ "The length of encoded headers should be " ++ show l ++ " but " ++ show (BS.length bs)+ [] -> return [] h' <- decodeHeader dtbl bs `E.catch` \(E.SomeException e) -> do putStrLn $ "decodeHeader: " ++ show e print h@@ -54,5 +54,7 @@ else do return False +{- fixme: form where these values come? linearLens :: [Int] linearLens = [250,312,26,390,288,204,224,204,200,202,204,204,206,206,228,100,204,204,218,208,228,434,208,608,232,208,208,208,98,202,208,256,168,208,208,224,208,208,382,84,242,208,208,232,208,208,208,210,210,210,210,208,210,222,208,210,400,224,238,206,206,230,252,222,202,202,198,138,250,204,216,204,204,108,96,306,250,242,208,94,226,206,264,222,40,224,810,204,38,266,144,158,254,100,206,110,132,38,254,144,102,132,102,102,102,102,102,210,230,208,204,464,224,142,198,198,410,156,250,218,130,18,26,338,284,238,222,36,142,208,92,34,552,152,206,1020,288,42,490,98,40,1884,434,300,240,206,278,278,268,252,460,632,178,220,298,144,430,746,724,202,330,144,204,206,782,146,206,206,146,240,228,204,206,208,300,144,160,146,146,38,280,220,144,146,100,144,418,206,204,294,144,300,228,204,204,146,144,240,204,244,218,230,286,102,256,202,208,206,144,146,206,836,204,842,300,220,326,182,300,148,150,204,144,144,98,146,204,206,146,100,204,222,202,202,166,268,146,40,38,142,38,206,418,318,226,174,256,246,274,208,208,208,208,208,544,254,146,146,144,268,160,572,362,178,224,590,362,3150,1034,316,402,204,228,206,206,40,146,142,266,158,142,354,380,264,702,74,424,674,410,688,322,250,300,204,188,60,298,204,206,468,230,200,232,222,208,210,272,282,252,218,724,144,238,206,208,210,100,254,146,144,124,38,112,204,204,216,168,208,276,100,206,116,100,326,892,194,102,210,102,210,206,40,126,102,100,208,98,242,206,218,278,282,292,234,144,40,144,202,288,206,98,40,146,148,40,116,850,242,38,40,40,148,204,110,290,162,662,212,218,230,100,100,134,100,1026,100,2442,100,100,100,208,100,100,112,100,164,144,100,100,100,110,100,518,202,232,342,728,46,384,204,230,100,398,100,208,114,102,290,208,246,324,782,296,280,796,636,268,84,74,246,34,38,284,612,1090,332,602,378,84,24,256,204,234,26,226,654,60,206,28,160,220,238,38,204,484,206,440,308,206,246,392,314,814,714,200,244,290,258,50,94,252,572,38,284,1050,286,24,252,24,728,46,400,390,330,214,740,368,244,38,252,32,244,252,246,36,94,22,638,296,206,304,32,34,246,240,20,306,340,28,276,226,814,638,278,40,226,50,38,34,42,630,552,252,84,244,252,240,20,198,346,284,290,202,240,300,206,102,214,204,210,430,210,208,144,252,210,240,208,304,224,208,100,354,102,210,764,102,240,210,208,208,102,208,102,208,208,100,102,208,210,100,100,154,268,222,286,256,260,92,642,232,208,262,204,146,100,260,226,146,72,206,38,98,394,1090,348,2602,112,102,490,526,312,486,366,368,368,368,368,674,46,462,202,220,210,516,906,154,384,300,280,206,102,102,102,102,102,102,102,626,102,160,88,226,50,248,34,36,632,308,1124,684,450,254,252,714,60]+-}