http2 2.0.6 → 3.0.0
raw patch · 90 files changed
+4800/−3655 lines, 90 filesdep +asyncdep +cryptonitedep +network-rundep ~basedep ~bytestringdep ~containersnew-component:exe:clientnew-component:exe:server
Dependencies added: async, cryptonite, network-run, typed-process, unix-time
Dependency ranges changed: base, bytestring, containers, network-byte-order
Files
- ChangeLog.md +10/−0
- Imports.hs +7/−0
- Network/HPACK.hs +6/−1
- Network/HPACK/HeaderBlock/Decode.hs +130/−95
- Network/HPACK/HeaderBlock/Encode.hs +99/−42
- Network/HPACK/HeaderBlock/Integer.hs +50/−27
- Network/HPACK/Huffman.hs +6/−6
- Network/HPACK/Huffman/ByteString.hs +0/−1
- Network/HPACK/Huffman/Decode.hs +35/−26
- Network/HPACK/Huffman/Encode.hs +19/−20
- Network/HPACK/Huffman/Tree.hs +10/−12
- Network/HPACK/Internal.hs +15/−0
- Network/HPACK/Table.hs +0/−2
- Network/HPACK/Table/Dynamic.hs +50/−61
- Network/HPACK/Table/Entry.hs +4/−4
- Network/HPACK/Table/RevIndex.hs +14/−14
- Network/HPACK/Table/Static.hs +3/−3
- Network/HPACK/Token.hs +115/−25
- Network/HPACK/Types.hs +3/−7
- Network/HTTP2.hs +4/−103
- Network/HTTP2/Arch.hs +29/−0
- Network/HTTP2/Arch/Cache.hs +28/−0
- Network/HTTP2/Arch/Config.hs +47/−0
- Network/HTTP2/Arch/Context.hs +168/−0
- Network/HTTP2/Arch/EncodeFrame.hs +34/−0
- Network/HTTP2/Arch/File.hs +36/−0
- Network/HTTP2/Arch/HPACK.hs +106/−0
- Network/HTTP2/Arch/Manager.hs +118/−0
- Network/HTTP2/Arch/Queue.hs +31/−0
- Network/HTTP2/Arch/Rate.hs +30/−0
- Network/HTTP2/Arch/ReadN.hs +41/−0
- Network/HTTP2/Arch/Receiver.hs +505/−0
- Network/HTTP2/Arch/Sender.hs +448/−0
- Network/HTTP2/Arch/Status.hs +44/−0
- Network/HTTP2/Arch/Stream.hs +77/−0
- Network/HTTP2/Arch/Types.hs +197/−0
- Network/HTTP2/Client.hs +154/−0
- Network/HTTP2/Client/Internal.hs +6/−0
- Network/HTTP2/Client/Run.hs +63/−0
- Network/HTTP2/Client/Types.hs +14/−0
- Network/HTTP2/Decode.hs +0/−278
- Network/HTTP2/Encode.hs +0/−238
- Network/HTTP2/Frame.hs +109/−0
- Network/HTTP2/Frame/Decode.hs +280/−0
- Network/HTTP2/Frame/Encode.hs +238/−0
- Network/HTTP2/Frame/Types.hs +660/−0
- Network/HTTP2/Internal.hs +31/−0
- Network/HTTP2/Priority.hs +9/−11
- Network/HTTP2/Priority/Internal.hs +5/−0
- Network/HTTP2/Priority/PSQ.hs +14/−12
- Network/HTTP2/Server.hs +79/−58
- Network/HTTP2/Server/API.hs +0/−131
- Network/HTTP2/Server/Config.hs +0/−39
- Network/HTTP2/Server/Context.hs +0/−113
- Network/HTTP2/Server/EncodeFrame.hs +0/−34
- Network/HTTP2/Server/File.hs +0/−16
- Network/HTTP2/Server/HPACK.hs +0/−124
- Network/HTTP2/Server/Internal.hs +7/−0
- Network/HTTP2/Server/Manager.hs +0/−113
- Network/HTTP2/Server/Queue.hs +0/−37
- Network/HTTP2/Server/ReadN.hs +0/−41
- Network/HTTP2/Server/Receiver.hs +0/−432
- Network/HTTP2/Server/Run.hs +8/−11
- Network/HTTP2/Server/Sender.hs +0/−459
- Network/HTTP2/Server/Stream.hs +0/−74
- Network/HTTP2/Server/Types.hs +30/−99
- Network/HTTP2/Server/Worker.hs +89/−73
- Network/HTTP2/Types.hs +0/−628
- bench-priority/BinaryHeap.hs +0/−1
- bench-priority/BinaryHeapSTM.hs +0/−1
- bench-priority/Main.hs +2/−2
- bench-priority/RandomSkewHeap.hs +1/−0
- http2.cabal +139/−155
- test-frame/Case.hs +2/−2
- test-frame/FrameSpec.hs +1/−1
- test-frame/JSON.hs +7/−7
- test-frame/frame-encode.hs +2/−2
- test-hpack/HPACKDecode.hs +3/−3
- test-hpack/HPACKEncode.hs +2/−1
- test-hpack/JSON.hs +1/−1
- test/HPACK/HeaderBlock.hs +1/−1
- test/HPACK/HuffmanSpec.hs +1/−1
- test/HPACK/IntegerSpec.hs +2/−2
- test/HTTP2/FrameSpec.hs +1/−3
- test/HTTP2/PrioritySpec.hs +3/−2
- test/HTTP2/ServerSpec.hs +156/−0
- test2/ServerSpec.hs +54/−0
- test2/Spec.hs +1/−0
- util/client.hs +35/−0
- util/server.hs +71/−0
ChangeLog.md view
@@ -1,3 +1,13 @@+## 3.0.0++* DOS preventions.+* Providing Network.HTTP.Client.+* `Internal` modules are exported.+* Dropping the priority feature from Network.HTTP.Server.+* `Network.HTTP2.Priority` is deprecated.+* `Network.HTTP2` module is deprecated. Use `Network.HTTP2.Frame` instead.+* Adding some tokens.+ ## 2.0.6 * Dropping support of GHC 7.x
Imports.hs view
@@ -11,6 +11,9 @@ , module Data.Word , module Data.Maybe , module Numeric+ , GCBuffer+ , withForeignPtr+ , mallocPlainForeignPtrBytes ) where import Control.Applicative@@ -24,4 +27,8 @@ import Data.Monoid import Data.Ord import Data.Word+import Foreign.ForeignPtr import Numeric+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)++type GCBuffer = ForeignPtr Word8
Network/HPACK.hs view
@@ -13,7 +13,6 @@ , defaultDynamicTableSize , newDynamicTableForEncoding , newDynamicTableForDecoding- , clearDynamicTable , withDynamicTableForEncoding , withDynamicTableForDecoding , setLimitForEncoding@@ -41,11 +40,17 @@ , Index , Buffer , BufferSize+ -- * Re-exports+ , original+ , foldedCase+ , mk ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif+import Data.CaseInsensitive+ import Network.HPACK.HeaderBlock import Network.HPACK.Table import Network.HPACK.Types
Network/HPACK/HeaderBlock/Decode.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Network.HPACK.HeaderBlock.Decode ( decodeHeader@@ -7,22 +7,26 @@ , HeaderTable , toHeaderTable , getHeaderValue+ , decodeString+ , decodeS+ , decodeSophisticated+ , decodeSimple -- testing ) where -import Control.Exception (throwIO)+import Control.Exception (throwIO, catch) 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 qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8-import Data.Char (isUpper) import Data.CaseInsensitive (CI(..))+import Data.Char (isUpper) import Network.ByteOrder import Imports hiding (empty) import Network.HPACK.Builder-import qualified Network.HPACK.HeaderBlock.Integer as I+import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table import Network.HPACK.Token@@ -48,7 +52,7 @@ decodeHeader :: DynamicTable -> ByteString -- ^ An HPACK format -> IO HeaderList-decodeHeader dyntbl inp = decodeHPACK dyntbl inp decodeSimple+decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl)) -- | Converting the HPACK format to 'TokenHeaderList' -- and 'ValueTable'.@@ -67,48 +71,71 @@ decodeTokenHeader :: DynamicTable -> ByteString -- ^ An HPACK format -> IO HeaderTable-decodeTokenHeader dyntbl inp = decodeHPACK dyntbl inp decodeSophisticated+decodeTokenHeader dyntbl inp =+ decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `catch` \BufferOverrun -> throwIO HeaderBlockTruncated decodeHPACK :: DynamicTable -> ByteString- -> (DynamicTable -> ReadBuffer -> IO a)+ -> (ReadBuffer -> IO a) -> IO a decodeHPACK dyntbl inp dec = withReadBuffer inp chkChange where chkChange rbuf = do- leftover <- remainingSize rbuf- if leftover >= 1 then do- w <- read8 rbuf- if isTableSizeUpdate w then do- tableSizeUpdate dyntbl w rbuf- chkChange rbuf- else do- ff rbuf (-1)- dec dyntbl rbuf- else- throwIO HeaderBlockTruncated+ w <- read8 rbuf+ if isTableSizeUpdate w then do+ tableSizeUpdate dyntbl w rbuf+ chkChange rbuf+ else do+ ff rbuf (-1)+ dec rbuf -decodeSimple :: DynamicTable -> ReadBuffer -> IO HeaderList-decodeSimple dyntbl rbuf = go empty+-- | Converting to 'HeaderList'.+--+-- * Headers are decoded as is.+-- * 'DecodeError' would be thrown if the HPACK format is broken.+-- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.+decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader)+ -> ReadBuffer+ -> IO HeaderList+decodeSimple decTokenHeader rbuf = go empty where go builder = do leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf- !tv <- toTokenHeader dyntbl w rbuf+ tv <- decTokenHeader w rbuf let builder' = builder << tv go builder' else do- let !tvs = run builder- !kvs = map (\(t,v) -> let !k = tokenFoldedKey t in (k,v)) tvs+ let tvs = run builder+ kvs = map (\(t,v) -> let k = tokenFoldedKey t in (k,v)) tvs return kvs -decodeSophisticated :: DynamicTable -> ReadBuffer+headerLimit :: Int+headerLimit = 200++-- | Converting to 'TokenHeaderList' and 'ValueTable'.+--+-- * Multiple values of Cookie: are concatenated.+-- * If a pseudo header appears multiple times,+-- 'IllegalHeaderName' is thrown.+-- * If unknown pseudo headers appear,+-- 'IllegalHeaderName' is thrown.+-- * If pseudo headers are found after normal headers,+-- 'IllegalHeaderName' is thrown.+-- * If a header key contains capital letters,+-- 'IllegalHeaderName' is thrown.+-- * If the number of header fields is too large,+-- 'TooLargeHeader' is thrown+-- * 'DecodeError' would be thrown if the HPACK format is broken.+-- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.+decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader)+ -> ReadBuffer -> IO HeaderTable-decodeSophisticated dyntbl rbuf = do+decodeSophisticated decTokenHeader rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing- !tvs <- pseudoNormal arr+ tvs <- pseudoNormal arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where@@ -119,44 +146,52 @@ leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf- tv@(!Token{..},!v) <- toTokenHeader dyntbl w rbuf+ tv@(Token{..},v) <- decTokenHeader w rbuf if isPseudo then do- mx <- unsafeRead arr ix+ mx <- unsafeRead arr tokenIx+ -- duplicated when (isJust mx) $ throwIO IllegalHeaderName- when (isMaxTokenIx ix) $ throwIO IllegalHeaderName- unsafeWrite arr ix (Just v)+ -- unknown+ when (isMaxTokenIx tokenIx) $ throwIO IllegalHeaderName+ unsafeWrite arr tokenIx (Just v) pseudo else do- when (isMaxTokenIx ix && B8.any isUpper (original tokenKey)) $+ -- 0-Length Headers Leak - CVE-2019-9516+ when (tokenKey == "") $ throwIO IllegalHeaderName+ when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ throwIO IllegalHeaderName- unsafeWrite arr ix (Just v)- if isCookieTokenIx ix then- normal empty (empty << v)+ unsafeWrite arr tokenIx (Just v)+ if isCookieTokenIx tokenIx then+ normal 0 empty (empty << v) else- normal (empty << tv) empty+ normal 0 (empty << tv) empty else return []- normal !builder !cookie = do+ normal n builder cookie+ | n > headerLimit = throwIO TooLargeHeader+ | otherwise = do leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf- tv@(Token{..},!v) <- toTokenHeader dyntbl w rbuf+ tv@(Token{..},v) <- decTokenHeader w rbuf when isPseudo $ throwIO IllegalHeaderName- when (isMaxTokenIx ix && B8.any isUpper (original tokenKey)) $+ -- 0-Length Headers Leak - CVE-2019-9516+ when (tokenKey == "") $ throwIO IllegalHeaderName+ when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ throwIO IllegalHeaderName- unsafeWrite arr ix (Just v)- if isCookieTokenIx ix then- normal builder (cookie << v)+ unsafeWrite arr tokenIx (Just v)+ if isCookieTokenIx tokenIx then+ normal (n+1) builder (cookie << v) else- normal (builder << tv) cookie+ normal (n+1) (builder << tv) cookie else do- let !tvs0 = run builder- !cook = run cookie+ let tvs0 = run builder+ cook = run cookie if null cook then return tvs0 else do- let !v = BS.intercalate "; " cook- !tvs = (tokenCookie, v) : tvs0+ let v = BS.intercalate "; " cook+ tvs = (tokenCookie, v) : tvs0 unsafeWrite arr cookieTokenIx (Just v) return tvs @@ -170,8 +205,8 @@ tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO () tableSizeUpdate dyntbl w rbuf = do- let !w' = mask5 w- !siz <- I.decode 5 w' rbuf+ let w' = mask5 w+ siz <- decodeI 5 w' rbuf suitable <- isSuitableSize siz dyntbl unless suitable $ throwIO TooLargeTableSize renewDynamicTable siz dyntbl@@ -180,8 +215,8 @@ indexed :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader indexed dyntbl w rbuf = do- let !w' = clearBit w 7- !idx <- I.decode 7 w' rbuf+ let w' = clearBit w 7+ idx <- decodeI 7 w' rbuf entryTokenHeader <$> toIndexedEntry dyntbl idx incrementalIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader@@ -190,7 +225,7 @@ indexedName dyntbl w rbuf 6 mask6 else newName dyntbl rbuf- let !e = toEntryToken t v+ let e = toEntryToken t v insertEntry e dyntbl return tv @@ -210,33 +245,55 @@ -> Int -> (Word8 -> Word8) -> IO TokenHeader indexedName dyntbl w rbuf n mask = do- let !p = mask w- !idx <- I.decode n p rbuf- !t <- entryToken <$> toIndexedEntry dyntbl idx- !val <- headerStuff dyntbl rbuf- let !tv = (t,val)+ let p = mask w+ idx <- decodeI n p rbuf+ t <- entryToken <$> toIndexedEntry dyntbl idx+ val <- decStr (huffmanDecoder dyntbl) rbuf+ let tv = (t,val) return tv newName :: DynamicTable -> ReadBuffer -> IO TokenHeader newName dyntbl rbuf = do- !t <- toToken <$> headerStuff dyntbl rbuf- !val <- headerStuff dyntbl rbuf- let !tv = (t,val)+ let hufdec = huffmanDecoder dyntbl+ t <- toToken <$> decStr hufdec rbuf+ val <- decStr hufdec rbuf+ let tv = (t,val) return tv ---------------------------------------------------------------- -headerStuff :: DynamicTable -> ReadBuffer -> IO HeaderStuff-headerStuff dyntbl rbuf = do- leftover <- remainingSize rbuf- if leftover >= 1 then do- w <- read8 rbuf- let !p = dropHuffman w- !huff = isHuffman w- !len <- I.decode 7 p rbuf- decodeString huff (huffmanDecoder dyntbl) rbuf len+isHuffman :: Word8 -> Bool+isHuffman w = w `testBit` 7++dropHuffman :: Word8 -> Word8+dropHuffman w = w `clearBit` 7++-- | String decoding (7+) with a temporal Huffman decoder whose buffer is 4096.+decodeString :: ReadBuffer -> IO ByteString+decodeString rbuf = do+ let bufsiz = 4096+ gcbuf <- mallocPlainForeignPtrBytes 4096+ decodeS dropHuffman isHuffman 7 (decodeH gcbuf bufsiz) rbuf++decStr :: HuffmanDecoder -> ReadBuffer -> IO ByteString+decStr = decodeS dropHuffman isHuffman 7++-- | String decoding with Huffman decoder.+decodeS :: (Word8 -> Word8) -- ^ Dropping prefix and Huffman+ -> (Word8 -> Bool) -- ^ Checking Huffman flag+ -> Int -- ^ N++ -> HuffmanDecoder+ -> ReadBuffer+ -> IO ByteString+decodeS mask isH n hufdec rbuf = do+ w <- read8 rbuf+ let p = mask w+ huff = isH w+ len <- decodeI n p rbuf+ if huff then+ hufdec rbuf len else- throwIO EmptyEncodedString+ extractByteString rbuf len ---------------------------------------------------------------- @@ -260,28 +317,6 @@ ---------------------------------------------------------------- -isHuffman :: Word8 -> Bool-isHuffman w = w `testBit` 7--dropHuffman :: Word8 -> Word8-dropHuffman w = w `clearBit` 7--------------------------------------------------------------------decodeString :: Bool -> HuffmanDecoding -> ReadBuffer -> Int -> IO HeaderStuff-decodeString huff hufdec rbuf len = do- leftover <- remainingSize rbuf- if leftover >= len then- if huff then- hufdec rbuf len- else- extractByteString rbuf len- else- throwIO HeaderBlockTruncated-------------------------------------------------------------------- -- | A pair of token list and value table. type HeaderTable = (TokenHeaderList, ValueTable) @@ -290,7 +325,7 @@ toHeaderTable :: [(CI HeaderName,HeaderValue)] -> IO HeaderTable toHeaderTable kvs = do arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing- !tvs <- conv arr+ tvs <- conv arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where@@ -300,8 +335,8 @@ go :: [(CI HeaderName,HeaderValue)] -> Builder TokenHeader -> IO TokenHeaderList go [] builder = return $ run builder go ((k,v):xs) builder = do- let !t = toToken (foldedCase k)+ let t = toToken (foldedCase k) unsafeWrite arr (tokenIx t) (Just v)- let !tv = (t,v)- !builder' = builder << tv+ let tv = (t,v)+ builder' = builder << tv go xs builder'
Network/HPACK/HeaderBlock/Encode.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.HeaderBlock.Encode ( encodeHeader , encodeTokenHeader+ , encodeString+ , encodeS ) where import Control.Exception (bracket, throwIO)@@ -15,8 +18,8 @@ import Network.ByteOrder import Imports-import qualified Network.HPACK.HeaderBlock.Integer as I-import qualified Network.HPACK.Huffman as Huffman+import Network.HPACK.HeaderBlock.Integer+import Network.HPACK.Huffman import Network.HPACK.Table import Network.HPACK.Token import Network.HPACK.Types@@ -47,7 +50,7 @@ -> IO ByteString -- ^ An HPACK format encodeHeader stgy siz dyntbl hs = encodeHeader' stgy siz dyntbl hs' where- hs' = map (\(k,v) -> let !t = toToken k in (t,v)) hs+ hs' = map (\(k,v) -> let t = toToken k in (t,v)) hs -- | Converting 'HeaderList' to the HPACK format.@@ -69,12 +72,8 @@ -- | Converting 'TokenHeaderList' to the HPACK format directly in the buffer. ----- 4th argument is relating to dynamic table size update. -- When calling this function for a new 'TokenHeaderList',--- it must be 'True'.--- If 'True' and set by 'setLimitForEncoding',--- dynamic table size update is generated at the beginning of--- the HPACK format.+-- 4th argument must be 'True'. -- -- The return value is a pair of leftover 'TokenHeaderList' and -- how many bytes are filled in the buffer.@@ -82,6 +81,11 @@ -- Otherwise, this function should be called with it again. -- 4th argument must be 'False'. --+-- 4th argument is relating to dynamic table size update.+-- If 'True' and the limit is set by 'setLimitForEncoding',+-- dynamic table size update is generated at the beginning of+-- the HPACK format.+-- encodeTokenHeader :: Buffer -> BufferSize -> EncodeStrategy@@ -107,7 +111,7 @@ ref2 <- newIORef hs0 loop wbuf ref1 ref2 step0 hs0 `E.catch` \BufferOverrun -> return () end <- readIORef ref1- let !len = end `minusPtr` buf+ let len = end `minusPtr` buf hs <- readIORef ref2 return (hs, len) where@@ -189,77 +193,130 @@ {-# INLINE change #-} change :: WriteBuffer -> Int -> IO ()-change wbuf i = I.encode wbuf set001 5 i+change wbuf i = encodeI wbuf set001 5 i {-# INLINE index #-} index :: WriteBuffer -> Int -> IO ()-index wbuf i = I.encode wbuf set1 7 i+index wbuf i = encodeI wbuf set1 7 i -- Using Huffman encoding {-# INLINE indexedName #-} 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+ encodeI wbuf set n idx+ encStr wbuf huff v -- Using Huffman encoding {-# INLINE newName #-} newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO () newName wbuf huff set k v = do write8 wbuf $ set 0- encodeString huff k wbuf- encodeString huff v wbuf+ encStr wbuf huff k+ encStr wbuf huff v ---------------------------------------------------------------- type Setter = Word8 -> Word8 -- Assuming MSBs are 0.-set1, set01, set001, set0000, setH :: Setter+set1, set01, set001, set0000 :: Setter set1 x = x `setBit` 7 set01 x = x `setBit` 6 set001 x = x `setBit` 5 -- set0001 x = x `setBit` 4 -- Never indexing set0000 = id-setH = set1 ---------------------------------------------------------------- -{-# INLINE encodeString #-}-encodeString :: Bool -> ByteString -> WriteBuffer -> IO ()-encodeString False bs wbuf = do- let !len = BS.length bs- I.encode wbuf id 7 len+-- | String encoding.+-- The algorithm based on copy avoidance and+-- selection of better result of huffman or raw.+encodeS :: WriteBuffer+ -> Bool -- ^ Use Huffman if efficient+ -> (Word8 -> Word8) -- ^ Setting prefix+ -> (Word8 -> Word8) -- ^ Setting huffman flag+ -> Int -- ^ N++ -> ByteString -- ^ Target+ -> IO ()+encodeS wbuf False set _ n bs = do+ let len = BS.length bs+ encodeI wbuf set n len copyByteString wbuf bs-encodeString True bs wbuf = do- let !origLen = BS.length bs- !expectedLen = (origLen `div` 10) * 8 -- 80%: decided by examples- !expectedIntLen = integerLength expectedLen+encodeS wbuf True set setH n bs = do+ let origLen = BS.length bs+ expectedLen = (origLen `div` 10) * 8 -- 80%: decided by examples+ expectedIntLen = integerLength n expectedLen ff wbuf expectedIntLen- len <- Huffman.encode wbuf bs- let !intLen = integerLength len+ len <- encodeH wbuf bs+ let intLen = integerLength n len if origLen < len then do ff wbuf (negate (expectedIntLen + len))- I.encode wbuf id 7 origLen+ encodeI wbuf set n origLen copyByteString wbuf bs else if intLen == expectedIntLen then do ff wbuf (negate (expectedIntLen + len))- I.encode wbuf setH 7 len+ encodeI wbuf (set . setH) n len ff wbuf len else do- let !gap = intLen - expectedIntLen+ let gap = intLen - expectedIntLen shiftLastN wbuf gap len ff wbuf (negate (intLen + len))- I.encode wbuf setH 7 len+ encodeI wbuf (set . setH) n len ff wbuf len --- For 7+:--- 1 byte: 0 - 126--- 2 bytes: 127 - 254--- 3 bytes: 255 - 16510+{-# INLINE encStr #-}+encStr :: WriteBuffer -> Bool -> ByteString -> IO ()+encStr wbuf h bs = encodeS wbuf h id (`setBit` 7) 7 bs++-- | String encoding (7+) with a temporary buffer whose size is 4096.+encodeString :: Bool -- ^ Use Huffman if efficient+ -> ByteString -- ^ Target+ -> IO ByteString+encodeString h bs = withWriteBuffer 4096 $ \wbuf -> encStr wbuf h bs++{-+N+ 1 2 3 <- bytes+8 254 382 16638+7 126 254 16510+6 62 190 16446+5 30 158 16414+4 14 142 16398+3 6 134 16390+2 2 130 16386+1 0 128 16384+-}+ {-# INLINE integerLength #-}-integerLength :: Int -> Int-integerLength n- | n <= 126 = 1- | n <= 254 = 2- | otherwise = 3+integerLength :: Int -> Int -> Int+integerLength 8 l+ | l <= 254 = 1+ | l <= 382 = 2+ | otherwise = 3+integerLength 7 l+ | l <= 126 = 1+ | l <= 254 = 2+ | otherwise = 3+integerLength 6 l+ | l <= 62 = 1+ | l <= 190 = 2+ | otherwise = 3+integerLength 5 l+ | l <= 30 = 1+ | l <= 158 = 2+ | otherwise = 3+integerLength 4 l+ | l <= 14 = 1+ | l <= 142 = 2+ | otherwise = 3+integerLength 3 l+ | l <= 6 = 1+ | l <= 134 = 2+ | otherwise = 3+integerLength 2 l+ | l <= 2 = 1+ | l <= 130 = 2+ | otherwise = 3+integerLength _ l+ | l <= 0 = 1+ | l <= 128 = 2+ | otherwise = 3
Network/HPACK/HeaderBlock/Integer.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.HeaderBlock.Integer (- encode+ encodeI , encodeInteger- , decode+ , decodeI , decodeInteger ) where @@ -32,25 +32,42 @@ encode I on 8 bits -} -encodeInteger :: Int -> Int -> IO ByteString-encodeInteger n i = withWriteBuffer 4096 $ \wbuf -> encode wbuf id n i+-- | Encoding integer with a temporary buffer whose size is 4096.+-- No prefix is set.+--+-- >>> BS.unpack <$> encodeInteger 5 10+-- [10]+-- >>> BS.unpack <$> encodeInteger 5 1337+-- [31,154,10]+-- >>> BS.unpack <$> encodeInteger 8 42+-- [42]+encodeInteger :: Int -- ^ N++ -> Int -- ^ Target+ -> IO ByteString+encodeInteger n i = withWriteBuffer 4096 $ \wbuf -> encodeI wbuf id n i -- Using write8 is faster than using internals directly.-{-# INLINABLE encode #-}-encode :: WriteBuffer -> (Word8 -> Word8) -> Int -> Int -> IO ()-encode wbuf set n i+--+-- | Integer encoding with a write buffer.+{-# INLINABLE encodeI #-}+encodeI :: WriteBuffer+ -> (Word8 -> Word8) -- ^ Setting prefix+ -> Int -- ^ N++ -> Int -- ^ Target+ -> IO ()+encodeI wbuf set n i | i < p = write8 wbuf $ set $ fromIntegral i | otherwise = do write8 wbuf $ set $ fromIntegral p encode' (i - p) where- !p = powerArray `unsafeAt` (n - 1)+ p = powerArray `unsafeAt` (n - 1) encode' :: Int -> IO () encode' j | j < 128 = write8 wbuf $ fromIntegral j | otherwise = do- let !q = j `shiftR` 7- !r = j .&. 0x7f+ let q = j `shiftR` 7+ r = j .&. 0x7f write8 wbuf $ fromIntegral (r + 128) encode' q @@ -77,22 +94,28 @@ -- 1337 -- >>> decodeInteger 8 42 $ BS.empty -- 42-decodeInteger :: Int -> Word8 -> ByteString -> IO Int-decodeInteger n w bs = withReadBuffer bs $ \rbuf -> decode n w rbuf+decodeInteger :: Int -- ^ N++ -> Word8 -- ^ The head of encoded integer whose prefix is already dropped+ -> ByteString -- ^ The tail of encoded integer+ -> IO Int+decodeInteger n w bs = withReadBuffer bs $ \rbuf -> decodeI n w rbuf -{-# INLINABLE decode #-}--- | Integer decoding. The first argument is N of prefix.-decode :: Int -> Word8 -> ReadBuffer -> IO Int-decode n w rbuf+{-# INLINABLE decodeI #-}+-- | Integer decoding with a read buffer. The first argument is N of prefix.+decodeI :: Int -- ^ N++ -> Word8 -- ^ The head of encoded integer whose prefix is already dropped+ -> ReadBuffer+ -> IO Int+decodeI n w rbuf | i < p = return i- | otherwise = decode' 0 i+ | otherwise = decode 0 i where- !p = powerArray `unsafeAt` (n - 1)- !i = fromIntegral w- decode' :: Int -> Int -> IO Int- decode' m j = do- !b <- readInt8 rbuf- let !j' = j + (b .&. 0x7f) * 2 ^ m- !m' = m + 7- !cont = b `testBit` 7- if cont then decode' m' j' else return j'+ p = powerArray `unsafeAt` (n - 1)+ i = fromIntegral w+ decode :: Int -> Int -> IO Int+ decode m j = do+ b <- fromIntegral <$> read8 rbuf+ let j' = j + (b .&. 0x7f) * 2 ^ m+ m' = m + 7+ cont = b `testBit` 7+ if cont then decode m' j' else return j'
Network/HPACK/Huffman.hs view
@@ -1,12 +1,12 @@ module Network.HPACK.Huffman (- -- * Type- HuffmanEncoding- , HuffmanDecoding- -- * Encoding/decoding- , encode+ -- * Huffman encoding/decoding+ encodeH , encodeHuffman- , decode+ , decodeH , decodeHuffman+ , HuffmanDecoder+ , decH+ , GCBuffer ) where import Network.HPACK.Huffman.Decode
Network/HPACK/Huffman/ByteString.hs view
@@ -6,7 +6,6 @@ ) where import Foreign.C.Types (CSize(..))-import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafeDupablePerformIO)
Network/HPACK/Huffman/Decode.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Huffman.Decode ( -- * Huffman decoding- HuffmanDecoding- , decode+ decodeH , decodeHuffman+ , HuffmanDecoder+ , decH+ , GCBuffer ) where import Control.Exception (throwIO)@@ -13,6 +15,7 @@ import qualified Data.ByteString as BS import Network.ByteOrder +import Imports import Network.HPACK.Huffman.Bit import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table@@ -22,20 +25,20 @@ ---------------------------------------------------------------- -- | Huffman decoding.-type HuffmanDecoding = ReadBuffer -> Int -> IO ByteString+type HuffmanDecoder = ReadBuffer -> Int -> IO ByteString ---------------------------------------------------------------- data Pin = EndOfString- | Forward {-# UNPACK #-} !Word8 -- node no.- | GoBack {-# UNPACK #-} !Word8 -- node no.- {-# UNPACK #-} !Word8 -- a decoded value- | GoBack2 {-# UNPACK #-} !Word8 -- node no.- {-# UNPACK #-} !Word8 -- a decoded value- {-# UNPACK #-} !Word8 -- a decoded value+ | Forward {-# UNPACK #-} Word8 -- node no.+ | GoBack {-# UNPACK #-} Word8 -- node no.+ {-# UNPACK #-} Word8 -- a decoded value+ | GoBack2 {-# UNPACK #-} Word8 -- node no.+ {-# UNPACK #-} Word8 -- a decoded value+ {-# UNPACK #-} Word8 -- a decoded value deriving Show -data WayStep = WayStep !(Maybe Int) !(Array Word8 Pin)+data WayStep = WayStep (Maybe Int) (Array Word8 Pin) type Way256 = Array Word8 WayStep next :: WayStep -> Word8 -> Pin@@ -44,25 +47,30 @@ ---------------------------------------------------------------- -- | Huffman decoding.-decode :: Buffer -> BufferSize -> HuffmanDecoding-decode buf siz rbuf len = do- wbuf <- newWriteBuffer buf siz- dec wbuf rbuf len+decodeH :: GCBuffer -- ^ A working space+ -> BufferSize+ -> ReadBuffer -- ^ A read buffer which contains the target+ -> Int -- ^ The target length+ -> IO ByteString+decodeH gcbuf bufsiz rbuf len = withForeignPtr gcbuf $ \buf -> do+ wbuf <- newWriteBuffer buf bufsiz+ decH wbuf rbuf len toByteString wbuf -dec :: WriteBuffer -> ReadBuffer -> Int -> IO ()-dec wbuf rbuf len = go len (way256 `unsafeAt` 0)+-- | Low devel Huffman decoding in a write buffer.+decH :: WriteBuffer -> ReadBuffer -> Int -> IO ()+decH wbuf rbuf len = go len (way256 `unsafeAt` 0) where go 0 way0 = case way0 of WayStep Nothing _ -> throwIO IllegalEos WayStep (Just i) _ | i <= 8 -> return () | otherwise -> throwIO TooLongEos- go !n !way0 = do+ go n way0 = do w <- read8 rbuf way <- doit way0 w go (n - 1) way- doit !way !w = case next way w of+ doit way w = case next way w of EndOfString -> throwIO EosInTheMiddle Forward n -> return $ way256 `unsafeAt` fromIntegral n GoBack n v -> do@@ -73,9 +81,10 @@ write8 wbuf v2 return $ way256 `unsafeAt` fromIntegral n +-- | Huffman decoding with a temporary buffer whose size is 4096. decodeHuffman :: ByteString -> IO ByteString decodeHuffman bs = withWriteBuffer 4096 $ \wbuf ->- withReadBuffer bs $ \rbuf -> dec wbuf rbuf (BS.length bs)+ withReadBuffer bs $ \rbuf -> decH wbuf rbuf $ BS.length bs ---------------------------------------------------------------- @@ -88,12 +97,12 @@ where to16ways x = WayStep ei a16 where- !ei = eosInfo x- !a16 = listArray (0,255) $ map (step decoder x Non) bits8s+ ei = eosInfo x+ a16 = listArray (0,255) $ map (step decoder x Non) bits8s data Chara = Non- | One !Word8- | Two !Word8 !Word8+ | One Word8+ | Two Word8 Word8 inc :: Chara -> Word8 -> Chara inc Non w = One w@@ -103,8 +112,8 @@ step :: HTree -> HTree -> Chara -> [B] -> Pin step root (Tip _ v) x bss | v == idxEos = EndOfString- | otherwise = let !w = fromIntegral v- !x' = inc x w+ | otherwise = let w = fromIntegral v+ x' = inc x w in step root root x' bss step _ (Bin _ n _ _) Non [] = Forward (fromIntegral n) step _ (Bin _ n _ _) (One w) [] = GoBack (fromIntegral n) w
Network/HPACK/Huffman/Encode.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE BangPatterns, RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} module Network.HPACK.Huffman.Encode ( -- * Huffman encoding- HuffmanEncoding- , encode+ encodeH , encodeHuffman ) where @@ -31,11 +30,10 @@ ---------------------------------------------------------------- -- | Huffman encoding.-type HuffmanEncoding = WriteBuffer -> ByteString -> IO Int---- | Huffman encoding.-encode :: HuffmanEncoding-encode dst bs = withReadBuffer bs $ enc dst+encodeH :: WriteBuffer+ -> ByteString -- ^ Target+ -> IO Int -- ^ The length of the encoded string.+encodeH dst bs = withReadBuffer bs $ enc dst -- The maximum length of Huffman code is 30. -- 40 is enough as a work space.@@ -50,11 +48,11 @@ beg <- readIORef offset end <- go (beg,0,initialOffset) writeIORef offset end- let !len = end `minusPtr` beg+ let len = end `minusPtr` beg return len where go (dst,encoded,off) = do- !i <- readInt8 rbuf+ i <- readInt8 rbuf if i >= 0 then cpy dst (bond i) >>= go else if off == initialOffset then@@ -66,27 +64,28 @@ {-# INLINE bond #-} bond i = (encoded', off') where- !len = huffmanLength `unsafeAt` i- !code = huffmanCode `unsafeAt` i- !scode = code `shiftL` (off - len)- !encoded' = encoded .|. scode- !off' = off - len+ len = huffmanLength `unsafeAt` i+ code = huffmanCode `unsafeAt` i+ scode = code `shiftL` (off - len)+ encoded' = encoded .|. scode+ off' = off - len {-# INLINE write #-} write p w = do when (p >= limit) $ throwIO BufferOverrun- let !w8 = fromIntegral (w `shiftR` shiftForWrite) :: Word8+ let w8 = fromIntegral (w `shiftR` shiftForWrite) :: Word8 poke p w8- let !p' = p `plusPtr` 1+ let p' = p `plusPtr` 1 return p' {-# 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+ let w' = w `shiftL` 8+ o' = o + 8 cpy p' (w',o') +-- | Huffman encoding with a temporary buffer whose size is 4096. encodeHuffman :: ByteString -> IO ByteString encodeHuffman bs = withWriteBuffer 4096 $ \wbuf ->- void $ encode wbuf bs+ void $ encodeH wbuf bs
Network/HPACK/Huffman/Tree.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- module Network.HPACK.Huffman.Tree ( -- * Huffman decoding HTree(..)@@ -22,13 +20,13 @@ -- | Type for Huffman decoding. data HTree = Tip- !EOSInfo -- EOS info from 1- {-# UNPACK #-} !Int -- Decoded value. Essentially Word8+ EOSInfo -- EOS info from 1+ {-# UNPACK #-} Int -- Decoded value. Essentially Word8 | Bin- !EOSInfo -- EOS info from 1- {-# UNPACK #-} !Int -- Sequence no from 0- !HTree -- Left- !HTree -- Right+ EOSInfo -- EOS info from 1+ {-# UNPACK #-} Int -- Sequence no from 0+ HTree -- Left+ HTree -- Right deriving Show eosInfo :: HTree -> EOSInfo@@ -60,10 +58,10 @@ eos = bs !! idxEos build :: Int -> [(Int,Bits)] -> (Int, HTree)-build !cnt0 [(v,[])] = (cnt0,Tip Nothing v)-build !cnt0 xs = let (cnt1,l) = build (cnt0 + 1) fs- (cnt2,r) = build cnt1 ts- in (cnt2, Bin Nothing cnt0 l r)+build cnt0 [(v,[])] = (cnt0,Tip Nothing v)+build cnt0 xs = let (cnt1,l) = build (cnt0 + 1) fs+ (cnt2,r) = build cnt1 ts+ in (cnt2, Bin Nothing cnt0 l r) where (fs',ts') = partition ((==) F . head . snd) xs fs = map (second tail) fs'
+ Network/HPACK/Internal.hs view
@@ -0,0 +1,15 @@+module Network.HPACK.Internal (+ -- * Integer encoding/decoding+ module Network.HPACK.HeaderBlock.Integer+ -- * String encoding/decoding+ , module Network.HPACK.HeaderBlock.Encode+ , module Network.HPACK.HeaderBlock.Decode+ , module Network.HPACK.Huffman+ , module Network.HPACK.Table.Entry+ ) where++import Network.HPACK.HeaderBlock.Decode (decodeString, decodeS, decodeSophisticated, decodeSimple)+import Network.HPACK.HeaderBlock.Encode (encodeString, encodeS)+import Network.HPACK.HeaderBlock.Integer+import Network.HPACK.Huffman+import Network.HPACK.Table.Entry
Network/HPACK/Table.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK hide #-} module Network.HPACK.Table (@@ -6,7 +5,6 @@ DynamicTable , newDynamicTableForEncoding , newDynamicTableForDecoding- , clearDynamicTable , withDynamicTableForEncoding , withDynamicTableForDecoding , huffmanDecoder
Network/HPACK/Table/Dynamic.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE TupleSections, RecordWildCards, FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-} module Network.HPACK.Table.Dynamic ( DynamicTable(..)@@ -17,7 +17,6 @@ , insertEntry , toDynamicEntry , CodeInfo(..)- , clearDynamicTable , withDynamicTableForEncoding , withDynamicTableForDecoding , toIndexedEntry@@ -25,12 +24,11 @@ , getRevIndex ) where -import Control.Exception (bracket, throwIO)+import Control.Exception (throwIO) 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 (mallocBytes, free) import Imports import Network.HPACK.Huffman@@ -46,7 +44,7 @@ toIndexedEntry :: DynamicTable -> Index -> IO Entry toIndexedEntry dyntbl idx | idx <= 0 = throwIO $ IndexOverrun idx- | idx <= staticTableSize = return $! toStaticEntry idx+ | idx <= staticTableSize = return $ toStaticEntry idx | otherwise = toDynamicEntry dyntbl idx -- For encoder@@ -57,7 +55,7 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset x <- adj maxN (didx - off)- return $! x + staticTableSize+ return $ x + staticTableSize ---------------------------------------------------------------- @@ -82,44 +80,43 @@ -} data CodeInfo =- EncodeInfo !RevIndex -- Reverse index+ EncodeInfo RevIndex -- Reverse index -- The value informed by SETTINGS_HEADER_TABLE_SIZE. -- If 'Nothing', dynamic table size update is not necessary. -- Otherwise, dynamic table size update is sent -- and this value should be set to 'Nothing'.- !(IORef (Maybe Size))- | DecodeInfo !HuffmanDecoding- !(IORef Size) -- The limit size- !(IO ()) -- Action to free the buffer+ (IORef (Maybe Size))+ | DecodeInfo HuffmanDecoder+ (IORef Size) -- The limit size -- | Type for dynamic table. data DynamicTable = DynamicTable {- codeInfo :: !CodeInfo+ codeInfo :: CodeInfo -- | An array- , circularTable :: !(IORef Table)+ , circularTable :: IORef Table -- | Start point- , offset :: !(IORef Index)+ , offset :: IORef Index -- | The current number of entries- , numOfEntries :: !(IORef Int)+ , numOfEntries :: IORef Int -- | The size of the array- , maxNumOfEntries :: !(IORef Int)+ , maxNumOfEntries :: IORef Int -- | The current dynamic table size (defined in HPACK)- , dynamicTableSize :: !(IORef Size)+ , dynamicTableSize :: IORef Size -- | The max dynamic table size (defined in HPACK)- , maxDynamicTableSize :: !(IORef Size)+ , maxDynamicTableSize :: IORef Size } {-# INLINE adj #-} adj :: Int -> Int -> IO Int adj maxN x | maxN == 0 = throwIO TooSmallTableSize- | otherwise = let !ret = (x + maxN) `mod` maxN+ | otherwise = let ret = (x + maxN) `mod` maxN in return ret -huffmanDecoder :: DynamicTable -> HuffmanDecoding+huffmanDecoder :: DynamicTable -> HuffmanDecoder huffmanDecoder DynamicTable{..} = dec where- DecodeInfo dec _ _ = codeInfo+ DecodeInfo dec _ = codeInfo ---------------------------------------------------------------- @@ -129,11 +126,11 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset n <- readIORef numOfEntries- let !beg = off + 1- !end = off + n+ let beg = off + 1+ end = off + n tbl <- readIORef circularTable es <- mapM (adj maxN >=> unsafeRead tbl) [beg .. end]- let !ts = zip [1..] es+ let ts = zip [1..] es mapM_ printEntry ts dsize <- readIORef dynamicTableSize maxdsize <- readIORef maxDynamicTableSize@@ -155,15 +152,15 @@ isDynamicTableEmpty :: DynamicTable -> IO Bool isDynamicTableEmpty DynamicTable{..} = do n <- readIORef numOfEntries- return $! n == 0+ return $ n == 0 isSuitableSize :: Size -> DynamicTable -> IO Bool isSuitableSize siz DynamicTable{..} = do- let DecodeInfo _ limref _ = codeInfo+ let DecodeInfo _ limref = codeInfo lim <- readIORef limref- return $! siz <= lim+ return $ siz <= lim -data TableSizeAction = Keep | Change !Size | Ignore !Size+data TableSizeAction = Keep | Change Size | Ignore Size needChangeTableSize :: DynamicTable -> IO TableSizeAction needChangeTableSize DynamicTable{..} = do@@ -196,7 +193,7 @@ newDynamicTableForEncoding maxsiz = do rev <- newRevIndex lim <- newIORef Nothing- let !info = EncodeInfo rev lim+ let info = EncodeInfo rev lim newDynamicTable maxsiz info -- | Creating 'DynamicTable' for decoding.@@ -205,10 +202,9 @@ -> IO DynamicTable newDynamicTableForDecoding maxsiz huftmpsiz = do lim <- newIORef maxsiz- buf <- mallocBytes huftmpsiz- let !decoder = decode buf huftmpsiz- !clear = free buf- !info = DecodeInfo decoder lim clear+ buf <- mallocPlainForeignPtrBytes huftmpsiz+ let decoder = decodeH buf huftmpsiz+ info = DecodeInfo decoder lim newDynamicTable maxsiz info newDynamicTable :: Size -> CodeInfo -> IO DynamicTable@@ -221,8 +217,8 @@ <*> newIORef 0 -- dynamicTableSize <*> newIORef maxsiz -- maxDynamicTableSize where- !maxN = maxNumbers maxsiz- !end = maxN - 1+ maxN = maxNumbers maxsiz+ end = maxN - 1 -- | Renewing 'DynamicTable' with necessary entries copied. renewDynamicTable :: Size -> DynamicTable -> IO ()@@ -230,9 +226,9 @@ renewDynamicTable maxsiz dyntbl@DynamicTable{..} = do renew <- shouldRenew dyntbl maxsiz when renew $ do- !entries <- getEntries dyntbl- let !maxN = maxNumbers maxsiz- !end = maxN - 1+ entries <- getEntries dyntbl+ let maxN = maxNumbers maxsiz+ end = maxN - 1 newtbl <- newArray (0,end) dummyEntry writeIORef circularTable newtbl writeIORef offset end@@ -267,7 +263,7 @@ shouldRenew :: DynamicTable -> Size -> IO Bool shouldRenew DynamicTable{..} maxsiz = do maxdsize <- readIORef maxDynamicTableSize- return $! maxdsize /= maxsiz+ return $ maxdsize /= maxsiz ---------------------------------------------------------------- @@ -278,7 +274,7 @@ -> (DynamicTable -> IO a) -> IO a withDynamicTableForEncoding maxsiz action =- bracket (newDynamicTableForEncoding maxsiz) clearDynamicTable action+ newDynamicTableForEncoding maxsiz >>= action -- | Creating 'DynamicTable' for decoding, -- performing the action and@@ -288,14 +284,7 @@ -> (DynamicTable -> IO a) -> IO a withDynamicTableForDecoding maxsiz huftmpsiz action =- bracket (newDynamicTableForDecoding maxsiz huftmpsiz) clearDynamicTable action---- | Clearing 'DynamicTable'.--- Currently, this frees the temporary buffer for Huffman decoding.-clearDynamicTable :: DynamicTable -> IO ()-clearDynamicTable DynamicTable{..} = case codeInfo of- EncodeInfo _ _ -> return ()- DecodeInfo _ _ clear -> clear+ newDynamicTableForDecoding maxsiz huftmpsiz >>= action ---------------------------------------------------------------- @@ -319,8 +308,8 @@ dsize <- readIORef dynamicTableSize table <- readIORef circularTable let i = off- !dsize' = dsize + entrySize e- !off' <- adj maxN (off - 1)+ dsize' = dsize + entrySize e+ off' <- adj maxN (off - 1) unsafeWrite table i e writeIORef offset off' writeIORef numOfEntries $ n + 1@@ -333,7 +322,7 @@ adjustTableSize dyntbl@DynamicTable{..} = adjust [] where adjust :: [Entry] -> IO [Entry]- adjust !es = do+ adjust es = do dsize <- readIORef dynamicTableSize maxdsize <- readIORef maxDynamicTableSize if dsize <= maxdsize then@@ -351,8 +340,8 @@ n <- readIORef numOfEntries dsize <- readIORef dynamicTableSize table <- readIORef circularTable- !i <- adj maxN (off + n + 1)- let !dsize' = dsize + entrySize e+ i <- adj maxN (off + n + 1)+ let dsize' = dsize + entrySize e unsafeWrite table i e writeIORef numOfEntries $ n + 1 writeIORef dynamicTableSize dsize'@@ -367,12 +356,12 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset n <- readIORef numOfEntries- !i <- adj maxN (off + n)+ i <- adj maxN (off + n) table <- readIORef circularTable e <- unsafeRead table i unsafeWrite table i dummyEntry -- let the entry GCed dsize <- readIORef dynamicTableSize- let !dsize' = dsize - entrySize e+ let dsize' = dsize - entrySize e writeIORef numOfEntries (n - 1) writeIORef dynamicTableSize dsize' return e@@ -382,12 +371,12 @@ {-# INLINE toDynamicEntry #-} toDynamicEntry :: DynamicTable -> Index -> IO Entry toDynamicEntry DynamicTable{..} idx = do- !maxN <- readIORef maxNumOfEntries- !off <- readIORef offset- !n <- readIORef numOfEntries+ maxN <- readIORef maxNumOfEntries+ off <- readIORef offset+ n <- readIORef numOfEntries when (idx > n + staticTableSize) $ throwIO $ IndexOverrun idx- !didx <- adj maxN (idx + off - staticTableSize)- !table <- readIORef circularTable+ didx <- adj maxN (idx + off - staticTableSize)+ table <- readIORef circularTable unsafeRead table didx ----------------------------------------------------------------
Network/HPACK/Table/Entry.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Table.Entry ( -- * Type@@ -55,13 +55,13 @@ toEntry :: Header -> Entry toEntry kv@(k,v) = Entry siz t v where- !t = toToken k- !siz = headerSize kv+ t = toToken k+ siz = headerSize kv toEntryToken :: Token -> HeaderValue -> Entry toEntryToken t v = Entry siz t v where- !siz = headerSize' t v+ siz = headerSize' t v ----------------------------------------------------------------
Network/HPACK/Table/RevIndex.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, OverloadedStrings, CPP, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.HPACK.Table.RevIndex ( RevIndex@@ -27,7 +29,7 @@ ---------------------------------------------------------------- -data RevIndex = RevIndex !DynamicRevIndex !OtherRevIdex+data RevIndex = RevIndex DynamicRevIndex OtherRevIdex type DynamicRevIndex = Array Int (IORef ValueMap) @@ -45,7 +47,7 @@ type StaticRevIndex = Array Int StaticEntry -data StaticEntry = StaticEntry !HIndex !(Maybe ValueMap) deriving Show+data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving Show type ValueMap = Map HeaderValue HIndex @@ -59,7 +61,7 @@ m = case xs of [] -> error "staticRevIndex" [("",i)] -> StaticEntry i Nothing- (_,i):_ -> let !vs = M.fromList xs+ (_,i):_ -> let vs = M.fromList xs in StaticEntry i (Just vs) zs = map extract $ groupBy ((==) `on` fst) lst where@@ -124,21 +126,19 @@ lookupOtherRevIndex :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO () lookupOtherRevIndex (k,v) ref fa' fc' = do oth <- readIORef ref- case M.lookup (KeyValue k v) oth of- Just i -> fa' i- Nothing -> fc'+ maybe fc' fa' $ M.lookup (KeyValue k v) oth {-# INLINE insertOtherRevIndex #-} insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO () insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i where- !k = tokenFoldedKey t+ k = tokenFoldedKey t {-# INLINE deleteOtherRevIndex #-} deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO () deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v) where- !k = tokenFoldedKey t+ k = tokenFoldedKey t ---------------------------------------------------------------- @@ -160,10 +160,10 @@ -> RevIndex -> IO () lookupRevIndex t@Token{..} v fa fb fc fd (RevIndex dyn oth)- | not (isStaticTokenIx ix) = lookupOtherRevIndex (k,v) oth fa' fc'- | shouldBeIndexed = lookupDynamicStaticRevIndex ix v dyn fa' fb'+ | not (isStaticTokenIx tokenIx) = lookupOtherRevIndex (k,v) oth fa' fc'+ | shouldBeIndexed = lookupDynamicStaticRevIndex tokenIx v dyn fa' fb' -- path: is not indexed but ":path /" should be used, sigh.- | otherwise = lookupStaticRevIndex ix v fa' fd'+ | otherwise = lookupStaticRevIndex tokenIx v fa' fd' where k = foldedCase tokenKey ent = toEntryToken t v@@ -180,8 +180,8 @@ -> (HeaderName -> HeaderValue -> IO ()) -> IO () lookupRevIndex' Token{..} v fa fd fe- | isStaticTokenIx ix = lookupStaticRevIndex ix v fa' fd'- | otherwise = fe'+ | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'+ | otherwise = fe' where k = foldedCase tokenKey fa' = fa
Network/HPACK/Table/Static.hs view
@@ -20,11 +20,11 @@ -- | Get 'Entry' from the static table. -- -- >>> toStaticEntry 1--- Entry 42 (Token {ix = 0, shouldBeIndexed = True, isPseudo = True, tokenKey = ":authority"}) ""+-- Entry 42 (Token {tokenIx = 0, shouldBeIndexed = True, isPseudo = True, tokenKey = ":authority"}) "" -- >>> toStaticEntry 8--- Entry 42 (Token {ix = 4, shouldBeIndexed = True, isPseudo = True, tokenKey = ":status"}) "200"+-- Entry 42 (Token {tokenIx = 4, shouldBeIndexed = True, isPseudo = True, tokenKey = ":status"}) "200" -- >>> toStaticEntry 50--- Entry 37 (Token {ix = 40, shouldBeIndexed = True, isPseudo = False, tokenKey = "Range"}) ""+-- Entry 37 (Token {tokenIx = 40, shouldBeIndexed = True, isPseudo = False, tokenKey = "Range"}) "" toStaticEntry :: Index -> Entry toStaticEntry sidx = staticTable `unsafeAt` (sidx - 1)
Network/HPACK/Token.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HPACK.Token ( -- * Data type Token(..)- , tokenIx , tokenCIKey , tokenFoldedKey , toToken@@ -73,6 +72,25 @@ , tokenConnection , tokenTE , tokenMax+ , tokenAccessControlAllowCredentials+ , tokenAccessControlAllowHeaders+ , tokenAccessControlAllowMethods+ , tokenAccessControlExposeHeaders+ , tokenAccessControlRequestHeaders+ , tokenAccessControlRequestMethod+ , tokenAltSvc+ , tokenContentSecurityPolicy+ , tokenEarlyData+ , tokenExpectCt+ , tokenForwarded+ , tokenOrigin+ , tokenPurpose+ , tokenTimingAllowOrigin+ , tokenUpgradeInsecureRequests+ , tokenXContentTypeOptions+ , tokenXForwardedFor+ , tokenXFrameOptions+ , tokenXXssProtection ) where import qualified Data.ByteString as B@@ -87,17 +105,12 @@ -- | Internal representation for header keys. data Token = Token {- ix :: !Int -- ^ Index for value table- , shouldBeIndexed :: !Bool -- ^ should be indexed in HPACK- , isPseudo :: !Bool -- ^ is this a pseudo header key?- , tokenKey :: !(CI ByteString) -- ^ Case insensitive header key+ tokenIx :: Int -- ^ Index for value table+ , shouldBeIndexed :: Bool -- ^ should be indexed in HPACK+ , isPseudo :: Bool -- ^ is this a pseudo header key?+ , tokenKey :: CI ByteString -- ^ Case insensitive header key } deriving (Eq, Show) --- | Extracting an index from a token.-{-# INLINE tokenIx #-}-tokenIx :: Token -> Int-tokenIx (Token n _ _ _) = n- -- | Extracting a case insensitive header key from a token. {-# INLINE tokenCIKey #-} tokenCIKey :: Token -> ByteString@@ -160,8 +173,28 @@ tokenVary :: Token tokenVia :: Token tokenWwwAuthenticate :: Token-tokenConnection :: Token -- Original-tokenTE :: Token -- Original+tokenConnection :: Token -- Warp+tokenTE :: Token -- Warp+tokenAccessControlAllowCredentials :: Token -- QPACK+tokenAccessControlAllowHeaders :: Token -- QPACK+tokenAccessControlAllowMethods :: Token -- QPACK+tokenAccessControlExposeHeaders :: Token -- QPACK+tokenAccessControlRequestHeaders :: Token -- QPACK+tokenAccessControlRequestMethod :: Token -- QPACK+tokenAltSvc :: Token -- QPACK+tokenContentSecurityPolicy :: Token -- QPACK+tokenEarlyData :: Token -- QPACK+tokenExpectCt :: Token -- QPACK+tokenForwarded :: Token -- QPACK+tokenOrigin :: Token -- QPACK+tokenPurpose :: Token -- QPACK+tokenTimingAllowOrigin :: Token -- QPACK+tokenUpgradeInsecureRequests :: Token -- QPACK+tokenXContentTypeOptions :: Token -- QPACK+tokenXForwardedFor :: Token -- QPACK+tokenXFrameOptions :: Token -- QPACK+tokenXXssProtection :: Token -- QPACK+ tokenMax :: Token -- Other tokens tokenAuthority = Token 0 True True ":authority"@@ -216,13 +249,34 @@ tokenVary = Token 49 True False "Vary" tokenVia = Token 50 True False "Via" tokenWwwAuthenticate = Token 51 True False "Www-Authenticate"--- | Not defined in the static table.-tokenConnection = Token 52 False False "Connection"--- | Not defined in the static table.-tokenTE = Token 53 False False "TE"+ -- | A place holder to hold header keys not defined in the static table.-tokenMax = Token 54 True False "for other tokens"+-- | For Warp+tokenConnection = Token 52 False False "Connection"+tokenTE = Token 53 False False "TE"+-- | For QPACK+tokenAccessControlAllowCredentials = Token 54 True False "Access-Control-Allow-Credentials"+tokenAccessControlAllowHeaders = Token 55 True False "Access-Control-Allow-Headers"+tokenAccessControlAllowMethods = Token 56 True False "Access-Control-Allow-Methods"+tokenAccessControlExposeHeaders = Token 57 True False "Access-Control-Expose-Headers"+tokenAccessControlRequestHeaders = Token 58 True False "Access-Control-Request-Headers"+tokenAccessControlRequestMethod = Token 59 True False "Access-Control-Request-Method"+tokenAltSvc = Token 60 True False "Alt-Svc"+tokenContentSecurityPolicy = Token 61 True False "Content-Security-Policy"+tokenEarlyData = Token 62 True False "Early-Data"+tokenExpectCt = Token 63 True False "Expect-Ct"+tokenForwarded = Token 64 True False "Forwarded"+tokenOrigin = Token 65 True False "Origin"+tokenPurpose = Token 66 True False "Purpose"+tokenTimingAllowOrigin = Token 67 True False "Timing-Allow-Origin"+tokenUpgradeInsecureRequests = Token 68 True False "Upgrade-Insecure-Requests"+tokenXContentTypeOptions = Token 69 True False "X-Content-Type-Options"+tokenXForwardedFor = Token 70 True False "X-Forwarded-For"+tokenXFrameOptions = Token 71 True False "X-Frame-Options"+tokenXXssProtection = Token 72 True False "X-Xss-Protection" +tokenMax = Token 73 True False "for other tokens"+ -- | Minimum token index. minTokenIx :: Int minTokenIx = 0@@ -233,7 +287,7 @@ -- | Maximum token index. maxTokenIx :: Int-maxTokenIx = 54+maxTokenIx = 73 -- | Token index for 'tokenCookie'. cookieTokenIx :: Int@@ -264,10 +318,11 @@ -- >>> toToken ":authority" == tokenAuthority -- True -- >>> toToken "foo"--- Token {ix = 54, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"}+-- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"} -- >>> toToken ":bar"--- Token {ix = 54, shouldBeIndexed = True, isPseudo = True, tokenKey = ":bar"}+-- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = True, tokenKey = ":bar"} toToken :: ByteString -> Token+toToken "" = Token maxTokenIx True False "" toToken bs = case len of 2 -> if bs === "te" then tokenTE else mkTokenMax bs 3 -> case lst of@@ -289,13 +344,16 @@ _ -> mkTokenMax bs 6 -> case lst of 101 | bs === "cookie" -> tokenCookie+ 110 | bs === "origin" -> tokenOrigin 114 | bs === "server" -> tokenServer 116 | bs === "expect" -> tokenExpect | bs === "accept" -> tokenAccept _ -> mkTokenMax bs 7 -> case lst of+ 99 | bs === "alt-svc" -> tokenAltSvc 100 | bs === ":method" -> tokenMethod 101 | bs === ":scheme" -> tokenScheme+ | bs === "purpose" -> tokenPurpose 104 | bs === "refresh" -> tokenRefresh 114 | bs === "referer" -> tokenReferer 115 | bs === "expires" -> tokenExpires@@ -306,7 +364,14 @@ 104 | bs === "if-match" -> tokenIfMatch 110 | bs === "location" -> tokenLocation _ -> mkTokenMax bs++ 9 -> case lst of+ 100 | bs === "forwarded" -> tokenForwarded+ 116 | bs === "expect-ct" -> tokenExpectCt+ _ -> mkTokenMax bs+ 10 -> case lst of+ 97 | bs === "early-data" -> tokenEarlyData 101 | bs === "set-cookie" -> tokenSetCookie 110 | bs === "connection" -> tokenConnection 116 | bs === "user-agent" -> tokenUserAgent@@ -334,12 +399,15 @@ 15 -> case lst of 101 | bs === "accept-language" -> tokenAcceptLanguage 103 | bs === "accept-encoding" -> tokenAcceptEncoding+ 114 | bs === "x-forwarded-for" -> tokenXForwardedFor+ 115 | bs === "x-frame-options" -> tokenXFrameOptions _ -> mkTokenMax bs 16 -> case lst of 101 | bs === "content-language" -> tokenContentLanguage | bs === "www-authenticate" -> tokenWwwAuthenticate 103 | bs === "content-encoding" -> tokenContentEncoding 110 | bs === "content-location" -> tokenContentLocation+ | bs === "x-xss-protection" -> tokenXXssProtection _ -> mkTokenMax bs 17 -> case lst of 101 | bs === "if-modified-since" -> tokenIfModifiedSince@@ -352,13 +420,35 @@ 101 | bs === "if-unmodified-since" -> tokenIfUnmodifiedSince 110 | bs === "proxy-authorization" -> tokenProxyAuthorization | bs === "content-disposition" -> tokenContentDisposition+ | bs === "timing-allow-origin" -> tokenTimingAllowOrigin _ -> mkTokenMax bs+ 22 -> case lst of+ 115 | bs === "x-content-type-options" -> tokenXContentTypeOptions+ _ -> mkTokenMax bs+ 23 -> case lst of+ 121 | bs === "content-security-policy" -> tokenContentSecurityPolicy+ _ -> mkTokenMax bs 25 -> case lst of+ 115 | bs === "upgrade-insecure-requests" -> tokenUpgradeInsecureRequests 121 | bs === "strict-transport-security" -> tokenStrictTransportSecurity _ -> mkTokenMax bs 27 -> case lst of 110 | bs === "access-control-allow-origin" -> tokenAccessControlAllowOrigin _ -> mkTokenMax bs+ 28 -> case lst of+ 115 | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders+ | bs === "access-control-allow-methods" -> tokenAccessControlAllowMethods+ _ -> mkTokenMax bs+ 29 -> case lst of+ 100 | bs === "access-control-request-method" -> tokenAccessControlRequestMethod+ 115 | bs === "access-control-expose-headers" -> tokenAccessControlExposeHeaders+ _ -> mkTokenMax bs+ 30 -> case lst of+ 115 | bs === "access-control-request-headers" -> tokenAccessControlRequestHeaders+ _ -> mkTokenMax bs+ 32 -> case lst of+ 115 | bs === "access-control-allow-credentials" -> tokenAccessControlAllowCredentials+ _ -> mkTokenMax bs _ -> mkTokenMax bs where len = B.length bs@@ -367,11 +457,11 @@ withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> do i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz- return $! i == 0+ return $ i == 0 mkTokenMax :: ByteString -> Token mkTokenMax bs = Token maxTokenIx True p (mk bs) where- !p | B.length bs == 0 = False- | B.head bs == 58 = True- | otherwise = False+ p | B.length bs == 0 = False+ | B.head bs == 58 = True+ | otherwise = False
Network/HPACK/Types.hs view
@@ -4,7 +4,6 @@ -- * Header HeaderName , HeaderValue- , HeaderStuff , Header , HeaderList , TokenHeader@@ -44,9 +43,6 @@ -- | Header list. type HeaderList = [Header] --- | To be a 'HeaderName' or 'HeaderValue'.-type HeaderStuff = ByteString- -- | TokenBased header. type TokenHeader = (Token, HeaderValue) @@ -71,9 +67,9 @@ -- | Strategy for HPACK encoding. data EncodeStrategy = EncodeStrategy { -- | Which compression algorithm is used.- compressionAlgo :: !CompressionAlgo+ compressionAlgo :: CompressionAlgo -- | Whether or not to use Huffman encoding for strings.- , useHuffman :: !Bool+ , useHuffman :: Bool } deriving (Eq, Show) -- | Default 'EncodeStrategy'.@@ -93,12 +89,12 @@ | EosInTheMiddle -- ^ Eos appears in the middle of huffman string | IllegalEos -- ^ Non-eos appears in the end of huffman string | TooLongEos -- ^ Eos of huffman string is more than 7 bits- | EmptyEncodedString -- ^ Encoded string has no length | TooSmallTableSize -- ^ A peer set the dynamic table size less than 32 | TooLargeTableSize -- ^ A peer tried to change the dynamic table size over the limit | IllegalTableSizeUpdate -- ^ Table size update at the non-beginning | HeaderBlockTruncated | IllegalHeaderName+ | TooLargeHeader deriving (Eq,Show,Typeable) instance Exception DecodeError
Network/HTTP2.hs view
@@ -1,106 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}- -- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).-module Network.HTTP2 (- -- * Frame- Frame(..)- , FrameHeader(..)- , FramePayload(..)- , HeaderBlockFragment- , Padding- , isPaddingDefined- -- * Encoding- , encodeFrame- , encodeFrameChunks- , encodeFrameHeader- , encodeFrameHeaderBuf- , encodeFramePayload- , EncodeInfo(..)- , encodeInfo- , module Network.HTTP2.Decode- -- * Frame type ID- , FrameTypeId(..)- , framePayloadToFrameTypeId- -- * Frame type- , FrameType- , fromFrameTypeId- , toFrameTypeId- -- * Priority- , Priority(..)- , Weight- , defaultPriority- , highestPriority- -- * Stream identifier- , StreamId- , isControl- , isRequest- , isResponse- -- * Stream identifier related- , testExclusive- , setExclusive- , clearExclusive- -- * Flags- , FrameFlags- , defaultFlags- , testEndStream- , testAck- , testEndHeader- , testPadded- , testPriority- , setEndStream- , setAck- , setEndHeader- , setPadded- , setPriority- -- * SettingsList- , SettingsList- , SettingsKeyId(..)- , SettingsValue- , fromSettingsKeyId- , toSettingsKeyId- , checkSettingsList- -- * Settings- , Settings(..)- , defaultSettings- , updateSettings- -- * Window- , WindowSize- , defaultInitialWindowSize- , maxWindowSize- , isWindowOverflow- -- * Error code- , ErrorCode- , ErrorCodeId(..)- , fromErrorCodeId- , toErrorCodeId- -- * Error- , HTTP2Error(..)- , errorCodeId- -- * Predefined values- , connectionPreface- , connectionPrefaceLength- , frameHeaderLength- , maxPayloadLength- , recommendedConcurrency+module Network.HTTP2 {-# DEPRECATED "Use Network.HTTP2.Frame instead" #-}+ (+ module Network.HTTP2.Frame ) where -import qualified Data.ByteString as BS--import Imports-import Network.HTTP2.Decode-import Network.HTTP2.Encode-import Network.HTTP2.Types---- | The preface of HTTP\/2.------ >>> connectionPreface--- "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"-connectionPreface :: ByteString-connectionPreface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"---- | Length of the preface.------ >>> connectionPrefaceLength--- 24-connectionPrefaceLength :: Int-connectionPrefaceLength = BS.length connectionPreface+import Network.HTTP2.Frame
+ Network/HTTP2/Arch.hs view
@@ -0,0 +1,29 @@+module Network.HTTP2.Arch (+ module Network.HTTP2.Arch.Config+ , module Network.HTTP2.Arch.Context+ , module Network.HTTP2.Arch.EncodeFrame+ , module Network.HTTP2.Arch.File+ , module Network.HTTP2.Arch.HPACK+ , module Network.HTTP2.Arch.Manager+ , module Network.HTTP2.Arch.Queue+ , module Network.HTTP2.Arch.ReadN+ , module Network.HTTP2.Arch.Receiver+ , module Network.HTTP2.Arch.Sender+ , module Network.HTTP2.Arch.Status+ , module Network.HTTP2.Arch.Stream+ , module Network.HTTP2.Arch.Types+ ) where++import Network.HTTP2.Arch.Config+import Network.HTTP2.Arch.Context+import Network.HTTP2.Arch.EncodeFrame+import Network.HTTP2.Arch.File+import Network.HTTP2.Arch.HPACK+import Network.HTTP2.Arch.Manager+import Network.HTTP2.Arch.Queue+import Network.HTTP2.Arch.ReadN+import Network.HTTP2.Arch.Receiver+import Network.HTTP2.Arch.Sender+import Network.HTTP2.Arch.Stream+import Network.HTTP2.Arch.Status+import Network.HTTP2.Arch.Types
+ Network/HTTP2/Arch/Cache.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Arch.Cache where++import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ++type Priority = Int++data Cache k v = Cache {+ cLimit :: Int+ , cSize :: Int+ , cTick :: Priority+ , cQueue :: OrdPSQ k Priority v+ }++emptyCache :: Int -> Cache k v+emptyCache lim = Cache lim 0 0 PSQ.empty++insert :: Ord k => k -> v -> Cache k v -> Cache k v+insert k v c@Cache{..}+ | cSize == cLimit = let q = PSQ.insert k cTick v $ PSQ.deleteMin cQueue+ in c { cTick = cTick + 1, cQueue = q }+ | otherwise = let q = PSQ.insert k cTick v cQueue+ in c { cTick = cTick + 1, cQueue = q, cSize = cSize + 1 }++lookup :: Ord k => k -> Cache k v -> Maybe v+lookup k Cache{..} = snd <$> PSQ.lookup k cQueue
+ Network/HTTP2/Arch/Config.hs view
@@ -0,0 +1,47 @@+module Network.HTTP2.Arch.Config where++import Data.ByteString (ByteString)+import Data.IORef+import Foreign.Marshal.Alloc (mallocBytes, free)+import Network.Socket+import Network.Socket.ByteString (sendAll)+import qualified System.TimeManager as T++import Network.HPACK+import Network.HTTP2.Arch.File+import Network.HTTP2.Arch.ReadN++-- | HTTP/2 configuration.+data Config = Config {+ -- confWriteBuffer is used only by frameSender.+ -- This MUST be freed after frameSender is terminated.+ confWriteBuffer :: Buffer+ , confBufferSize :: BufferSize+ , confSendAll :: ByteString -> IO ()+ , confReadN :: Int -> IO ByteString+ , confPositionReadMaker :: PositionReadMaker+ , confTimeoutManager :: T.Manager+ }++-- | Making simple configuration whose IO is not efficient.+-- A write buffer is allocated internally.+allocSimpleConfig :: Socket -> BufferSize -> IO Config+allocSimpleConfig s bufsiz = do+ buf <- mallocBytes bufsiz+ ref <- newIORef Nothing+ timmgr <- T.initialize $ 30 * 1000000+ let config = Config {+ confWriteBuffer = buf+ , confBufferSize = bufsiz+ , confSendAll = sendAll s+ , confReadN = defaultReadN s ref+ , confPositionReadMaker = defaultPositionReadMaker+ , confTimeoutManager = timmgr+ }+ return config++-- | Deallocating the resource of the simple configuration.+freeSimpleConfig :: Config -> IO ()+freeSimpleConfig conf = do+ free $ confWriteBuffer conf+ T.killManager $ confTimeoutManager conf
+ Network/HTTP2/Arch/Context.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE NamedFieldPuns #-}++module Network.HTTP2.Arch.Context where++import Control.Concurrent.STM+import Data.IORef+import Network.HTTP.Types (Method)++import Imports hiding (insert)+import Network.HPACK+import Network.HTTP2.Arch.Cache (Cache, emptyCache)+import qualified Network.HTTP2.Arch.Cache as Cache+import Network.HTTP2.Arch.Rate+import Network.HTTP2.Arch.Stream+import Network.HTTP2.Arch.Types+import Network.HTTP2.Frame++data Role = Client | Server deriving (Eq,Show)++----------------------------------------------------------------++data RoleInfo = ServerInfo {+ inputQ :: TQueue (Input Stream)+ }+ | ClientInfo {+ scheme :: ByteString+ , authority :: ByteString+ , cache :: IORef (Cache (Method,ByteString) Stream)+ }++newServerInfo :: IO RoleInfo+newServerInfo = ServerInfo <$> newTQueueIO++newClientInfo :: ByteString -> ByteString -> Int -> IO RoleInfo+newClientInfo scm auth lim = ClientInfo scm auth <$> newIORef (emptyCache lim)++insertCache :: Method -> ByteString -> Stream -> RoleInfo -> IO ()+insertCache m path v (ClientInfo _ _ ref) = atomicModifyIORef' ref $ \c ->+ (Cache.insert (m,path) v c, ())+insertCache _ _ _ _ = error "insertCache"++lookupCache :: Method -> ByteString -> RoleInfo -> IO (Maybe Stream)+lookupCache m path (ClientInfo _ _ ref) = Cache.lookup (m,path) <$> readIORef ref+lookupCache _ _ _ = error "lookupCache"++----------------------------------------------------------------++-- | The context for HTTP/2 connection.+data Context = Context {+ role :: Role+ , roleInfo :: RoleInfo+ -- HTTP/2 settings received from a browser+ , http2settings :: IORef Settings+ , firstSettings :: IORef Bool+ , streamTable :: StreamTable+ , concurrency :: 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)+ , myStreamId :: IORef StreamId+ , peerStreamId :: IORef StreamId+ , outputQ :: TQueue (Output Stream)+ , controlQ :: TQueue Control+ , encodeDynamicTable :: DynamicTable+ , decodeDynamicTable :: DynamicTable+ -- the connection window for data from a server to a browser.+ , connectionWindow :: TVar WindowSize+ , pingRate :: Rate+ , settingsRate :: Rate+ , emptyFrameRate :: Rate+ }++----------------------------------------------------------------++newContext :: RoleInfo -> IO Context+newContext rinfo =+ Context rl rinfo+ <$> newIORef defaultSettings+ <*> newIORef False+ <*> newStreamTable+ <*> newIORef 0+ <*> newIORef Nothing+ <*> newIORef sid0+ <*> newIORef 0+ <*> newTQueueIO+ <*> newTQueueIO+ <*> newDynamicTableForEncoding defaultDynamicTableSize+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096+ <*> newTVarIO defaultInitialWindowSize+ <*> newRate+ <*> newRate+ <*> newRate+ where+ rl = case rinfo of+ ClientInfo{} -> Client+ _ -> Server+ sid0 | rl == Client = 1+ | otherwise = 2++----------------------------------------------------------------++isClient :: Context -> Bool+isClient ctx = role ctx == Client++isServer :: Context -> Bool+isServer ctx = role ctx == Server++----------------------------------------------------------------++getMyNewStreamId :: Context -> IO StreamId+getMyNewStreamId ctx = atomicModifyIORef' (myStreamId ctx) inc2+ where+ inc2 n = let n' = n + 2 in (n', n)++getPeerStreamID :: Context -> IO StreamId+getPeerStreamID ctx = readIORef $ peerStreamId ctx++setPeerStreamID :: Context -> StreamId -> IO ()+setPeerStreamID ctx sid = writeIORef (peerStreamId ctx) sid++----------------------------------------------------------------++{-# 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++openStream :: Context -> StreamId -> FrameTypeId -> IO Stream+openStream ctx@Context{streamTable, http2settings} sid ftyp = do+ ws <- initialWindowSize <$> readIORef http2settings+ newstrm <- newStream sid $ fromIntegral ws+ when (ftyp == FrameHeaders || ftyp == FramePushPromise) $ opened ctx newstrm+ insert streamTable sid newstrm+ return newstrm
+ Network/HTTP2/Arch/EncodeFrame.hs view
@@ -0,0 +1,34 @@+module Network.HTTP2.Arch.EncodeFrame where++import Network.HTTP2.Frame++import Imports++----------------------------------------------------------------++goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString+goawayFrame sid etype debugmsg = encodeFrame einfo frame+ where+ einfo = encodeInfo id 0+ frame = GoAwayFrame sid etype debugmsg++resetFrame :: ErrorCodeId -> StreamId -> ByteString+resetFrame etype sid = encodeFrame einfo frame+ where+ einfo = encodeInfo id sid+ frame = RSTStreamFrame etype++settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist+ where+ einfo = encodeInfo func 0++pingFrame :: ByteString -> ByteString+pingFrame bs = encodeFrame einfo $ PingFrame bs+ where+ einfo = encodeInfo setAck 0++windowUpdateFrame :: StreamId -> WindowSize -> ByteString+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz+ where+ einfo = encodeInfo id sid
+ Network/HTTP2/Arch/File.hs view
@@ -0,0 +1,36 @@+module Network.HTTP2.Arch.File where++import System.IO++import Imports+import Network.HPACK++-- | 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)+-- | Position read based on 'Handle'.+defaultPositionReadMaker :: PositionReadMaker+defaultPositionReadMaker file = do+ hdl <- openBinaryFile file ReadMode+ return (pread hdl, Closer $ hClose hdl)+ where+ pread :: Handle -> PositionRead+ pread hdl off bytes buf = do+ hSeek hdl AbsoluteSeek $ fromIntegral off+ fromIntegral <$> hGetBufSome hdl buf (fromIntegral bytes)
+ Network/HTTP2/Arch/HPACK.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Arch.HPACK (+ hpackEncodeHeader+ , hpackEncodeHeaderLoop+ , hpackDecodeHeader+ , hpackDecodeTrailer+ , just+ , fixHeaders+ ) where++import qualified Control.Exception as E+import Network.ByteOrder+import qualified Network.HTTP.Types as H++import Imports+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP2.Arch.Context+import Network.HTTP2.Frame++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders+fixHeaders hdr = deleteUnnecessaryHeaders hdr++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 isClient ctx || checkRequestHeader vt then+ return tbl+ else+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"++hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable+hpackDecodeTrailer hdrblk Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl+ where+ handl IllegalHeaderName =+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"+ handl _ =+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"++{-# INLINE checkRequestHeader #-}+checkRequestHeader :: ValueTable -> Bool+checkRequestHeader reqvt+ | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme+ | isJust mStatus = False+ | isNothing mMethod = False+ | isNothing mScheme = False+ | isNothing mPath = False+ | mPath == Just "" = False+ | isJust mConnection = False+ | just mTE (/= "trailers") = False+ | otherwise = True+ where+ mStatus = getHeaderValue tokenStatus reqvt+ mScheme = getHeaderValue tokenScheme reqvt+ mPath = getHeaderValue tokenPath reqvt+ mMethod = getHeaderValue tokenMethod reqvt+ mConnection = getHeaderValue tokenConnection reqvt+ mTE = getHeaderValue tokenTE reqvt++{-# INLINE just #-}+just :: Maybe a -> (a -> Bool) -> Bool+just Nothing _ = False+just (Just x) p+ | p x = True+ | otherwise = False
+ Network/HTTP2/Arch/Manager.hs view
@@ -0,0 +1,118 @@+-- | A thread pool manager.+-- The manager has responsibility to spawn and kill+-- worker threads.+module Network.HTTP2.Arch.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++----------------------------------------------------------------++-- | Action to be spawned by the manager.+type Action = IO ()++noAction :: Action+noAction = return ()++data Command = Stop | Spawn | Add ThreadId | Delete ThreadId++-- | Manager to manage the thread pool and the timer.+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 :: T.Manager -> IO Manager+start timmgr = do+ q <- newTQueueIO+ ref <- newIORef noAction+ void $ forkIO $ go q Set.empty ref+ return $ Manager q ref timmgr+ where+ go q tset0 ref = do+ x <- atomically $ readTQueue q+ case x of+ Stop -> kill tset0+ Spawn -> next tset0+ Add newtid -> let tset = add newtid tset0+ in go q tset ref+ Delete oldtid -> let tset = del oldtid tset0+ in go q tset ref+ where+ next tset = do+ action <- readIORef ref+ newtid <- forkIO action+ let tset' = add newtid tset+ go q tset' ref++-- | Setting the action to be spawned.+setAction :: Manager -> Action -> IO ()+setAction (Manager _ ref _) action = writeIORef ref action++-- | Stopping the manager.+stop :: Manager -> IO ()+stop (Manager q _ _) = atomically $ writeTQueue q Stop++-- | Spawning the action.+spawnAction :: Manager -> IO ()+spawnAction (Manager q _ _) = atomically $ writeTQueue q Spawn++-- | Adding my thread id to the kill-thread list on stopping.+addMyId :: Manager -> IO ()+addMyId (Manager q _ _) = do+ tid <- myThreadId+ atomically $ writeTQueue q $ Add tid++-- | Deleting my thread id from the kill-thread list on stopping.+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++-- | Killing the IO action of the second argument on timeout.+timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()+timeoutKillThread (Manager _ _ tmgr) action = E.bracket register T.cancel action+ where+ register = T.registerKillThread tmgr noAction++-- | Registering closer for a resource and+-- returning a timer refresher.+timeoutClose :: Manager -> IO () -> IO (IO ())+timeoutClose (Manager _ _ tmgr) closer = do+ th <- T.register tmgr closer+ return $ T.tickle th
+ Network/HTTP2/Arch/Queue.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Arch.Queue where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Exception (bracket)++import Imports+import Network.HTTP2.Arch.Manager+import Network.HTTP2.Arch.Types++{-# INLINE forkAndEnqueueWhenReady #-}+forkAndEnqueueWhenReady :: IO () -> TQueue (Output Stream) -> Output Stream -> 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 :: TQueue (Output Stream) -> Output Stream -> IO ()+enqueueOutput outQ out = atomically $ writeTQueue outQ out++{-# INLINE enqueueControl #-}+enqueueControl :: TQueue Control -> Control -> IO ()+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl++----------------------------------------------------------------
+ Network/HTTP2/Arch/Rate.hs view
@@ -0,0 +1,30 @@+module Network.HTTP2.Arch.Rate (+ Rate+ , newRate+ , getRate+ ) where++import Data.IORef+import Data.UnixTime++newtype Rate = Rate (IORef Counter)++data Counter = Counter Int UnixTime++newRate :: IO Rate+newRate = do+ cntr <- Counter 0 <$> getUnixTime+ Rate <$> newIORef cntr++getRate :: Rate -> IO Int+getRate (Rate ref) = do+ Counter n beg <- readIORef ref+ cur <- getUnixTime+ if (cur `diffUnixTime` beg) > 1 then do+ let n' = 1+ writeIORef ref $ Counter n' cur+ return n'+ else do+ let n' = n + 1+ writeIORef ref $ Counter n' beg+ return n'
+ Network/HTTP2/Arch/ReadN.hs view
@@ -0,0 +1,41 @@+module Network.HTTP2.Arch.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 _ _ 0 = return B.empty+defaultReadN s ref n = do+ mbs <- readIORef ref+ writeIORef ref Nothing+ case mbs of+ Nothing -> do+ bs <- N.recv s n+ if B.null bs then+ return B.empty+ else 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'+ if B.null bs1 then+ return B.empty+ else do+ let bs2 = bs `B.append` bs1+ if B.length bs2 == n then+ return bs2+ else+ loop bs2
+ Network/HTTP2/Arch/Receiver.hs view
@@ -0,0 +1,505 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Arch.Receiver (+ frameReceiver+ , maxConcurrency+ , initialFrame+ ) 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 Imports hiding (delete, insert)+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP2.Arch.Context+import Network.HTTP2.Arch.EncodeFrame+import Network.HTTP2.Arch.HPACK+import Network.HTTP2.Arch.Queue+import Network.HTTP2.Arch.Rate+import Network.HTTP2.Arch.Stream+import Network.HTTP2.Arch.Types+import Network.HTTP2.Frame++----------------------------------------------------------------++maxConcurrency :: Int+maxConcurrency = recommendedConcurrency++continuationLimit :: Int+continuationLimit = 10++headerFragmentLimit :: Int+headerFragmentLimit = 51200 -- 50K++pingRateLimit :: Int+pingRateLimit = 4++settingsRateLimit :: Int+settingsRateLimit = 4++emptyFrameRateLimit :: Int+emptyFrameRateLimit = 4++----------------------------------------------------------------++initialFrame :: ByteString+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]++----------------------------------------------------------------++type RecvN = Int -> IO ByteString++frameReceiver :: Context -> RecvN -> IO ()+frameReceiver ctx@Context{..} recvN = loop 0 `E.catch` sendGoaway+ where+ 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 <- processFrame ctx recvN $ decodeFrameHeader hd+ when cont $ loop (n + 1)++ sendGoaway e+ | Just (ConnectionError err msg) <- E.fromException e = do+ psid <- getPeerStreamID ctx+ let frame = goawayFrame psid err msg+ enqueueControl controlQ $ CGoaway frame+ | otherwise = return ()++----------------------------------------------------------------++processFrame :: Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool+processFrame ctx _recvN (fid, FrameHeader{streamId})+ | isServer ctx &&+ isServerInitiated streamId &&+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"+processFrame Context{..} recvN (FrameUnknown _, FrameHeader{payloadLength}) = do+ mx <- readIORef continued+ case mx of+ Nothing -> do+ -- ignoring unknown frame+ void $ recvN payloadLength+ return True+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"+processFrame ctx recvN (FramePushPromise, header@FrameHeader{payloadLength})+ | isServer ctx = E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"+ | otherwise = do+ pl <- recvN payloadLength+ PushPromiseFrame sid frag <- guardIt $ decodePushPromiseFrame header pl+ unless (isServerInitiated sid) $+ E.throwIO $ ConnectionError ProtocolError "wrong sid for push promise"+ when (frag == "") $+ E.throwIO $ ConnectionError ProtocolError "wrong header fragment for push promise"+ (_,vt) <- hpackDecodeHeader frag ctx+ let ClientInfo{..} = roleInfo ctx+ when (getHeaderValue tokenAuthority vt == Just authority+ && getHeaderValue tokenScheme vt == Just scheme) $ do+ let mmethod = getHeaderValue tokenMethod vt+ mpath = getHeaderValue tokenPath vt+ case (mmethod, mpath) of+ (Just method, Just path) -> do+ strm <- openStream ctx sid FramePushPromise+ insertCache method path strm $ roleInfo ctx+ _ -> return ()+ return True+processFrame ctx@Context{..} recvN typhdr@(ftyp, header@FrameHeader{payloadLength}) = do+ settings <- readIORef http2settings+ case checkFrameHeader settings typhdr of+ Left h2err -> case h2err of+ StreamError err sid -> do+ resetStream err sid+ void $ recvN payloadLength+ return True+ connErr -> E.throwIO connErr+ Right _ -> do+ ex <- E.try $ controlOrStream ctx recvN ftyp header+ case ex of+ Left (StreamError err sid) -> do+ resetStream err sid+ return True+ Left connErr -> E.throw connErr+ Right cont -> return cont+ where+ resetStream err sid = do+ let frame = resetFrame err sid+ enqueueControl controlQ $ CFrame frame++----------------------------------------------------------------++controlOrStream :: Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool+controlOrStream ctx@Context{..} recvN ftyp header@FrameHeader{streamId, payloadLength}+ | isControl streamId = do+ pl <- recvN payloadLength+ control ftyp header pl ctx+ | otherwise = do+ checkContinued+ mstrm <- getStream ctx ftyp streamId+ pl <- recvN payloadLength+ case mstrm of+ Just strm -> do+ state0 <- readStreamState strm+ state <- stream ftyp header pl ctx state0 strm+ resetContinued+ set <- processState state ctx strm streamId+ when set setContinued+ Nothing+ | ftyp == FramePriority -> do+ -- for h2spec only+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl+ checkPriority newpri streamId+ | otherwise -> return ()+ 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"++----------------------------------------------------------------++processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool+processState (Open (NoBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do+ let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamError ProtocolError streamId+ halfClosedRemote ctx strm+ tlr <- newIORef Nothing+ let inpObj = InpObj tbl (Just 0) (return "") tlr+ if isServer ctx then+ atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj+ else+ putMVar streamInput inpObj+ return False+processState (Open (HasBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do+ let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ bodyLength <- newIORef 0+ tlr <- newIORef Nothing+ q <- newTQueueIO+ setStreamState ctx strm $ Open (Body q mcl bodyLength tlr)+ bodySource <- mkSource (updateWindow controlQ streamId) q+ let inpObj = InpObj tbl mcl (readSource bodySource) tlr+ if isServer ctx then+ atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj+ else+ putMVar streamInput inpObj+ return False+processState s@(Open Continued{}) ctx strm _streamId = do+ setStreamState ctx strm s+ return True+processState HalfClosedRemote ctx strm _streamId = do+ halfClosedRemote ctx strm+ return False+processState s ctx strm _streamId = do+ -- Idle, Open Body, Closed+ setStreamState ctx strm s+ return False++----------------------------------------------------------------++getStream :: Context -> FrameTypeId -> StreamId -> IO (Maybe Stream)+getStream ctx@Context{..} ftyp streamId =+ search streamTable streamId >>= getStream' ctx ftyp streamId++getStream' :: Context -> FrameTypeId -> StreamId -> Maybe Stream -> IO (Maybe Stream)+getStream' ctx ftyp _streamId 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 idle stream+ when (isIdle st) $ opened ctx strm0+ return js+getStream' ctx@Context{..} ftyp streamId Nothing+ | isServerInitiated streamId = return Nothing+ | isServer ctx = do+ csid <- getPeerStreamID ctx+ 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+ setPeerStreamID ctx streamId+ cnt <- readIORef concurrency+ -- Checking the limitation of concurrency+ when (cnt >= maxConcurrency) $ E.throwIO $ StreamError RefusedStream streamId+ Just <$> openStream ctx streamId ftyp+ | otherwise = undefined -- never reach++----------------------------------------------------------------++control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool+control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable, settingsRate} = do+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs+ traverse_ E.throwIO $ checkSettingsList alist+ -- HTTP/2 Setting from a browser+ if testAck flags then+ return True+ else do+ -- Settings Flood - CVE-2019-9515+ rate <- getRate settingsRate+ if rate > settingsRateLimit then+ E.throwIO $ ConnectionError ProtocolError "too many settings"+ else 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,pingRate} =+ if testAck flags then+ return True+ else do+ -- Ping Flood - CVE-2019-9512+ rate <- getRate pingRate+ if rate > pingRateLimit then+ E.throwIO $ ConnectionError ProtocolError "too many ping"+ 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 s@(Open JustOpened) Stream{streamNumber} = do+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs+ let endOfStream = testEndStream flags+ endOfHeader = testEndHeader flags+ if frag == "" && not endOfStream && not endOfHeader then do+ -- Empty Frame Flooding - CVE-2019-9518+ rate <- getRate $ emptyFrameRate ctx+ if rate > emptyFrameRateLimit then+ E.throwIO $ ConnectionError ProtocolError "too many empty headers"+ else+ return s+ else do+ case mp of+ Nothing -> return ()+ Just p -> checkPriority p streamNumber+ if endOfHeader then do+ tbl <- hpackDecodeHeader frag ctx+ return $ if endOfStream then+ Open (NoBody tbl)+ else+ Open (HasBody tbl)+ else do+ let siz = BS.length frag+ return $ Open $ Continued [frag] siz 1 endOfStream++stream FrameHeaders header@FrameHeader{flags} bs ctx (Open (Body q _ _ tlr)) _ = do+ HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs+ let endOfStream = testEndStream flags+ -- checking frag == "" is not necessary+ 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 _)+ _ = do+ when (payloadLength /= 0) $ do+ let frame = windowUpdateFrame 0 payloadLength+ enqueueControl controlQ $ CFrame frame+ let endOfStream = testEndStream flags+ if endOfStream then do+ return HalfClosedRemote+ else+ return s++stream FrameData+ header@FrameHeader{flags,payloadLength,streamId}+ bs+ Context{emptyFrameRate} s@(Open (Body q mcl bodyLength _))+ _ = do+ DataFrame body <- guardIt $ decodeDataFrame header bs+ len0 <- readIORef bodyLength+ let len = len0 + payloadLength+ endOfStream = testEndStream flags+ -- Empty Frame Flooding - CVE-2019-9518+ if body == "" then+ unless endOfStream $ do+ rate <- getRate emptyFrameRate+ when (rate > emptyFrameRateLimit) $ do+ E.throwIO $ ConnectionError ProtocolError "too many empty data"+ else do+ writeIORef bodyLength len+ 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 s@(Open (Continued rfrags siz n endOfStream)) _ = do+ let endOfHeader = testEndHeader flags+ if frag == "" && not endOfHeader then do+ -- Empty Frame Flooding - CVE-2019-9518+ rate <- getRate $ emptyFrameRate ctx+ if rate > emptyFrameRateLimit then+ E.throwIO $ ConnectionError ProtocolError "too many empty continuation"+ else+ return s+ else do+ let rfrags' = frag : rfrags+ siz' = siz + BS.length frag+ n' = n + 1+ when (siz' > headerFragmentLimit) $+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"+ when (n' > continuationLimit) $+ 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)+ else+ Open (HasBody tbl)+ else+ return $ Open $ Continued rfrags' siz' n' endOfStream++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 _ s Stream{streamNumber} = do+ -- ignore+ -- Resource Loop - CVE-2019-9513+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs+ checkPriority newpri streamNumber+ 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++----------------------------------------------------------------++-- | Type for input streaming.+data Source = Source (Int -> IO ())+ (TQueue ByteString)+ (IORef ByteString)+ (IORef Bool)++mkSource :: (Int -> IO ()) -> TQueue ByteString -> IO Source+mkSource update q = Source update q <$> newIORef "" <*> newIORef False++updateWindow :: TQueue Control -> StreamId -> Int -> IO ()+updateWindow _ _ 0 = return ()+updateWindow controlQ sid len = enqueueControl controlQ $ CFrame frame+ where+ frame1 = windowUpdateFrame 0 len+ frame2 = windowUpdateFrame sid len+ frame = frame1 `BS.append` frame2++readSource :: Source -> IO ByteString+readSource (Source update q refBS refEOF) = do+ eof <- readIORef refEOF+ if eof then+ return ""+ else do+ bs <- readBS+ let len = BS.length bs+ update len+ return bs+ where+ readBS = do+ bs0 <- readIORef refBS+ if bs0 == "" then do+ bs <- atomically $ readTQueue q+ when (bs == "") $ writeIORef refEOF True+ return bs+ else do+ writeIORef refBS ""+ return bs0
+ Network/HTTP2/Arch/Sender.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Arch.Sender (+ frameSender+ , fillBuilderBodyGetNext+ , fillFileBodyGetNext+ , fillStreamBodyGetNext+ , runTrailersMaker+ ) 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 Foreign.Ptr (plusPtr)+import Network.ByteOrder++import Imports+import Network.HPACK (setLimitForEncoding, toHeaderTable)+import Network.HTTP2.Arch.Config+import Network.HTTP2.Arch.Context+import Network.HTTP2.Arch.EncodeFrame+import Network.HTTP2.Arch.File+import Network.HTTP2.Arch.HPACK+import Network.HTTP2.Arch.Manager hiding (start)+import Network.HTTP2.Arch.Queue+import Network.HTTP2.Arch.Stream+import Network.HTTP2.Arch.Types+import Network.HTTP2.Frame++----------------------------------------------------------------++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 (Output Stream)+ | Flush++frameSender :: Context -> Config -> Manager -> IO ()+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}+ 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 <- isEmptyTQueue outputQ+ if emp then+ if off /= 0 then return Flush else retry+ else+ O <$> readTQueue outputQ+ else+ C <$> readTQueue controlQ++ hardLimit = confBufferSize - 512++ 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 out -> do+ off' <- outputOrEnqueueAgain out off+ case off' of+ 0 -> loop 0+ _ | off' > hardLimit -> flushN off' >> loop 0+ | 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 OutObj{} (ONext curr tlrmkr) _ sentinel) off0 lim = do+ -- Data frame payload+ let payloadOff = off0 + frameHeaderLength+ datBuf = confWriteBuffer `plusPtr` payloadOff+ datBufSiz = confBufferSize - payloadOff+ Next datPayloadLen mnext <- curr datBuf datBufSiz lim -- checkme+ NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen+ fillDataHeaderEnqueueNext strm off0 datPayloadLen mnext tlrmkr' sentinel out++ output out@(Output strm (OutObj hdr body tlrmkr) OObj mtbq _) off0 lim = do+ -- Header frame and Continuation frame+ let sid = streamNumber strm+ endOfStream = case body of+ OutBodyNone -> True+ _ -> False+ (ths,_) <- toHeaderTable $ fixHeaders hdr+ kvlen <- headerContinue sid ths endOfStream off0+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen+ case body of+ OutBodyNone -> do+ -- halfClosedLocal calls closed which removes+ -- the stream from stream table.+ when (isServer ctx) $ halfClosedLocal ctx strm Finished+ return off+ OutBodyFile (FileSpec path fileoff bytecount) -> do+ (pread, sentinel') <- confPositionReadMaker path+ refresh <- case sentinel' of+ Closer closer -> timeoutClose mgr closer+ Refresher refresher -> return refresher+ let next = fillFileBodyGetNext pread fileoff bytecount refresh+ out' = out { outputType = ONext next tlrmkr }+ output out' off lim+ OutBodyBuilder builder -> do+ let next = fillBuilderBodyGetNext builder+ out' = out { outputType = ONext next tlrmkr }+ output out' off lim+ OutBodyStreaming _ -> do+ let tbq = fromJust mtbq+ takeQ = atomically $ tryReadTBQueue tbq+ next = fillStreamBodyGetNext takeQ+ out' = out { outputType = ONext next tlrmkr }+ output out' off lim++ 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=OObj} off lim++ output _ _ _ = undefined -- never reach++ outputOrEnqueueAgain :: Output Stream -> 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=OObj} 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+ when (isServer ctx) $ 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 -- checkme+ 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++ {-# INLINE ignore #-}+ ignore :: E.SomeException -> IO ()+ ignore _ = return ()++-- | Running trailers-maker.+--+-- > bufferIO buf siz $ \bs -> tlrmkr (Just bs)+runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker+runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs)++----------------------------------------------------------------++fillBuilderBodyGetNext :: Builder -> DynaNext+fillBuilderBodyGetNext bb buf siz lim = do+ let room = min siz lim+ (len, signal) <- B.runBuilder bb buf room+ return $ nextForBuilder len signal++fillFileBodyGetNext :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext+fillFileBodyGetNext pread start bytecount refresh buf siz lim = do+ let room = min siz lim+ len <- pread start (mini room bytecount) buf+ let len' = fromIntegral len+ return $ nextForFile len' pread (start + len) (bytecount - len) refresh++fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext+fillStreamBodyGetNext takeQ buf siz lim = do+ let room = min siz lim+ (leftover, cont, len) <- runStreamBuilder buf room takeQ+ return $ nextForStream takeQ leftover cont len++----------------------------------------------------------------++fillBufBuilder :: Leftover -> DynaNext+fillBufBuilder leftover buf0 siz0 lim = do+ let room = min siz0 lim+ case leftover of+ LZero -> error "fillBufBuilder: LZero"+ LOne writer -> do+ (len, signal) <- writer buf0 room+ getNext len signal+ LTwo bs writer+ | BS.length bs <= room -> do+ buf1 <- copy buf0 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 buf0 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 -> IO (Maybe StreamingChunk)+ -> IO (Leftover, Bool, BytesFilled)+runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0+ where+ loop buf room total = do+ mbuilder <- takeQ+ case mbuilder of+ Nothing -> return (LZero, True, total)+ Just (StreamingBuilder 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 StreamingFlush -> return (LZero, True, total)+ Just StreamingFinished -> return (LZero, False, total)++fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext+fillBufStream leftover0 takeQ buf0 siz0 lim0 = do+ let room0 = min siz0 lim0+ case leftover0 of+ LZero -> do+ (leftover, cont, len) <- runStreamBuilder buf0 room0 takeQ+ getNext leftover cont len+ LOne writer -> write writer buf0 room0 0+ LTwo bs writer+ | BS.length bs <= room0 -> do+ buf1 <- copy buf0 bs+ let len = BS.length bs+ write writer buf1 (room0 - len) len+ | otherwise -> do+ let (bs1,bs2) = BS.splitAt room0 bs+ void $ copy buf0 bs1+ getNext (LTwo bs2 writer) True room0+ where+ getNext l b r = return $ nextForStream takeQ 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) takeQ+ 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 :: IO (Maybe StreamingChunk)+ -> Leftover -> Bool -> BytesFilled+ -> Next+nextForStream _ _ False len = Next len Nothing+nextForStream takeQ leftOrZero True len =+ Next len $ Just (fillBufStream leftOrZero takeQ)++----------------------------------------------------------------++fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext+fillBufFile pread start bytes refresh buf siz lim = do+ let room = min siz lim+ len <- pread start (mini room bytes) buf+ refresh+ let len' = fromIntegral len+ return $ nextForFile len' pread (start + len) (bytes - len) refresh++nextForFile :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next+nextForFile 0 _ _ _ _ = Next 0 Nothing+nextForFile len _ _ 0 _ = Next len Nothing+nextForFile len pread start bytes refresh =+ Next len $ Just (fillBufFile pread start bytes refresh)++{-# INLINE mini #-}+mini :: Int -> Int64 -> Int64+mini i n+ | fromIntegral i < n = fromIntegral i+ | otherwise = n
+ Network/HTTP2/Arch/Status.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP2.Arch.Status (+ getStatus+ , setStatus+ ) where++import Data.ByteString.Internal (unsafeCreate)+import qualified Data.ByteString.Char8 as C8+import Foreign.Ptr (plusPtr)+import Foreign.Storable (poke)+import qualified Network.HTTP.Types as H++import Imports+import Network.HPACK+import Network.HPACK.Token++----------------------------------------------------------------++getStatus :: HeaderTable -> Maybe H.Status+getStatus (_,vt) = getHeaderValue tokenStatus vt >>= toStatus++setStatus :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders+setStatus st hdr = (":status", fromStatus st) : hdr++----------------------------------------------------------------++fromStatus :: H.Status -> ByteString+fromStatus 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 = H.statusCode status+ (q0,r0) = s `divMod` 10+ (q1,r1) = q0 `divMod` 10+ r2 = q1 `mod` 10++toStatus :: ByteString -> Maybe H.Status+toStatus bs = case C8.readInt bs of+ Nothing -> Nothing+ Just (code,_) -> Just $ H.mkStatus code "fixme"
+ Network/HTTP2/Arch/Stream.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE NamedFieldPuns #-}++module Network.HTTP2.Arch.Stream where++import Control.Concurrent+import Control.Concurrent.STM+import Data.IORef+import qualified Data.IntMap.Strict as M++import Imports+import Network.HTTP2.Arch.Types+import Network.HTTP2.Frame++----------------------------------------------------------------++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+ <*> newEmptyMVar++newPushStream :: StreamId -> WindowSize -> IO Stream+newPushStream sid win = Stream sid <$> newIORef Reserved+ <*> newTVarIO win+ <*> newEmptyMVar++----------------------------------------------------------------++{-# INLINE readStreamState #-}+readStreamState :: Stream -> IO StreamState+readStreamState Stream{streamState} = readIORef streamState++----------------------------------------------------------------++newStreamTable :: IO StreamTable+newStreamTable = StreamTable <$> newIORef M.empty++insert :: StreamTable -> M.Key -> Stream -> IO ()+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->+ let m' = M.insert k v m+ in (m', ())++remove :: StreamTable -> M.Key -> IO ()+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->+ let m' = M.delete k m+ in (m', ())++search :: StreamTable -> M.Key -> IO (Maybe Stream)+search (StreamTable ref) k = M.lookup k <$> readIORef ref++updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()+updateAllStreamWindow adst (StreamTable ref) = do+ strms <- M.elems <$> readIORef ref+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst
+ Network/HTTP2/Arch/Types.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP2.Arch.Types where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (SomeException)+import Data.ByteString.Builder (Builder)+import Data.IORef+import Data.IntMap.Strict (IntMap)+import qualified Network.HTTP.Types as H++import Imports+import Network.HPACK+import Network.HTTP2.Arch.File+import Network.HTTP2.Frame++----------------------------------------------------------------++-- | "http" or "https".+type Scheme = ByteString++-- | For so-called "Host:" header.+type Authority = ByteString++-- | Path.+type Path = ByteString++----------------------------------------------------------------++type InpBody = IO ByteString++data OutBody = OutBodyNone+ -- | Streaming body takes a write action and a flush action.+ | OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ())+ | OutBodyBuilder Builder+ | OutBodyFile FileSpec++-- | Input object+data InpObj = InpObj {+ inpObjHeaders :: HeaderTable -- ^ Accessor for headers.+ , inpObjBodySize :: Maybe Int -- ^ Accessor for body length specified in content-length:.+ , inpObjBody :: InpBody -- ^ Accessor for body.+ , inpObjTrailers :: IORef (Maybe HeaderTable) -- ^ Accessor for trailers.+ }++instance Show InpObj where+ show (InpObj (thl,_) _ _body _tref) = show thl++-- | Output object+data OutObj = OutObj {+ outObjHeaders :: [H.Header] -- ^ Accessor for header.+ , outObjBody :: OutBody -- ^ Accessor for outObj body.+ , outObjTrailers :: TrailersMaker -- ^ Accessor for trailers maker.+ }++instance Show OutObj where+ show (OutObj hdr _ _) = show hdr++-- | 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++-- | TrailersMake to create no trailers.+defaultTrailersMaker :: TrailersMaker+defaultTrailersMaker Nothing = return $ Trailers []+defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker++-- | Either the next trailers maker or final trailers.+data NextTrailersMaker = NextTrailersMaker TrailersMaker+ | Trailers [H.Header]++----------------------------------------------------------------++-- | File specification.+data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)++----------------------------------------------------------------++data OpenState =+ JustOpened+ | Continued [HeaderBlockFragment]+ Int -- Total size+ Int -- The number of continuation frames+ Bool -- End of stream+ | NoBody HeaderTable+ | HasBody HeaderTable+ | 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+ , streamInput :: MVar InpObj -- Client only+ }++instance Show Stream where+ show s = show (streamNumber s)++----------------------------------------------------------------++newtype StreamTable = StreamTable (IORef (IntMap Stream))++----------------------------------------------------------------++data Input a = Input a InpObj++data Output a = Output {+ outputStream :: a+ , outputObject :: OutObj+ , outputType :: OutputType+ , outputStrmQ :: Maybe (TBQueue StreamingChunk)+ , outputSentinel :: IO ()+ }++data OutputType = OObj+ | 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 StreamingChunk = StreamingFinished+ | StreamingFlush+ | StreamingBuilder Builder
+ Network/HTTP2/Client.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}++-- | HTTP\/2 client library.+--+-- Example:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > module Main where+-- >+-- > import qualified Control.Exception as E+-- > import Control.Concurrent (forkIO, threadDelay)+-- > import qualified Data.ByteString.Char8 as C8+-- > import Network.HTTP.Types+-- > import Network.Run.TCP (runTCPClient) -- network-run+-- >+-- > import Network.HTTP2.Client+-- >+-- > serverName :: String+-- > serverName = "127.0.0.1"+-- >+-- > main :: IO ()+-- > main = runTCPClient serverName "80" runHTTP2Client+-- > where+-- > cliconf = ClientConfig "http" (C8.pack serverName) 20+-- > runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)+-- > freeSimpleConfig+-- > (\conf -> run cliconf conf client)+-- > client sendRequest = do+-- > let req = requestNoBody methodGet "/" []+-- > _ <- forkIO $ sendRequest req $ \rsp -> do+-- > print rsp+-- > getResponseBodyChunk rsp >>= C8.putStrLn+-- > sendRequest req $ \rsp -> do+-- > threadDelay 100000+-- > print rsp+-- > getResponseBodyChunk rsp >>= C8.putStrLn++module Network.HTTP2.Client (+ -- * Runner+ run+ , Scheme+ , Authority+ -- * Runner arguments+ , ClientConfig(..)+ , Config(..)+ , allocSimpleConfig+ , freeSimpleConfig+ -- * HTTP\/2 client+ , Client+ -- * Request+ , Request+ -- * Creating request+ , requestNoBody+ , requestFile+ , requestStreaming+ , requestBuilder+ -- ** Trailers maker+ , TrailersMaker+ , NextTrailersMaker(..)+ , defaultTrailersMaker+ , setRequestTrailersMaker+ -- * Response+ , Response+ -- ** Accessing response+ , responseStatus+ , responseHeaders+ , responseBodySize+ , getResponseBodyChunk+ , getResponseTrailers+ -- * Types+ , Method+ , Path+ , FileSpec(..)+ , FileOffset+ , ByteCount+ -- * RecvN+ , defaultReadN+ -- * Position read for files+ , PositionReadMaker+ , PositionRead+ , Sentinel(..)+ , defaultPositionReadMaker+ ) where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.IORef (readIORef)+import Network.HTTP.Types++import Network.HPACK+import Network.HTTP2.Arch+import Network.HTTP2.Client.Types+import Network.HTTP2.Client.Run++----------------------------------------------------------------++-- | Creating request without body.+requestNoBody :: Method -> Path -> RequestHeaders -> Request+requestNoBody m p hdr = Request $ OutObj hdr' OutBodyNone defaultTrailersMaker+ where+ hdr' = addHeaders m p hdr++-- | Creating request with file.+requestFile :: Method -> Path -> RequestHeaders -> FileSpec -> Request+requestFile m p hdr fileSpec = Request $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker+ where+ hdr' = addHeaders m p hdr++-- | Creating request with builder.+requestBuilder :: Method -> Path -> RequestHeaders -> Builder -> Request+requestBuilder m p hdr builder = Request $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker+ where+ hdr' = addHeaders m p hdr++-- | Creating request with streaming.+requestStreaming :: Method -> Path -> RequestHeaders+ -> ((Builder -> IO ()) -> IO () -> IO ())+ -> Request+requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker+ where+ hdr' = addHeaders m p hdr+++addHeaders :: Method -> Path -> RequestHeaders -> RequestHeaders+addHeaders m p hdr = (":method", m) : (":path", p) : hdr++-- | Setting 'TrailersMaker' to 'Response'.+setRequestTrailersMaker :: Request -> TrailersMaker -> Request+setRequestTrailersMaker (Request req) tm = Request req { outObjTrailers = tm }++----------------------------------------------------------------++-- | Getting the status of a response.+responseStatus :: Response -> Maybe Status+responseStatus (Response rsp) = getStatus $ inpObjHeaders rsp++-- | Getting the headers from a response.+responseHeaders :: Response -> HeaderTable+responseHeaders (Response rsp) = inpObjHeaders rsp++-- | Getting the body size from a response.+responseBodySize :: Response -> Maybe Int+responseBodySize (Response rsp) = inpObjBodySize rsp++-- | Reading a chunk of the response body.+-- An empty 'ByteString' returned when finished.+getResponseBodyChunk :: Response -> IO ByteString+getResponseBodyChunk (Response rsp) = inpObjBody rsp++-- | Reading response trailers.+-- This function must be called after 'getResponseBodyChunk'+-- returns an empty.+getResponseTrailers :: Response -> IO (Maybe HeaderTable)+getResponseTrailers (Response rsp) = readIORef (inpObjTrailers rsp)
+ Network/HTTP2/Client/Internal.hs view
@@ -0,0 +1,6 @@+module Network.HTTP2.Client.Internal (+ Request(..)+ , Response(..)+ ) where++import Network.HTTP2.Client.Types
+ Network/HTTP2/Client/Run.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Client.Run where++import Control.Concurrent+import qualified Control.Exception as E+import Data.IORef (writeIORef)++import Network.HTTP2.Arch+import Network.HTTP2.Client.Types+import Network.HTTP2.Frame++-- | Client configuration+data ClientConfig = ClientConfig {+ scheme :: Scheme -- ^ https or http+ , authority :: Authority -- ^ Server name+ , cacheLimit :: Int -- ^ How many pushed responses are contained in the cache+ }++-- | Running HTTP/2 client.+run :: ClientConfig -> Config -> Client a -> IO a+run ClientConfig{..} conf@Config{..} client = do+ clientInfo <- newClientInfo scheme authority cacheLimit+ ctx <- newContext clientInfo+ mgr <- start confTimeoutManager+ tid0 <- forkIO $ frameReceiver ctx confReadN+ -- fixme: if frameSender is terminated but the main thread is alive,+ -- what will happen?+ tid1 <- forkIO $ frameSender ctx conf mgr+ exchangeSettings conf ctx+ client (sendRequest ctx scheme authority) `E.finally` do+ stop mgr+ killThread tid0+ killThread tid1++sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a+sendRequest ctx@Context{..} scheme auth (Request req) processResponse = do+ let hdr = outObjHeaders req+ Just method = lookup ":method" hdr+ Just path = lookup ":path" hdr+ mstrm0 <- lookupCache method path roleInfo+ strm <- case mstrm0 of+ Nothing -> do+ let hdr' = (":scheme", scheme)+ : (":authority", auth)+ : hdr+ req' = req { outObjHeaders = hdr' }+ sid <- getMyNewStreamId ctx+ newstrm <- openStream ctx sid FrameHeaders+ enqueueOutput outputQ $ Output newstrm req' OObj Nothing (return ())+ return newstrm+ Just strm0 -> return strm0+ rsp <- takeMVar $ streamInput strm+ processResponse $ Response rsp++exchangeSettings :: Config -> Context -> IO ()+exchangeSettings Config{..} Context{..} = do+ confSendAll connectionPreface+ let setframe = CSettings initialFrame [] -- fixme alist+ writeIORef firstSettings True+ enqueueControl controlQ setframe+
+ Network/HTTP2/Client/Types.hs view
@@ -0,0 +1,14 @@+module Network.HTTP2.Client.Types where++import Network.HTTP2.Arch++----------------------------------------------------------------++-- | Client type.+type Client a = (Request -> (Response -> IO a) -> IO a) -> IO a++-- | Request from client.+newtype Request = Request OutObj deriving (Show)++-- | Response from server.+newtype Response = Response InpObj deriving (Show)
− Network/HTTP2/Decode.hs
@@ -1,278 +0,0 @@-{-# LANGUAGE TupleSections, BangPatterns, RecordWildCards, OverloadedStrings #-}--module Network.HTTP2.Decode (- -- * Decoding- decodeFrame- , decodeFrameHeader- , checkFrameHeader- -- * Decoding payload- , decodeFramePayload- , FramePayloadDecoder- , decodeDataFrame- , decodeHeadersFrame- , decodePriorityFrame- , decoderstStreamFrame- , decodeSettingsFrame- , decodePushPromiseFrame- , decodePingFrame- , decodeGoAwayFrame- , decodeWindowUpdateFrame- , decodeContinuationFrame- ) where--import Data.Array (Array, listArray, (!))-import qualified Data.ByteString as BS-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---------------------------------------------------------------------- | Decoding an HTTP/2 frame to 'ByteString'.--- The second argument must be include the entire of frame.--- So, this function is not useful for real applications--- but useful for testing.-decodeFrame :: Settings -- ^ HTTP/2 settings- -> ByteString -- ^ Input byte-stream- -> Either HTTP2Error Frame -- ^ Decoded frame-decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0)- >>= \(typ,header) -> decodeFramePayload typ header bs1- >>= \payload -> return $ Frame header payload- where- (bs0,bs1) = BS.splitAt 9 bs---------------------------------------------------------------------- | Decoding an HTTP/2 frame header.--- Must supply 9 bytes.-decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)-decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do- let p = ptr +. off- len <- fromIntegral <$> N.peek24 p 0- typ <- toFrameTypeId <$> N.peek8 p 3- flg <- N.peek8 p 4- w32 <- N.peek32 p 5- let !sid = streamIdentifier w32- return (typ, FrameHeader len flg sid)--(+.) :: Ptr Word8 -> Int -> Ptr Word8-(+.) = plusPtr---------------------------------------------------------------------- | Checking a frame header and reporting an error if any.------ >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0))--- Left (ConnectionError ProtocolError "cannot used in control stream")-checkFrameHeader :: Settings- -> (FrameTypeId, FrameHeader)- -> Either HTTP2Error (FrameTypeId, FrameHeader)-checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..})- | payloadLength > maxFrameSize =- Left $ ConnectionError FrameSizeError "exceeds maximum frame size"- | typ `elem` nonZeroFrameTypes && isControl streamId =- Left $ ConnectionError ProtocolError "cannot used in control stream"- | typ `elem` zeroFrameTypes && not (isControl streamId) =- Left $ ConnectionError ProtocolError "cannot used in non-zero stream"- | otherwise = checkType typ- where- checkType FrameHeaders- | testPadded flags && payloadLength < 1 =- Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length"- | testPriority flags && payloadLength < 5 =- Left $ ConnectionError FrameSizeError "insufficient payload for priority fields"- | testPadded flags && testPriority flags && payloadLength < 6 =- Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length and priority fields"- checkType FramePriority | payloadLength /= 5 =- Left $ StreamError FrameSizeError streamId- checkType FrameRSTStream | payloadLength /= 4 =- Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame"- checkType FrameSettings- | payloadLength `mod` 6 /= 0 =- Left $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame"- | testAck flags && payloadLength /= 0 =- Left $ ConnectionError FrameSizeError "payload length must be 0 if ack flag is set"- checkType FramePushPromise- | not enablePush =- Left $ ConnectionError ProtocolError "push not enabled" -- checkme- | not (isResponse streamId) =- Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier"- checkType FramePing | payloadLength /= 8 =- Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame"- checkType FrameGoAway | payloadLength < 8 =- Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger"- checkType FrameWindowUpdate | payloadLength /= 4 =- Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame"- checkType _ = Right typfrm--zeroFrameTypes :: [FrameTypeId]-zeroFrameTypes = [- FrameSettings- , FramePing- , FrameGoAway- ]--nonZeroFrameTypes :: [FrameTypeId]-nonZeroFrameTypes = [- FrameData- , FrameHeaders- , FramePriority- , FrameRSTStream- , FramePushPromise- , FrameContinuation- ]---------------------------------------------------------------------- | The type for frame payload decoder.-type FramePayloadDecoder = FrameHeader -> ByteString- -> Either HTTP2Error FramePayload--payloadDecoders :: Array Word8 FramePayloadDecoder-payloadDecoders = listArray (minFrameType, maxFrameType)- [ decodeDataFrame- , decodeHeadersFrame- , decodePriorityFrame- , decoderstStreamFrame- , decodeSettingsFrame- , decodePushPromiseFrame- , decodePingFrame- , decodeGoAwayFrame- , decodeWindowUpdateFrame- , decodeContinuationFrame- ]---- | Decoding an HTTP/2 frame payload.--- This function is considered to return a frame payload decoder--- according to a frame type.-decodeFramePayload :: FrameTypeId -> FramePayloadDecoder-decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ-decodeFramePayload ftyp = checkFrameSize decoder- where- decoder = payloadDecoders ! fromFrameTypeId ftyp---------------------------------------------------------------------- | Frame payload decoder for DATA frame.-decodeDataFrame :: FramePayloadDecoder-decodeDataFrame header bs = decodeWithPadding header bs DataFrame---- | Frame payload decoder for HEADERS frame.-decodeHeadersFrame :: FramePayloadDecoder-decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' ->- if hasPriority then- let (bs0,bs1) = BS.splitAt 5 bs'- p = priority bs0- in HeadersFrame (Just p) bs1- else- HeadersFrame Nothing bs'- where- hasPriority = testPriority $ flags header---- | Frame payload decoder for PRIORITY frame.-decodePriorityFrame :: FramePayloadDecoder-decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs---- | Frame payload decoder for RST_STREAM frame.-decoderstStreamFrame :: FramePayloadDecoder-decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (N.word32 bs)---- | Frame payload decoder for SETTINGS frame.-decodeSettingsFrame :: FramePayloadDecoder-decodeSettingsFrame FrameHeader{..} (PS fptr off _) = Right $ SettingsFrame alist- where- num = payloadLength `div` 6- alist = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do- let p = ptr +. off- settings num p id- settings 0 _ builder = return $ builder []- settings n p builder = do- rawSetting <- N.peek16 p 0- let msettings = toSettingsKeyId rawSetting- n' = n - 1- case msettings of- Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2)- Just k -> do- w32 <- N.peek32 p 2- let v = fromIntegral w32- settings n' (p +. 6) (builder. ((k,v):))---- | Frame payload decoder for PUSH_PROMISE frame.-decodePushPromiseFrame :: FramePayloadDecoder-decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' ->- let (bs0,bs1) = BS.splitAt 4 bs'- sid = streamIdentifier (N.word32 bs0)- in PushPromiseFrame sid bs1---- | Frame payload decoder for PING frame.-decodePingFrame :: FramePayloadDecoder-decodePingFrame _ bs = Right $ PingFrame bs---- | Frame payload decoder for GOAWAY frame.-decodeGoAwayFrame :: FramePayloadDecoder-decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2- where- (bs0,bs1') = BS.splitAt 4 bs- (bs1,bs2) = BS.splitAt 4 bs1'- sid = streamIdentifier (N.word32 bs0)- ecid = toErrorCodeId (N.word32 bs1)---- | Frame payload decoder for WINDOW_UPDATE frame.-decodeWindowUpdateFrame :: FramePayloadDecoder-decodeWindowUpdateFrame _ bs- | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0"- | otherwise = Right $ WindowUpdateFrame wsi- where- !wsi = fromIntegral (N.word32 bs `clearBit` 31)---- | Frame payload decoder for CONTINUATION frame.-decodeContinuationFrame :: FramePayloadDecoder-decodeContinuationFrame _ bs = Right $ ContinuationFrame bs--decodeUnknownFrame :: FrameType -> FramePayloadDecoder-decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs--------------------------------------------------------------------checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder-checkFrameSize func header@FrameHeader{..} body- | payloadLength > BS.length body =- Left $ ConnectionError FrameSizeError "payload is too short"- | otherwise = func header body---- | Helper function to pull off the padding if its there, and will--- eat up the trailing padding automatically. Calls the decoder func--- passed in with the length of the unpadded portion between the--- padding octet and the actual padding-decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either HTTP2Error FramePayload-decodeWithPadding FrameHeader{..} bs body- | padded = let Just (w8,rest) = BS.uncons bs- padlen = intFromWord8 w8- bodylen = payloadLength - padlen - 1- in if bodylen < 0 then- Left $ ConnectionError ProtocolError "padding is not enough"- else- Right . body $ BS.take bodylen rest- | otherwise = Right $ body bs- where- padded = testPadded flags--streamIdentifier :: Word32 -> StreamId-streamIdentifier w32 = clearExclusive $ fromIntegral w32--priority :: ByteString -> Priority-priority (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do- let p = ptr +. off- w32 <- N.peek32 p 0- let !streamdId = streamIdentifier w32- !exclusive = testExclusive (fromIntegral w32) -- fixme- w8 <- N.peek8 p 4- let weight = intFromWord8 w8 + 1- return $ Priority exclusive streamdId weight--intFromWord8 :: Word8 -> Int-intFromWord8 = fromIntegral
− Network/HTTP2/Encode.hs
@@ -1,238 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Encode (- encodeFrame- , encodeFrameChunks- , encodeFrameHeader- , encodeFrameHeaderBuf- , encodeFramePayload- , EncodeInfo(..)- , encodeInfo- ) where--import qualified Data.ByteString as BS-import Data.ByteString.Internal (unsafeCreate)-import Foreign.Ptr (Ptr, plusPtr)-import qualified Network.ByteOrder as N--import Imports-import Network.HTTP2.Types--------------------------------------------------------------------type Builder = [ByteString] -> [ByteString]---- | Auxiliary information for frame encoding.-data EncodeInfo = EncodeInfo {- -- | Flags to be set in a frame header- encodeFlags :: !FrameFlags- -- | Stream id to be set in a frame header- , encodeStreamId :: !StreamId- -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set.- , encodePadding :: !(Maybe Padding)- } deriving (Show,Read)---------------------------------------------------------------------- | A smart builder of 'EncodeInfo'.------ >>> encodeInfo setAck 0--- EncodeInfo {encodeFlags = 1, encodeStreamId = 0, encodePadding = Nothing}-encodeInfo :: (FrameFlags -> FrameFlags)- -> Int -- ^ stream identifier- -> EncodeInfo-encodeInfo set sid = EncodeInfo (set defaultFlags) sid Nothing---------------------------------------------------------------------- | Encoding an HTTP/2 frame to 'ByteString'.--- This function is not efficient enough for high performace--- program because of the concatenation of 'ByteString'.------ >>> encodeFrame (encodeInfo id 1) (DataFrame "body")--- "\NUL\NUL\EOT\NUL\NUL\NUL\NUL\NUL\SOHbody"-encodeFrame :: EncodeInfo -> FramePayload -> ByteString-encodeFrame einfo payload = BS.concat $ encodeFrameChunks einfo payload---- | Encoding an HTTP/2 frame to ['ByteString'].--- This is suitable for sendMany.-encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString]-encodeFrameChunks einfo payload = bs : bss- where- ftid = framePayloadToFrameTypeId payload- bs = encodeFrameHeader ftid header- (header, bss) = encodeFramePayload einfo payload---- | Encoding an HTTP/2 frame header.--- The frame header must be completed.-encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString-encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr---- | Writing an encoded HTTP/2 frame header to the buffer.--- The length of the buffer must be larger than or equal to 9 bytes.-encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO ()-encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do- N.poke24 plen ptr 0- N.poke8 typ ptr 3- N.poke8 flags ptr 4- N.poke32 sid ptr 5- where- plen = fromIntegral payloadLength- typ = fromFrameTypeId ftid- sid = fromIntegral streamId---- | Encoding an HTTP/2 frame payload.--- This returns a complete frame header and chunks of payload.-encodeFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, [ByteString])-encodeFramePayload einfo payload = (header, builder [])- where- (header, builder) = buildFramePayload einfo payload--------------------------------------------------------------------buildFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, Builder)-buildFramePayload einfo (DataFrame body) =- buildFramePayloadData einfo body-buildFramePayload einfo (HeadersFrame mpri hdr) =- buildFramePayloadHeaders einfo mpri hdr-buildFramePayload einfo (PriorityFrame pri) =- buildFramePayloadPriority einfo pri-buildFramePayload einfo (RSTStreamFrame e) =- buildFramePayloadRSTStream einfo e-buildFramePayload einfo (SettingsFrame settings) =- buildFramePayloadSettings einfo settings-buildFramePayload einfo (PushPromiseFrame sid hdr) =- buildFramePayloadPushPromise einfo sid hdr-buildFramePayload einfo (PingFrame opaque) =- buildFramePayloadPing einfo opaque-buildFramePayload einfo (GoAwayFrame sid e debug) =- buildFramePayloadGoAway einfo sid e debug-buildFramePayload einfo (WindowUpdateFrame size) =- buildFramePayloadWindowUpdate einfo size-buildFramePayload einfo (ContinuationFrame hdr) =- buildFramePayloadContinuation einfo hdr-buildFramePayload einfo (UnknownFrame _ opaque) =- buildFramePayloadUnknown einfo opaque--------------------------------------------------------------------buildPadding :: EncodeInfo- -> Builder- -> Int -- ^ Payload length.- -> (FrameHeader, Builder)-buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len =- (header, builder)- where- header = FrameHeader len encodeFlags encodeStreamId-buildPadding EncodeInfo{ encodePadding = Just padding, ..} btarget targetLength =- (header, builder)- where- header = FrameHeader len newflags encodeStreamId- builder = (b1 :) . btarget . (padding :)- b1 = BS.singleton $ fromIntegral paddingLength- paddingLength = BS.length padding- len = targetLength + paddingLength + 1- newflags = setPadded encodeFlags--buildPriority :: Priority -> Builder-buildPriority Priority{..} = builder- where- builder = (priority :)- estream- | exclusive = setExclusive streamDependency- | otherwise = streamDependency- priority = unsafeCreate 5 $ \ptr -> do- let esid = fromIntegral estream- w = fromIntegral $ weight - 1- N.poke32 esid ptr 0- N.poke8 w ptr 4--------------------------------------------------------------------buildFramePayloadData :: EncodeInfo -> ByteString -> (FrameHeader, Builder)-buildFramePayloadData einfo body = buildPadding einfo builder len- where- builder = (body :)- len = BS.length body--buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment- -> (FrameHeader, Builder)-buildFramePayloadHeaders einfo Nothing hdr =- buildPadding einfo builder len- where- builder = (hdr :)- len = BS.length hdr-buildFramePayloadHeaders einfo (Just pri) hdr =- buildPadding einfo' builder len- where- builder = buildPriority pri . (hdr :)- len = BS.length hdr + 5- einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) }--buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder)-buildFramePayloadPriority EncodeInfo{..} p = (header, builder)- where- builder = buildPriority p- header = FrameHeader 5 encodeFlags encodeStreamId--buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder)-buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder)- where- builder = (b4 :)- b4 = N.bytestring32 $ fromErrorCodeId e- header = FrameHeader 4 encodeFlags encodeStreamId--buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder)-buildFramePayloadSettings EncodeInfo{..} alist = (header, builder)- where- builder = (settings :)- settings = unsafeCreate len $ \ptr -> go ptr alist- go _ [] = return ()- go p ((k,v):kvs) = do- N.poke16 (fromSettingsKeyId k) p 0- N.poke32 (fromIntegral v) p 2- go (p `plusPtr` 6) kvs- len = length alist * 6- header = FrameHeader len encodeFlags encodeStreamId--buildFramePayloadPushPromise :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder)-buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len- where- builder = (b4 :) . (hdr :)- b4 = N.bytestring32 $ fromIntegral sid- len = 4 + BS.length hdr--buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder)-buildFramePayloadPing EncodeInfo{..} odata = (header, builder)- where- builder = (odata :)- header = FrameHeader 8 encodeFlags encodeStreamId--buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)-buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder)- where- builder = (b8 :) . (debug :)- len0 = 8- b8 = unsafeCreate len0 $ \ptr -> do- N.poke32 (fromIntegral sid) ptr 0- N.poke32 (fromErrorCodeId e) ptr 4- len = len0 + BS.length debug- header = FrameHeader len encodeFlags encodeStreamId--buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSize -> (FrameHeader, Builder)-buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder)- where- -- fixme: reserve bit- builder = (b4 :)- b4 = N.bytestring32 $ fromIntegral size- header = FrameHeader 4 encodeFlags encodeStreamId--buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder)-buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder)- where- builder = (hdr :)- len = BS.length hdr- header = FrameHeader len encodeFlags encodeStreamId--buildFramePayloadUnknown :: EncodeInfo -> ByteString -> (FrameHeader, Builder)-buildFramePayloadUnknown = buildFramePayloadData
+ Network/HTTP2/Frame.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).+module Network.HTTP2.Frame (+ -- * Frame+ Frame(..)+ , FrameHeader(..)+ , FramePayload(..)+ , HeaderBlockFragment+ , Padding+ , isPaddingDefined+ -- * Encoding+ , encodeFrame+ , encodeFrameChunks+ , encodeFrameHeader+ , encodeFrameHeaderBuf+ , encodeFramePayload+ , EncodeInfo(..)+ , encodeInfo+ , module Network.HTTP2.Frame.Decode+ -- * Frame type ID+ , FrameTypeId(..)+ , framePayloadToFrameTypeId+ -- * Frame type+ , FrameType+ , fromFrameTypeId+ , toFrameTypeId+ -- * Priority+ , Priority(..)+ , Weight+ , defaultPriority+ , highestPriority+ , defaultWeight+ -- * Stream identifier+ , StreamId+ , isControl+ , isClientInitiated+ , isServerInitiated+ , isRequest+ , isResponse+ -- * Stream identifier related+ , testExclusive+ , setExclusive+ , clearExclusive+ -- * Flags+ , FrameFlags+ , defaultFlags+ , testEndStream+ , testAck+ , testEndHeader+ , testPadded+ , testPriority+ , setEndStream+ , setAck+ , setEndHeader+ , setPadded+ , setPriority+ -- * SettingsList+ , SettingsList+ , SettingsKeyId(..)+ , SettingsValue+ , fromSettingsKeyId+ , toSettingsKeyId+ , checkSettingsList+ -- * Settings+ , Settings(..)+ , defaultSettings+ , updateSettings+ -- * Window+ , WindowSize+ , defaultInitialWindowSize+ , maxWindowSize+ , isWindowOverflow+ -- * Error code+ , ErrorCode+ , ErrorCodeId(..)+ , fromErrorCodeId+ , toErrorCodeId+ -- * Error+ , HTTP2Error(..)+ , errorCodeId+ -- * Predefined values+ , connectionPreface+ , connectionPrefaceLength+ , frameHeaderLength+ , maxPayloadLength+ , recommendedConcurrency+ ) where++import qualified Data.ByteString as BS++import Imports+import Network.HTTP2.Frame.Decode+import Network.HTTP2.Frame.Encode+import Network.HTTP2.Frame.Types++-- | The preface of HTTP\/2.+--+-- >>> connectionPreface+-- "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"+connectionPreface :: ByteString+connectionPreface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"++-- | Length of the preface.+--+-- >>> connectionPrefaceLength+-- 24+connectionPrefaceLength :: Int+connectionPrefaceLength = BS.length connectionPreface
+ Network/HTTP2/Frame/Decode.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP2.Frame.Decode (+ -- * Decoding+ decodeFrame+ , decodeFrameHeader+ , checkFrameHeader+ -- * Decoding payload+ , decodeFramePayload+ , FramePayloadDecoder+ , decodeDataFrame+ , decodeHeadersFrame+ , decodePriorityFrame+ , decoderstStreamFrame+ , decodeSettingsFrame+ , decodePushPromiseFrame+ , decodePingFrame+ , decodeGoAwayFrame+ , decodeWindowUpdateFrame+ , decodeContinuationFrame+ ) where++import Data.Array (Array, listArray, (!))+import qualified Data.ByteString as BS+import Foreign.Ptr (Ptr, plusPtr)+import qualified Network.ByteOrder as N+import System.IO.Unsafe (unsafeDupablePerformIO)++import Imports+import Network.HTTP2.Frame.Types++----------------------------------------------------------------++-- | Decoding an HTTP/2 frame to 'ByteString'.+-- The second argument must be include the entire of frame.+-- So, this function is not useful for real applications+-- but useful for testing.+decodeFrame :: Settings -- ^ HTTP/2 settings+ -> ByteString -- ^ Input byte-stream+ -> Either HTTP2Error Frame -- ^ Decoded frame+decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0)+ >>= \(typ,header) -> decodeFramePayload typ header bs1+ >>= \payload -> return $ Frame header payload+ where+ (bs0,bs1) = BS.splitAt 9 bs++----------------------------------------------------------------++-- | Decoding an HTTP/2 frame header.+-- Must supply 9 bytes.+decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)+decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ len <- fromIntegral <$> N.peek24 p 0+ typ <- toFrameTypeId <$> N.peek8 p 3+ flg <- N.peek8 p 4+ w32 <- N.peek32 p 5+ let sid = streamIdentifier w32+ return (typ, FrameHeader len flg sid)++(+.) :: Ptr Word8 -> Int -> Ptr Word8+(+.) = plusPtr++----------------------------------------------------------------++-- | Checking a frame header and reporting an error if any.+--+-- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0))+-- Left (ConnectionError ProtocolError "cannot used in control stream")+checkFrameHeader :: Settings+ -> (FrameTypeId, FrameHeader)+ -> Either HTTP2Error (FrameTypeId, FrameHeader)+checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..})+ | payloadLength > maxFrameSize =+ Left $ ConnectionError FrameSizeError "exceeds maximum frame size"+ | typ `elem` nonZeroFrameTypes && isControl streamId =+ Left $ ConnectionError ProtocolError "cannot used in control stream"+ | typ `elem` zeroFrameTypes && not (isControl streamId) =+ Left $ ConnectionError ProtocolError "cannot used in non-zero stream"+ | otherwise = checkType typ+ where+ checkType FrameHeaders+ | testPadded flags && payloadLength < 1 =+ Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length"+ | testPriority flags && payloadLength < 5 =+ Left $ ConnectionError FrameSizeError "insufficient payload for priority fields"+ | testPadded flags && testPriority flags && payloadLength < 6 =+ Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length and priority fields"+ checkType FramePriority | payloadLength /= 5 =+ Left $ StreamError FrameSizeError streamId+ checkType FrameRSTStream | payloadLength /= 4 =+ Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame"+ checkType FrameSettings+ | payloadLength `mod` 6 /= 0 =+ Left $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame"+ | testAck flags && payloadLength /= 0 =+ Left $ ConnectionError FrameSizeError "payload length must be 0 if ack flag is set"+ checkType FramePushPromise+ | not enablePush =+ Left $ ConnectionError ProtocolError "push not enabled" -- checkme+ | isClientInitiated streamId =+ Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier"+ checkType FramePing | payloadLength /= 8 =+ Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame"+ checkType FrameGoAway | payloadLength < 8 =+ Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger"+ checkType FrameWindowUpdate | payloadLength /= 4 =+ Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame"+ checkType _ = Right typfrm++zeroFrameTypes :: [FrameTypeId]+zeroFrameTypes = [+ FrameSettings+ , FramePing+ , FrameGoAway+ ]++nonZeroFrameTypes :: [FrameTypeId]+nonZeroFrameTypes = [+ FrameData+ , FrameHeaders+ , FramePriority+ , FrameRSTStream+ , FramePushPromise+ , FrameContinuation+ ]++----------------------------------------------------------------++-- | The type for frame payload decoder.+type FramePayloadDecoder = FrameHeader -> ByteString+ -> Either HTTP2Error FramePayload++payloadDecoders :: Array Word8 FramePayloadDecoder+payloadDecoders = listArray (minFrameType, maxFrameType)+ [ decodeDataFrame+ , decodeHeadersFrame+ , decodePriorityFrame+ , decoderstStreamFrame+ , decodeSettingsFrame+ , decodePushPromiseFrame+ , decodePingFrame+ , decodeGoAwayFrame+ , decodeWindowUpdateFrame+ , decodeContinuationFrame+ ]++-- | Decoding an HTTP/2 frame payload.+-- This function is considered to return a frame payload decoder+-- according to a frame type.+decodeFramePayload :: FrameTypeId -> FramePayloadDecoder+decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ+decodeFramePayload ftyp = checkFrameSize decoder+ where+ decoder = payloadDecoders ! fromFrameTypeId ftyp++----------------------------------------------------------------++-- | Frame payload decoder for DATA frame.+decodeDataFrame :: FramePayloadDecoder+decodeDataFrame header bs = decodeWithPadding header bs DataFrame++-- | Frame payload decoder for HEADERS frame.+decodeHeadersFrame :: FramePayloadDecoder+decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' ->+ if hasPriority then+ let (bs0,bs1) = BS.splitAt 5 bs'+ p = priority bs0+ in HeadersFrame (Just p) bs1+ else+ HeadersFrame Nothing bs'+ where+ hasPriority = testPriority $ flags header++-- | Frame payload decoder for PRIORITY frame.+decodePriorityFrame :: FramePayloadDecoder+decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs++-- | Frame payload decoder for RST_STREAM frame.+decoderstStreamFrame :: FramePayloadDecoder+decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (N.word32 bs)++-- | Frame payload decoder for SETTINGS frame.+decodeSettingsFrame :: FramePayloadDecoder+decodeSettingsFrame FrameHeader{..} (PS fptr off _)+ | num > 10 = Left $ ConnectionError EnhanceYourCalm "Settings is too large"+ | otherwise = Right $ SettingsFrame alist+ where+ num = payloadLength `div` 6+ alist = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ settings num p id+ settings 0 _ builder = return $ builder []+ settings n p builder = do+ rawSetting <- N.peek16 p 0+ let msettings = toSettingsKeyId rawSetting+ n' = n - 1+ case msettings of+ Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2)+ Just k -> do+ w32 <- N.peek32 p 2+ let v = fromIntegral w32+ settings n' (p +. 6) (builder. ((k,v):))++-- | Frame payload decoder for PUSH_PROMISE frame.+decodePushPromiseFrame :: FramePayloadDecoder+decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' ->+ let (bs0,bs1) = BS.splitAt 4 bs'+ sid = streamIdentifier (N.word32 bs0)+ in PushPromiseFrame sid bs1++-- | Frame payload decoder for PING frame.+decodePingFrame :: FramePayloadDecoder+decodePingFrame _ bs = Right $ PingFrame bs++-- | Frame payload decoder for GOAWAY frame.+decodeGoAwayFrame :: FramePayloadDecoder+decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2+ where+ (bs0,bs1') = BS.splitAt 4 bs+ (bs1,bs2) = BS.splitAt 4 bs1'+ sid = streamIdentifier (N.word32 bs0)+ ecid = toErrorCodeId (N.word32 bs1)++-- | Frame payload decoder for WINDOW_UPDATE frame.+decodeWindowUpdateFrame :: FramePayloadDecoder+decodeWindowUpdateFrame _ bs+ | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0"+ | otherwise = Right $ WindowUpdateFrame wsi+ where+ wsi = fromIntegral (N.word32 bs `clearBit` 31)++-- | Frame payload decoder for CONTINUATION frame.+decodeContinuationFrame :: FramePayloadDecoder+decodeContinuationFrame _ bs = Right $ ContinuationFrame bs++decodeUnknownFrame :: FrameType -> FramePayloadDecoder+decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs++----------------------------------------------------------------++checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder+checkFrameSize func header@FrameHeader{..} body+ | payloadLength > BS.length body =+ Left $ ConnectionError FrameSizeError "payload is too short"+ | otherwise = func header body++-- | Helper function to pull off the padding if its there, and will+-- eat up the trailing padding automatically. Calls the decoder func+-- passed in with the length of the unpadded portion between the+-- padding octet and the actual padding+decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either HTTP2Error FramePayload+decodeWithPadding FrameHeader{..} bs body+ | padded = let Just (w8,rest) = BS.uncons bs+ padlen = intFromWord8 w8+ bodylen = payloadLength - padlen - 1+ in if bodylen < 0 then+ Left $ ConnectionError ProtocolError "padding is not enough"+ else+ Right . body $ BS.take bodylen rest+ | otherwise = Right $ body bs+ where+ padded = testPadded flags++streamIdentifier :: Word32 -> StreamId+streamIdentifier w32 = clearExclusive $ fromIntegral w32++priority :: ByteString -> Priority+priority (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ w32 <- N.peek32 p 0+ let streamdId = streamIdentifier w32+ exclusive = testExclusive (fromIntegral w32) -- fixme+ w8 <- N.peek8 p 4+ let weight = intFromWord8 w8 + 1+ return $ Priority exclusive streamdId weight++intFromWord8 :: Word8 -> Int+intFromWord8 = fromIntegral
+ Network/HTTP2/Frame/Encode.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Frame.Encode (+ encodeFrame+ , encodeFrameChunks+ , encodeFrameHeader+ , encodeFrameHeaderBuf+ , encodeFramePayload+ , EncodeInfo(..)+ , encodeInfo+ ) where++import qualified Data.ByteString as BS+import Data.ByteString.Internal (unsafeCreate)+import Foreign.Ptr (Ptr, plusPtr)+import qualified Network.ByteOrder as N++import Imports+import Network.HTTP2.Frame.Types++----------------------------------------------------------------++type Builder = [ByteString] -> [ByteString]++-- | Auxiliary information for frame encoding.+data EncodeInfo = EncodeInfo {+ -- | Flags to be set in a frame header+ encodeFlags :: FrameFlags+ -- | Stream id to be set in a frame header+ , encodeStreamId :: StreamId+ -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set.+ , encodePadding :: Maybe Padding+ } deriving (Show,Read)++----------------------------------------------------------------++-- | A smart builder of 'EncodeInfo'.+--+-- >>> encodeInfo setAck 0+-- EncodeInfo {encodeFlags = 1, encodeStreamId = 0, encodePadding = Nothing}+encodeInfo :: (FrameFlags -> FrameFlags)+ -> Int -- ^ stream identifier+ -> EncodeInfo+encodeInfo set sid = EncodeInfo (set defaultFlags) sid Nothing++----------------------------------------------------------------++-- | Encoding an HTTP/2 frame to 'ByteString'.+-- This function is not efficient enough for high performace+-- program because of the concatenation of 'ByteString'.+--+-- >>> encodeFrame (encodeInfo id 1) (DataFrame "body")+-- "\NUL\NUL\EOT\NUL\NUL\NUL\NUL\NUL\SOHbody"+encodeFrame :: EncodeInfo -> FramePayload -> ByteString+encodeFrame einfo payload = BS.concat $ encodeFrameChunks einfo payload++-- | Encoding an HTTP/2 frame to ['ByteString'].+-- This is suitable for sendMany.+encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString]+encodeFrameChunks einfo payload = bs : bss+ where+ ftid = framePayloadToFrameTypeId payload+ bs = encodeFrameHeader ftid header+ (header, bss) = encodeFramePayload einfo payload++-- | Encoding an HTTP/2 frame header.+-- The frame header must be completed.+encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString+encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr++-- | Writing an encoded HTTP/2 frame header to the buffer.+-- The length of the buffer must be larger than or equal to 9 bytes.+encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO ()+encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do+ N.poke24 plen ptr 0+ N.poke8 typ ptr 3+ N.poke8 flags ptr 4+ N.poke32 sid ptr 5+ where+ plen = fromIntegral payloadLength+ typ = fromFrameTypeId ftid+ sid = fromIntegral streamId++-- | Encoding an HTTP/2 frame payload.+-- This returns a complete frame header and chunks of payload.+encodeFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, [ByteString])+encodeFramePayload einfo payload = (header, builder [])+ where+ (header, builder) = buildFramePayload einfo payload++----------------------------------------------------------------++buildFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, Builder)+buildFramePayload einfo (DataFrame body) =+ buildFramePayloadData einfo body+buildFramePayload einfo (HeadersFrame mpri hdr) =+ buildFramePayloadHeaders einfo mpri hdr+buildFramePayload einfo (PriorityFrame pri) =+ buildFramePayloadPriority einfo pri+buildFramePayload einfo (RSTStreamFrame e) =+ buildFramePayloadRSTStream einfo e+buildFramePayload einfo (SettingsFrame settings) =+ buildFramePayloadSettings einfo settings+buildFramePayload einfo (PushPromiseFrame sid hdr) =+ buildFramePayloadPushPromise einfo sid hdr+buildFramePayload einfo (PingFrame opaque) =+ buildFramePayloadPing einfo opaque+buildFramePayload einfo (GoAwayFrame sid e debug) =+ buildFramePayloadGoAway einfo sid e debug+buildFramePayload einfo (WindowUpdateFrame size) =+ buildFramePayloadWindowUpdate einfo size+buildFramePayload einfo (ContinuationFrame hdr) =+ buildFramePayloadContinuation einfo hdr+buildFramePayload einfo (UnknownFrame _ opaque) =+ buildFramePayloadUnknown einfo opaque++----------------------------------------------------------------++buildPadding :: EncodeInfo+ -> Builder+ -> Int -- ^ Payload length.+ -> (FrameHeader, Builder)+buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len =+ (header, builder)+ where+ header = FrameHeader len encodeFlags encodeStreamId+buildPadding EncodeInfo{ encodePadding = Just padding, ..} btarget targetLength =+ (header, builder)+ where+ header = FrameHeader len newflags encodeStreamId+ builder = (b1 :) . btarget . (padding :)+ b1 = BS.singleton $ fromIntegral paddingLength+ paddingLength = BS.length padding+ len = targetLength + paddingLength + 1+ newflags = setPadded encodeFlags++buildPriority :: Priority -> Builder+buildPriority Priority{..} = builder+ where+ builder = (priority :)+ estream+ | exclusive = setExclusive streamDependency+ | otherwise = streamDependency+ priority = unsafeCreate 5 $ \ptr -> do+ let esid = fromIntegral estream+ w = fromIntegral $ weight - 1+ N.poke32 esid ptr 0+ N.poke8 w ptr 4++----------------------------------------------------------------++buildFramePayloadData :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadData einfo body = buildPadding einfo builder len+ where+ builder = (body :)+ len = BS.length body++buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment+ -> (FrameHeader, Builder)+buildFramePayloadHeaders einfo Nothing hdr =+ buildPadding einfo builder len+ where+ builder = (hdr :)+ len = BS.length hdr+buildFramePayloadHeaders einfo (Just pri) hdr =+ buildPadding einfo' builder len+ where+ builder = buildPriority pri . (hdr :)+ len = BS.length hdr + 5+ einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) }++buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder)+buildFramePayloadPriority EncodeInfo{..} p = (header, builder)+ where+ builder = buildPriority p+ header = FrameHeader 5 encodeFlags encodeStreamId++buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder)+buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder)+ where+ builder = (b4 :)+ b4 = N.bytestring32 $ fromErrorCodeId e+ header = FrameHeader 4 encodeFlags encodeStreamId++buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder)+buildFramePayloadSettings EncodeInfo{..} alist = (header, builder)+ where+ builder = (settings :)+ settings = unsafeCreate len $ \ptr -> go ptr alist+ go _ [] = return ()+ go p ((k,v):kvs) = do+ N.poke16 (fromSettingsKeyId k) p 0+ N.poke32 (fromIntegral v) p 2+ go (p `plusPtr` 6) kvs+ len = length alist * 6+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadPushPromise :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len+ where+ builder = (b4 :) . (hdr :)+ b4 = N.bytestring32 $ fromIntegral sid+ len = 4 + BS.length hdr++buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadPing EncodeInfo{..} odata = (header, builder)+ where+ builder = (odata :)+ header = FrameHeader 8 encodeFlags encodeStreamId++buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)+buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder)+ where+ builder = (b8 :) . (debug :)+ len0 = 8+ b8 = unsafeCreate len0 $ \ptr -> do+ N.poke32 (fromIntegral sid) ptr 0+ N.poke32 (fromErrorCodeId e) ptr 4+ len = len0 + BS.length debug+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSize -> (FrameHeader, Builder)+buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder)+ where+ -- fixme: reserve bit+ builder = (b4 :)+ b4 = N.bytestring32 $ fromIntegral size+ header = FrameHeader 4 encodeFlags encodeStreamId++buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder)+ where+ builder = (hdr :)+ len = BS.length hdr+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadUnknown :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadUnknown = buildFramePayloadData
+ Network/HTTP2/Frame/Types.hs view
@@ -0,0 +1,660 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP2.Frame.Types (+ -- * Constant+ frameHeaderLength+ , maxPayloadLength+ -- * SettingsList+ , SettingsKeyId(..)+ , checkSettingsList+ , fromSettingsKeyId+ , SettingsValue+ , SettingsList+ , toSettingsKeyId+ -- * Settings+ , Settings(..)+ , defaultSettings+ , updateSettings+ -- * Error+ , HTTP2Error(..)+ , errorCodeId+ -- * Error code+ , ErrorCode+ , ErrorCodeId(..)+ , fromErrorCodeId+ , toErrorCodeId+ -- * Frame type+ , FrameType+ , minFrameType+ , maxFrameType+ , FrameTypeId(..)+ , fromFrameTypeId+ , toFrameTypeId+ -- * Frame+ , Frame(..)+ , FrameHeader(..)+ , FramePayload(..)+ , framePayloadToFrameTypeId+ , isPaddingDefined+ -- * Stream identifier+ , StreamId+ , isControl+ , isClientInitiated+ , isServerInitiated+ , isRequest+ , isResponse+ , testExclusive+ , setExclusive+ , clearExclusive+ -- * Flags+ , FrameFlags+ , defaultFlags+ , testEndStream+ , testAck+ , testEndHeader+ , testPadded+ , testPriority+ , setEndStream+ , setAck+ , setEndHeader+ , setPadded+ , setPriority+ -- * Window+ , WindowSize+ , defaultInitialWindowSize+ , maxWindowSize+ , isWindowOverflow+ -- * Misc+ , recommendedConcurrency+ -- * Types+ , HeaderBlockFragment+ , Weight+ , defaultWeight+ , Priority(..)+ , defaultPriority+ , highestPriority+ , Padding+ ) where++import qualified Control.Exception as E+import Data.Typeable++import Imports++----------------------------------------------------------------++-- | The length of HTTP/2 frame header.+--+-- >>> frameHeaderLength+-- 9+frameHeaderLength :: Int+frameHeaderLength = 9++----------------------------------------------------------------++-- | The type for raw error code.+type ErrorCode = Word32++-- | The type for error code. See <https://tools.ietf.org/html/rfc7540#section-7>.+data ErrorCodeId = NoError+ | ProtocolError+ | InternalError+ | FlowControlError+ | SettingsTimeout+ | StreamClosed+ | FrameSizeError+ | RefusedStream+ | Cancel+ | CompressionError+ | ConnectError+ | EnhanceYourCalm+ | InadequateSecurity+ | HTTP11Required+ -- our extensions+ | UnknownErrorCode ErrorCode+ deriving (Show, Read, Eq, Ord)++-- | Converting 'ErrorCodeId' to 'ErrorCode'.+--+-- >>> fromErrorCodeId NoError+-- 0+-- >>> fromErrorCodeId InadequateSecurity+-- 12+fromErrorCodeId :: ErrorCodeId -> ErrorCode+fromErrorCodeId NoError = 0x0+fromErrorCodeId ProtocolError = 0x1+fromErrorCodeId InternalError = 0x2+fromErrorCodeId FlowControlError = 0x3+fromErrorCodeId SettingsTimeout = 0x4+fromErrorCodeId StreamClosed = 0x5+fromErrorCodeId FrameSizeError = 0x6+fromErrorCodeId RefusedStream = 0x7+fromErrorCodeId Cancel = 0x8+fromErrorCodeId CompressionError = 0x9+fromErrorCodeId ConnectError = 0xa+fromErrorCodeId EnhanceYourCalm = 0xb+fromErrorCodeId InadequateSecurity = 0xc+fromErrorCodeId HTTP11Required = 0xd+fromErrorCodeId (UnknownErrorCode w) = w++-- | Converting 'ErrorCode' to 'ErrorCodeId'.+--+-- >>> toErrorCodeId 0+-- NoError+-- >>> toErrorCodeId 0xc+-- InadequateSecurity+-- >>> toErrorCodeId 0xe+-- UnknownErrorCode 14+toErrorCodeId :: ErrorCode -> ErrorCodeId+toErrorCodeId 0x0 = NoError+toErrorCodeId 0x1 = ProtocolError+toErrorCodeId 0x2 = InternalError+toErrorCodeId 0x3 = FlowControlError+toErrorCodeId 0x4 = SettingsTimeout+toErrorCodeId 0x5 = StreamClosed+toErrorCodeId 0x6 = FrameSizeError+toErrorCodeId 0x7 = RefusedStream+toErrorCodeId 0x8 = Cancel+toErrorCodeId 0x9 = CompressionError+toErrorCodeId 0xa = ConnectError+toErrorCodeId 0xb = EnhanceYourCalm+toErrorCodeId 0xc = InadequateSecurity+toErrorCodeId 0xd = HTTP11Required+toErrorCodeId w = UnknownErrorCode w++----------------------------------------------------------------++-- | The connection error or the stream error.+data HTTP2Error = ConnectionError ErrorCodeId ByteString+ | StreamError ErrorCodeId StreamId+ deriving (Eq, Show, Typeable, Read)++instance E.Exception HTTP2Error++-- | Obtaining 'ErrorCodeId' from 'HTTP2Error'.+errorCodeId :: HTTP2Error -> ErrorCodeId+errorCodeId (ConnectionError err _) = err+errorCodeId (StreamError err _) = err++----------------------------------------------------------------++-- | The type for SETTINGS key.+data SettingsKeyId = SettingsHeaderTableSize+ | SettingsEnablePush+ | SettingsMaxConcurrentStreams+ | SettingsInitialWindowSize+ | SettingsMaxFrameSize -- this means payload size+ | SettingsMaxHeaderBlockSize+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++-- | The type for raw SETTINGS value.+type SettingsValue = Int -- Word32++-- | Converting 'SettingsKeyId' to raw value.+--+-- >>> fromSettingsKeyId SettingsHeaderTableSize+-- 1+-- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize+-- 6+fromSettingsKeyId :: SettingsKeyId -> Word16+fromSettingsKeyId x = fromIntegral (fromEnum x) + 1++minSettingsKeyId :: Word16+minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId)++maxSettingsKeyId :: Word16+maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId)++-- | Converting raw value to 'SettingsKeyId'.+--+-- >>> toSettingsKeyId 0+-- Nothing+-- >>> toSettingsKeyId 1+-- Just SettingsHeaderTableSize+-- >>> toSettingsKeyId 6+-- Just SettingsMaxHeaderBlockSize+-- >>> toSettingsKeyId 7+-- Nothing+toSettingsKeyId :: Word16 -> Maybe SettingsKeyId+toSettingsKeyId x+ | minSettingsKeyId <= n && n <= maxSettingsKeyId = Just . toEnum . fromIntegral $ n+ | otherwise = Nothing+ where+ n = x - 1++----------------------------------------------------------------++-- | Association list of SETTINGS.+type SettingsList = [(SettingsKeyId,SettingsValue)]++-- | Checking 'SettingsList' and reporting an error if any.+--+-- >>> checkSettingsList [(SettingsEnablePush,2)]+-- Just (ConnectionError ProtocolError "enable push must be 0 or 1")+checkSettingsList :: SettingsList -> Maybe HTTP2Error+checkSettingsList settings = case mapMaybe checkSettingsValue settings of+ [] -> Nothing+ (x:_) -> Just x++checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error+checkSettingsValue (SettingsEnablePush,v)+ | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1"+checkSettingsValue (SettingsInitialWindowSize,v)+ | v > 2147483647 = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535"+checkSettingsValue (SettingsMaxFrameSize,v)+ | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215"+checkSettingsValue _ = Nothing++----------------------------------------------------------------++-- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context.+data Settings = Settings {+ headerTableSize :: Int+ , enablePush :: Bool+ , maxConcurrentStreams :: Maybe Int+ , initialWindowSize :: WindowSize+ , maxFrameSize :: Int+ , maxHeaderBlockSize :: Maybe Int+ } deriving (Show)++-- | The default settings.+--+-- >>> defaultSettings+-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Nothing}+defaultSettings :: Settings+defaultSettings = Settings {+ headerTableSize = 4096+ , enablePush = True+ , maxConcurrentStreams = Nothing+ , initialWindowSize = defaultInitialWindowSize+ , maxFrameSize = 16384+ , maxHeaderBlockSize = Nothing+ }++-- | Updating settings.+--+-- >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)]+-- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200}+updateSettings :: Settings -> SettingsList -> Settings+updateSettings settings kvs = foldl' update settings kvs+ where+ update def (SettingsHeaderTableSize,x) = def { headerTableSize = x }+ -- fixme: x should be 0 or 1+ update def (SettingsEnablePush,x) = def { enablePush = x > 0 }+ update def (SettingsMaxConcurrentStreams,x) = def { maxConcurrentStreams = Just x }+ update def (SettingsInitialWindowSize,x) = def { initialWindowSize = x }+ update def (SettingsMaxFrameSize,x) = def { maxFrameSize = x }+ update def (SettingsMaxHeaderBlockSize,x) = def { maxHeaderBlockSize = Just x }++-- | The type for window size.+type WindowSize = Int++-- | The default initial window size.+--+-- >>> defaultInitialWindowSize+-- 65535+defaultInitialWindowSize :: WindowSize+defaultInitialWindowSize = 65535++-- | The maximum window size.+--+-- >>> maxWindowSize+-- 2147483647+maxWindowSize :: WindowSize+maxWindowSize = 2147483647++-- | Checking if a window size exceeds the maximum window size.+--+-- >>> isWindowOverflow 10+-- False+-- >>> isWindowOverflow maxWindowSize+-- False+-- >>> isWindowOverflow (maxWindowSize + 1)+-- True+isWindowOverflow :: WindowSize -> Bool+isWindowOverflow w = testBit w 31+++-- | Default concurrency.+--+-- >>> recommendedConcurrency+-- 100+recommendedConcurrency :: Int+recommendedConcurrency = 100++----------------------------------------------------------------++-- | The type for weight in priority. Its values are from 1 to 256.+type Weight = Int++-- | Default weight.+--+-- >>> defaultWeight+-- 16+defaultWeight :: Weight+defaultWeight = 16+{-# DEPRECATED defaultWeight "Don't use this" #-}++-- | Type for stream priority+data Priority = Priority {+ exclusive :: Bool+ , streamDependency :: StreamId+ , weight :: Weight+ } deriving (Show, Read, Eq)++-- | Default priority which depends on stream 0.+--+-- >>> defaultPriority+-- Priority {exclusive = False, streamDependency = 0, weight = 16}+defaultPriority :: Priority+defaultPriority = Priority False 0 defaultWeight++-- | Highest priority which depends on stream 0.+--+-- >>> highestPriority+-- Priority {exclusive = False, streamDependency = 0, weight = 256}+highestPriority :: Priority+highestPriority = Priority False 0 256++----------------------------------------------------------------++-- | The type for raw frame type.+type FrameType = Word8++minFrameType :: FrameType+minFrameType = 0++maxFrameType :: FrameType+maxFrameType = 9++-- | The type for frame type.+data FrameTypeId = FrameData+ | FrameHeaders+ | FramePriority+ | FrameRSTStream+ | FrameSettings+ | FramePushPromise+ | FramePing+ | FrameGoAway+ | FrameWindowUpdate+ | FrameContinuation+ | FrameUnknown FrameType+ deriving (Show, Eq, Ord)++-- | Converting 'FrameTypeId' to 'FrameType'.+--+-- >>> fromFrameTypeId FrameData+-- 0+-- >>> fromFrameTypeId FrameContinuation+-- 9+-- >>> fromFrameTypeId (FrameUnknown 10)+-- 10+fromFrameTypeId :: FrameTypeId -> FrameType+fromFrameTypeId FrameData = 0+fromFrameTypeId FrameHeaders = 1+fromFrameTypeId FramePriority = 2+fromFrameTypeId FrameRSTStream = 3+fromFrameTypeId FrameSettings = 4+fromFrameTypeId FramePushPromise = 5+fromFrameTypeId FramePing = 6+fromFrameTypeId FrameGoAway = 7+fromFrameTypeId FrameWindowUpdate = 8+fromFrameTypeId FrameContinuation = 9+fromFrameTypeId (FrameUnknown x) = x++-- | Converting 'FrameType' to 'FrameTypeId'.+--+-- >>> toFrameTypeId 0+-- FrameData+-- >>> toFrameTypeId 9+-- FrameContinuation+-- >>> toFrameTypeId 10+-- FrameUnknown 10+toFrameTypeId :: FrameType -> FrameTypeId+toFrameTypeId 0 = FrameData+toFrameTypeId 1 = FrameHeaders+toFrameTypeId 2 = FramePriority+toFrameTypeId 3 = FrameRSTStream+toFrameTypeId 4 = FrameSettings+toFrameTypeId 5 = FramePushPromise+toFrameTypeId 6 = FramePing+toFrameTypeId 7 = FrameGoAway+toFrameTypeId 8 = FrameWindowUpdate+toFrameTypeId 9 = FrameContinuation+toFrameTypeId x = FrameUnknown x++----------------------------------------------------------------++-- | The maximum length of HTTP/2 payload.+--+-- >>> maxPayloadLength+-- 16384+maxPayloadLength :: Int+maxPayloadLength = 2^(14::Int)++----------------------------------------------------------------+-- Flags++-- | The type for flags.+type FrameFlags = Word8++-- | The initial value of flags. No flags are set.+--+-- >>> defaultFlags+-- 0+defaultFlags :: FrameFlags+defaultFlags = 0++-- | Checking if the END_STREAM flag is set.+-- >>> testEndStream 0x1+-- True+testEndStream :: FrameFlags -> Bool+testEndStream x = x `testBit` 0++-- | Checking if the ACK flag is set.+-- >>> testAck 0x1+-- True+testAck :: FrameFlags -> Bool+testAck x = x `testBit` 0 -- fixme: is the spec intentional?++-- | Checking if the END_HEADERS flag is set.+--+-- >>> testEndHeader 0x4+-- True+testEndHeader :: FrameFlags -> Bool+testEndHeader x = x `testBit` 2++-- | Checking if the PADDED flag is set.+--+-- >>> testPadded 0x8+-- True+testPadded :: FrameFlags -> Bool+testPadded x = x `testBit` 3++-- | Checking if the PRIORITY flag is set.+--+-- >>> testPriority 0x20+-- True+testPriority :: FrameFlags -> Bool+testPriority x = x `testBit` 5++-- | Setting the END_STREAM flag.+--+-- >>> setEndStream 0+-- 1+setEndStream :: FrameFlags -> FrameFlags+setEndStream x = x `setBit` 0++-- | Setting the ACK flag.+--+-- >>> setAck 0+-- 1+setAck :: FrameFlags -> FrameFlags+setAck x = x `setBit` 0 -- fixme: is the spec intentional?++-- | Setting the END_HEADERS flag.+--+-- >>> setEndHeader 0+-- 4+setEndHeader :: FrameFlags -> FrameFlags+setEndHeader x = x `setBit` 2++-- | Setting the PADDED flag.+--+-- >>> setPadded 0+-- 8+setPadded :: FrameFlags -> FrameFlags+setPadded x = x `setBit` 3++-- | Setting the PRIORITY flag.+--+-- >>> setPriority 0+-- 32+setPriority :: FrameFlags -> FrameFlags+setPriority x = x `setBit` 5++----------------------------------------------------------------++-- | The type for stream identifier+type StreamId = Int++-- | Checking if the stream identifier for control.+--+-- >>> isControl 0+-- True+-- >>> isControl 1+-- False+isControl :: StreamId -> Bool+isControl 0 = True+isControl _ = False++-- | Checking if the stream identifier is from a client.+--+-- >>> isClientInitiated 0+-- False+-- >>> isClientInitiated 1+-- True+isClientInitiated :: StreamId -> Bool+isClientInitiated = odd++-- | Checking if the stream identifier is from a server.+--+-- >>> isServerInitiated 0+-- False+-- >>> isServerInitiated 2+-- True+isServerInitiated :: StreamId -> Bool+isServerInitiated 0 = False+isServerInitiated n = even n++-- | Checking if the stream identifier for request.+--+-- >>> isRequest 0+-- False+-- >>> isRequest 1+-- True+isRequest :: StreamId -> Bool+isRequest = odd+{-# DEPRECATED isRequest "Use isClientInitiated instead" #-}++-- | Checking if the stream identifier for response.+--+-- >>> isResponse 0+-- False+-- >>> isResponse 2+-- True+isResponse :: StreamId -> Bool+isResponse 0 = False+isResponse n = even n+{-# DEPRECATED isResponse "Use isServerInitiated instead" #-}++-- | Checking if the exclusive flag is set.+testExclusive :: StreamId -> Bool+testExclusive n = n `testBit` 31++-- | Setting the exclusive flag.+setExclusive :: StreamId -> StreamId+setExclusive n = n `setBit` 31++-- | Clearing the exclusive flag.+clearExclusive :: StreamId -> StreamId+clearExclusive n = n `clearBit` 31++----------------------------------------------------------------++-- | The type for fragments of a header encoded with HPACK.+type HeaderBlockFragment = ByteString++-- | The type for padding in payloads.+type Padding = ByteString++----------------------------------------------------------------++-- | The data type for HTTP/2 frames.+data Frame = Frame+ { frameHeader :: FrameHeader+ , framePayload :: FramePayload+ } deriving (Show, Read, Eq)++-- | The data type for HTTP/2 frame headers.+data FrameHeader = FrameHeader+ { payloadLength :: Int+ , flags :: FrameFlags+ , streamId :: StreamId+ } deriving (Show, Read, Eq)++-- | The data type for HTTP/2 frame payloads.+data FramePayload =+ DataFrame ByteString+ | HeadersFrame (Maybe Priority) HeaderBlockFragment+ | PriorityFrame Priority+ | RSTStreamFrame ErrorCodeId+ | SettingsFrame SettingsList+ | PushPromiseFrame StreamId HeaderBlockFragment+ | PingFrame ByteString+ | GoAwayFrame StreamId ErrorCodeId ByteString+ | WindowUpdateFrame WindowSize+ | ContinuationFrame HeaderBlockFragment+ | UnknownFrame FrameType ByteString+ deriving (Show, Read, Eq)++----------------------------------------------------------------++-- | Getting 'FrameType' from 'FramePayload'.+--+-- >>> framePayloadToFrameTypeId (DataFrame "body")+-- FrameData+framePayloadToFrameTypeId :: FramePayload -> FrameTypeId+framePayloadToFrameTypeId DataFrame{} = FrameData+framePayloadToFrameTypeId HeadersFrame{} = FrameHeaders+framePayloadToFrameTypeId PriorityFrame{} = FramePriority+framePayloadToFrameTypeId RSTStreamFrame{} = FrameRSTStream+framePayloadToFrameTypeId SettingsFrame{} = FrameSettings+framePayloadToFrameTypeId PushPromiseFrame{} = FramePushPromise+framePayloadToFrameTypeId PingFrame{} = FramePing+framePayloadToFrameTypeId GoAwayFrame{} = FrameGoAway+framePayloadToFrameTypeId WindowUpdateFrame{} = FrameWindowUpdate+framePayloadToFrameTypeId ContinuationFrame{} = FrameContinuation+framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8++----------------------------------------------------------------++-- | Checking if padding is defined in this frame type.+--+-- >>> isPaddingDefined $ DataFrame ""+-- True+-- >>> isPaddingDefined $ PingFrame ""+-- False+isPaddingDefined :: FramePayload -> Bool+isPaddingDefined DataFrame{} = True+isPaddingDefined HeadersFrame{} = True+isPaddingDefined PriorityFrame{} = False+isPaddingDefined RSTStreamFrame{} = False+isPaddingDefined SettingsFrame{} = False+isPaddingDefined PushPromiseFrame{} = True+isPaddingDefined PingFrame{} = False+isPaddingDefined GoAwayFrame{} = False+isPaddingDefined WindowUpdateFrame{} = False+isPaddingDefined ContinuationFrame{} = False+isPaddingDefined UnknownFrame{} = False
+ Network/HTTP2/Internal.hs view
@@ -0,0 +1,31 @@+module Network.HTTP2.Internal (+ -- * File+ module Network.HTTP2.Arch.File+ -- * Types+ , Scheme+ , Authority+ , Path+ -- * Request and response+ , InpObj(..)+ , InpBody+ , OutObj(..)+ , OutBody(..)+ , FileSpec(..)+ -- * Sender+ , Next(..)+ , BytesFilled+ , DynaNext+ , StreamingChunk(..)+ , fillBuilderBodyGetNext+ , fillFileBodyGetNext+ , fillStreamBodyGetNext+ -- * Trailer+ , TrailersMaker+ , defaultTrailersMaker+ , NextTrailersMaker(..)+ , runTrailersMaker+ ) where++import Network.HTTP2.Arch.File+import Network.HTTP2.Arch.Types+import Network.HTTP2.Arch.Sender
Network/HTTP2/Priority.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- | This is partial implementation of the priority of HTTP/2. -- -- This implementation does support structured priority queue@@ -13,7 +11,7 @@ -- -- Only one entry per stream should be enqueued. -module Network.HTTP2.Priority (+module Network.HTTP2.Priority {-# DEPRECATED "Should be replaced with extensible priority" #-} ( -- * Precedence Precedence , defaultPrecedence@@ -38,13 +36,13 @@ import Imports hiding (delete, empty) import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence) import qualified Network.HTTP2.Priority.Queue as Q-import Network.HTTP2.Types+import Network.HTTP2.Frame.Types ---------------------------------------------------------------- -- | Abstract data type for priority trees.-data PriorityTree a = PriorityTree !(TVar (Glue a))- !(TNestedPriorityQueue a)+data PriorityTree a = PriorityTree (TVar (Glue a))+ (TNestedPriorityQueue a) type Glue a = IntMap (TNestedPriorityQueue a, Precedence) @@ -52,8 +50,8 @@ -- another TNestedPriorityQueue. type TNestedPriorityQueue a = TPriorityQueue (Element a) -data Element a = Child !a- | Parent !(TNestedPriorityQueue a)+data Element a = Child a+ | Parent (TNestedPriorityQueue a) ----------------------------------------------------------------@@ -90,7 +88,7 @@ enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO () enqueue (PriorityTree var q0) sid p0 x = atomically $ do m <- readTVar var- let !el = Child x+ let el = Child x loop m el p0 where loop m el p@@ -102,7 +100,7 @@ notQueued <- Q.isEmpty q' Q.enqueue q' sid p el when notQueued $ do- let !el' = Parent q'+ let el' = Parent q' loop m el' p' where pid = Q.dependency p@@ -127,7 +125,7 @@ loop q = do (sid,p,el) <- Q.dequeue q case el of- Child x -> return $! (sid, p, x)+ Child x -> return (sid, p, x) Parent q' -> do entr <- loop q' empty <- Q.isEmpty q'
+ Network/HTTP2/Priority/Internal.hs view
@@ -0,0 +1,5 @@+module Network.HTTP2.Priority.Internal (+ module Network.HTTP2.Priority.PSQ+ ) where++import Network.HTTP2.Priority.PSQ
Network/HTTP2/Priority/PSQ.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Priority.PSQ ( Key+ , Weight+ , Deficit , Precedence(..) , newPrecedence , PriorityQueue(..)+ , Heap , empty , isEmpty , enqueue@@ -27,10 +29,10 @@ -- The precedence of a dequeued entry should be specified -- to enqueue when the entry is enqueued again. data Precedence = Precedence {- deficit :: {-# UNPACK #-} !Deficit- , weight :: {-# UNPACK #-} !Weight+ deficit :: Deficit+ , weight :: Weight -- stream dependency, used by the upper layer- , dependency :: {-# UNPACK #-} !Key+ , dependency :: Key } deriving Show -- | For test only@@ -48,8 +50,8 @@ type Heap a = IntPSQ Precedence a data PriorityQueue a = PriorityQueue {- baseDeficit :: {-# UNPACK #-} !Deficit- , queue :: !(Heap a)+ baseDeficit :: Deficit+ , queue :: Heap a } ----------------------------------------------------------------@@ -84,16 +86,16 @@ enqueue k p@Precedence{..} v PriorityQueue{..} = PriorityQueue baseDeficit queue' where- !d = weightToDeficit weight- !b = if deficit == 0 then baseDeficit else deficit- !deficit' = max (b + d) baseDeficit- !p' = p { deficit = deficit' }- !queue' = P.insert k p' v queue+ d = weightToDeficit weight+ b = if deficit == 0 then baseDeficit else deficit+ deficit' = max (b + d) baseDeficit+ p' = p { deficit = deficit' }+ queue' = P.insert k p' v queue dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a) dequeue PriorityQueue{..} = case P.minView queue of Nothing -> Nothing- Just (k, p, v, queue') -> let !base = deficit p+ Just (k, p, v, queue') -> let base = deficit p in Just (k, p, v, PriorityQueue base queue') delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)
Network/HTTP2/Server.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} -- | HTTP\/2 server library. --@@ -8,51 +7,24 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main (main) where -- >--- > import Control.Concurrent (forkFinally)--- > import Control.Exception (SomeException(..)) -- > import qualified Control.Exception as E--- > import Control.Monad (forever, void) -- > import Data.ByteString.Builder (byteString) -- > import Network.HTTP.Types (ok200)+-- > import Network.Run.TCP (runTCPServer) -- network-run+-- > -- > import Network.HTTP2.Server--- > import Network.Socket -- > -- > main :: IO ()--- > main = runTCPServer "80" $ \s _peer -> runHTTP2Server s+-- > main = runTCPServer Nothing "80" $ \s _peer -> runHTTP2Server s -- > where -- > runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)--- > (\config -> run config server) -- > freeSimpleConfig+-- > (\config -> run config server) -- > server _req _aux sendResponse = sendResponse response [] -- > where -- > response = responseBuilder ok200 header body -- > header = [("Content-Type", "text/plain")] -- > body = byteString "Hello, world!\n"--- >--- > runTCPServer :: String -> (Socket -> SockAddr -> IO a) -> IO a--- > runTCPServer port server = withSocketsDo $ do--- > addr <- resolve--- > E.bracket (open addr) close loop--- > where--- > resolve = do--- > let hints = defaultHints {--- > addrFlags = [AI_PASSIVE]--- > , addrSocketType = Stream--- > }--- > head <$> getAddrInfo (Just hints) Nothing (Just port)--- > open addr = do--- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)--- > setSocketOption sock ReuseAddr 1--- > withFdSocket sock $ setCloseOnExecIfNeeded--- > bind sock $ addrAddress addr--- > listen sock 1024--- > return sock--- > loop sock = forever $ do--- > (conn, peer) <- accept sock--- > void $ forkFinally (server conn peer) (clear conn)--- > clear conn _ = shutdown conn ShutdownSend `E.catch` ignore--- > where--- > ignore (SomeException _) = return () module Network.HTTP2.Server ( -- * Runner@@ -61,11 +33,15 @@ , Config(..) , allocSimpleConfig , freeSimpleConfig- , makeSimpleConfig- -- * HTTP/2 server+ -- * HTTP\/2 server , Server -- * Request , Request+ -- ** Accessing request+ , requestMethod+ , requestPath+ , requestAuthority+ , requestScheme , requestHeaders , requestBodySize , getRequestBodyChunk@@ -81,7 +57,6 @@ , responseStreaming , responseBuilder -- ** Accessing response- , responseStatus , responseBodySize -- ** Trailers maker , TrailersMaker@@ -94,7 +69,11 @@ , promiseRequestPath , promiseResponse , promiseWeight+ , defaultWeight -- * Types+ , Path+ , Authority+ , Scheme , FileSpec(..) , FileOffset , ByteCount@@ -107,63 +86,105 @@ , defaultPositionReadMaker ) where -import Data.IORef (readIORef) import Data.ByteString.Builder (Builder)+import Data.IORef (readIORef) import qualified Network.HTTP.Types as H import Imports import Network.HPACK-import Network.HTTP2.Server.API-import Network.HTTP2.Server.Config-import Network.HTTP2.Server.File (defaultPositionReadMaker)-import Network.HTTP2.Server.ReadN (defaultReadN)+import Network.HPACK.Token+import Network.HTTP2.Arch+import Network.HTTP2.Frame.Types import Network.HTTP2.Server.Run (run)-import Network.HTTP2.Types+import Network.HTTP2.Server.Types ---------------------------------------------------------------- +-- | Getting the method from a request.+requestMethod :: Request -> Maybe H.Method+requestMethod (Request req) = getHeaderValue tokenMethod vt+ where+ (_,vt) = inpObjHeaders req++-- | Getting the path from a request.+requestPath :: Request -> Maybe Path+requestPath (Request req) = getHeaderValue tokenPath vt+ where+ (_,vt) = inpObjHeaders req++-- | Getting the authority from a request.+requestAuthority :: Request -> Maybe Authority+requestAuthority (Request req) = getHeaderValue tokenAuthority vt+ where+ (_,vt) = inpObjHeaders req++-- | Getting the scheme from a request.+requestScheme :: Request -> Maybe Scheme+requestScheme (Request req) = getHeaderValue tokenScheme vt+ where+ (_,vt) = inpObjHeaders req++-- | Getting the headers from a request.+requestHeaders :: Request -> HeaderTable+requestHeaders (Request req) = inpObjHeaders req++-- | Getting the body size from a request.+requestBodySize :: Request -> Maybe Int+requestBodySize (Request req) = inpObjBodySize req+ -- | Reading a chunk of the request body. -- An empty 'ByteString' returned when finished. getRequestBodyChunk :: Request -> IO ByteString-getRequestBodyChunk = requestBody+getRequestBodyChunk (Request req) = inpObjBody req -- | Reading request trailers. -- This function must be called after 'getRequestBodyChunk' -- returns an empty. getRequestTrailers :: Request -> IO (Maybe HeaderTable)-getRequestTrailers = readIORef . requestTrailers_+getRequestTrailers (Request req) = readIORef (inpObjTrailers req) --- |Creating response without body.+----------------------------------------------------------------++-- | Creating response without body. responseNoBody :: H.Status -> H.ResponseHeaders -> Response-responseNoBody st hdr = Response st hdr RspNoBody defaultTrailersMaker+responseNoBody st hdr = Response $ OutObj hdr' OutBodyNone defaultTrailersMaker+ where+ hdr' = setStatus st hdr --- |Creating response with file.+-- | Creating response with file. responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response-responseFile st hdr fileSpec = Response st hdr (RspFile fileSpec) defaultTrailersMaker+responseFile st hdr fileSpec = Response $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker+ where+ hdr' = setStatus st hdr --- |Creating response with builder.+-- | 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.+responseBuilder st hdr builder = Response $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker+ where+ hdr' = setStatus st hdr++-- | Creating response with streaming. responseStreaming :: H.Status -> H.ResponseHeaders -> ((Builder -> IO ()) -> IO () -> IO ()) -> Response-responseStreaming st hdr strmbdy = Response st hdr (RspStreaming strmbdy) defaultTrailersMaker+responseStreaming st hdr strmbdy = Response $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker+ where+ hdr' = setStatus st hdr +----------------------------------------------------------------+ -- | 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+responseBodySize (Response (OutObj _ (OutBodyFile (FileSpec _ _ len)) _)) = Just (fromIntegral len)+responseBodySize _ = Nothing -- | Setting 'TrailersMaker' to 'Response'. setResponseTrailersMaker :: Response -> TrailersMaker -> Response-setResponseTrailersMaker rsp tm = rsp { responseTrailers = tm }+setResponseTrailersMaker (Response rsp) tm = Response rsp { outObjTrailers = tm } --- | TrailersMake to create no trailers.-defaultTrailersMaker :: TrailersMaker-defaultTrailersMaker Nothing = return $ Trailers []-defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker+---------------------------------------------------------------- -- | Creating push promise.+-- The third argument is traditional, not used. pushPromise :: ByteString -> Response -> Weight -> PushPromise pushPromise path rsp w = PushPromise path rsp w
− Network/HTTP2/Server/API.hs
@@ -1,131 +0,0 @@-module Network.HTTP2.Server.API where--import Data.ByteString.Builder (Builder)-import Data.IORef (IORef)-import qualified Network.HTTP.Types as H-import qualified System.TimeManager as T--import Imports-import Network.HPACK-import Network.HTTP2---- | HTTP/2 server configuration.-data Config = Config {- confWriteBuffer :: Buffer- , confBufferSize :: BufferSize- , confSendAll :: ByteString -> IO ()- , confReadN :: Int -> IO ByteString- , confPositionReadMaker :: PositionReadMaker- }---------------------------------------------------------------------- | HTTP\/2 server takes a HTTP request, should--- generate a HTTP response and push promises, then--- should give them to the sending function.--- The sending function would throw exceptions so that--- they can be logged.-type Server = Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()---- | HTTP request.-data Request = Request {- requestHeaders :: HeaderTable -- ^ Accessor for request headers.- , requestBodySize :: Maybe Int -- ^ Accessor for body length specified in content-length:.- , requestBody :: IO ByteString -- ^ Accessor for body.- , requestTrailers_ :: IORef (Maybe HeaderTable)- }---- | Additional information.-data Aux = Aux {- -- | Time handle for the worker processing this request and response.- auxTimeHandle :: T.Handle- }---- | HTTP response.-data Response = Response {- responseStatus :: H.Status -- ^ Accessor for response status.- , responseHeaders :: H.ResponseHeaders -- ^ Accessor for response header.- , responseBody :: ResponseBody -- ^ Accessor for response body.- , responseTrailers :: TrailersMaker -- ^ Accessor for response trailers maker.- }---- | HTTP response body.-data ResponseBody = RspNoBody- -- | Streaming body takes a write action and a flush action.- | RspStreaming ((Builder -> IO ()) -> IO () -> IO ())- | RspBuilder Builder- | RspFile FileSpec---- | Trailers maker. A chunks of the response body is passed--- with 'Just'. The maker should update internal state--- with the 'ByteString' and return the next trailers maker.--- When response body reaches its end,--- 'Nothing' is passed and the maker should generate--- trailers. An example:------ > {-# LANGUAGE BangPatterns #-}--- > import Data.ByteString (ByteString)--- > import qualified Data.ByteString.Char8 as C8--- > import Crypto.Hash (Context, SHA1) -- cryptonite--- > import qualified Crypto.Hash as CH--- >--- > -- Strictness is important for Context.--- > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker--- > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]--- > where--- > !sha1 = C8.pack $ show $ CH.hashFinalize ctx--- > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'--- > where--- > !ctx' = CH.hashUpdate ctx bs------ Usage example:------ > let h2rsp = responseFile ...--- > maker = trailersMaker (CH.hashInit :: Context SHA1)--- > h2rsp' = setResponseTrailersMaker h2rsp maker----type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker---- | Either the next trailers maker or final trailers.-data NextTrailersMaker = NextTrailersMaker !TrailersMaker- | Trailers H.ResponseHeaders---- | HTTP/2 push promise or sever push.--- Pseudo REQUEST headers in push promise is automatically generated.--- Then, a server push is sent according to 'promiseResponse'.-data PushPromise = PushPromise {- -- | Accessor for a URL path in a push promise (a virtual request from a server).- -- E.g. \"\/style\/default.css\".- promiseRequestPath :: ByteString- -- | Accessor for response actually pushed from a server.- , promiseResponse :: Response- -- | Accessor for response weight.- , promiseWeight :: Weight- }---------------------------------------------------------------------- | File specification.-data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)---- | Offset for file.-type FileOffset = Int64--- | How many bytes to read-type ByteCount = Int64---------------------------------------------------------------------- | Position read for files.-type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount---- | Manipulating a file resource.-data Sentinel =- -- | Closing a file resource. Its refresher is automatiaclly generated by- -- the internal timer.- Closer (IO ())- -- | Refreshing a file resource while reading.- -- Closing the file must be done by its own timer or something.- | Refresher (IO ())---- | Making a position read and its closer.-type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel)
− Network/HTTP2/Server/Config.hs
@@ -1,39 +0,0 @@-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--{-# DEPRECATED makeSimpleConfig "Use allocSimpleConfig instead" #-}--- | 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- config <- allocSimpleConfig s bufsiz- return (config, freeSimpleConfig config)---- | Making simple configuration whose IO is not efficient.--- A write buffer is allocated internally.-allocSimpleConfig :: Socket -> BufferSize -> IO Config-allocSimpleConfig 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---- | Deallocating the resource of the simple configuration.-freeSimpleConfig :: Config -> IO ()-freeSimpleConfig conf = free $ confWriteBuffer conf
− Network/HTTP2/Server/Context.hs
@@ -1,113 +0,0 @@-{-# 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 = do- clearDynamicTable $ encodeDynamicTable ctx- clearDynamicTable $ decodeDynamicTable ctx--------------------------------------------------------------------newPushStream :: Context -> WindowSize -> Precedence -> IO Stream-newPushStream Context{serverStreamId} win pre = do- sid <- atomicModifyIORef' serverStreamId inc2- Stream sid <$> newIORef Reserved- <*> newTVarIO win- <*> newIORef pre- where- inc2 x = let !x' = x + 2 in (x', x')--------------------------------------------------------------------{-# INLINE setStreamState #-}-setStreamState :: Context -> Stream -> StreamState -> IO ()-setStreamState _ Stream{streamState} val = writeIORef streamState val--opened :: Context -> Stream -> IO ()-opened ctx@Context{concurrency} strm = do- atomicModifyIORef' concurrency (\x -> (x+1,()))- setStreamState ctx strm (Open JustOpened)--halfClosedRemote :: Context -> Stream -> IO ()-halfClosedRemote ctx stream@Stream{streamState} = do- !closingCode <- atomicModifyIORef streamState closeHalf- traverse_ (closed ctx stream) closingCode- where- closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)- closeHalf x@(Closed _) = (x, Nothing)- closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)- closeHalf _ = (HalfClosedRemote, Nothing)--halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()-halfClosedLocal ctx stream@Stream{streamState} cc = do- shouldFinalize <- atomicModifyIORef streamState closeHalf- when shouldFinalize $- closed ctx stream cc- where- closeHalf :: StreamState -> (StreamState, Bool)- closeHalf x@(Closed _) = (x, False)- closeHalf HalfClosedRemote = (Closed cc, True)- closeHalf _ = (HalfClosedLocal cc, False)--closed :: Context -> Stream -> ClosedCode -> IO ()-closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do- remove streamTable streamNumber- -- TODO: prevent double-counting- atomicModifyIORef' concurrency (\x -> (x-1,()))- setStreamState ctx strm (Closed cc) -- anyway
− Network/HTTP2/Server/EncodeFrame.hs
@@ -1,34 +0,0 @@-module Network.HTTP2.Server.EncodeFrame where--import Network.HTTP2--import Imports--------------------------------------------------------------------goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString-goawayFrame sid etype debugmsg = encodeFrame einfo frame- where- einfo = encodeInfo id 0- frame = GoAwayFrame sid etype debugmsg--resetFrame :: ErrorCodeId -> StreamId -> ByteString-resetFrame etype sid = encodeFrame einfo frame- where- einfo = encodeInfo id sid- frame = RSTStreamFrame etype--settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString-settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist- where- einfo = encodeInfo func 0--pingFrame :: ByteString -> ByteString-pingFrame bs = encodeFrame einfo $ PingFrame bs- where- einfo = encodeInfo setAck 0--windowUpdateFrame :: StreamId -> WindowSize -> ByteString-windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz- where- einfo = encodeInfo id sid
− Network/HTTP2/Server/File.hs
@@ -1,16 +0,0 @@-module Network.HTTP2.Server.File where--import System.IO--import Network.HTTP2.Server.API---- | Position read based on 'Handle'.-defaultPositionReadMaker :: PositionReadMaker-defaultPositionReadMaker file = do- hdl <- openBinaryFile file ReadMode- return (pread hdl, Closer $ hClose hdl)- where- pread :: Handle -> PositionRead- pread hdl off bytes buf = do- hSeek hdl AbsoluteSeek $ fromIntegral off- fromIntegral <$> (hGetBufSome hdl buf $ fromIntegral bytes)
− Network/HTTP2/Server/HPACK.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Server.HPACK (- hpackEncodeHeader- , hpackEncodeHeaderLoop- , hpackDecodeHeader- , hpackDecodeTrailer- , just- , fixHeaders- ) where--import qualified Control.Exception as E-import Data.ByteString.Internal (unsafeCreate)-import Foreign.Ptr (plusPtr)-import Foreign.Storable (poke)-import Network.ByteOrder-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2-import Network.HTTP2.Server.Context---- $setup--- >>> :set -XOverloadedStrings--------------------------------------------------------------------fixHeaders :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders-fixHeaders st hdr = (":status", packStatus st) : deleteUnnecessaryHeaders hdr--packStatus :: H.Status -> ByteString-packStatus status = unsafeCreate 3 $ \p -> do- poke p (toW8 r2)- poke (p `plusPtr` 1) (toW8 r1)- poke (p `plusPtr` 2) (toW8 r0)- where- toW8 :: Int -> Word8- toW8 n = 48 + fromIntegral n- !s = fromIntegral $ H.statusCode status- (!q0,!r0) = s `divMod` 10- (!q1,!r1) = q0 `divMod` 10- !r2 = q1 `mod` 10--deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders-deleteUnnecessaryHeaders hdr = filter del hdr- where- del (k,_) = k `notElem` headersToBeRemoved--headersToBeRemoved :: [H.HeaderName]-headersToBeRemoved = [ H.hConnection- , "Transfer-Encoding"- -- Keep-Alive- -- Proxy-Connection- -- Upgrade- ]--------------------------------------------------------------------strategy :: EncodeStrategy-strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }---- Set-Cookie: contains only one cookie value.--- So, we don't need to split it.-hpackEncodeHeader :: Context -> Buffer -> BufferSize- -> TokenHeaderList- -> IO (TokenHeaderList, Int)-hpackEncodeHeader Context{..} buf siz ths =- encodeTokenHeader buf siz strategy True encodeDynamicTable ths--hpackEncodeHeaderLoop :: Context -> Buffer -> BufferSize- -> TokenHeaderList- -> IO (TokenHeaderList, Int)-hpackEncodeHeaderLoop Context{..} buf siz hs =- encodeTokenHeader buf siz strategy False encodeDynamicTable hs--------------------------------------------------------------------hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeHeader hdrblk ctx = do- tbl@(_,vt) <- hpackDecodeTrailer hdrblk ctx- if checkRequestHeader vt then- return tbl- else- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"--hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeTrailer hdrblk Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl- where- handl IllegalHeaderName =- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"- handl _ =- E.throwIO $ ConnectionError CompressionError "cannot decompress the header"--{-# INLINE checkRequestHeader #-}-checkRequestHeader :: ValueTable -> Bool-checkRequestHeader reqvt- | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme- | isJust mStatus = False- | isNothing mMethod = False- | isNothing mScheme = False- | isNothing mPath = False- | mPath == Just "" = False- | isJust mConnection = False- | just mTE (/= "trailers") = False- | otherwise = True- where- mStatus = getHeaderValue tokenStatus reqvt- mScheme = getHeaderValue tokenScheme reqvt- mPath = getHeaderValue tokenPath reqvt- mMethod = getHeaderValue tokenMethod reqvt- mConnection = getHeaderValue tokenConnection reqvt- mTE = getHeaderValue tokenTE reqvt--{-# INLINE just #-}-just :: Maybe a -> (a -> Bool) -> Bool-just Nothing _ = False-just (Just x) p- | p x = True- | otherwise = False
+ Network/HTTP2/Server/Internal.hs view
@@ -0,0 +1,7 @@+module Network.HTTP2.Server.Internal (+ Request(..)+ , Response(..)+ , Aux(..)+ ) where++import Network.HTTP2.Server.Types
− Network/HTTP2/Server/Manager.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | A thread pool manager.--- The manager has responsibility to spawn and kill--- worker threads.-module Network.HTTP2.Server.Manager (- Manager- , Action- , start- , setAction- , stop- , spawnAction- , addMyId- , deleteMyId- , timeoutKillThread- , timeoutClose- ) where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import Data.Foldable-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import qualified System.TimeManager as T--import Imports--------------------------------------------------------------------type Action = IO ()--noAction :: Action-noAction = return ()--data Command = Stop | Spawn | Add ThreadId | Delete ThreadId--data Manager = Manager (TQueue Command) (IORef Action) T.Manager---- | Starting a thread pool manager.--- Its action is initially set to 'return ()' and should be set--- by 'setAction'. This allows that the action can include--- the manager itself.-start :: IO Manager-start = do- q <- newTQueueIO- ref <- newIORef noAction- timmgr <- T.initialize $ 30 * 1000000 -- fixme- void $ forkIO $ go q Set.empty ref timmgr- return $ Manager q ref timmgr- where- go q !tset0 ref timmgr = do- x <- atomically $ readTQueue q- case x of- Stop -> kill tset0 >> T.killManager timmgr- Spawn -> next tset0- Add newtid -> let !tset = add newtid tset0- in go q tset ref timmgr- Delete oldtid -> let !tset = del oldtid tset0- in go q tset ref timmgr- where- next tset = do- action <- readIORef ref- newtid <- forkIO action- let !tset' = add newtid tset- go q tset' ref timmgr--setAction :: Manager -> Action -> IO ()-setAction (Manager _ ref _) action = writeIORef ref action--stop :: Manager -> IO ()-stop (Manager q _ _) = atomically $ writeTQueue q Stop--spawnAction :: Manager -> IO ()-spawnAction (Manager q _ _) = atomically $ writeTQueue q Spawn--addMyId :: Manager -> IO ()-addMyId (Manager q _ _) = do- tid <- myThreadId- atomically $ writeTQueue q $ Add tid--deleteMyId :: Manager -> IO ()-deleteMyId (Manager q _ _) = do- tid <- myThreadId- atomically $ writeTQueue q $ Delete tid--------------------------------------------------------------------add :: ThreadId -> Set ThreadId -> Set ThreadId-add tid set = set'- where- !set' = Set.insert tid set--del :: ThreadId -> Set ThreadId -> Set ThreadId-del tid set = set'- where- !set' = Set.delete tid set--kill :: Set ThreadId -> IO ()-kill set = traverse_ killThread set--timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()-timeoutKillThread (Manager _ _ tmgr) action = E.bracket register T.cancel action- where- register = T.registerKillThread tmgr noAction---- | Registering closer for a resource and--- returning a timer refresher.-timeoutClose :: Manager -> IO () -> IO (IO ())-timeoutClose (Manager _ _ tmgr) closer = do- th <- T.register tmgr closer- return $ T.tickle th
− Network/HTTP2/Server/Queue.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Server.Queue where--import Control.Concurrent (forkIO)-import Control.Concurrent.STM-import Control.Exception (bracket)-import Data.IORef--import Imports-import Network.HTTP2.Priority-import Network.HTTP2.Server.Manager-import Network.HTTP2.Server.Types--{-# INLINE forkAndEnqueueWhenReady #-}-forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()-forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->- void . forkIO $ do- wait- enqueueOutput outQ out- where- setup = addMyId mgr- teardown _ = deleteMyId mgr--{-# INLINE enqueueOutput #-}-enqueueOutput :: PriorityTree Output -> Output -> IO ()-enqueueOutput outQ out = do- let Stream{..} = outputStream out- pre <- readIORef streamPrecedence- enqueue outQ streamNumber pre out--{-# INLINE enqueueControl #-}-enqueueControl :: TQueue Control -> Control -> IO ()-enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl------------------------------------------------------------------
− Network/HTTP2/Server/ReadN.hs
@@ -1,41 +0,0 @@-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 _ _ 0 = return B.empty-defaultReadN s ref n = do- mbs <- readIORef ref- writeIORef ref Nothing- case mbs of- Nothing -> do- bs <- N.recv s n- if B.null bs then- return B.empty- else 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'- if B.null bs1 then- return B.empty- else do- let bs2 = bs `B.append` bs1- if B.length bs2 == n then- return bs2- else- loop bs2
− Network/HTTP2/Server/Receiver.hs
@@ -1,432 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}--module Network.HTTP2.Server.Receiver (frameReceiver) where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import Data.IORef-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2-import Network.HTTP2.Priority (toPrecedence, delete, prepare)--import Imports hiding (delete, insert)-import Network.HTTP2.Server.API-import Network.HTTP2.Server.EncodeFrame-import Network.HTTP2.Server.HPACK-import Network.HTTP2.Server.Types-import Network.HTTP2.Server.Context-import Network.HTTP2.Server.Stream-import Network.HTTP2.Server.Queue---------------------------------------------------------------------- | Type for input streaming.-data Source = Source !(IORef ByteString) !(IO ByteString)--mkSource :: IO ByteString -> IO Source-mkSource func = do- ref <- newIORef BS.empty- return $! Source ref func--readSource :: Source -> IO ByteString-readSource (Source ref func) = do- bs <- readIORef ref- if BS.null bs- then func- else do- writeIORef ref BS.empty- return bs--frameReceiver :: Context -> (BufferSize -> IO ByteString) -> IO ()-frameReceiver ctx recvN = loop 0 `E.catch` sendGoaway- where- Context{ http2settings- , streamTable- , concurrency- , continued- , clientStreamId- , inputQ- , controlQ- } = ctx- sendGoaway e- | Just (ConnectionError err msg) <- E.fromException e = do- csid <- readIORef clientStreamId- let !frame = goawayFrame csid err msg- enqueueControl controlQ $ CGoaway frame- | otherwise = return ()-- sendReset err sid = do- let !frame = resetFrame err sid- enqueueControl controlQ $ CFrame frame-- loop :: Int -> IO ()- loop !n- | n == 6 = do- yield- loop 0- | otherwise = do- hd <- recvN frameHeaderLength- if BS.null hd then- enqueueControl controlQ CFinish- else do- cont <- processStreamGuardingError $ decodeFrameHeader hd- when cont $ loop (n + 1)-- processStreamGuardingError (fid, FrameHeader{streamId})- | isResponse streamId &&- (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =- E.throwIO $ ConnectionError ProtocolError "stream id should be odd"- processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do- mx <- readIORef continued- case mx of- Nothing -> do- -- ignoring unknown frame- consume payloadLength- return True- Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"- processStreamGuardingError (FramePushPromise, _) =- E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"- processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do- settings <- readIORef http2settings- case checkFrameHeader settings typhdr of- Left h2err -> case h2err of- StreamError err sid -> do- sendReset err sid- consume payloadLength- return True- connErr -> E.throwIO connErr- Right _ -> do- ex <- E.try $ controlOrStream ftyp header- case ex of- Left (StreamError err sid) -> do- sendReset err sid- return True- Left connErr -> E.throw connErr- Right cont -> return cont-- controlOrStream ftyp header@FrameHeader{streamId, payloadLength}- | isControl streamId = do- pl <- recvN payloadLength- control ftyp header pl ctx- | otherwise = do- checkContinued- !mstrm <- getStream- pl <- recvN payloadLength- case mstrm of- Nothing -> do- -- for h2spec only- when (ftyp == FramePriority) $ do- PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl- checkPriority newpri streamId- return True -- just ignore this frame- Just strm@Stream{streamPrecedence} -> do- state <- readStreamState strm- state' <- stream ftyp header pl ctx state strm- case state' of- Open (NoBody tbl@(_,reqvt) pri) -> do- resetContinued- let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)- when (just mcl (/= (0 :: Int))) $- E.throwIO $ StreamError ProtocolError streamId- writeIORef streamPrecedence $ toPrecedence pri- halfClosedRemote ctx strm- tlr <- newIORef Nothing- atomically $ writeTQueue inputQ $ Input strm $ Request tbl (Just 0) (return "") tlr- Open (HasBody tbl@(_,reqvt) pri) -> do- resetContinued- q <- newTQueueIO- let !mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)- writeIORef streamPrecedence $ toPrecedence pri- bodyLength <- newIORef 0- tlr <- newIORef Nothing- setStreamState ctx strm $ Open (Body q mcl bodyLength tlr)- readQ <- newReadBody q- bodySource <- mkSource readQ- atomically $ writeTQueue inputQ $ Input strm $ Request tbl mcl (readSource bodySource) tlr- s@(Open Continued{}) -> do- setContinued- setStreamState ctx strm s- HalfClosedRemote -> do- resetContinued- halfClosedRemote ctx strm- s -> do -- Idle, Open Body, Closed- resetContinued- setStreamState ctx strm s- return True- where- setContinued = writeIORef continued (Just streamId)- resetContinued = writeIORef continued Nothing- checkContinued = do- mx <- readIORef continued- case mx of- Nothing -> return ()- Just sid- | sid == streamId && ftyp == FrameContinuation -> return ()- | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"- getStream = do- mstrm0 <- search streamTable streamId- case mstrm0 of- js@(Just strm0) -> do- when (ftyp == FrameHeaders) $ do- st <- readStreamState strm0- when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"- -- Priority made an idele stream- when (isIdle st) $ opened ctx strm0- return js- Nothing- | isResponse streamId -> return Nothing- | otherwise -> do- csid <- readIORef clientStreamId- if streamId <= csid then -- consider the stream closed- if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then- return Nothing -- will be ignored- else- E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"- else do -- consider the stream idle- when (ftyp `notElem` [FrameHeaders,FramePriority]) $- E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)- when (ftyp == FrameHeaders) $ do- writeIORef clientStreamId streamId- cnt <- readIORef concurrency- -- Checking the limitation of concurrency- when (cnt >= maxConcurrency) $- E.throwIO $ StreamError RefusedStream streamId- ws <- initialWindowSize <$> readIORef http2settings- newstrm <- newStream streamId (fromIntegral ws)- when (ftyp == FrameHeaders) $ opened ctx newstrm- insert streamTable streamId newstrm- return $ Just newstrm-- consume = void . recvN--maxConcurrency :: Int-maxConcurrency = recommendedConcurrency--initialFrame :: ByteString-initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]--------------------------------------------------------------------control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool-control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do- SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs- traverse_ E.throwIO $ checkSettingsList alist- -- HTTP/2 Setting from a browser- unless (testAck flags) $ do- oldws <- initialWindowSize <$> readIORef http2settings- modifyIORef' http2settings $ \old -> updateSettings old alist- newws <- initialWindowSize <$> readIORef http2settings- let diff = newws - oldws- when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable- let !frame = settingsFrame setAck []- sent <- readIORef firstSettings- let !setframe- | sent = CSettings frame alist- | otherwise = CSettings0 initialFrame frame alist- unless sent $ writeIORef firstSettings True- enqueueControl controlQ setframe- return True--control FramePing FrameHeader{flags} bs Context{controlQ} =- if testAck flags then- return True -- just ignore- else do- let !frame = pingFrame bs- enqueueControl controlQ $ CFrame frame- return True--control FrameGoAway _ _ Context{controlQ} = do- enqueueControl controlQ CFinish- return False--control FrameWindowUpdate header bs Context{connectionWindow} = do- WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs- !w <- atomically $ do- w0 <- readTVar connectionWindow- let !w1 = w0 + n- writeTVar connectionWindow w1- return w1- when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"- return True--control _ _ _ _ =- -- must not reach here- return False--------------------------------------------------------------------{-# INLINE guardIt #-}-guardIt :: Either HTTP2Error a -> IO a-guardIt x = case x of- Left err -> E.throwIO err- Right frame -> return frame---{-# INLINE checkPriority #-}-checkPriority :: Priority -> StreamId -> IO ()-checkPriority p me- | dep == me = E.throwIO $ StreamError ProtocolError me- | otherwise = return ()- where- dep = streamDependency p--stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState-stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do- HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs- pri <- case mp of- Nothing -> return defaultPriority- Just p -> do- checkPriority p streamNumber- return p- let !endOfStream = testEndStream flags- !endOfHeader = testEndHeader flags- if endOfHeader then do- tbl <- hpackDecodeHeader frag ctx -- fixme- return $ if endOfStream then- Open (NoBody tbl pri)- else- Open (HasBody tbl pri)- else do- let !siz = BS.length frag- return $ Open $ Continued [frag] siz 1 endOfStream pri--stream FrameHeaders header@FrameHeader{flags} bs ctx (Open (Body q _ _ tlr)) _ = do- HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs- let !endOfStream = testEndStream flags- if endOfStream then do- tbl <- hpackDecodeTrailer frag ctx- writeIORef tlr (Just tbl)- atomically $ writeTQueue q ""- return HalfClosedRemote- else- -- we don't support continuation here.- E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"---- ignore data-frame except for flow-control when we're done locally-stream FrameData- FrameHeader{flags,payloadLength}- _bs- Context{controlQ} s@(HalfClosedLocal _)- Stream{streamNumber} = do- let !endOfStream = testEndStream flags- when (payloadLength /= 0) $ do- let !frame1 = windowUpdateFrame 0 payloadLength- !frame2 = windowUpdateFrame streamNumber payloadLength- !frame = frame1 `BS.append` frame2- enqueueControl controlQ $ CFrame frame- if endOfStream then do- return HalfClosedRemote- else- return s--stream FrameData- header@FrameHeader{flags,payloadLength,streamId}- bs- Context{controlQ} s@(Open (Body q mcl bodyLength _))- Stream{streamNumber} = do- DataFrame body <- guardIt $ decodeDataFrame header bs- let !endOfStream = testEndStream flags- len0 <- readIORef bodyLength- let !len = len0 + payloadLength- writeIORef bodyLength len- when (payloadLength /= 0) $ do- let !frame1 = windowUpdateFrame 0 payloadLength- !frame2 = windowUpdateFrame streamNumber payloadLength- !frame = frame1 `BS.append` frame2- enqueueControl controlQ $ CFrame frame- atomically $ writeTQueue q body- if endOfStream then do- case mcl of- Nothing -> return ()- Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId- -- no trailers- atomically $ writeTQueue q ""- return HalfClosedRemote- else- return s--stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do- let !endOfHeader = testEndHeader flags- !rfrags' = frag : rfrags- !siz' = siz + BS.length frag- !n' = n + 1- when (siz' > 51200) $ -- fixme: hard coding: 50K- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"- when (n' > 10) $ -- fixme: hard coding- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"- if endOfHeader then do- let !hdrblk = BS.concat $ reverse rfrags'- tbl <- hpackDecodeHeader hdrblk ctx- return $ if endOfStream then- Open (NoBody tbl pri)- else- Open (HasBody tbl pri)- else- return $ Open $ Continued rfrags' siz' n' endOfStream pri--stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do- WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs- !w <- atomically $ do- w0 <- readTVar streamWindow- let !w1 = w0 + n- writeTVar streamWindow w1- return w1- when (isWindowOverflow w) $- E.throwIO $ StreamError FlowControlError streamId- return s--stream FrameRSTStream header bs ctx _ strm = do- RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs- let !cc = Reset e- closed ctx strm cc- return $ Closed cc -- will be written to streamState again--stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do- PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs- checkPriority newpri streamNumber- oldpre <- readIORef streamPrecedence- let !newpre = toPrecedence newpri- writeIORef streamPrecedence newpre- if isIdle s then do- n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))- -- fixme hard coding- when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"- prepare outputQ streamNumber newpri- else do- mout <- delete outputQ streamNumber oldpre- traverse_ (enqueueOutput outputQ) mout- return s---- this ordering is important-stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"-stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"--- Ignore frames to streams we have just reset, per section 5.1.-stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId-stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId--------------------------------------------------------------------{-# INLINE newReadBody #-}-newReadBody :: TQueue ByteString -> IO (IO ByteString)-newReadBody q = do- ref <- newIORef False- return $ readBody q ref--{-# INLINE readBody #-}-readBody :: TQueue ByteString -> IORef Bool -> IO ByteString-readBody q ref = do- eof <- readIORef ref- if eof then- return ""- else do- bs <- atomically $ readTQueue q- when (bs == "") $ writeIORef ref True- return bs
Network/HTTP2/Server/Run.hs view
@@ -7,14 +7,10 @@ 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.Arch+import Network.HTTP2.Frame+import Network.HTTP2.Server.Types import Network.HTTP2.Server.Worker-import Network.HTTP2.Server.Context ---------------------------------------------------------------- @@ -23,10 +19,12 @@ run conf@Config{..} server = do ok <- checkPreface when ok $ do- ctx <- newContext+ serverInfo <- newServerInfo+ ctx <- newContext serverInfo -- Workers, worker manager and timer manager- mgr <- start- setAction mgr $ worker ctx mgr server+ mgr <- start confTimeoutManager+ let wc = fromContext ctx+ setAction mgr $ worker wc 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.@@ -39,7 +37,6 @@ -- 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
− Network/HTTP2/Server/Sender.hs
@@ -1,459 +0,0 @@-{-# 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-- hardLimit = confBufferSize - 512-- 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' > hardLimit -> flushN off' >> loop 0- | otherwise -> loop off'- Flush -> flushN off >> loop 0-- control CFinish _ = return (-1)- control (CGoaway frame) _ = confSendAll frame >> return (-1)- control (CFrame frame) _ = confSendAll frame >> return 0- control (CSettings frame alist) _ = do- confSendAll frame- setLimit alist- return 0- control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case- let !buf = confWriteBuffer `plusPtr` off- !off' = off + BS.length frame1 + BS.length frame2- buf' <- copy buf frame1- void $ copy buf' frame2- setLimit alist- return off'-- {-# INLINE setLimit #-}- setLimit alist = case lookup SettingsHeaderTableSize alist of- Nothing -> return ()- Just siz -> setLimitForEncoding siz encodeDynamicTable-- output out@(Output strm (Response _ _ _ _) (ONext curr tlrmkr) _ sentinel) off0 lim = do- -- Data frame payload- let !buf = confWriteBuffer `plusPtr` off0- !siz = confBufferSize - off0- !payloadOff = off0 + frameHeaderLength- Next datPayloadLen mnext <- curr buf siz lim- NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen- fillDataHeaderEnqueueNext strm off0 datPayloadLen mnext tlrmkr' sentinel out-- output out@(Output strm (Response st hdr body tlrmkr) ORspn mtbq sentinel) off0 lim = do- -- Header frame and Continuation frame- let !sid = streamNumber strm- !endOfStream = case body of- RspNoBody -> True- _ -> False- (ths,_) <- toHeaderTable $ fixHeaders st hdr- kvlen <- headerContinue sid ths endOfStream off0- off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen- case body of- RspNoBody -> do- halfClosedLocal ctx strm Finished- return off- RspFile (FileSpec path fileoff bytecount) -> do- -- Data frame payload- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillFileBodyGetNext conf payloadOff lim path fileoff bytecount mgr confPositionReadMaker- NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen- fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out- RspBuilder builder -> do- -- Data frame payload- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillBuilderBodyGetNext conf payloadOff lim builder- NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen- fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out- RspStreaming _ -> do- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillStreamBodyGetNext conf payloadOff lim (fromJust mtbq) strm- NextTrailersMaker !tlrmkr' <- runTrailersMaker tlrmkr payloadOff datPayloadLen- fillDataHeaderEnqueueNext strm off datPayloadLen mnext tlrmkr' sentinel out-- output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do- -- Creating a push promise header- -- Frame id should be associated stream id from the client.- let !sid = streamNumber strm- len <- pushPromise pid sid ths off0- off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len- output out{outputType=ORspn} off lim-- output _ _ _ = undefined -- never reach-- outputOrEnqueueAgain :: Output -> Int -> IO Int- outputOrEnqueueAgain out@(Output strm _ otyp _ _) off = E.handle resetStream $ do- state <- readStreamState strm- if isHalfClosedLocal state then- return off- else case otyp of- OWait wait -> do- -- Checking if all push are done.- forkAndEnqueueWhenReady wait outputQ out{outputType=ORspn} mgr- return off- _ -> case mtbq of- Just tbq -> checkStreaming tbq- _ -> checkStreamWindowSize- where- mtbq = outputStrmQ out- checkStreaming tbq = do- isEmpty <- atomically $ isEmptyTBQueue tbq- if isEmpty then do- forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr- return off- else- checkStreamWindowSize- checkStreamWindowSize = do- sws <- getStreamWindowSize strm- if sws == 0 then do- forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr- return off- else do- cws <- readTVarIO connectionWindow -- not 0- let !lim = min cws sws- output out off lim- resetStream e = do- closed ctx strm (ResetByMe e)- let !rst = resetFrame InternalError $ streamNumber strm- enqueueControl controlQ $ CFrame rst- return off-- {-# INLINE flushN #-}- -- Flush the connection buffer to the socket, where the first 'n' bytes of- -- the buffer are filled.- flushN :: Int -> IO ()- flushN n = bufferIO confWriteBuffer n confSendAll-- headerContinue sid ths endOfStream off = do- let !offkv = off + frameHeaderLength- let !bufkv = confWriteBuffer `plusPtr` offkv- !limkv = confBufferSize - offkv- (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths- let flag0 = case hs of- [] -> setEndHeader defaultFlags- _ -> defaultFlags- flag = if endOfStream then setEndStream flag0 else flag0- let buf = confWriteBuffer `plusPtr` off- fillFrameHeader FrameHeaders kvlen sid flag buf- continue sid kvlen hs-- !bufHeaderPayload = confWriteBuffer `plusPtr` frameHeaderLength- !headerPayloadLim = confBufferSize - frameHeaderLength-- continue _ kvlen [] = return kvlen- continue sid kvlen ths = do- flushN $ kvlen + frameHeaderLength- -- Now off is 0- (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths- when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"- let flag = case ths' of- [] -> setEndHeader defaultFlags- _ -> defaultFlags- fillFrameHeader FrameContinuation kvlen' sid flag confWriteBuffer- continue sid kvlen' ths'-- {-# INLINE sendHeadersIfNecessary #-}- -- Send headers if there is not room for a 1-byte data frame, and return- -- the offset of the next frame's first header byte.- sendHeadersIfNecessary off- -- True if the connection buffer has room for a 1-byte data frame.- | off + frameHeaderLength < confBufferSize = return off- | otherwise = do- flushN off- return 0-- fillDataHeaderEnqueueNext strm@Stream{streamWindow,streamNumber}- off datPayloadLen Nothing tlrmkr tell _ = do- let !buf = confWriteBuffer `plusPtr` off- !off' = off + frameHeaderLength + datPayloadLen- (mtrailers, flag) <- do- Trailers !trailers <- tlrmkr Nothing- if null trailers then- return (Nothing, setEndStream defaultFlags)- else- return (Just trailers, defaultFlags)- fillFrameHeader FrameData datPayloadLen streamNumber flag buf- off'' <- handleTrailers mtrailers off'- void tell- halfClosedLocal ctx strm Finished- atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)- atomically $ modifyTVar' streamWindow (subtract datPayloadLen)- return off''- where- handleTrailers Nothing off0 = return off0- handleTrailers (Just trailers) off0 = do- (ths,_) <- toHeaderTable trailers- kvlen <- headerContinue streamNumber ths True off0- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen-- fillDataHeaderEnqueueNext Stream{streamWindow,streamNumber}- off datPayloadLen (Just next) tlrmkr _ out = do- let !buf = confWriteBuffer `plusPtr` off- !off' = off + frameHeaderLength + datPayloadLen- flag = defaultFlags- fillFrameHeader FrameData datPayloadLen streamNumber flag buf- atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)- atomically $ modifyTVar' streamWindow (subtract datPayloadLen)- let !out' = out { outputType = ONext next tlrmkr }- enqueueOutput outputQ out'- return off'-- pushPromise pid sid ths off = do- let !offsid = off + frameHeaderLength- !bufsid = confWriteBuffer `plusPtr` offsid- poke32 (fromIntegral sid) bufsid 0- let !offkv = offsid + 4- !bufkv = confWriteBuffer `plusPtr` offkv- !limkv = confBufferSize - offkv- (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths- let !flag = setEndHeader defaultFlags -- No EndStream flag- !buf = confWriteBuffer `plusPtr` off- !len = kvlen + 4- fillFrameHeader FramePushPromise len pid flag buf- return len-- {-# INLINE fillFrameHeader #-}- fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf- where- hinfo = FrameHeader len flag sid-- runTrailersMaker tlrmkr off siz = do- let datBuf = confWriteBuffer `plusPtr` off- bufferIO datBuf siz $ \bs -> tlrmkr (Just bs)-- {-# INLINE ignore #-}- ignore :: E.SomeException -> IO ()- ignore _ = return ()--------------------------------------------------------------------fillBuilderBodyGetNext :: Config -> Int -> WindowSize -> Builder -> IO Next-fillBuilderBodyGetNext Config{confWriteBuffer,confBufferSize}- off lim bb = do- let datBuf = confWriteBuffer `plusPtr` off- room = min (confBufferSize - off) lim- (len, signal) <- B.runBuilder bb datBuf room- return $ nextForBuilder len signal--fillFileBodyGetNext :: Config -> Int -> WindowSize -> FilePath -> FileOffset -> ByteCount -> Manager -> PositionReadMaker -> IO Next-fillFileBodyGetNext Config{confWriteBuffer,confBufferSize}- off lim path start bytecount mgr prmaker = do- let datBuf = confWriteBuffer `plusPtr` off- room = min (confBufferSize - off) lim- (pread, sentinel) <- prmaker path- refresh <- case sentinel of- Closer closer -> timeoutClose mgr closer- Refresher refresher -> return refresher- len <- pread start (mini room bytecount) datBuf- let len' = fromIntegral len- return $ nextForFile len' pread (start + len) (bytecount - len) refresh--------------------------------------------------------------------fillStreamBodyGetNext :: Config -> Int -> WindowSize -> TBQueue RspStreaming -> Stream -> IO Next-fillStreamBodyGetNext Config{confWriteBuffer,confBufferSize}- off lim sq strm = do- let datBuf = confWriteBuffer `plusPtr` off- room = min (confBufferSize - off) lim- (leftover, cont, len) <- runStreamBuilder datBuf room sq- return $ nextForStream sq strm leftover cont len--------------------------------------------------------------------fillBufBuilder :: Leftover -> DynaNext-fillBufBuilder leftover buf0 siz0 lim = do- let payloadBuf = buf0 `plusPtr` frameHeaderLength- room = min (siz0 - frameHeaderLength) lim- case leftover of- LZero -> error "fillBufBuilder: LZero"- LOne writer -> do- (len, signal) <- writer payloadBuf room- getNext len signal- LTwo bs writer- | BS.length bs <= room -> do- buf1 <- copy payloadBuf bs- let len1 = BS.length bs- (len2, signal) <- writer buf1 (room - len1)- getNext (len1 + len2) signal- | otherwise -> do- let (bs1,bs2) = BS.splitAt room bs- void $ copy payloadBuf bs1- getNext room (B.Chunk bs2 writer)- where- getNext l s = return $ nextForBuilder l s--nextForBuilder :: BytesFilled -> B.Next -> Next-nextForBuilder len B.Done- = Next len Nothing-nextForBuilder len (B.More _ writer)- = Next len $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer)- = Next len $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder :: Buffer -> BufferSize -> TBQueue RspStreaming- -> IO (Leftover, Bool, BytesFilled)-runStreamBuilder buf0 room0 sq = loop buf0 room0 0- where- loop !buf !room !total = do- mbuilder <- atomically $ tryReadTBQueue sq- case mbuilder of- Nothing -> return (LZero, True, total)- Just (RSBuilder builder) -> do- (len, signal) <- B.runBuilder builder buf room- let !total' = total + len- case signal of- B.Done -> loop (buf `plusPtr` len) (room - len) total'- B.More _ writer -> return (LOne writer, True, total')- B.Chunk bs writer -> return (LTwo bs writer, True, total')- Just RSFlush -> return (LZero, True, total)- Just RSFinish -> return (LZero, False, total)--fillBufStream :: Leftover -> TBQueue RspStreaming -> Stream -> DynaNext-fillBufStream leftover0 sq strm buf0 siz0 lim0 = do- let payloadBuf = buf0 `plusPtr` frameHeaderLength- room0 = min (siz0 - frameHeaderLength) lim0- case leftover0 of- LZero -> do- (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq- getNext leftover cont len- LOne writer -> write writer payloadBuf room0 0- LTwo bs writer- | BS.length bs <= room0 -> do- buf1 <- copy payloadBuf bs- let len = BS.length bs- write writer buf1 (room0 - len) len- | otherwise -> do- let (bs1,bs2) = BS.splitAt room0 bs- void $ copy payloadBuf bs1- getNext (LTwo bs2 writer) True room0- where- getNext l b r = return $ nextForStream sq strm l b r- write writer1 buf room sofar = do- (len, signal) <- writer1 buf room- case signal of- B.Done -> do- (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq- let !total = sofar + len + extra- getNext leftover cont total- B.More _ writer -> do- let !total = sofar + len- getNext (LOne writer) True total- B.Chunk bs writer -> do- let !total = sofar + len- getNext (LTwo bs writer) True total--nextForStream :: TBQueue RspStreaming -> Stream- -> Leftover -> Bool -> BytesFilled- -> Next-nextForStream _ _ _ False len = Next len Nothing-nextForStream sq strm leftOrZero True len =- Next len $ Just (fillBufStream leftOrZero sq strm)--------------------------------------------------------------------fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillBufFile pread start bytes refresh buf siz lim = do- let payloadBuf = buf `plusPtr` frameHeaderLength- room = min (siz - frameHeaderLength) lim- len <- pread start (mini room bytes) payloadBuf- refresh- let len' = fromIntegral len- return $ nextForFile len' pread (start + len) (bytes - len) refresh--nextForFile :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next-nextForFile 0 _ _ _ _ = Next 0 Nothing-nextForFile len _ _ 0 _ = Next len Nothing-nextForFile len pread start bytes refresh =- Next len $ Just (fillBufFile pread start bytes refresh)--{-# INLINE mini #-}-mini :: Int -> Int64 -> Int64-mini i n- | fromIntegral i < n = fromIntegral i- | otherwise = n
− Network/HTTP2/Server/Stream.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}--module Network.HTTP2.Server.Stream where--import Control.Concurrent.STM-import Data.IORef-import qualified Data.IntMap.Strict as M--import Imports-import Network.HTTP2-import Network.HTTP2.Priority-import Network.HTTP2.Server.Types--------------------------------------------------------------------isIdle :: StreamState -> Bool-isIdle Idle = True-isIdle _ = False--isOpen :: StreamState -> Bool-isOpen Open{} = True-isOpen _ = False--isHalfClosedRemote :: StreamState -> Bool-isHalfClosedRemote HalfClosedRemote = True-isHalfClosedRemote (Closed _) = True-isHalfClosedRemote _ = False--isHalfClosedLocal :: StreamState -> Bool-isHalfClosedLocal (HalfClosedLocal _) = True-isHalfClosedLocal (Closed _) = True-isHalfClosedLocal _ = False--isClosed :: StreamState -> Bool-isClosed Closed{} = True-isClosed _ = False--------------------------------------------------------------------newStream :: StreamId -> WindowSize -> IO Stream-newStream sid win = Stream sid <$> newIORef Idle- <*> newTVarIO win- <*> newIORef defaultPrecedence--------------------------------------------------------------------{-# INLINE readStreamState #-}-readStreamState :: Stream -> IO StreamState-readStreamState Stream{streamState} = readIORef streamState--------------------------------------------------------------------newStreamTable :: IO StreamTable-newStreamTable = StreamTable <$> newIORef M.empty--insert :: StreamTable -> M.Key -> Stream -> IO ()-insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->- let !m' = M.insert k v m- in (m', ())--remove :: StreamTable -> M.Key -> IO ()-remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->- let !m' = M.delete k m- in (m', ())--search :: StreamTable -> M.Key -> IO (Maybe Stream)-search (StreamTable ref) k = M.lookup k <$> readIORef ref--updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()-updateAllStreamWindow adst (StreamTable ref) = do- strms <- M.elems <$> readIORef ref- forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst-
Network/HTTP2/Server/Types.hs view
@@ -1,112 +1,43 @@-{-# 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 qualified System.TimeManager as T 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"+import Network.HTTP2.Arch+import Network.HTTP2.Frame ---------------------------------------------------------------- -data Stream = Stream {- streamNumber :: !StreamId- , streamState :: !(IORef StreamState)- , streamWindow :: !(TVar WindowSize)- , streamPrecedence :: !(IORef Precedence)- }--instance Show Stream where- show s = show (streamNumber s)+-- | Server type. 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 () -----------------------------------------------------------------+-- | Request from client.+newtype Request = Request InpObj deriving (Show) -newtype StreamTable = StreamTable (IORef (IntMap Stream))+-- | Response from server.+newtype Response = Response OutObj deriving (Show) -----------------------------------------------------------------+-- | 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+ } -data Input = Input Stream Request+{-# DEPRECATED promiseWeight "Don't use this" #-} -data Output = Output {- outputStream :: Stream- , outputResponse :: Response- , outputType :: OutputType- , outputStrmQ :: Maybe (TBQueue RspStreaming)- , outputSentinel :: IO ()+-- | Additional information.+newtype Aux = Aux {+ -- | Time handle for the worker processing this request and response.+ auxTimeHandle :: T.Handle }--data OutputType = ORspn- | OWait (IO ())- | OPush !TokenHeaderList !StreamId -- associated stream id from client- | ONext !DynaNext !TrailersMaker--------------------------------------------------------------------type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next--type BytesFilled = Int--data Next = Next !BytesFilled (Maybe DynaNext)--------------------------------------------------------------------data Control = CFinish- | CGoaway !ByteString- | CFrame !ByteString- | CSettings !ByteString !SettingsList- | CSettings0 !ByteString !ByteString !SettingsList--------------------------------------------------------------------data RspStreaming = RSFinish- | RSFlush- | RSBuilder Builder
Network/HTTP2/Server/Worker.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}@@ -6,6 +5,8 @@ module Network.HTTP2.Server.Worker ( worker+ , WorkerConf(..)+ , fromContext ) where import Control.Concurrent.STM@@ -18,87 +19,104 @@ 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.Arch+import Network.HTTP2.Frame import Network.HTTP2.Server.Types ---------------------------------------------------------------- -pushStream :: Context- -> Stream -- parent stream+data WorkerConf a = WorkerConf {+ readInputQ :: IO (Input a)+ , writeOutputQ :: Output a -> IO ()+ , workerCleanup :: a -> IO ()+ , isPushable :: IO Bool+ , insertStream :: StreamId -> a -> IO ()+ , makePushStream :: a -> PushPromise -> IO (StreamId, StreamId, a)+ }++fromContext :: Context -> WorkerConf Stream+fromContext ctx@Context{..} = WorkerConf {+ readInputQ = atomically $ readTQueue $ inputQ roleInfo+ , writeOutputQ = enqueueOutput outputQ+ , workerCleanup = \strm -> do+ closed ctx strm Killed+ let frame = resetFrame InternalError (streamNumber strm)+ enqueueControl controlQ $ CFrame frame+ , isPushable = enablePush <$> readIORef http2settings+ , insertStream = insert streamTable+ , makePushStream = \pstrm _ -> do+ ws <- initialWindowSize <$> readIORef http2settings+ sid <- getMyNewStreamId ctx+ newstrm <- newPushStream sid ws+ let pid = streamNumber pstrm+ return (pid, sid, newstrm)+ }++----------------------------------------------------------------++pushStream :: WorkerConf a+ -> a -- parent stream -> ValueTable -- request -> [PushPromise] -> IO OutputType-pushStream _ _ _ [] = return ORspn-pushStream ctx@Context{..} pstrm reqvt pps0- | len == 0 = return ORspn+pushStream _ _ _ [] = return OObj+pushStream WorkerConf{..} pstrm reqvt pps0+ | len == 0 = return OObj | otherwise = do- pushable <- enablePush <$> readIORef http2settings+ pushable <- isPushable if pushable then do tvar <- newTVarIO 0 lim <- push tvar pps0 0 if lim == 0 then- return ORspn+ return OObj else return $ OWait (waiter lim tvar) else- return ORspn+ return OObj where- !pid = streamNumber pstrm- !len = length pps0+ 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+ push _ [] n = return (n :: Int)+ push tvar (pp:pps) n = do+ (pid, sid, newstrm) <- makePushStream pstrm pp+ insertStream sid newstrm+ let scheme = fromJust $ getHeaderValue tokenScheme reqvt -- fixme: this value can be Nothing- !auth = fromJust (getHeaderValue tokenHost reqvt+ 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+ path = promiseRequestPath pp+ promiseRequest = [(tokenMethod, H.methodGet)+ ,(tokenScheme, scheme)+ ,(tokenAuthority, auth)+ ,(tokenPath, path)]+ ot = OPush promiseRequest pid+ Response rsp = promiseResponse pp+ out = Output newstrm rsp ot Nothing $ increment tvar+ writeOutputQ 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+response :: WorkerConf a -> Manager -> T.Handle -> ThreadContinue -> a -> Request -> Response -> [PushPromise] -> IO ()+response wc@WorkerConf{..} mgr th tconf strm (Request req) (Response rsp) pps = case outObjBody rsp of+ OutBodyNone -> do setThreadContinue tconf True- enqueueOutput outputQ $ Output strm rsp ORspn Nothing (return ())- RspBuilder _ -> do- otyp <- pushStream ctx strm reqvt pps+ writeOutputQ $ Output strm rsp OObj Nothing (return ())+ OutBodyBuilder _ -> do+ otyp <- pushStream wc strm reqvt pps setThreadContinue tconf True- enqueueOutput outputQ $ Output strm rsp otyp Nothing (return ())- RspFile _ -> do- otyp <- pushStream ctx strm reqvt pps+ writeOutputQ $ Output strm rsp otyp Nothing (return ())+ OutBodyFile _ -> do+ otyp <- pushStream wc 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.+ writeOutputQ $ Output strm rsp otyp Nothing (return ())+ OutBodyStreaming strmbdy -> do+ otyp <- pushStream wc strm reqvt pps+ -- We must not exit this server application. -- If the application exits, streaming would be also closed. -- So, this work occupies this thread. --@@ -110,20 +128,21 @@ -- 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 ())+ writeOutputQ $ Output strm rsp otyp (Just tbq) (return ()) let push b = do T.pause th- atomically $ writeTBQueue tbq (RSBuilder b)+ atomically $ writeTBQueue tbq (StreamingBuilder b) T.resume th- flush = atomically $ writeTBQueue tbq RSFlush+ flush = atomically $ writeTBQueue tbq StreamingFlush strmbdy push flush- atomically $ writeTBQueue tbq RSFinish+ atomically $ writeTBQueue tbq StreamingFinished deleteMyId mgr where- (_,reqvt) = requestHeaders req+ (_,reqvt) = inpObjHeaders req -worker :: Context -> Manager -> Server -> Action-worker ctx@Context{inputQ,controlQ} mgr server = do+-- | Worker for server applications.+worker :: WorkerConf a -> Manager -> Server -> Action+worker wc@WorkerConf{..} mgr server = do sinfo <- newStreamInfo tcont <- newThreadContinue timeoutKillThread mgr $ go sinfo tcont@@ -132,13 +151,13 @@ setThreadContinue tcont True ex <- E.try $ do T.pause th- Input strm req <- atomically $ readTQueue inputQ+ Input strm req <- readInputQ 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'+ server (Request req') aux $ response wc mgr th tcont strm (Request req') cont1 <- case ex of Right () -> return True Left e@(SomeException _)@@ -154,10 +173,10 @@ cont2 <- getThreadContinue tcont clearStreamInfo sinfo when (cont1 && cont2) $ go sinfo tcont th- pauseRequestBody req th = req { requestBody = readBody' }+ pauseRequestBody req th = req { inpObjBody = readBody' } where- !readBody = requestBody req- !readBody' = do+ readBody = inpObjBody req+ readBody' = do T.pause th bs <- readBody T.resume th@@ -166,10 +185,7 @@ 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+ Just strm -> workerCleanup strm ---------------------------------------------------------------- @@ -194,20 +210,20 @@ ---------------------------------------------------------------- -- | The type for cleaning up.-newtype StreamInfo = StreamInfo (IORef (Maybe Stream))+newtype StreamInfo a = StreamInfo (IORef (Maybe a)) {-# INLINE newStreamInfo #-}-newStreamInfo :: IO StreamInfo+newStreamInfo :: IO (StreamInfo a) newStreamInfo = StreamInfo <$> newIORef Nothing {-# INLINE clearStreamInfo #-}-clearStreamInfo :: StreamInfo -> IO ()+clearStreamInfo :: StreamInfo a -> IO () clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing {-# INLINE setStreamInfo #-}-setStreamInfo :: StreamInfo -> Stream -> IO ()+setStreamInfo :: StreamInfo a -> a -> IO () setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp {-# INLINE getStreamInfo #-}-getStreamInfo :: StreamInfo -> IO (Maybe Stream)+getStreamInfo :: StreamInfo a -> IO (Maybe a) getStreamInfo (StreamInfo ref) = readIORef ref
− Network/HTTP2/Types.hs
@@ -1,628 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}--module Network.HTTP2.Types (- -- * Constant- frameHeaderLength- , maxPayloadLength- -- * SettingsList- , SettingsKeyId(..)- , checkSettingsList- , fromSettingsKeyId- , SettingsValue- , SettingsList- , toSettingsKeyId- -- * Settings- , Settings(..)- , defaultSettings- , updateSettings- -- * Error- , HTTP2Error(..)- , errorCodeId- -- * Error code- , ErrorCode- , ErrorCodeId(..)- , fromErrorCodeId- , toErrorCodeId- -- * Frame type- , FrameType- , minFrameType- , maxFrameType- , FrameTypeId(..)- , fromFrameTypeId- , toFrameTypeId- -- * Frame- , Frame(..)- , FrameHeader(..)- , FramePayload(..)- , framePayloadToFrameTypeId- , isPaddingDefined- -- * Stream identifier- , StreamId- , isControl- , isRequest- , isResponse- , testExclusive- , setExclusive- , clearExclusive- -- * Flags- , FrameFlags- , defaultFlags- , testEndStream- , testAck- , testEndHeader- , testPadded- , testPriority- , setEndStream- , setAck- , setEndHeader- , setPadded- , setPriority- -- * Window- , WindowSize- , defaultInitialWindowSize- , maxWindowSize- , isWindowOverflow- -- * Misc- , recommendedConcurrency- -- * Types- , HeaderBlockFragment- , Weight- , Priority(..)- , defaultPriority- , highestPriority- , Padding- ) where--import qualified Control.Exception as E-import Data.Typeable--import Imports---------------------------------------------------------------------- | The length of HTTP/2 frame header.------ >>> frameHeaderLength--- 9-frameHeaderLength :: Int-frameHeaderLength = 9---------------------------------------------------------------------- | The type for raw error code.-type ErrorCode = Word32---- | The type for error code. See <https://tools.ietf.org/html/rfc7540#section-7>.-data ErrorCodeId = NoError- | ProtocolError- | InternalError- | FlowControlError- | SettingsTimeout- | StreamClosed- | FrameSizeError- | RefusedStream- | Cancel- | CompressionError- | ConnectError- | EnhanceYourCalm- | InadequateSecurity- | HTTP11Required- -- our extensions- | UnknownErrorCode ErrorCode- deriving (Show, Read, Eq, Ord)---- | Converting 'ErrorCodeId' to 'ErrorCode'.------ >>> fromErrorCodeId NoError--- 0--- >>> fromErrorCodeId InadequateSecurity--- 12-fromErrorCodeId :: ErrorCodeId -> ErrorCode-fromErrorCodeId NoError = 0x0-fromErrorCodeId ProtocolError = 0x1-fromErrorCodeId InternalError = 0x2-fromErrorCodeId FlowControlError = 0x3-fromErrorCodeId SettingsTimeout = 0x4-fromErrorCodeId StreamClosed = 0x5-fromErrorCodeId FrameSizeError = 0x6-fromErrorCodeId RefusedStream = 0x7-fromErrorCodeId Cancel = 0x8-fromErrorCodeId CompressionError = 0x9-fromErrorCodeId ConnectError = 0xa-fromErrorCodeId EnhanceYourCalm = 0xb-fromErrorCodeId InadequateSecurity = 0xc-fromErrorCodeId HTTP11Required = 0xd-fromErrorCodeId (UnknownErrorCode w) = w---- | Converting 'ErrorCode' to 'ErrorCodeId'.------ >>> toErrorCodeId 0--- NoError--- >>> toErrorCodeId 0xc--- InadequateSecurity--- >>> toErrorCodeId 0xe--- UnknownErrorCode 14-toErrorCodeId :: ErrorCode -> ErrorCodeId-toErrorCodeId 0x0 = NoError-toErrorCodeId 0x1 = ProtocolError-toErrorCodeId 0x2 = InternalError-toErrorCodeId 0x3 = FlowControlError-toErrorCodeId 0x4 = SettingsTimeout-toErrorCodeId 0x5 = StreamClosed-toErrorCodeId 0x6 = FrameSizeError-toErrorCodeId 0x7 = RefusedStream-toErrorCodeId 0x8 = Cancel-toErrorCodeId 0x9 = CompressionError-toErrorCodeId 0xa = ConnectError-toErrorCodeId 0xb = EnhanceYourCalm-toErrorCodeId 0xc = InadequateSecurity-toErrorCodeId 0xd = HTTP11Required-toErrorCodeId w = UnknownErrorCode w---------------------------------------------------------------------- | The connection error or the stream error.-data HTTP2Error = ConnectionError !ErrorCodeId !ByteString- | StreamError !ErrorCodeId !StreamId- deriving (Eq, Show, Typeable, Read)--instance E.Exception HTTP2Error---- | Obtaining 'ErrorCodeId' from 'HTTP2Error'.-errorCodeId :: HTTP2Error -> ErrorCodeId-errorCodeId (ConnectionError err _) = err-errorCodeId (StreamError err _) = err---------------------------------------------------------------------- | The type for SETTINGS key.-data SettingsKeyId = SettingsHeaderTableSize- | SettingsEnablePush- | SettingsMaxConcurrentStreams- | SettingsInitialWindowSize- | SettingsMaxFrameSize -- this means payload size- | SettingsMaxHeaderBlockSize- deriving (Show, Read, Eq, Ord, Enum, Bounded)---- | The type for raw SETTINGS value.-type SettingsValue = Int -- Word32---- | Converting 'SettingsKeyId' to raw value.------ >>> fromSettingsKeyId SettingsHeaderTableSize--- 1--- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize--- 6-fromSettingsKeyId :: SettingsKeyId -> Word16-fromSettingsKeyId x = fromIntegral (fromEnum x) + 1--minSettingsKeyId :: Word16-minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId)--maxSettingsKeyId :: Word16-maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId)---- | Converting raw value to 'SettingsKeyId'.------ >>> toSettingsKeyId 0--- Nothing--- >>> toSettingsKeyId 1--- Just SettingsHeaderTableSize--- >>> toSettingsKeyId 6--- Just SettingsMaxHeaderBlockSize--- >>> toSettingsKeyId 7--- Nothing-toSettingsKeyId :: Word16 -> Maybe SettingsKeyId-toSettingsKeyId x- | minSettingsKeyId <= n && n <= maxSettingsKeyId = Just . toEnum . fromIntegral $ n- | otherwise = Nothing- where- n = x - 1---------------------------------------------------------------------- | Association list of SETTINGS.-type SettingsList = [(SettingsKeyId,SettingsValue)]---- | Checking 'SettingsList' and reporting an error if any.------ >>> checkSettingsList [(SettingsEnablePush,2)]--- Just (ConnectionError ProtocolError "enable push must be 0 or 1")-checkSettingsList :: SettingsList -> Maybe HTTP2Error-checkSettingsList settings = case mapMaybe checkSettingsValue settings of- [] -> Nothing- (x:_) -> Just x--checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error-checkSettingsValue (SettingsEnablePush,v)- | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1"-checkSettingsValue (SettingsInitialWindowSize,v)- | v > 2147483647 = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535"-checkSettingsValue (SettingsMaxFrameSize,v)- | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215"-checkSettingsValue _ = Nothing---------------------------------------------------------------------- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context.-data Settings = Settings {- headerTableSize :: !Int- , enablePush :: !Bool- , maxConcurrentStreams :: !(Maybe Int)- , initialWindowSize :: !WindowSize- , maxFrameSize :: !Int- , maxHeaderBlockSize :: !(Maybe Int)- } deriving (Show)---- | The default settings.------ >>> defaultSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Nothing}-defaultSettings :: Settings-defaultSettings = Settings {- headerTableSize = 4096- , enablePush = True- , maxConcurrentStreams = Nothing- , initialWindowSize = defaultInitialWindowSize- , maxFrameSize = 16384- , maxHeaderBlockSize = Nothing- }---- | Updating settings.------ >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)]--- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200}-updateSettings :: Settings -> SettingsList -> Settings-updateSettings settings kvs = foldl' update settings kvs- where- update def (SettingsHeaderTableSize,x) = def { headerTableSize = x }- -- fixme: x should be 0 or 1- update def (SettingsEnablePush,x) = def { enablePush = x > 0 }- update def (SettingsMaxConcurrentStreams,x) = def { maxConcurrentStreams = Just x }- update def (SettingsInitialWindowSize,x) = def { initialWindowSize = x }- update def (SettingsMaxFrameSize,x) = def { maxFrameSize = x }- update def (SettingsMaxHeaderBlockSize,x) = def { maxHeaderBlockSize = Just x }---- | The type for window size.-type WindowSize = Int---- | The default initial window size.------ >>> defaultInitialWindowSize--- 65535-defaultInitialWindowSize :: WindowSize-defaultInitialWindowSize = 65535---- | The maximum window size.------ >>> maxWindowSize--- 2147483647-maxWindowSize :: WindowSize-maxWindowSize = 2147483647---- | Checking if a window size exceeds the maximum window size.------ >>> isWindowOverflow 10--- False--- >>> isWindowOverflow maxWindowSize--- False--- >>> isWindowOverflow (maxWindowSize + 1)--- True-isWindowOverflow :: WindowSize -> Bool-isWindowOverflow w = testBit w 31----- | Default concurrency.------ >>> recommendedConcurrency--- 100-recommendedConcurrency :: Int-recommendedConcurrency = 100---------------------------------------------------------------------- | The type for weight in priority. Its values are from 1 to 256.-type Weight = Int---- | Type for stream priority-data Priority = Priority {- exclusive :: !Bool- , streamDependency :: !StreamId- , weight :: !Weight- } deriving (Show, Read, Eq)---- | Default priority which depends on stream 0.------ >>> defaultPriority--- Priority {exclusive = False, streamDependency = 0, weight = 16}-defaultPriority :: Priority-defaultPriority = Priority False 0 16---- | Highest priority which depends on stream 0.------ >>> highestPriority--- Priority {exclusive = False, streamDependency = 0, weight = 256}-highestPriority :: Priority-highestPriority = Priority False 0 256---------------------------------------------------------------------- | The type for raw frame type.-type FrameType = Word8--minFrameType :: FrameType-minFrameType = 0--maxFrameType :: FrameType-maxFrameType = 9---- | The type for frame type.-data FrameTypeId = FrameData- | FrameHeaders- | FramePriority- | FrameRSTStream- | FrameSettings- | FramePushPromise- | FramePing- | FrameGoAway- | FrameWindowUpdate- | FrameContinuation- | FrameUnknown FrameType- deriving (Show, Eq, Ord)---- | Converting 'FrameTypeId' to 'FrameType'.------ >>> fromFrameTypeId FrameData--- 0--- >>> fromFrameTypeId FrameContinuation--- 9--- >>> fromFrameTypeId (FrameUnknown 10)--- 10-fromFrameTypeId :: FrameTypeId -> FrameType-fromFrameTypeId FrameData = 0-fromFrameTypeId FrameHeaders = 1-fromFrameTypeId FramePriority = 2-fromFrameTypeId FrameRSTStream = 3-fromFrameTypeId FrameSettings = 4-fromFrameTypeId FramePushPromise = 5-fromFrameTypeId FramePing = 6-fromFrameTypeId FrameGoAway = 7-fromFrameTypeId FrameWindowUpdate = 8-fromFrameTypeId FrameContinuation = 9-fromFrameTypeId (FrameUnknown x) = x---- | Converting 'FrameType' to 'FrameTypeId'.------ >>> toFrameTypeId 0--- FrameData--- >>> toFrameTypeId 9--- FrameContinuation--- >>> toFrameTypeId 10--- FrameUnknown 10-toFrameTypeId :: FrameType -> FrameTypeId-toFrameTypeId 0 = FrameData-toFrameTypeId 1 = FrameHeaders-toFrameTypeId 2 = FramePriority-toFrameTypeId 3 = FrameRSTStream-toFrameTypeId 4 = FrameSettings-toFrameTypeId 5 = FramePushPromise-toFrameTypeId 6 = FramePing-toFrameTypeId 7 = FrameGoAway-toFrameTypeId 8 = FrameWindowUpdate-toFrameTypeId 9 = FrameContinuation-toFrameTypeId x = FrameUnknown x---------------------------------------------------------------------- | The maximum length of HTTP/2 payload.------ >>> maxPayloadLength--- 16384-maxPayloadLength :: Int-maxPayloadLength = 2^(14::Int)--------------------------------------------------------------------- Flags---- | The type for flags.-type FrameFlags = Word8---- | The initial value of flags. No flags are set.------ >>> defaultFlags--- 0-defaultFlags :: FrameFlags-defaultFlags = 0---- | Checking if the END_STREAM flag is set.--- >>> testEndStream 0x1--- True-testEndStream :: FrameFlags -> Bool-testEndStream x = x `testBit` 0---- | Checking if the ACK flag is set.--- >>> testAck 0x1--- True-testAck :: FrameFlags -> Bool-testAck x = x `testBit` 0 -- fixme: is the spec intentional?---- | Checking if the END_HEADERS flag is set.------ >>> testEndHeader 0x4--- True-testEndHeader :: FrameFlags -> Bool-testEndHeader x = x `testBit` 2---- | Checking if the PADDED flag is set.------ >>> testPadded 0x8--- True-testPadded :: FrameFlags -> Bool-testPadded x = x `testBit` 3---- | Checking if the PRIORITY flag is set.------ >>> testPriority 0x20--- True-testPriority :: FrameFlags -> Bool-testPriority x = x `testBit` 5---- | Setting the END_STREAM flag.------ >>> setEndStream 0--- 1-setEndStream :: FrameFlags -> FrameFlags-setEndStream x = x `setBit` 0---- | Setting the ACK flag.------ >>> setAck 0--- 1-setAck :: FrameFlags -> FrameFlags-setAck x = x `setBit` 0 -- fixme: is the spec intentional?---- | Setting the END_HEADERS flag.------ >>> setEndHeader 0--- 4-setEndHeader :: FrameFlags -> FrameFlags-setEndHeader x = x `setBit` 2---- | Setting the PADDED flag.------ >>> setPadded 0--- 8-setPadded :: FrameFlags -> FrameFlags-setPadded x = x `setBit` 3---- | Setting the PRIORITY flag.------ >>> setPriority 0--- 32-setPriority :: FrameFlags -> FrameFlags-setPriority x = x `setBit` 5---------------------------------------------------------------------- | The type for stream identifier-type StreamId = Int---- | Checking if the stream identifier for control.------ >>> isControl 0--- True--- >>> isControl 1--- False-isControl :: StreamId -> Bool-isControl 0 = True-isControl _ = False---- | Checking if the stream identifier for request.------ >>> isRequest 0--- False--- >>> isRequest 1--- True-isRequest :: StreamId -> Bool-isRequest = odd---- | Checking if the stream identifier for response.------ >>> isResponse 0--- False--- >>> isResponse 2--- True-isResponse :: StreamId -> Bool-isResponse 0 = False-isResponse n = even n---- | Checking if the exclusive flag is set.-testExclusive :: StreamId -> Bool-testExclusive n = n `testBit` 31---- | Setting the exclusive flag.-setExclusive :: StreamId -> StreamId-setExclusive n = n `setBit` 31---- | Clearing the exclusive flag.-clearExclusive :: StreamId -> StreamId-clearExclusive n = n `clearBit` 31---------------------------------------------------------------------- | The type for fragments of a header encoded with HPACK.-type HeaderBlockFragment = ByteString---- | The type for padding in payloads.-type Padding = ByteString---------------------------------------------------------------------- | The data type for HTTP/2 frames.-data Frame = Frame- { frameHeader :: !FrameHeader- , framePayload :: !FramePayload- } deriving (Show, Read, Eq)---- | The data type for HTTP/2 frame headers.-data FrameHeader = FrameHeader- { payloadLength :: !Int- , flags :: !FrameFlags- , streamId :: !StreamId- } deriving (Show, Read, Eq)---- | The data type for HTTP/2 frame payloads.-data FramePayload =- DataFrame !ByteString- | HeadersFrame !(Maybe Priority) !HeaderBlockFragment- | PriorityFrame !Priority- | RSTStreamFrame !ErrorCodeId- | SettingsFrame !SettingsList- | PushPromiseFrame !StreamId !HeaderBlockFragment- | PingFrame !ByteString- | GoAwayFrame !StreamId !ErrorCodeId !ByteString- | WindowUpdateFrame !WindowSize- | ContinuationFrame !HeaderBlockFragment- | UnknownFrame !FrameType !ByteString- deriving (Show, Read, Eq)---------------------------------------------------------------------- | Getting 'FrameType' from 'FramePayload'.------ >>> framePayloadToFrameTypeId (DataFrame "body")--- FrameData-framePayloadToFrameTypeId :: FramePayload -> FrameTypeId-framePayloadToFrameTypeId (DataFrame _) = FrameData-framePayloadToFrameTypeId (HeadersFrame _ _) = FrameHeaders-framePayloadToFrameTypeId (PriorityFrame _) = FramePriority-framePayloadToFrameTypeId (RSTStreamFrame _) = FrameRSTStream-framePayloadToFrameTypeId (SettingsFrame _) = FrameSettings-framePayloadToFrameTypeId (PushPromiseFrame _ _) = FramePushPromise-framePayloadToFrameTypeId (PingFrame _) = FramePing-framePayloadToFrameTypeId (GoAwayFrame _ _ _) = FrameGoAway-framePayloadToFrameTypeId (WindowUpdateFrame _) = FrameWindowUpdate-framePayloadToFrameTypeId (ContinuationFrame _) = FrameContinuation-framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8---------------------------------------------------------------------- | Checking if padding is defined in this frame type.------ >>> isPaddingDefined $ DataFrame ""--- True--- >>> isPaddingDefined $ PingFrame ""--- False-isPaddingDefined :: FramePayload -> Bool-isPaddingDefined (DataFrame _) = True-isPaddingDefined (HeadersFrame _ _) = True-isPaddingDefined (PriorityFrame _) = False-isPaddingDefined (RSTStreamFrame _) = False-isPaddingDefined (SettingsFrame _) = False-isPaddingDefined (PushPromiseFrame _ _) = True-isPaddingDefined (PingFrame _) = False-isPaddingDefined (GoAwayFrame _ _ _) = False-isPaddingDefined (WindowUpdateFrame _) = False-isPaddingDefined (ContinuationFrame _) = False-isPaddingDefined (UnknownFrame _ _) = False
bench-priority/BinaryHeap.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts, CPP #-}
bench-priority/BinaryHeapSTM.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts, CPP #-}
bench-priority/Main.hs view
@@ -152,7 +152,7 @@ ents <- createB xs q mapM_ (\ent -> atomically $ B.delete ent q) ents -createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO ([B.Entry Key])+createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO [B.Entry Key] createB [] _ = return [] createB ((k,w):xs) !q = do ent <- atomically $ B.newEntry k w@@ -180,7 +180,7 @@ ents <- createBIO xs q mapM_ (\ent -> BIO.delete ent q) ents -createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO ([BIO.Entry Key])+createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO [BIO.Entry Key] createBIO [] _ = return [] createBIO ((k,w):xs) !q = do ent <- BIO.newEntry k w
bench-priority/RandomSkewHeap.hs view
@@ -103,5 +103,6 @@ go !q [] = q go !q ((k,w,v):xks) = go (enqueue k w v q) xks +{-# NOINLINE gen #-} gen :: GenIO gen = unsafePerformIO createSystemRandom
http2.cabal view
@@ -1,11 +1,11 @@ Name: http2-Version: 2.0.6+Version: 3.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3 License-File: LICENSE Synopsis: HTTP/2 library-Description: HTTP/2 library including frames, priority queues, HPACK and server.+Description: HTTP/2 library including frames, priority queues, HPACK, client and server. Homepage: https://github.com/kazu-yamamoto/http2 Category: Network Cabal-Version: >= 1.10@@ -45,19 +45,40 @@ Description: Development commands Default: False +Flag h2spec+ Description: Development commands+ Default: False++Flag doc+ Description: Doctest+ Default: False+ ---------------------------------------------------------------- Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.HPACK+ Network.HPACK.Internal Network.HPACK.Table Network.HPACK.Token Network.HTTP2+ Network.HTTP2.Client+ Network.HTTP2.Client.Internal+ Network.HTTP2.Frame+ Network.HTTP2.Internal Network.HTTP2.Priority+ Network.HTTP2.Priority.Internal Network.HTTP2.Server+ Network.HTTP2.Server.Internal Other-Modules: Imports Network.HPACK.Builder+ Network.HTTP2.Client.Types+ Network.HTTP2.Client.Run+ Network.HPACK.HeaderBlock+ Network.HPACK.HeaderBlock.Decode+ Network.HPACK.HeaderBlock.Encode+ Network.HPACK.HeaderBlock.Integer Network.HPACK.Huffman Network.HPACK.Huffman.Bit Network.HPACK.Huffman.ByteString@@ -66,35 +87,35 @@ Network.HPACK.Huffman.Params Network.HPACK.Huffman.Table Network.HPACK.Huffman.Tree- Network.HPACK.HeaderBlock- Network.HPACK.HeaderBlock.Decode- Network.HPACK.HeaderBlock.Encode- Network.HPACK.HeaderBlock.Integer Network.HPACK.Table.Dynamic Network.HPACK.Table.Entry Network.HPACK.Table.RevIndex Network.HPACK.Table.Static Network.HPACK.Types- Network.HTTP2.Decode- Network.HTTP2.Encode+ Network.HTTP2.Arch+ Network.HTTP2.Arch.Cache+ Network.HTTP2.Arch.Config+ Network.HTTP2.Arch.Context+ Network.HTTP2.Arch.EncodeFrame+ Network.HTTP2.Arch.File+ Network.HTTP2.Arch.HPACK+ Network.HTTP2.Arch.Manager+ Network.HTTP2.Arch.Queue+ Network.HTTP2.Arch.Rate+ Network.HTTP2.Arch.ReadN+ Network.HTTP2.Arch.Receiver+ Network.HTTP2.Arch.Sender+ Network.HTTP2.Arch.Status+ Network.HTTP2.Arch.Stream+ Network.HTTP2.Arch.Types+ Network.HTTP2.Frame.Decode+ Network.HTTP2.Frame.Encode+ Network.HTTP2.Frame.Types 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.9 && < 5 , array , bytestring >= 0.10@@ -102,30 +123,33 @@ , containers >= 0.5 , http-types , network- , network-byte-order >= 0.1.1+ , network-byte-order >= 0.1.5 , psqueues , stm , time-manager- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ , unix-time+ Default-Extensions: Strict StrictData ---------------------------------------------------------------- Test-Suite doctest+ if flag(doc)+ Buildable: True+ else+ Buildable: False Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -Wall Main-Is: doctests.hs- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , doctest >= 0.9.3- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010- HS-Source-Dirs: test, .+ HS-Source-Dirs: test Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: HPACK.DecodeSpec@@ -135,139 +159,64 @@ HPACK.IntegerSpec HTTP2.FrameSpec HTTP2.PrioritySpec- Imports- Network.HPACK- Network.HPACK.Builder- Network.HPACK.HeaderBlock- Network.HPACK.HeaderBlock.Decode- Network.HPACK.HeaderBlock.Encode- Network.HPACK.HeaderBlock.Integer- Network.HPACK.Huffman- Network.HPACK.Huffman.Bit- Network.HPACK.Huffman.Decode- Network.HPACK.Huffman.Encode- Network.HPACK.Huffman.Params- Network.HPACK.Huffman.Table- Network.HPACK.Huffman.Tree- Network.HPACK.Table- Network.HPACK.Table.Dynamic- Network.HPACK.Table.Entry- Network.HPACK.Table.RevIndex- 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+ HTTP2.ServerSpec+ Build-Depends: base >= 4.9 && < 5+ , async , base16-bytestring >= 1.0 , bytestring- , case-insensitive- , containers+ , cryptonite , hspec >= 1.3 , http-types- , network- , network-byte-order- , psqueues- , stm- , time-manager- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ , http2+ , network-run >= 0.1.0+ , typed-process+ Default-Extensions: Strict StrictData+ Build-Tool-Depends: hspec-discover:hspec-discover ++Test-Suite spec2+ if flag(h2spec)+ Buildable: True+ else+ Buildable: False+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ HS-Source-Dirs: test2+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: ServerSpec+ Build-Depends: base >= 4.9 && < 5+ , bytestring+ , hspec >= 1.3+ , http-types+ , http2+ , network-run >= 0.1.0+ , typed-process+ Default-Extensions: Strict StrictData+ Build-Tool-Depends: hspec-discover:hspec-discover+ Test-Suite hpack Type: exitcode-stdio-1.0 Default-Language: Haskell2010- HS-Source-Dirs: test-hpack, .+ HS-Source-Dirs: test-hpack Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: HPACKDecode HPACKSpec JSON- Imports- Network.HPACK- Network.HPACK.Builder- Network.HPACK.HeaderBlock- Network.HPACK.HeaderBlock.Decode- Network.HPACK.HeaderBlock.Encode- Network.HPACK.HeaderBlock.Integer- Network.HPACK.Huffman- Network.HPACK.Huffman.Bit- Network.HPACK.Huffman.Decode- Network.HPACK.Huffman.Encode- Network.HPACK.Huffman.Params- Network.HPACK.Huffman.Table- Network.HPACK.Huffman.Tree- Network.HPACK.Table- Network.HPACK.Table.Dynamic- Network.HPACK.Table.Entry- Network.HPACK.Table.RevIndex- 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+ Build-Depends: base >= 4.9 && < 5 , aeson- , aeson-pretty- , array , base16-bytestring >= 1.0 , bytestring- , case-insensitive- , containers , directory , filepath , hspec >= 1.3- , http-types- , network- , network-byte-order- , psqueues- , stm+ , http2 , text- , time-manager , unordered-containers , vector- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData+ Build-Tool-Depends: hspec-discover:hspec-discover Test-Suite frame Type: exitcode-stdio-1.0@@ -278,7 +227,7 @@ Other-Modules: Case FrameSpec JSON- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , Glob >= 0.9 , aeson , aeson-pretty@@ -291,11 +240,46 @@ , network-byte-order , text , unordered-containers- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData+ Build-Tool-Depends: hspec-discover:hspec-discover ---------------------------------------------------------------- +Executable client+ Default-Language: Haskell2010+ HS-Source-Dirs: util+ GHC-Options: -Wall -threaded+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: client.hs+ Build-Depends: base >= 4.9 && < 5+ , bytestring+ , http-types+ , http2+ , network-run+ Default-Extensions: Strict StrictData++Executable server+ Default-Language: Haskell2010+ HS-Source-Dirs: util+ GHC-Options: -Wall -threaded+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: server.hs+ Build-Depends: base >= 4.9 && < 5+ , bytestring+ , cryptonite+ , http2+ , http-types+ , network-run+ Default-Extensions: Strict StrictData++----------------------------------------------------------------+ Executable hpack-encode Default-Language: Haskell2010 HS-Source-Dirs: test-hpack@@ -307,7 +291,7 @@ Main-Is: hpack-encode.hs Other-Modules: HPACKEncode JSON- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , aeson , aeson-pretty , array@@ -321,6 +305,7 @@ , unordered-containers , vector , word8+ Default-Extensions: Strict StrictData Executable hpack-debug Default-Language: Haskell2010@@ -333,7 +318,7 @@ Main-Is: hpack-debug.hs Other-Modules: HPACKDecode JSON- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , aeson , array , base16-bytestring >= 1.0@@ -346,8 +331,7 @@ , unordered-containers , vector , word8- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData Executable hpack-stat Default-Language: Haskell2010@@ -359,7 +343,7 @@ Buildable: False Main-Is: hpack-stat.hs Other-Modules: JSON- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , aeson , aeson-pretty , array@@ -374,8 +358,7 @@ , unordered-containers , vector , word8- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData Executable frame-encode Default-Language: Haskell2010@@ -388,7 +371,7 @@ Main-Is: frame-encode.hs Other-Modules: Case JSON- Build-Depends: base >= 4 && < 5+ Build-Depends: base >= 4.9 && < 5 , aeson , aeson-pretty , base16-bytestring >= 1.0@@ -396,9 +379,10 @@ , http2 , text , unordered-containers- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData +----------------------------------------------------------------+ Benchmark priority Type: exitcode-stdio-1.0 Default-Language: Haskell2010@@ -413,7 +397,7 @@ RingOfQueues RingOfQueuesSTM Network.HTTP2.Priority.PSQ- Build-Depends: base+ Build-Depends: base >= 4.9 && < 5 , array , case-insensitive , containers@@ -423,6 +407,7 @@ , network-byte-order , psqueues , stm+ Default-Extensions: Strict StrictData Benchmark header-compression Type: exitcode-stdio-1.0@@ -439,5 +424,4 @@ , network-byte-order , stm , http2- if impl(ghc >= 8)- Default-Extensions: Strict StrictData+ Default-Extensions: Strict StrictData
test-frame/Case.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-}+{-# LANGUAGE RecordWildCards, CPP #-} module Case where @@ -9,7 +9,7 @@ import qualified Data.ByteString.Base16 as B16 import JSON-import Network.HTTP2+import Network.HTTP2.Frame data CaseSource = CaseSource { cs_description :: String
test-frame/FrameSpec.hs view
@@ -9,7 +9,7 @@ import Data.Aeson (eitherDecode) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL-import Network.HTTP2+import Network.HTTP2.Frame import System.FilePath.Glob (compile, globDir) import Test.Hspec
test-frame/JSON.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -15,11 +15,11 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (union)-import Data.Maybe (fromJust, fromMaybe)+import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP2+import Network.HTTP2.Frame ---------------------------------------------------------------- @@ -42,7 +42,7 @@ , fpPad :: Maybe Pad } deriving (Show, Read) -data Pad = Pad Padding deriving (Show, Read)+newtype Pad = Pad Padding deriving (Show, Read) unPad :: Pad -> Padding unPad (Pad x) = x@@ -91,9 +91,9 @@ "data" .= body ] toJSON (HeadersFrame mpri hdr) = object [- "exclusive" .= fromMaybe Null (toJSON . exclusive <$> mpri)- , "stream_dependency" .= fromMaybe Null (toJSON . streamDependency <$> mpri)- , "weight" .= fromMaybe Null (toJSON . weight <$> mpri)+ "exclusive" .= maybe Null (toJSON . exclusive) mpri+ , "stream_dependency" .= maybe Null (toJSON . streamDependency) mpri+ , "weight" .= maybe Null (toJSON . weight) mpri , "header_block_fragment" .= hdr ] toJSON (PriorityFrame pri) = object [
test-frame/frame-encode.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} module Main where @@ -13,7 +13,7 @@ main = do args <- getArgs xs <- getContents- if length args /= 0 then -- "-w"+ if not (null args) then -- "-w" printWire xs else printJSON xs
test-hpack/HPACKDecode.hs view
@@ -21,14 +21,14 @@ import JSON -data Conf = Conf {+newtype Conf = Conf { debug :: Bool } data Result = Pass | Fail String deriving (Eq,Show) run :: Bool -> Test -> IO Result-run _ (Test _ []) = return $ Pass+run _ (Test _ []) = return Pass run d (Test _ ccs) = do -- 'size c' must not be used. Initial value is defaultDynamicTableSize! withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dyntbl -> do@@ -39,7 +39,7 @@ -> [Case] -> DynamicTable -> IO Result-testLoop _ [] _ = return $ Pass+testLoop _ [] _ = return Pass testLoop conf (c:cs) dyntbl = do res <- test conf c dyntbl case res of
test-hpack/HPACKEncode.hs view
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as C8 import Data.Char+import Data.Maybe (fromMaybe) import Network.HPACK import Network.HPACK.Table @@ -25,7 +26,7 @@ run :: Bool -> EncodeStrategy -> Test -> IO [ByteString] run _ _ (Test _ []) = return [] run d stgy (Test _ ccs@(c:_)) = do- let siz = maybe 4096 id $ size c+ let siz = fromMaybe 4096 $ size c withDynamicTableForEncoding siz $ \dyntbl -> do let conf = Conf { debug = d, enc = encodeHeader stgy 4096 } testLoop conf ccs dyntbl []
test-hpack/JSON.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module JSON (
test/HPACK/HeaderBlock.hs view
@@ -4,7 +4,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Base16-import Network.HPACK.Types+import Network.HPACK fromHexString :: ByteString -> ByteString fromHexString = decodeLenient
test/HPACK/HuffmanSpec.hs view
@@ -10,7 +10,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) import Network.HPACK-import Network.HPACK.Huffman+import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck
test/HPACK/IntegerSpec.hs view
@@ -1,9 +1,9 @@ module HPACK.IntegerSpec where -import Network.HPACK.HeaderBlock.Integer+import qualified Data.ByteString as BS+import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck-import qualified Data.ByteString as BS dual :: Int -> Int -> Expectation dual n i = do
test/HTTP2/FrameSpec.hs view
@@ -5,9 +5,7 @@ import Test.Hspec import Data.ByteString.Char8 ()-import Network.HTTP2.Decode-import Network.HTTP2.Encode-import Network.HTTP2.Types+import Network.HTTP2.Frame spec :: Spec spec = do
test/HTTP2/PrioritySpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, CPP #-}+{-# OPTIONS_GHC -Wno-deprecations #-} module HTTP2.PrioritySpec where @@ -8,9 +9,9 @@ import Data.List (group, sort) import Test.Hspec +import Network.HTTP2.Frame import Network.HTTP2.Priority-import qualified Network.HTTP2.Priority.PSQ as P-import Network.HTTP2.Types+import qualified Network.HTTP2.Priority.Internal as P spec :: Spec spec = do
+ test/HTTP2/ServerSpec.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module HTTP2.ServerSpec where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Monad+import Crypto.Hash (Context, SHA1) -- cryptonite+import qualified Crypto.Hash as CH+import qualified Data.ByteString as B+import Data.ByteString.Builder (byteString)+import Data.ByteString.Char8+import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import Network.Run.TCP+import Test.Hspec++import Network.HPACK+import qualified Network.HTTP2.Client as C+import Network.HTTP2.Server++port :: String+port = "8080"++host :: String+host = "127.0.0.1"++spec :: Spec+spec = do+ describe "server" $ do+ it "handles normal cases" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runClient++runServer :: IO ()+runServer = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (`run` server)++server :: Server+server req _aux sendResponse = case requestMethod req of+ Just "GET" -> case requestPath req of+ Just "/" -> sendResponse responseHello []+ Just "/push" -> do+ let pp = pushPromise "/push-pp" responsePP 0+ sendResponse responseHello [pp]+ _ -> sendResponse response404 []+ Just "POST" -> case requestPath req of+ Just "/echo" -> sendResponse (responseEcho req) []+ _ -> sendResponse responseHello []+ _ -> sendResponse response405 []++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++responsePP :: Response+responsePP = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")+ ,("x-push", "True")]+ body = byteString "Push\n"++response404 :: Response+response404 = responseNoBody notFound404 []++response405 :: Response+response405 = responseNoBody methodNotAllowed405 []++responseEcho :: Request -> Response+responseEcho req = setResponseTrailersMaker h2rsp maker+ where+ h2rsp = responseStreaming ok200 header streamingBody+ header = [("Content-Type", "text/plain")]+ streamingBody write _flush = do+ loop+ mt <- getRequestTrailers req+ firstTrailerValue <$> mt `shouldBe` Just "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+ where+ loop = do+ bs <- getRequestBodyChunk req+ unless (B.null bs) $ do+ void $ write $ byteString bs+ loop+ maker = trailersMaker (CH.hashInit :: Context SHA1)++-- 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++runClient :: IO ()+runClient = runTCPClient host port $ runHTTP2Client+ where+ authority = C8.pack host+ cliconf = C.ClientConfig "http" authority 20+ runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> C.run cliconf conf client)+ client sendRequest = mapConcurrently_ ($ sendRequest) clients+ clients = [client0,client1,client2,client3,client4]++client0 :: C.Client ()+client0 sendRequest = do+ let req = C.requestNoBody methodGet "/" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200++client1 :: C.Client ()+client1 sendRequest = do+ let req = C.requestNoBody methodGet "/push-pp" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just notFound404++client2 :: C.Client ()+client2 sendRequest = do+ let req = C.requestNoBody methodPut "/" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just methodNotAllowed405++client3 :: C.Client ()+client3 sendRequest = do+ let req0 = C.requestFile methodPost "/echo" [] $ FileSpec "test/inputFile" 0 1012731+ req = C.setRequestTrailersMaker req0 maker+ sendRequest req $ \rsp -> do+ let comsumeBody = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) comsumeBody+ comsumeBody+ mt <- C.getResponseTrailers rsp+ firstTrailerValue <$> mt `shouldBe` Just "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+ where+ !maker = trailersMaker (CH.hashInit :: Context SHA1)++client4 :: C.Client ()+client4 sendRequest = do+ let req0 = C.requestNoBody methodGet "/push" []+ sendRequest req0 $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ let req1 = C.requestNoBody methodGet "/push-pp" []+ sendRequest req1 $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200++firstTrailerValue :: HeaderTable -> HeaderValue+firstTrailerValue = snd . Prelude.head . fst
+ test2/ServerSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module ServerSpec (spec) where++import Control.Concurrent+import qualified Control.Exception as E+import Data.ByteString.Builder (byteString)+import Network.HTTP.Types+import Network.Run.TCP+import System.Exit+import System.Process.Typed+import Test.Hspec++import Network.HTTP2.Server++port :: String+port = "8080"++host :: String+host = "127.0.0.1"++spec :: Spec+spec = do+ describe "server" $ do+ it "handles error cases" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ runProcess (proc "h2spec" ["-h",host,"-p",port]) `shouldReturn` ExitSuccess++runServer :: IO ()+runServer = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (`run` server)++server :: Server+server req _aux sendResponse = case requestMethod req of+ Just "GET" -> case requestPath req of+ Just "/" -> sendResponse responseHello []+ _ -> sendResponse response404 []+ _ -> sendResponse response405 []++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++response404 :: Response+response404 = responseNoBody notFound404 []++response405 :: Response+response405 = responseNoBody methodNotAllowed405 []
+ test2/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ util/client.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent (forkIO, threadDelay)+import qualified Control.Exception as E+import Control.Monad+import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import Network.HTTP2.Client+import Network.Run.TCP (runTCPClient) -- network-run+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ when (length args /= 2) $ do+ putStrLn "client <addr> <port>"+ exitFailure+ let [host,port] = args+ runTCPClient host port $ runHTTP2Client host+ where+ cliconf host = ClientConfig "http" (C8.pack host) 20+ runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> run (cliconf host) conf client)+ client sendRequest = do+ let req = requestNoBody methodGet "/" []+ _ <- forkIO $ sendRequest req $ \rsp -> do+ print rsp+ getResponseBodyChunk rsp >>= C8.putStrLn+ sendRequest req $ \rsp -> do+ threadDelay 100000+ print rsp+ getResponseBodyChunk rsp >>= C8.putStrLn
+ util/server.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import qualified Control.Exception as E+import Control.Monad+import Crypto.Hash (Context, SHA1) -- cryptonite+import qualified Crypto.Hash as CH+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as C8+import Network.HPACK+import Network.HPACK.Token+import Network.HTTP.Types+import Network.HTTP2.Server+import Network.Run.TCP -- network-run+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ when (length args /= 2) $ do+ putStrLn "server <addr> <port>"+ exitFailure+ let [host,port] = args+ runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (`run` server)+ server req _aux sendResponse = case getHeaderValue tokenMethod vt of+ Just "GET" -> sendResponse responseHello []+ Just "POST" -> sendResponse (responseEcho req) []+ _ -> sendResponse response404 []+ where+ (_, vt) = requestHeaders req++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++response404 :: Response+response404 = responseNoBody notFound404 []++responseEcho :: Request -> Response+responseEcho req = setResponseTrailersMaker h2rsp maker+ where+ h2rsp = responseStreaming ok200 header streamingBody+ header = [("Content-Type", "text/plain")]+ streamingBody write _flush = loop+ where+ loop = do+ bs <- getRequestBodyChunk req+ unless (B.null bs) $ do+ void $ write $ byteString bs+ loop+ maker = trailersMaker (CH.hashInit :: Context SHA1)++-- 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