diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Imports.hs b/Imports.hs new file mode 100644 --- /dev/null +++ b/Imports.hs @@ -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 diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -33,6 +33,7 @@ , TokenHeader -- * Value table , ValueTable + , HeaderTable , getHeaderValue , toHeaderTable -- * Basic types diff --git a/Network/HPACK/Buffer.hs b/Network/HPACK/Buffer.hs deleted file mode 100644 --- a/Network/HPACK/Buffer.hs +++ /dev/null @@ -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 diff --git a/Network/HPACK/HeaderBlock.hs b/Network/HPACK/HeaderBlock.hs --- a/Network/HPACK/HeaderBlock.hs +++ b/Network/HPACK/HeaderBlock.hs @@ -2,6 +2,7 @@ decodeHeader , decodeTokenHeader , ValueTable + , HeaderTable , toHeaderTable , getHeaderValue , encodeHeader diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock/Integer.hs b/Network/HPACK/HeaderBlock/Integer.hs --- a/Network/HPACK/HeaderBlock/Integer.hs +++ b/Network/HPACK/HeaderBlock/Integer.hs @@ -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 diff --git a/Network/HPACK/Huffman/Bit.hs b/Network/HPACK/Huffman/Bit.hs --- a/Network/HPACK/Huffman/Bit.hs +++ b/Network/HPACK/Huffman/Bit.hs @@ -5,8 +5,7 @@ , fromBits ) where -import Data.Word (Word8) -import Data.List (foldl') +import Imports -- | Data type for Bit. data B = F -- ^ Zero diff --git a/Network/HPACK/Huffman/ByteString.hs b/Network/HPACK/Huffman/ByteString.hs --- a/Network/HPACK/Huffman/ByteString.hs +++ b/Network/HPACK/Huffman/ByteString.hs @@ -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 diff --git a/Network/HPACK/Huffman/Decode.hs b/Network/HPACK/Huffman/Decode.hs --- a/Network/HPACK/Huffman/Decode.hs +++ b/Network/HPACK/Huffman/Decode.hs @@ -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 diff --git a/Network/HPACK/Huffman/Encode.hs b/Network/HPACK/Huffman/Encode.hs --- a/Network/HPACK/Huffman/Encode.hs +++ b/Network/HPACK/Huffman/Encode.hs @@ -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 diff --git a/Network/HPACK/Huffman/Table.hs b/Network/HPACK/Huffman/Table.hs --- a/Network/HPACK/Huffman/Table.hs +++ b/Network/HPACK/Huffman/Table.hs @@ -1,6 +1,6 @@ module Network.HPACK.Huffman.Table where -import Data.Word (Word64) +import Imports import Network.HPACK.Huffman.Bit huffmanTable :: [Bits] diff --git a/Network/HPACK/Huffman/Tree.hs b/Network/HPACK/Huffman/Tree.hs --- a/Network/HPACK/Huffman/Tree.hs +++ b/Network/HPACK/Huffman/Tree.hs @@ -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 diff --git a/Network/HPACK/Table.hs b/Network/HPACK/Table.hs --- a/Network/HPACK/Table.hs +++ b/Network/HPACK/Table.hs @@ -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 diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -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 diff --git a/Network/HPACK/Table/RevIndex.hs b/Network/HPACK/Table/RevIndex.hs --- a/Network/HPACK/Table/RevIndex.hs +++ b/Network/HPACK/Table/RevIndex.hs @@ -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 diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -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 diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs --- a/Network/HTTP2.hs +++ b/Network/HTTP2.hs @@ -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 diff --git a/Network/HTTP2/Decode.hs b/Network/HTTP2/Decode.hs --- a/Network/HTTP2/Decode.hs +++ b/Network/HTTP2/Decode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/Encode.hs b/Network/HTTP2/Encode.hs --- a/Network/HTTP2/Encode.hs +++ b/Network/HTTP2/Encode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/Priority.hs b/Network/HTTP2/Priority.hs --- a/Network/HTTP2/Priority.hs +++ b/Network/HTTP2/Priority.hs @@ -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 diff --git a/Network/HTTP2/Priority/PSQ.hs b/Network/HTTP2/Priority/PSQ.hs --- a/Network/HTTP2/Priority/PSQ.hs +++ b/Network/HTTP2/Priority/PSQ.hs @@ -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 diff --git a/Network/HTTP2/Priority/Queue.hs b/Network/HTTP2/Priority/Queue.hs --- a/Network/HTTP2/Priority/Queue.hs +++ b/Network/HTTP2/Priority/Queue.hs @@ -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 diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server.hs @@ -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 diff --git a/Network/HTTP2/Server/API.hs b/Network/HTTP2/Server/API.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/API.hs @@ -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) diff --git a/Network/HTTP2/Server/Config.hs b/Network/HTTP2/Server/Config.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Config.hs @@ -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) diff --git a/Network/HTTP2/Server/Context.hs b/Network/HTTP2/Server/Context.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Context.hs @@ -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 diff --git a/Network/HTTP2/Server/EncodeFrame.hs b/Network/HTTP2/Server/EncodeFrame.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/EncodeFrame.hs @@ -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 diff --git a/Network/HTTP2/Server/File.hs b/Network/HTTP2/Server/File.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/File.hs @@ -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) diff --git a/Network/HTTP2/Server/HPACK.hs b/Network/HTTP2/Server/HPACK.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/HPACK.hs @@ -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 diff --git a/Network/HTTP2/Server/Manager.hs b/Network/HTTP2/Server/Manager.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Manager.hs @@ -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 diff --git a/Network/HTTP2/Server/Queue.hs b/Network/HTTP2/Server/Queue.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Queue.hs @@ -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 + +---------------------------------------------------------------- diff --git a/Network/HTTP2/Server/ReadN.hs b/Network/HTTP2/Server/ReadN.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/ReadN.hs @@ -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 diff --git a/Network/HTTP2/Server/Receiver.hs b/Network/HTTP2/Server/Receiver.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Receiver.hs @@ -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 diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Run.hs @@ -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 diff --git a/Network/HTTP2/Server/Sender.hs b/Network/HTTP2/Server/Sender.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Sender.hs @@ -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 diff --git a/Network/HTTP2/Server/Stream.hs b/Network/HTTP2/Server/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Stream.hs @@ -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 + diff --git a/Network/HTTP2/Server/Types.hs b/Network/HTTP2/Server/Types.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Types.hs @@ -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 diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Server/Worker.hs @@ -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 diff --git a/Network/HTTP2/Types.hs b/Network/HTTP2/Types.hs --- a/Network/HTTP2/Types.hs +++ b/Network/HTTP2/Types.hs @@ -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 ---------------------------------------------------------------- diff --git a/bench-hpack/Main.hs b/bench-hpack/Main.hs --- a/bench-hpack/Main.hs +++ b/bench-hpack/Main.hs @@ -3,7 +3,7 @@ module Main where import Control.Exception -import Criterion.Main +import Gauge.Main import Network.HPACK import Data.ByteString (ByteString) diff --git a/bench-priority/Main.hs b/bench-priority/Main.hs --- a/bench-priority/Main.hs +++ b/bench-priority/Main.hs @@ -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 diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,11 +1,11 @@ Name: http2 -Version: 1.6.5 +Version: 2.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/test/HPACK/EncodeSpec.hs b/test/HPACK/EncodeSpec.hs --- a/test/HPACK/EncodeSpec.hs +++ b/test/HPACK/EncodeSpec.hs @@ -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] +-}