http2 5.1.4 → 5.4.1
raw patch · 67 files changed
Files
- ChangeLog.md +148/−1
- Imports.hs +13/−0
- Network/HPACK.hs +11/−14
- Network/HPACK/HeaderBlock.hs +3/−3
- Network/HPACK/HeaderBlock/Decode.hs +17/−33
- Network/HPACK/HeaderBlock/Encode.hs +18/−16
- Network/HPACK/HeaderBlock/Integer.hs +0/−2
- Network/HPACK/Huffman/Tree.hs +7/−3
- Network/HPACK/Internal.hs +5/−0
- Network/HPACK/Table/Dynamic.hs +7/−5
- Network/HPACK/Table/Entry.hs +14/−14
- Network/HPACK/Table/RevIndex.hs +28/−27
- Network/HPACK/Table/Static.hs +1/−0
- Network/HPACK/Token.hs +2/−482
- Network/HPACK/Types.hs +2/−29
- Network/HTTP2/Client.hs +22/−137
- Network/HTTP2/Client/Internal.hs +4/−1
- Network/HTTP2/Client/Run.hs +117/−89
- Network/HTTP2/Client/Types.hs +0/−25
- Network/HTTP2/Frame.hs +1/−1
- Network/HTTP2/Frame/Decode.hs +18/−11
- Network/HTTP2/Frame/Types.hs +8/−9
- Network/HTTP2/H2.hs +2/−8
- Network/HTTP2/H2/Config.hs +22/−20
- Network/HTTP2/H2/Context.hs +97/−82
- Network/HTTP2/H2/EncodeFrame.hs +3/−3
- Network/HTTP2/H2/File.hs +0/−38
- Network/HTTP2/H2/HPACK.hs +16/−16
- Network/HTTP2/H2/Manager.hs +0/−182
- Network/HTTP2/H2/Queue.hs +6/−13
- Network/HTTP2/H2/ReadN.hs +0/−40
- Network/HTTP2/H2/Receiver.hs +177/−120
- Network/HTTP2/H2/Sender.hs +161/−337
- Network/HTTP2/H2/Settings.hs +14/−8
- Network/HTTP2/H2/Status.hs +0/−44
- Network/HTTP2/H2/Stream.hs +85/−16
- Network/HTTP2/H2/StreamTable.hs +1/−1
- Network/HTTP2/H2/Sync.hs +118/−0
- Network/HTTP2/H2/Types.hs +53/−153
- Network/HTTP2/H2/Window.hs +29/−5
- Network/HTTP2/Internal.hs +0/−39
- Network/HTTP2/Server.hs +20/−168
- Network/HTTP2/Server/Internal.hs +5/−1
- Network/HTTP2/Server/Run.hs +65/−54
- Network/HTTP2/Server/Types.hs +0/−43
- Network/HTTP2/Server/Worker.hs +148/−206
- bench-hpack/Main.hs +3/−3
- http2.cabal +33/−36
- test-frame/FrameSpec.hs +2/−2
- test-frame/frame-encode.hs +0/−2
- test-hpack/HPACKDecode.hs +3/−3
- test-hpack/HPACKEncode.hs +1/−1
- test-hpack/JSON.hs +11/−8
- test-hpack/hpack-stat.hs +2/−1
- test/HPACK/DecodeSpec.hs +5/−5
- test/HPACK/EncodeSpec.hs +2/−2
- test/HPACK/HeaderBlock.hs +8/−8
- test/HTTP2/ClientSpec.hs +12/−11
- test/HTTP2/ServerSpec.hs +22/−19
- test2/ServerSpec.hs +1/−2
- util/Client.hs +117/−0
- util/Monitor.hs +30/−0
- util/Server.hs +77/−0
- util/client.hs +0/−48
- util/h2c-client.hs +95/−0
- util/h2c-server.hs +65/−0
- util/server.hs +0/−75
ChangeLog.md view
@@ -1,3 +1,150 @@+# ChangeLog for http2++## 5.4.1++* Ensure sender notices when receiver has terminated.+ [#167](https://github.com/kazu-yamamoto/http2/pull/167)++## 5.4.0++* Providing `defaultConfig`.+* Except the item above, this version is identical to v5.3.11 which+ includes breaking changes and is thus deprecated.++## 5.3.11++* Implementing `auxSendPing` for client.+* Server and client terminates their threads in the right order.+* Using `copy` in frame decoders to avoid potential fragmentation of+ `ByteString`.+* Defining `confReadNTimeout` (default to `False`). If `confReadN`+ implements timeout by itself, set it to `True`.+* TCP closing is now treaated as `ConnectionIsClosed` instead of+ `ConnectionIsTimeout`.+* GOAWAY now contains a right last streamd ID.++## 5.3.10++* Introducing closure.+ [#157](https://github.com/kazu-yamamoto/http2/pull/157)++## 5.3.9++* Using `ThreadManager` of `time-manager`.++## 5.3.8++* `forkManagedTimeout` ensures that only one asynchronous exception is+ thrown. Fixing the thread leak via `Weak ThreadId` and `modifyTVar'`.+ [#156](https://github.com/kazu-yamamoto/http2/pull/156)++## 5.3.7++* Using `withHandle` of time-manager.+* Getting `Handle` for each thread.+* Providing allocSimpleConfig' to enable customizing WAI tiemout manager.+* Monitor option (-m) for h2c-client and h2c-server.++## 5.3.6++* Making `runIO` friendly with the new synchronism mechanism.+ [#152](https://github.com/kazu-yamamoto/http2/pull/152)+* Re-throwing asynchronous exceptions to prevent thread leak.+* Simplifying the synchronism mechanism between workers and the sender.+ [#148](https://github.com/kazu-yamamoto/http2/pull/148)++## 5.3.5++* Using `http-semantics` v0.3.+* Deprecating `numberOfWorkers`.+* Removing `unliftio`.+* Avoid `undefined` in client.+ [#146](https://github.com/kazu-yamamoto/http2/pull/146)++## 5.3.4++* Support stream cancellation+ [#142](https://github.com/kazu-yamamoto/http2/pull/142)++## 5.3.3++* Enclosing IPv6 literal authority with square brackets.+ [#143](https://github.com/kazu-yamamoto/http2/pull/143)++## 5.3.2++* Avoid unnecessary empty data frames at end of stream+ [#140](https://github.com/kazu-yamamoto/http2/pull/140)+* Removing unnecessary API from ServerIO++## 5.3.1++* Fix treatment of async exceptions+ [#138](https://github.com/kazu-yamamoto/http2/pull/138)+* Avoid race condition+ [#137](https://github.com/kazu-yamamoto/http2/pull/137)++## 5.3.0++* New server architecture: spawning worker on demand instead of the+ worker pool. This reduce huge numbers of threads for streaming into+ only 2. No API changes but workers do not terminate quicly. Rather+ workers collaborate with the sender after queuing a response and+ finish after all response data are sent.+* All threads are labeled with `labelThread`. You can see them by+ `listThreads` if necessary.++## 5.2.6++* Recover rxflow on closing.+ [#126](https://github.com/kazu-yamamoto/http2/pull/126)+* Fixing ClientSpec for stream errors.+* Allowing negative window. (h2spec http2/6.9.2)+* Update for latest http-semantics+ [#122](https://github.com/kazu-yamamoto/http2/pull/124)++## 5.2.5++* Setting peer initial window size properly.+ [#123](https://github.com/kazu-yamamoto/http2/pull/123)++## 5.2.4++* Update for latest http-semantics+ [#122](https://github.com/kazu-yamamoto/http2/pull/122)+* Measuring performance concurrently for h2c-client++## 5.2.3++* Update for latest http-semantics+ [#120](https://github.com/kazu-yamamoto/http2/pull/120)+* Enable containers 0.7 (ghc 9.10)+ [#117](https://github.com/kazu-yamamoto/http2/pull/117)++## 5.2.2++* Mark final chunk as final+ [#116](https://github.com/kazu-yamamoto/http2/pull/116)++## 5.2.1++* Using time-manager v0.1.0.+ [#115](https://github.com/kazu-yamamoto/http2/pull/115)++## 5.2.0++* Using http-semantics+ [#114](https://github.com/kazu-yamamoto/http2/pull/114)+* `Header` of `http-types` should be used as high-level header.+* `TokenHeader` of `http-semantics` should be used as low-level header.+* Breaking change: `encodeHeader` takes `Header` of `http-types`.+* Breaking change: `decodeHeader` returns `Header` of `http-types`.+* Breaking change: `HeaderName` as `ByteString` is removed.++## 5.1.4++* Using network-control v0.1.+ ## 5.1.3 * Defining SendRequest type synonym.@@ -59,7 +206,7 @@ [#80](https://github.com/kazu-yamamoto/http2/pull/80) * Introducing `KilledByHttp2ThreadManager` instead of `ThreadKilled`. [#79](https://github.com/kazu-yamamoto/http2/pull/79)- [#81](https://github.com/kazu-yamamoto/http2/pull/82)+ [#81](https://github.com/kazu-yamamoto/http2/pull/81) [#82](https://github.com/kazu-yamamoto/http2/pull/82) * Handle RST_STREAM with NO_ERROR. [#78](https://github.com/kazu-yamamoto/http2/pull/78)
Imports.hs view
@@ -14,9 +14,13 @@ module Data.String, module Data.Word, module Numeric,+ module Network.HTTP.Semantics,+ module Network.HTTP.Types,+ module Data.CaseInsensitive, GCBuffer, withForeignPtr, mallocPlainForeignPtrBytes,+ labelMe, ) where import Control.Applicative@@ -24,6 +28,7 @@ import Data.Bits hiding (Bits) import Data.ByteString.Internal (ByteString (..)) import Data.ByteString.Short (ShortByteString)+import Data.CaseInsensitive (foldedCase, mk, original) import Data.Either import Data.Foldable import Data.Int@@ -34,7 +39,15 @@ import Data.String import Data.Word import Foreign.ForeignPtr+import GHC.Conc.Sync import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import Network.HTTP.Semantics+import Network.HTTP.Types import Numeric type GCBuffer = ForeignPtr Word8++labelMe :: String -> IO ()+labelMe l = do+ tid <- myThreadId+ labelThread tid l
Network/HPACK.hs view
@@ -5,6 +5,10 @@ -- * Encoding and decoding encodeHeader, decodeHeader,+ Header,+ original,+ foldedCase,+ mk, -- * Encoding and decoding with token encodeTokenHeader,@@ -28,37 +32,30 @@ DecodeError (..), BufferOverrun (..), - -- * Headers- HeaderList,- Header,- HeaderName,- HeaderValue,- TokenHeaderList,+ -- * Token header+ FieldValue, TokenHeader,+ TokenHeaderList,+ toTokenHeaderTable, -- * Value table ValueTable,- HeaderTable,+ TokenHeaderTable,+ getFieldValue, getHeaderValue,- toHeaderTable, -- * Basic types Size, Index, Buffer, BufferSize,-- -- * Re-exports- original,- foldedCase,- mk, ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Data.CaseInsensitive +import Imports import Network.HPACK.HeaderBlock import Network.HPACK.Table import Network.HPACK.Types
Network/HPACK/HeaderBlock.hs view
@@ -2,9 +2,9 @@ decodeHeader, decodeTokenHeader, ValueTable,- HeaderTable,- toHeaderTable,- getHeaderValue,+ TokenHeaderTable,+ toTokenHeaderTable,+ getFieldValue, encodeHeader, encodeTokenHeader, ) where
Network/HPACK/HeaderBlock/Decode.hs view
@@ -5,9 +5,9 @@ decodeHeader, decodeTokenHeader, ValueTable,- HeaderTable,- toHeaderTable,- getHeaderValue,+ TokenHeaderTable,+ toTokenHeaderTable,+ getFieldValue, decodeString, decodeS, decodeSophisticated,@@ -15,37 +15,25 @@ ) where import Control.Exception (catch, throwIO)-import Data.Array (Array)-import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite)+import Data.Array.Base (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.CaseInsensitive (CI (..)) import Data.Char (isUpper) import Network.ByteOrder+import Network.HTTP.Semantics import Imports hiding (empty) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table-import Network.HPACK.Token import Network.HPACK.Types --- | An array to get 'HeaderValue' quickly.--- 'getHeaderValue' should be used.--- Internally, the key is 'tokenIx'.-type ValueTable = Array Int (Maybe HeaderValue)---- | Accessing 'HeaderValue' with 'Token'.-{-# INLINE getHeaderValue #-}-getHeaderValue :: Token -> ValueTable -> Maybe HeaderValue-getHeaderValue t tbl = tbl `unsafeAt` tokenIx t- ---------------------------------------------------------------- --- | Converting the HPACK format to 'HeaderList'.+-- | Converting the HPACK format to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.@@ -54,7 +42,7 @@ :: DynamicTable -> ByteString -- ^ An HPACK format- -> IO HeaderList+ -> IO [Header] decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl)) -- | Converting the HPACK format to 'TokenHeaderList'@@ -75,7 +63,7 @@ :: DynamicTable -> ByteString -- ^ An HPACK format- -> IO HeaderTable+ -> IO TokenHeaderTable decodeTokenHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `catch` \BufferOverrun -> throwIO HeaderBlockTruncated @@ -96,7 +84,7 @@ ff rbuf (-1) dec rbuf --- | Converting to 'HeaderList'.+-- | Converting to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.@@ -104,7 +92,7 @@ decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer- -> IO HeaderList+ -> IO [Header] decodeSimple decTokenHeader rbuf = go empty where go builder = do@@ -117,7 +105,7 @@ go builder' else do let tvs = run builder- kvs = map (\(t, v) -> let k = tokenFoldedKey t in (k, v)) tvs+ kvs = map (\(t, v) -> let k = tokenKey t in (k, v)) tvs return kvs headerLimit :: Int@@ -141,7 +129,7 @@ decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer- -> IO HeaderTable+ -> IO TokenHeaderTable decodeSophisticated decTokenHeader rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing@@ -149,7 +137,7 @@ tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where- pseudoNormal :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList+ pseudoNormal :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList pseudoNormal arr = pseudo where pseudo = do@@ -334,23 +322,19 @@ ---------------------------------------------------------------- --- | A pair of token list and value table.-type HeaderTable = (TokenHeaderList, ValueTable)- -- | Converting a header list of the http-types style to -- 'TokenHeaderList' and 'ValueTable'.-toHeaderTable :: [(CI HeaderName, HeaderValue)] -> IO HeaderTable-toHeaderTable kvs = do+toTokenHeaderTable :: [Header] -> IO TokenHeaderTable+toTokenHeaderTable kvs = do arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing tvs <- conv arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where- conv :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList+ conv :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList conv arr = go kvs empty where- go- :: [(CI HeaderName, HeaderValue)] -> Builder TokenHeader -> IO TokenHeaderList+ go :: [Header] -> Builder TokenHeader -> IO TokenHeaderList go [] builder = return $ run builder go ((k, v) : xs) builder = do let t = toToken (foldedCase k)
Network/HPACK/HeaderBlock/Encode.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.HPACK.HeaderBlock.Encode (@@ -17,12 +16,12 @@ import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (minusPtr) import Network.ByteOrder+import Network.HTTP.Semantics import Imports import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table-import Network.HPACK.Token import Network.HPACK.Types ----------------------------------------------------------------@@ -41,7 +40,7 @@ ---------------------------------------------------------------- --- | Converting 'HeaderList' to the HPACK format.+-- | Converting '[Header]' to the HPACK format. -- This function has overhead of allocating/freeing a temporary buffer. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader@@ -49,14 +48,17 @@ -> Size -- ^ The size of a temporary buffer. -> DynamicTable- -> HeaderList+ -> [Header] -> 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+ mk' (k, v) = (t, v)+ where+ t = toToken $ foldedCase k+ hs' = map mk' hs --- | Converting 'HeaderList' to the HPACK format.+-- | Converting 'TokenHeaderList' to the HPACK format. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader' :: EncodeStrategy@@ -135,26 +137,26 @@ ---------------------------------------------------------------- naiveStep- :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO ()+ :: (FieldName -> FieldValue -> IO ()) -> Token -> FieldValue -> IO () naiveStep fe t v = fe (tokenFoldedKey t) v ---------------------------------------------------------------- -staticStep :: FA -> FD -> FE -> Token -> HeaderValue -> IO ()+staticStep :: FA -> FD -> FE -> Token -> FieldValue -> IO () staticStep fa fd fe t v = lookupRevIndex' t v fa fd fe ---------------------------------------------------------------- -linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> HeaderValue -> IO ()+linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> FieldValue -> IO () linearStep rev fa fb fc fd t v = lookupRevIndex t v fa fb fc fd rev ---------------------------------------------------------------- type FA = HIndex -> IO ()-type FB = HeaderValue -> Entry -> HIndex -> IO ()-type FC = HeaderName -> HeaderValue -> Entry -> IO ()-type FD = HeaderValue -> HIndex -> IO ()-type FE = HeaderName -> HeaderValue -> IO ()+type FB = FieldValue -> Entry -> HIndex -> IO ()+type FC = FieldName -> FieldValue -> Entry -> IO ()+type FD = FieldValue -> HIndex -> IO ()+type FE = FieldName -> FieldValue -> IO () -- 6.1. Indexed Header Field Representation -- Indexed Header Field@@ -194,7 +196,7 @@ newName wbuf huff set0000 k v literalHeaderFieldWithoutIndexingNewName'- :: DynamicTable -> WriteBuffer -> Bool -> HeaderName -> HeaderValue -> IO ()+ :: DynamicTable -> WriteBuffer -> Bool -> FieldName -> FieldValue -> IO () literalHeaderFieldWithoutIndexingNewName' _ wbuf huff k v = newName wbuf huff set0000 k v @@ -211,14 +213,14 @@ -- Using Huffman encoding {-# INLINE indexedName #-} indexedName- :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()+ :: WriteBuffer -> Bool -> Int -> Setter -> FieldValue -> Index -> IO () indexedName wbuf huff n set v idx = do encodeI wbuf set n idx encStr wbuf huff v -- Using Huffman encoding {-# INLINE newName #-}-newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO ()+newName :: WriteBuffer -> Bool -> Setter -> FieldName -> FieldValue -> IO () newName wbuf huff set k v = do write8 wbuf $ set 0 encStr wbuf huff k
Network/HPACK/HeaderBlock/Integer.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.HPACK.HeaderBlock.Integer ( encodeI, encodeInteger,
Network/HPACK/Huffman/Tree.hs view
@@ -72,9 +72,13 @@ (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'- ts = map (second tail) ts'+ (fs', ts') = partition (isHeadF . snd) xs+ fs = map (second (drop 1)) fs'+ ts = map (second (drop 1)) ts'++isHeadF :: Bits -> Bool+isHeadF [] = error "isHeadF"+isHeadF (b : _) = b == F -- | Marking the EOS path mark :: Int -> Bits -> HTree -> HTree
Network/HPACK/Internal.hs view
@@ -7,6 +7,9 @@ module Network.HPACK.HeaderBlock.Decode, module Network.HPACK.Huffman, module Network.HPACK.Table.Entry,++ -- * Types+ module Network.HPACK.Types, ) where import Network.HPACK.HeaderBlock.Decode (@@ -14,8 +17,10 @@ decodeSimple, decodeSophisticated, decodeString,+ toTokenHeaderTable, ) import Network.HPACK.HeaderBlock.Encode (encodeS, encodeString) import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table.Entry+import Network.HPACK.Types (CompressionAlgo (..), EncodeStrategy (..))
Network/HPACK/Table/Dynamic.hs view
@@ -156,9 +156,9 @@ putStr "] (s = " putStr $ show $ entrySize e putStr ") "- BS.putStr $ entryHeaderName e+ BS.putStr $ original $ entryHeaderName e putStr ": "- BS.putStrLn $ entryHeaderValue e+ BS.putStrLn $ entryFieldValue e ---------------------------------------------------------------- @@ -312,11 +312,12 @@ ---------------------------------------------------------------- -- | Inserting 'Entry' to 'DynamicTable'.--- New 'DynamicTable', the largest new 'Index'--- and a set of dropped OLD 'Index'--- are returned. insertEntry :: Entry -> DynamicTable -> IO () insertEntry e dyntbl@DynamicTable{..} = do+ -- Theoretically speaking, dropping entries by adjustTableSize+ -- should be first. However, non-used slots always exist since the+ -- size of dynamic table calculated via the minimum entry size (32+ -- bytes). To simply adjustTableSize, insertFront is called first. insertFront e dyntbl es <- adjustTableSize dyntbl case codeInfo of@@ -359,6 +360,7 @@ ---------------------------------------------------------------- +-- Used in copyEntries. insertEnd :: Entry -> DynamicTable -> IO () insertEnd e DynamicTable{..} = do maxN <- readIORef maxNumOfEntries
Network/HPACK/Table/Entry.hs view
@@ -4,9 +4,7 @@ -- * Type Size, Entry (..),- Header, -- re-exporting- HeaderName, -- re-exporting- HeaderValue, -- re-exporting+ FieldValue, -- re-exporting Index, -- re-exporting -- * Header and Entry@@ -18,7 +16,7 @@ entryTokenHeader, entryToken, entryHeaderName,- entryHeaderValue,+ entryFieldValue, -- * For initialization dummyEntry,@@ -26,16 +24,18 @@ ) where import qualified Data.ByteString as BS-import Network.HPACK.Token import Network.HPACK.Types+import Network.HTTP.Semantics +import Imports+ ---------------------------------------------------------------- -- | Size in bytes. type Size = Int -- | Type for table entry. Size includes the 32 bytes magic number.-data Entry = Entry Size Token HeaderValue deriving (Show)+data Entry = Entry Size Token FieldValue deriving (Show) ---------------------------------------------------------------- @@ -44,11 +44,11 @@ headerSize :: Header -> Size headerSize (k, v) =- BS.length k+ BS.length (foldedCase k) + BS.length v + headerSizeMagicNumber -headerSize' :: Token -> HeaderValue -> Size+headerSize' :: Token -> FieldValue -> Size headerSize' t v = BS.length (tokenFoldedKey t) + BS.length v@@ -60,10 +60,10 @@ toEntry :: Header -> Entry toEntry kv@(k, v) = Entry siz t v where- t = toToken k+ t = toToken $ foldedCase k siz = headerSize kv -toEntryToken :: Token -> HeaderValue -> Entry+toEntryToken :: Token -> FieldValue -> Entry toEntryToken t v = Entry siz t v where siz = headerSize' t v@@ -84,11 +84,11 @@ -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName-entryHeaderName (Entry _ t _) = tokenFoldedKey t+entryHeaderName (Entry _ t _) = tokenKey t -- xxx --- | Getting 'HeaderValue'.-entryHeaderValue :: Entry -> HeaderValue-entryHeaderValue (Entry _ _ v) = v+-- | Getting 'FieldValue'.+entryFieldValue :: Entry -> FieldValue+entryFieldValue (Entry _ _ v) = v ----------------------------------------------------------------
Network/HPACK/Table/RevIndex.hs view
@@ -15,16 +15,17 @@ import Data.Array (Array) import qualified Data.Array as A import Data.Array.Base (unsafeAt)-import Data.CaseInsensitive (foldedCase) import Data.Function (on) import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as M+import Network.HTTP.Semantics import Imports import Network.HPACK.Table.Entry import Network.HPACK.Table.Static-import Network.HPACK.Token import Network.HPACK.Types ----------------------------------------------------------------@@ -33,7 +34,7 @@ type DynamicRevIndex = Array Int (IORef ValueMap) -data KeyValue = KeyValue HeaderName HeaderValue deriving (Eq, Ord)+data KeyValue = KeyValue FieldName FieldValue deriving (Eq, Ord) -- We always create an index for a pair of an unknown header and its value -- in Linear{H}.@@ -55,29 +56,29 @@ data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show) -type ValueMap = Map HeaderValue HIndex+type ValueMap = Map FieldValue HIndex ---------------------------------------------------------------- staticRevIndex :: StaticRevIndex staticRevIndex = A.array (minTokenIx, maxStaticTokenIx) $ map toEnt zs where- toEnt (k, xs) = (tokenIx (toToken k), m)+ toEnt (k, xs) = (tokenIx $ toToken $ foldedCase k, m) where m = case xs of- [] -> error "staticRevIndex"- [("", i)] -> StaticEntry i Nothing- (_, i) : _ ->- let vs = M.fromList xs+ ("", i) :| [] -> StaticEntry i Nothing+ (_, i) :| _ ->+ let vs = M.fromList $ NE.toList xs in StaticEntry i (Just vs)- zs = map extract $ groupBy ((==) `on` fst) lst+ zs = map extract $ NE.groupBy ((==) `on` fst) lst where lst = zipWith (\(k, v) i -> (k, (v, i))) staticTableList $ map SIndex [1 ..]- extract xs = (fst (head xs), map snd xs) + extract xs = (fst (NE.head xs), NE.map snd xs)+ {-# INLINE lookupStaticRevIndex #-} lookupStaticRevIndex- :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()+ :: Int -> FieldValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO () lookupStaticRevIndex ix v fa' fbd' = case staticRevIndex `unsafeAt` ix of StaticEntry i Nothing -> fbd' i StaticEntry i (Just m) -> case M.lookup v m of@@ -87,9 +88,9 @@ ---------------------------------------------------------------- newDynamicRevIndex :: IO DynamicRevIndex-newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk lst+newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk' lst where- mk _ = newIORef M.empty+ mk' _ = newIORef M.empty lst = [minTokenIx .. maxStaticTokenIx] renewDynamicRevIndex :: DynamicRevIndex -> IO ()@@ -100,7 +101,7 @@ {-# INLINE lookupDynamicStaticRevIndex #-} lookupDynamicStaticRevIndex :: Int- -> HeaderValue+ -> FieldValue -> DynamicRevIndex -> (HIndex -> IO ()) -> (HIndex -> IO ())@@ -114,13 +115,13 @@ {-# INLINE insertDynamicRevIndex #-} insertDynamicRevIndex- :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()+ :: Token -> FieldValue -> HIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i where ref = drev `unsafeAt` tokenIx t {-# INLINE deleteDynamicRevIndex #-}-deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO ()+deleteDynamicRevIndex :: Token -> FieldValue -> DynamicRevIndex -> IO () deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v where ref = drev `unsafeAt` tokenIx t@@ -135,19 +136,19 @@ {-# INLINE lookupOtherRevIndex #-} lookupOtherRevIndex- :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()+ :: (FieldName, FieldValue) -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO () lookupOtherRevIndex (k, v) ref fa' fc' = do oth <- readIORef ref maybe fc' fa' $ M.lookup (KeyValue k v) oth {-# INLINE insertOtherRevIndex #-}-insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()+insertOtherRevIndex :: Token -> FieldValue -> HIndex -> OtherRevIdex -> IO () insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i where k = tokenFoldedKey t {-# INLINE deleteOtherRevIndex #-}-deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO ()+deleteOtherRevIndex :: Token -> FieldValue -> OtherRevIdex -> IO () deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v) where k = tokenFoldedKey t@@ -165,11 +166,11 @@ {-# INLINE lookupRevIndex #-} lookupRevIndex :: Token- -> HeaderValue+ -> FieldValue -> (HIndex -> IO ())- -> (HeaderValue -> Entry -> HIndex -> IO ())- -> (HeaderName -> HeaderValue -> Entry -> IO ())- -> (HeaderValue -> HIndex -> IO ())+ -> (FieldValue -> Entry -> HIndex -> IO ())+ -> (FieldName -> FieldValue -> Entry -> IO ())+ -> (FieldValue -> HIndex -> IO ()) -> RevIndex -> IO () lookupRevIndex t@Token{..} v fa fb fc fd (RevIndex dyn oth)@@ -189,10 +190,10 @@ {-# INLINE lookupRevIndex' #-} lookupRevIndex' :: Token- -> HeaderValue+ -> FieldValue -> (HIndex -> IO ())- -> (HeaderValue -> HIndex -> IO ())- -> (HeaderName -> HeaderValue -> IO ())+ -> (FieldValue -> HIndex -> IO ())+ -> (FieldName -> FieldValue -> IO ()) -> IO () lookupRevIndex' Token{..} v fa fd fe | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'
Network/HPACK/Table/Static.hs view
@@ -9,6 +9,7 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry+import Network.HTTP.Types (Header) ----------------------------------------------------------------
Network/HPACK/Token.hs view
@@ -1,485 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.HPACK.Token (- -- * Data type- Token (..),- tokenCIKey,- tokenFoldedKey,- toToken,-- -- * Ix- minTokenIx,- maxStaticTokenIx,- maxTokenIx,- cookieTokenIx,-- -- * Utilities- isMaxTokenIx,- isCookieTokenIx,- isStaticTokenIx,- isStaticToken,-- -- * Defined tokens- tokenAuthority,- tokenMethod,- tokenPath,- tokenScheme,- tokenStatus,- tokenAcceptCharset,- tokenAcceptEncoding,- tokenAcceptLanguage,- tokenAcceptRanges,- tokenAccept,- tokenAccessControlAllowOrigin,- tokenAge,- tokenAllow,- tokenAuthorization,- tokenCacheControl,- tokenContentDisposition,- tokenContentEncoding,- tokenContentLanguage,- tokenContentLength,- tokenContentLocation,- tokenContentRange,- tokenContentType,- tokenCookie,- tokenDate,- tokenEtag,- tokenExpect,- tokenExpires,- tokenFrom,- tokenHost,- tokenIfMatch,- tokenIfModifiedSince,- tokenIfNoneMatch,- tokenIfRange,- tokenIfUnmodifiedSince,- tokenLastModified,- tokenLink,- tokenLocation,- tokenMaxForwards,- tokenProxyAuthenticate,- tokenProxyAuthorization,- tokenRange,- tokenReferer,- tokenRefresh,- tokenRetryAfter,- tokenServer,- tokenSetCookie,- tokenStrictTransportSecurity,- tokenTransferEncoding,- tokenUserAgent,- tokenVary,- tokenVia,- tokenWwwAuthenticate,- tokenConnection,- tokenTE,- tokenMax,- tokenAccessControlAllowCredentials,- tokenAccessControlAllowHeaders,- tokenAccessControlAllowMethods,- tokenAccessControlExposeHeaders,- tokenAccessControlRequestHeaders,- tokenAccessControlRequestMethod,- tokenAltSvc,- tokenContentSecurityPolicy,- tokenEarlyData,- tokenExpectCt,- tokenForwarded,- tokenOrigin,- tokenPurpose,- tokenTimingAllowOrigin,- tokenUpgradeInsecureRequests,- tokenXContentTypeOptions,- tokenXForwardedFor,- tokenXFrameOptions,- tokenXXssProtection,+ module Network.HTTP.Semantics.Token, ) where -import qualified Data.ByteString as B-import Data.ByteString.Internal (ByteString (..), memcmp)-import Data.CaseInsensitive (CI (..), mk, original)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (plusPtr)-import System.IO.Unsafe (unsafeDupablePerformIO)---- $setup--- >>> :set -XOverloadedStrings---- | Internal representation for header keys.-data Token = Token- { 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 a case insensitive header key from a token.-{-# INLINE tokenCIKey #-}-tokenCIKey :: Token -> ByteString-tokenCIKey (Token _ _ _ ci) = original ci---- | Extracting a folded header key from a token.-{-# INLINE tokenFoldedKey #-}-tokenFoldedKey :: Token -> ByteString-tokenFoldedKey (Token _ _ _ ci) = foldedCase ci--{- FOURMOLU_DISABLE -}-tokenAuthority :: Token-tokenMethod :: Token-tokenPath :: Token-tokenScheme :: Token-tokenStatus :: Token-tokenAcceptCharset :: Token-tokenAcceptEncoding :: Token-tokenAcceptLanguage :: Token-tokenAcceptRanges :: Token-tokenAccept :: Token-tokenAccessControlAllowOrigin :: Token-tokenAge :: Token-tokenAllow :: Token-tokenAuthorization :: Token-tokenCacheControl :: Token-tokenContentDisposition :: Token-tokenContentEncoding :: Token-tokenContentLanguage :: Token-tokenContentLength :: Token-tokenContentLocation :: Token-tokenContentRange :: Token-tokenContentType :: Token-tokenCookie :: Token-tokenDate :: Token-tokenEtag :: Token-tokenExpect :: Token-tokenExpires :: Token-tokenFrom :: Token-tokenHost :: Token-tokenIfMatch :: Token-tokenIfModifiedSince :: Token-tokenIfNoneMatch :: Token-tokenIfRange :: Token-tokenIfUnmodifiedSince :: Token-tokenLastModified :: Token-tokenLink :: Token-tokenLocation :: Token-tokenMaxForwards :: Token-tokenProxyAuthenticate :: Token-tokenProxyAuthorization :: Token-tokenRange :: Token-tokenReferer :: Token-tokenRefresh :: Token-tokenRetryAfter :: Token-tokenServer :: Token-tokenSetCookie :: Token-tokenStrictTransportSecurity :: Token-tokenTransferEncoding :: Token-tokenUserAgent :: Token-tokenVary :: Token-tokenVia :: Token-tokenWwwAuthenticate :: Token-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"-tokenMethod = Token 1 True True ":method"-tokenPath = Token 2 False True ":path"-tokenScheme = Token 3 True True ":scheme"-tokenStatus = Token 4 True True ":status"-tokenAcceptCharset = Token 5 True False "Accept-Charset"-tokenAcceptEncoding = Token 6 True False "Accept-Encoding"-tokenAcceptLanguage = Token 7 True False "Accept-Language"-tokenAcceptRanges = Token 8 True False "Accept-Ranges"-tokenAccept = Token 9 True False "Accept"-tokenAccessControlAllowOrigin = Token 10 True False "Access-Control-Allow-Origin"-tokenAge = Token 11 True False "Age"-tokenAllow = Token 12 True False "Allow"-tokenAuthorization = Token 13 True False "Authorization"-tokenCacheControl = Token 14 True False "Cache-Control"-tokenContentDisposition = Token 15 True False "Content-Disposition"-tokenContentEncoding = Token 16 True False "Content-Encoding"-tokenContentLanguage = Token 17 True False "Content-Language"-tokenContentLength = Token 18 False False "Content-Length"-tokenContentLocation = Token 19 False False "Content-Location"-tokenContentRange = Token 20 True False "Content-Range"-tokenContentType = Token 21 True False "Content-Type"-tokenCookie = Token 22 True False "Cookie"-tokenDate = Token 23 True False "Date"-tokenEtag = Token 24 False False "Etag"-tokenExpect = Token 25 True False "Expect"-tokenExpires = Token 26 True False "Expires"-tokenFrom = Token 27 True False "From"-tokenHost = Token 28 True False "Host"-tokenIfMatch = Token 29 True False "If-Match"-tokenIfModifiedSince = Token 30 True False "If-Modified-Since"-tokenIfNoneMatch = Token 31 True False "If-None-Match"-tokenIfRange = Token 32 True False "If-Range"-tokenIfUnmodifiedSince = Token 33 True False "If-Unmodified-Since"-tokenLastModified = Token 34 True False "Last-Modified"-tokenLink = Token 35 True False "Link"-tokenLocation = Token 36 True False "Location"-tokenMaxForwards = Token 37 True False "Max-Forwards"-tokenProxyAuthenticate = Token 38 True False "Proxy-Authenticate"-tokenProxyAuthorization = Token 39 True False "Proxy-Authorization"-tokenRange = Token 40 True False "Range"-tokenReferer = Token 41 True False "Referer"-tokenRefresh = Token 42 True False "Refresh"-tokenRetryAfter = Token 43 True False "Retry-After"-tokenServer = Token 44 True False "Server"-tokenSetCookie = Token 45 False False "Set-Cookie"-tokenStrictTransportSecurity = Token 46 True False "Strict-Transport-Security"-tokenTransferEncoding = Token 47 True False "Transfer-Encoding"-tokenUserAgent = Token 48 True False "User-Agent"-tokenVary = Token 49 True False "Vary"-tokenVia = Token 50 True False "Via"-tokenWwwAuthenticate = Token 51 True False "Www-Authenticate"---- | A place holder to hold header keys not defined in the static table.--- | 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"-{- FOURMOLU_ENABLE -}---- | Minimum token index.-minTokenIx :: Int-minTokenIx = 0---- | Maximun token index defined in the static table.-maxStaticTokenIx :: Int-maxStaticTokenIx = 51---- | Maximum token index.-maxTokenIx :: Int-maxTokenIx = 73---- | Token index for 'tokenCookie'.-cookieTokenIx :: Int-cookieTokenIx = 22---- | Is this token ix for Cookie?-{-# INLINE isCookieTokenIx #-}-isCookieTokenIx :: Int -> Bool-isCookieTokenIx n = n == cookieTokenIx---- | Is this token ix to be held in the place holder?-{-# INLINE isMaxTokenIx #-}-isMaxTokenIx :: Int -> Bool-isMaxTokenIx n = n == maxTokenIx---- | Is this token ix for a header not defined in the static table?-{-# INLINE isStaticTokenIx #-}-isStaticTokenIx :: Int -> Bool-isStaticTokenIx n = n <= maxStaticTokenIx---- | Is this token for a header not defined in the static table?-{-# INLINE isStaticToken #-}-isStaticToken :: Token -> Bool-isStaticToken n = tokenIx n <= maxStaticTokenIx---- | Making a token from a header key.------ >>> toToken ":authority" == tokenAuthority--- True--- >>> toToken "foo"--- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"}--- >>> toToken ":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- 97 | bs === "via" -> tokenVia- 101 | bs === "age" -> tokenAge- _ -> mkTokenMax bs- 4 -> case lst of- 101 | bs === "date" -> tokenDate- 103 | bs === "etag" -> tokenEtag- 107 | bs === "link" -> tokenLink- 109 | bs === "from" -> tokenFrom- 116 | bs === "host" -> tokenHost- 121 | bs === "vary" -> tokenVary- _ -> mkTokenMax bs- 5 -> case lst of- 101 | bs === "range" -> tokenRange- 104 | bs === ":path" -> tokenPath- 119 | bs === "allow" -> tokenAllow- _ -> 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- | bs === ":status" -> tokenStatus- _ -> mkTokenMax bs- 8 -> case lst of- 101 | bs === "if-range" -> tokenIfRange- 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- 121 | bs === ":authority" -> tokenAuthority- _ -> mkTokenMax bs- 11 -> case lst of- 114 | bs === "retry-after" -> tokenRetryAfter- _ -> mkTokenMax bs- 12 -> case lst of- 101 | bs === "content-type" -> tokenContentType- 115 | bs === "max-forwards" -> tokenMaxForwards- _ -> mkTokenMax bs- 13 -> case lst of- 100 | bs === "last-modified" -> tokenLastModified- 101 | bs === "content-range" -> tokenContentRange- 104 | bs === "if-none-match" -> tokenIfNoneMatch- 108 | bs === "cache-control" -> tokenCacheControl- 110 | bs === "authorization" -> tokenAuthorization- 115 | bs === "accept-ranges" -> tokenAcceptRanges- _ -> mkTokenMax bs- 14 -> case lst of- 104 | bs === "content-length" -> tokenContentLength- 116 | bs === "accept-charset" -> tokenAcceptCharset- _ -> mkTokenMax bs- 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- 103 | bs === "transfer-encoding" -> tokenTransferEncoding- _ -> mkTokenMax bs- 18 -> case lst of- 101 | bs === "proxy-authenticate" -> tokenProxyAuthenticate- _ -> mkTokenMax bs- 19 -> case lst of- 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- lst = B.last bs- PS fp1 off1 siz === PS fp2 off2 _ = unsafeDupablePerformIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 -> do- i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz- 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+import Network.HTTP.Semantics.Token
Network/HPACK/Types.hs view
@@ -1,11 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}- module Network.HPACK.Types ( -- * Header- HeaderName,- HeaderValue,- Header,- HeaderList,+ FieldValue, TokenHeader, TokenHeaderList, @@ -26,34 +21,12 @@ ) where import Control.Exception as E-import Data.Typeable import Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize) import Imports-import Network.HPACK.Token (Token) ---------------------------------------------------------------- --- | Header name.-type HeaderName = ByteString---- | Header value.-type HeaderValue = ByteString---- | Header.-type Header = (HeaderName, HeaderValue)---- | Header list.-type HeaderList = [Header]---- | TokenBased header.-type TokenHeader = (Token, HeaderValue)---- | TokenBased header list.-type TokenHeaderList = [TokenHeader]------------------------------------------------------------------- -- | Index for table. type Index = Int @@ -112,6 +85,6 @@ | HeaderBlockTruncated | IllegalHeaderName | TooLargeHeader- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) instance Exception DecodeError
Network/HTTP2/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | HTTP\/2 client library.@@ -10,11 +9,11 @@ -- > -- > module Main where -- >--- > import Control.Concurrent.Async--- > import qualified Control.Exception as E -- > import qualified Data.ByteString.Char8 as C8 -- > import Network.HTTP.Types -- > import Network.Run.TCP (runTCPClient) -- network-run+-- > import Control.Concurrent.Async+-- > import qualified Control.Exception as E -- > -- > import Network.HTTP2.Client -- >@@ -24,7 +23,7 @@ -- > main :: IO () -- > main = runTCPClient serverName "80" $ runHTTP2Client serverName -- > where--- > cliconf host = defaultClientConfig { authority = C8.pack host }+-- > cliconf host = defaultClientConfig { authority = host } -- > runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096) -- > freeSimpleConfig -- > (\conf -> run (cliconf host) conf client)@@ -47,8 +46,6 @@ run, -- * Client configuration- Scheme,- Authority, ClientConfig, defaultClientConfig, scheme,@@ -66,53 +63,29 @@ initialWindowSize, maxFrameSize, maxHeaderListSize,++ -- ** Rate limits pingRateLimit,+ settingsRateLimit,+ emptyFrameRateLimit,+ rstRateLimit, -- * Common configuration- Config (..),+ Config,+ defaultConfig,+ confWriteBuffer,+ confBufferSize,+ confSendAll,+ confReadN,+ confPositionReadMaker,+ confTimeoutManager,+ confMySockAddr,+ confPeerSockAddr,+ confReadNTimeout, allocSimpleConfig,+ allocSimpleConfig', freeSimpleConfig,-- -- * HTTP\/2 client- Client,- SendRequest,-- -- * Request- Request,-- -- * Creating request- requestNoBody,- requestFile,- requestStreaming,- requestStreamingUnmask,- requestBuilder,-- -- ** Trailers maker- TrailersMaker,- NextTrailersMaker (..),- defaultTrailersMaker,- setRequestTrailersMaker,-- -- * Response- Response,-- -- ** Accessing response- responseStatus,- responseHeaders,- responseBodySize,- getResponseBodyChunk,- getResponseTrailers,-- -- * Aux- Aux,- auxPossibleClientStreams,-- -- * Types- Method,- Path,- FileSpec (..),- FileOffset,- ByteCount,+ module Network.HTTP.Semantics.Client, -- * Error HTTP2Error (..),@@ -134,98 +107,10 @@ InadequateSecurity, HTTP11Required ),-- -- * 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.HTTP.Semantics.Client -import Network.HPACK import Network.HTTP2.Client.Run-import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 hiding (authority, scheme)---------------------------------------------------------------------- | 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---- | Like 'requestStreaming', but run the action with exceptions masked-requestStreamingUnmask- :: Method- -> Path- -> RequestHeaders- -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())- -> Request-requestStreamingUnmask m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingUnmask 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
@@ -1,6 +1,7 @@ module Network.HTTP2.Client.Internal ( Request (..), Response (..),+ Config (..), ClientConfig (..), Settings (..), Aux (..),@@ -11,6 +12,8 @@ runIO, ) where +import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.Client.Internal+ import Network.HTTP2.Client.Run-import Network.HTTP2.Client.Types import Network.HTTP2.H2
Network/HTTP2/Client/Run.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Client.Run where -import Control.Concurrent.STM (check)+import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Exception-import Data.ByteString.Builder (Builder) import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef+import Data.IP (IPv6) import Network.Control (RxFlow (..), defaultMaxData)+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.Client.Internal+import Network.HTTP.Semantics.IO import Network.Socket (SockAddr)-import UnliftIO.Async-import UnliftIO.Concurrent-import UnliftIO.STM+import qualified System.ThreadManager as T+import Text.Read (readMaybe) import Imports-import Network.HTTP.Types (Header)-import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 @@ -52,7 +53,7 @@ -- @userinfo\@@ as part of the authority. -- -- >>> defaultClientConfig--- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}}+-- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultClientConfig :: ClientConfig defaultClientConfig = ClientConfig@@ -66,8 +67,8 @@ -- | Running HTTP/2 client. run :: ClientConfig -> Config -> Client a -> IO a run cconf@ClientConfig{..} conf client = do- (ctx, mgr) <- setup cconf conf- runH2 conf ctx mgr $ runClient ctx mgr+ ctx <- setup cconf conf+ runH2 conf ctx $ runClient ctx where serverMaxStreams ctx = do mx <- maxConcurrentStreams <$> readIORef (peerSettings ctx)@@ -79,35 +80,41 @@ n <- oddConc <$> readTVarIO (oddStreamTable ctx) return (x - n) aux ctx =- Aux+ defaultAux { auxPossibleClientStreams = possibleClientStream ctx+ , auxSendPing =+ sendPing+ ctx+ False+ "Haskell!" -- 8 bytes }- clientCore ctx mgr req processResponse = do- strm <- sendRequest ctx mgr scheme authority req+ clientCore ctx req processResponse = do+ (strm, moutobj) <- makeStream ctx scheme authority req+ case moutobj of+ Nothing -> return ()+ Just outobj -> sendRequest conf ctx strm outobj False rsp <- getResponse strm- processResponse rsp- runClient ctx mgr = do- x <- client (clientCore ctx mgr) $ aux ctx- waitCounter0 mgr- let frame = goawayFrame 0 NoError "graceful closing"- mvar <- newMVar ()- enqueueControl (controlQ ctx) $ CGoaway frame mvar- takeMVar mvar+ x <- processResponse rsp+ adjustRxWindow ctx strm return x+ runClient ctx = client (clientCore ctx) $ aux ctx -- | Launching a receiver and a sender. runIO :: ClientConfig -> Config -> (ClientIO -> IO (IO a)) -> IO a runIO cconf@ClientConfig{..} conf@Config{..} action = do- (ctx@Context{..}, mgr) <- setup cconf conf+ ctx@Context{..} <- setup cconf conf let putB bs = enqueueControl controlQ $ CFrames Nothing [bs] putR req = do- strm <- sendRequest ctx mgr scheme authority req+ (strm, moutobj) <- makeStream ctx scheme authority req+ case moutobj of+ Nothing -> return ()+ Just outobj -> sendRequest conf ctx strm outobj True return (streamNumber strm, strm) get = getResponse create = openOddStreamWait ctx runClient <- action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create- runH2 conf ctx mgr runClient+ runH2 conf ctx runClient getResponse :: Stream -> IO Response getResponse strm = do@@ -116,7 +123,7 @@ Left err -> throwIO err Right rsp -> return $ Response rsp -setup :: ClientConfig -> Config -> IO (Context, Manager)+setup :: ClientConfig -> Config -> IO Context setup ClientConfig{..} conf@Config{..} = do let clientInfo = newClientInfo scheme authority ctx <-@@ -126,102 +133,123 @@ cacheLimit connectionWindowSize settings- mgr <- start confTimeoutManager+ confTimeoutManager+ Nothing exchangeSettings ctx- return (ctx, mgr)+ return ctx -runH2 :: Config -> Context -> Manager -> IO a -> IO a-runH2 conf ctx mgr runClient =- stopAfter mgr (race runBackgroundThreads runClient) $ \res -> do- closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $- either Just (const Nothing) res- case res of- Left err ->- throwIO err- Right (Left ()) ->- undefined -- never reach- Right (Right x) ->- return x+runH2 :: Config -> Context -> IO a -> IO a+runH2 conf ctx runClient = do+ T.stopAfter mgr (try runAll >>= closureClient conf ctx) $ \res ->+ closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res where+ mgr = threadManager ctx runReceiver = frameReceiver ctx conf- runSender = frameSender ctx conf mgr- runBackgroundThreads = concurrently_ runReceiver runSender+ runSender = frameSender ctx conf+ runClientReceiver = do+ labelMe "H2 ClientReceiver"+ er <- race runReceiver runClient+ case er of+ Right r -> return r+ Left err -> throwIO err -sendRequest+ -- When 'runClientReceiver' terminates, it is important we give the sender+ -- a chance to terminate cleanly also (it's possible the client terminated+ -- but there are still some messages in the queue to be sent).+ --+ -- If the client terminated successfully, we ignore any other errors in the+ -- sender (indeed, any exception here might simply be that the background+ -- threads were cancelled /because/ the client terminated).+ runAll = snd <$> concurrently runSender runClientReceiver++makeStream :: Context- -> Manager -> Scheme -> Authority -> Request- -> IO Stream-sendRequest ctx@Context{..} mgr scheme auth (Request req) = do+ -> IO (Stream, Maybe OutObj)+makeStream ctx@Context{..} scheme auth (Request req) = do -- Checking push promises let hdr0 = outObjHeaders req- method = fromMaybe (error "sendRequest:method") $ lookup ":method" hdr0- path = fromMaybe (error "sendRequest:path") $ lookup ":path" hdr0+ method = fromMaybe (error "makeStream:method") $ lookup ":method" hdr0+ path = fromMaybe (error "makeStream:path") $ lookup ":path" hdr0 mstrm0 <- lookupEvenCache evenStreamTable method path case mstrm0 of Just strm0 -> do deleteEvenCache evenStreamTable method path- return strm0+ return (strm0, Nothing) Nothing -> do -- Arch/Sender is originally implemented for servers where -- the ordering of responses can be out-of-order. -- But for clients, the ordering must be maintained. -- To implement this, 'outputQStreamID' is used.- -- Also, for 'OutBodyStreaming', TBQ must not be empty- -- when its 'Output' is enqueued into 'outputQ'.- -- Otherwise, it would be re-enqueue because of empty- -- resulting in out-of-order.- -- To implement this, 'tbqNonEmpty' is used.+ let isIPv6 = isJust (readMaybe auth :: Maybe IPv6)+ auth'+ | isIPv6 = "[" <> UTF8.fromString auth <> "]"+ | otherwise = UTF8.fromString auth let hdr1, hdr2 :: [Header] hdr1 | scheme /= "" = (":scheme", scheme) : hdr0 | otherwise = hdr0 hdr2- | auth /= "" = (":authority", UTF8.fromString auth) : hdr1+ | auth /= "" = (":authority", auth') : hdr1 | otherwise = hdr1 req' = req{outObjHeaders = hdr2} -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit- (sid, newstrm) <- openOddStreamWait ctx- case outObjBody req of- OutBodyStreaming strmbdy ->- sendStreaming ctx mgr req' sid newstrm $ \unmask push flush ->- unmask $ strmbdy push flush- OutBodyStreamingUnmask strmbdy ->- sendStreaming ctx mgr req' sid newstrm strmbdy- _ -> atomically $ do- sidOK <- readTVar outputQStreamID- check (sidOK == sid)- writeTVar outputQStreamID (sid + 2)- writeTQueue outputQ $ Output newstrm req' OObj Nothing (return ())- return newstrm+ (_sid, newstrm) <- openOddStreamWait ctx+ return (newstrm, Just req') +sendRequest :: Config -> Context -> Stream -> OutObj -> Bool -> IO ()+sendRequest Config{..} ctx@Context{..} strm OutObj{..} io = do+ let sid = streamNumber strm+ (mnext, mtbq) <- case outObjBody of+ OutBodyNone -> return (Nothing, Nothing)+ OutBodyFile (FileSpec path fileoff bytecount) -> do+ (pread, sentinel) <- confPositionReadMaker path+ let next = fillFileBodyGetNext pread fileoff bytecount sentinel+ return (Just next, Nothing)+ OutBodyBuilder builder -> do+ let next = fillBuilderBodyGetNext builder+ return (Just next, Nothing)+ OutBodyStreaming strmbdy -> do+ q <- sendStreaming ctx strm $ \iface ->+ outBodyUnmask iface $ strmbdy (outBodyPush iface) (outBodyFlush iface)+ let next = nextForStreaming q+ return (Just next, Just q)+ OutBodyStreamingIface strmbdy -> do+ q <- sendStreaming ctx strm strmbdy+ let next = nextForStreaming q+ return (Just next, Just q)+ let ot = OHeader outObjHeaders mnext outObjTrailers+ if io+ then do+ let out = makeOutputIO ctx strm ot+ pushOutput sid out+ else do+ (pop, out) <- makeOutput strm ot+ pushOutput sid out+ lc <- newLoopCheck strm mtbq+ T.forkManaged threadManager label $ syncWithSender' ctx pop lc+ where+ label = "H2 request sender for stream " ++ show (streamNumber strm)+ pushOutput sid out = atomically $ do+ sidOK <- readTVar outputQStreamID+ check (sidOK == sid)+ writeTVar outputQStreamID (sid + 2)+ enqueueOutputSTM outputQ out+ sendStreaming :: Context- -> Manager- -> OutObj- -> StreamId -> Stream- -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())- -> IO ()-sendStreaming Context{..} mgr req sid newstrm strmbdy = do+ -> (OutBodyIface -> IO ())+ -> IO (TBQueue StreamingChunk)+sendStreaming Context{..} strm strmbdy = do tbq <- newTBQueueIO 10 -- fixme: hard coding: 10- tbqNonEmpty <- newTVarIO False- forkManagedUnmask mgr $ \unmask -> do- let push b = atomically $ do- writeTBQueue tbq (StreamingBuilder b)- writeTVar tbqNonEmpty True- flush = atomically $ writeTBQueue tbq StreamingFlush- finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr)- incCounter mgr- strmbdy unmask push flush `finally` finished- atomically $ do- sidOK <- readTVar outputQStreamID- ready <- readTVar tbqNonEmpty- check (sidOK == sid && ready)- writeTVar outputQStreamID (sid + 2)- writeTQueue outputQ $ Output newstrm req OObj (Just tbq) (return ())+ T.forkManagedUnmask threadManager label $ \unmask ->+ withOutBodyIface tbq unmask strmbdy+ return tbq+ where+ label = "H2 request streaming sender for stream " ++ show (streamNumber strm) exchangeSettings :: Context -> IO () exchangeSettings Context{..} = do
− Network/HTTP2/Client/Types.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Network.HTTP2.Client.Types where--import Network.HTTP2.H2---------------------------------------------------------------------- | Send a request and receive its response.-type SendRequest = forall r. Request -> (Response -> IO r) -> IO r---- | Client type.-type Client a = SendRequest -> Aux -> IO a---- | Request from client.-newtype Request = Request OutObj deriving (Show)---- | Response from server.-newtype Response = Response InpObj deriving (Show)---- | Additional information.-data Aux = Aux- { auxPossibleClientStreams :: IO Int- -- ^ How many streams can be created without blocking.- }
Network/HTTP2/Frame.hs view
@@ -73,7 +73,7 @@ SettingsList, SettingsKey ( SettingsKey,- SettingsHeaderTableSize,+ SettingsTokenHeaderTableSize, SettingsEnablePush, SettingsMaxConcurrentStreams, SettingsInitialWindowSize,
Network/HTTP2/Frame/Decode.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -215,11 +214,11 @@ -- | Frame payload decoder for DATA frame. decodeDataFrame :: FramePayloadDecoder-decodeDataFrame header bs = decodeWithPadding header bs DataFrame+decodeDataFrame header _bs = decodeWithPadding header _bs DataFrame -- | Frame payload decoder for HEADERS frame. decodeHeadersFrame :: FramePayloadDecoder-decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' ->+decodeHeadersFrame header _bs = decodeWithPadding header _bs $ \bs' -> if hasPriority then let (bs0, bs1) = BS.splitAt 5 bs'@@ -235,7 +234,7 @@ -- | Frame payload decoder for RST_STREAM frame. decodeRSTStreamFrame :: FramePayloadDecoder-decodeRSTStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode (N.word32 bs)+decodeRSTStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode $ N.word32 bs -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder@@ -259,19 +258,22 @@ -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder-decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' ->+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+decodePingFrame _ _bs = Right $ PingFrame bs+ where+ bs = BS.copy _bs -- | Frame payload decoder for GOAWAY frame. decodeGoAwayFrame :: FramePayloadDecoder-decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2+decodeGoAwayFrame _ _bs = Right $ GoAwayFrame sid ecid bs2 where+ bs = BS.copy _bs (bs0, bs1') = BS.splitAt 4 bs (bs1, bs2) = BS.splitAt 4 bs1' sid = streamIdentifier (N.word32 bs0)@@ -288,10 +290,14 @@ -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder-decodeContinuationFrame _ bs = Right $ ContinuationFrame bs+decodeContinuationFrame _ _bs = Right $ ContinuationFrame bs+ where+ bs = BS.copy _bs decodeUnknownFrame :: FrameType -> FramePayloadDecoder-decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs+decodeUnknownFrame typ _ _bs = Right $ UnknownFrame typ bs+ where+ bs = BS.copy _bs ---------------------------------------------------------------- @@ -312,14 +318,15 @@ -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body | padded =- let (w8, rest) = fromMaybe (error "decodeWithPadding") $ BS.uncons bs+ let (w8, rest) = fromMaybe (error "decodeWithPadding") $ BS.uncons bs' padlen = intFromWord8 w8 bodylen = payloadLength - padlen - 1 in if bodylen < 0 then Left $ FrameDecodeError ProtocolError streamId "padding is not enough" else Right . body $ BS.take bodylen rest- | otherwise = Right $ body bs+ | otherwise = Right $ body bs' where+ bs' = BS.copy bs padded = testPadded flags streamIdentifier :: Word32 -> StreamId
Network/HTTP2/Frame/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -114,8 +113,8 @@ maxSettingsKey = SettingsKey 6 {- FOURMOLU_DISABLE -}-pattern SettingsHeaderTableSize :: SettingsKey-pattern SettingsHeaderTableSize = SettingsKey 1+pattern SettingsTokenHeaderTableSize :: SettingsKey+pattern SettingsTokenHeaderTableSize = SettingsKey 1 pattern SettingsEnablePush :: SettingsKey pattern SettingsEnablePush = SettingsKey 2@@ -135,7 +134,7 @@ {- FOURMOLU_DISABLE -} instance Show SettingsKey where- show SettingsHeaderTableSize = "SettingsHeaderTableSize"+ show SettingsTokenHeaderTableSize = "SettingsTokenHeaderTableSize" show SettingsEnablePush = "SettingsEnablePush" show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams" show SettingsInitialWindowSize = "SettingsInitialWindowSize"@@ -150,7 +149,7 @@ Ident idnt <- lexP readSK idnt where- readSK "SettingsHeaderTableSize" = return SettingsHeaderTableSize+ readSK "SettingsTokenHeaderTableSize" = return SettingsTokenHeaderTableSize readSK "SettingsEnablePush" = return SettingsEnablePush readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams readSK "SettingsInitialWindowSize" = return SettingsInitialWindowSize@@ -190,7 +189,7 @@ -- >>> isWindowOverflow (maxWindowSize + 1) -- True isWindowOverflow :: WindowSize -> Bool-isWindowOverflow w = testBit w 31+isWindowOverflow w = w > maxWindowSize -- | Default concurrency. --@@ -541,6 +540,6 @@ type SettingsKeyId = SettingsKey type FrameTypeId = FrameType {- FOURMOLU_ENABLE -}-{- DEPRECATED ErrorCodeId "Use ErrorCode instead" -}-{- DEPRECATED SettingsKeyId "Use SettingsKey instead" -}-{- DEPRECATED FrameTypeId "Use FrameType instead" -}+{-# DEPRECATED ErrorCodeId "Use ErrorCode instead" #-}+{-# DEPRECATED SettingsKeyId "Use SettingsKey instead" #-}+{-# DEPRECATED FrameTypeId "Use FrameType instead" #-}
Network/HTTP2/H2.hs view
@@ -2,17 +2,14 @@ module Network.HTTP2.H2.Config, module Network.HTTP2.H2.Context, module Network.HTTP2.H2.EncodeFrame,- module Network.HTTP2.H2.File, module Network.HTTP2.H2.HPACK,- module Network.HTTP2.H2.Manager, module Network.HTTP2.H2.Queue,- module Network.HTTP2.H2.ReadN, module Network.HTTP2.H2.Receiver, module Network.HTTP2.H2.Sender, module Network.HTTP2.H2.Settings,- module Network.HTTP2.H2.Status, module Network.HTTP2.H2.Stream, module Network.HTTP2.H2.StreamTable,+ module Network.HTTP2.H2.Sync, module Network.HTTP2.H2.Types, module Network.HTTP2.H2.Window, ) where@@ -20,16 +17,13 @@ import Network.HTTP2.H2.Config import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame-import Network.HTTP2.H2.File import Network.HTTP2.H2.HPACK-import Network.HTTP2.H2.Manager import Network.HTTP2.H2.Queue-import Network.HTTP2.H2.ReadN import Network.HTTP2.H2.Receiver import Network.HTTP2.H2.Sender import Network.HTTP2.H2.Settings-import Network.HTTP2.H2.Status import Network.HTTP2.H2.Stream import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Sync import Network.HTTP2.H2.Types import Network.HTTP2.H2.Window
Network/HTTP2/H2/Config.hs view
@@ -1,37 +1,39 @@+{-# LANGUAGE RecordWildCards #-}+ module Network.HTTP2.H2.Config where import Data.IORef import Foreign.Marshal.Alloc (free, mallocBytes)+import Network.HTTP.Semantics.Client import Network.Socket import Network.Socket.ByteString (sendAll) import qualified System.TimeManager as T import Network.HPACK-import Network.HTTP2.H2.File-import Network.HTTP2.H2.ReadN import Network.HTTP2.H2.Types -- | Making simple configuration whose IO is not efficient. -- A write buffer is allocated internally.+-- WAI timeout manger is initialized with 30_000_000 microseconds. allocSimpleConfig :: Socket -> BufferSize -> IO Config-allocSimpleConfig s bufsiz = do- buf <- mallocBytes bufsiz- ref <- newIORef Nothing- timmgr <- T.initialize $ 30 * 1000000- mysa <- getSocketName s- peersa <- getPeerName s- let config =- Config- { confWriteBuffer = buf- , confBufferSize = bufsiz- , confSendAll = sendAll s- , confReadN = defaultReadN s ref- , confPositionReadMaker = defaultPositionReadMaker- , confTimeoutManager = timmgr- , confMySockAddr = mysa- , confPeerSockAddr = peersa- }- return config+allocSimpleConfig s bufsiz = allocSimpleConfig' s bufsiz (30 * 1000000)++-- | Making simple configuration whose IO is not efficient.+-- A write buffer is allocated internally.+-- The third argument is microseconds to initialize WAI+-- timeout manager.+allocSimpleConfig' :: Socket -> BufferSize -> Int -> IO Config+allocSimpleConfig' s bufsiz usec = do+ confWriteBuffer <- mallocBytes bufsiz+ let confBufferSize = bufsiz+ let confSendAll = sendAll s+ confReadN <- defaultReadN s <$> newIORef Nothing+ let confPositionReadMaker = defaultPositionReadMaker+ confTimeoutManager <- T.initialize usec+ confMySockAddr <- getSocketName s+ confPeerSockAddr <- getPeerName s+ let confReadNTimeout = False+ return Config{..} -- | Deallocating the resource of the simple configuration. freeSimpleConfig :: Config -> IO ()
Network/HTTP2/H2/Context.hs view
@@ -4,13 +4,13 @@ module Network.HTTP2.H2.Context where +import Control.Concurrent.STM import Control.Exception+import qualified Control.Exception as E import Data.IORef import Network.Control-import Network.HTTP.Types (Method) import Network.Socket (SockAddr)-import qualified UnliftIO.Exception as E-import UnliftIO.STM+import qualified System.ThreadManager as T import Imports hiding (insert) import Network.HPACK@@ -26,8 +26,10 @@ data RoleInfo = RIS ServerInfo | RIC ClientInfo -data ServerInfo = ServerInfo- { inputQ :: TQueue (Input Stream)+type Launch = Context -> Stream -> InpObj -> IO ()++newtype ServerInfo = ServerInfo+ { launch :: Launch } data ClientInfo = ClientInfo@@ -43,110 +45,114 @@ toClientInfo (RIC x) = x toClientInfo _ = error "toClientInfo" -newServerInfo :: IO RoleInfo-newServerInfo = RIS . ServerInfo <$> newTQueueIO+newServerInfo :: Launch -> RoleInfo+newServerInfo = RIS . ServerInfo newClientInfo :: ByteString -> Authority -> RoleInfo newClientInfo scm auth = RIC $ ClientInfo scm auth ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} -- | The context for HTTP/2 connection. data Context = Context- { role :: Role- , roleInfo :: RoleInfo+ { role :: Role+ , roleInfo :: RoleInfo , -- Settings- mySettings :: Settings- , myFirstSettings :: IORef Bool- , peerSettings :: IORef Settings- , oddStreamTable :: TVar OddStreamTable- , evenStreamTable :: TVar EvenStreamTable- , continued :: IORef (Maybe StreamId)+ mySettings :: Settings+ , myFirstSettings :: IORef Bool+ , peerSettings :: IORef Settings+ , oddStreamTable :: TVar OddStreamTable+ , evenStreamTable :: TVar EvenStreamTable+ , continued :: IORef (Maybe StreamId) -- ^ RFC 9113 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.- , myStreamId :: TVar StreamId- , peerStreamId :: IORef StreamId- , outputBufferLimit :: IORef Int- , outputQ :: TQueue (Output Stream)- , outputQStreamID :: TVar StreamId- , controlQ :: TQueue Control+ , myStreamId :: TVar StreamId+ , peerStreamId :: IORef StreamId+ , peerLastStreamId :: IORef StreamId+ , outputBufferLimit :: IORef Int+ , outputQ :: TQueue Output+ -- ^ Invariant: Each stream will only ever have at most one 'Output'+ -- object in this queue at any moment.+ , outputQStreamID :: TVar StreamId+ , controlQ :: TQueue Control , encodeDynamicTable :: DynamicTable , decodeDynamicTable :: DynamicTable , -- the connection window for sending data- txFlow :: TVar TxFlow- , rxFlow :: IORef RxFlow- , pingRate :: Rate- , settingsRate :: Rate- , emptyFrameRate :: Rate- , rstRate :: Rate- , mySockAddr :: SockAddr- , peerSockAddr :: SockAddr+ txFlow :: TVar TxFlow+ , rxFlow :: IORef RxFlow+ , pingRate :: Rate+ , settingsRate :: Rate+ , emptyFrameRate :: Rate+ , rstRate :: Rate+ , mySockAddr :: SockAddr+ , peerSockAddr :: SockAddr+ , threadManager :: T.ThreadManager+ , receiverDone :: TVar (Maybe SomeException)+ , workersDone :: STM Bool }+{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} newContext :: RoleInfo -> Config -> Int -> Int -> Settings+ -> T.Manager+ -> Maybe (STM Bool) -> IO Context-newContext rinfo Config{..} cacheSiz connRxWS settings =+newContext roleInfo Config{..} cacheSiz connRxWS mySettings timmgr mdone = do -- My: Use this even if ack has not been received yet.- Context rl rinfo settings- <$> newIORef False- -- Peer: The spec defines max concurrency is infinite unless- -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged.- -- But it is vulnerable, so we set the limitations.- <*> newIORef settings- <*> newTVarIO emptyOddStreamTable- <*> newTVarIO (emptyEvenStreamTable cacheSiz)- <*> newIORef Nothing- <*> newTVarIO sid0- <*> newIORef 0- <*> newIORef buflim- <*> newTQueueIO- <*> newTVarIO sid0- <*> newTQueueIO- -- My SETTINGS_HEADER_TABLE_SIZE- <*> newDynamicTableForEncoding defaultDynamicTableSize- <*> newDynamicTableForDecoding (headerTableSize settings) 4096- <*> newTVarIO (newTxFlow defaultWindowSize) -- 64K- <*> newIORef (newRxFlow connRxWS)- <*> newRate- <*> newRate- <*> newRate- <*> newRate- <*> return confMySockAddr- <*> return confPeerSockAddr+ myFirstSettings <- newIORef False+ -- Peer: The spec defines max concurrency is infinite unless+ -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged.+ -- But it is vulnerable, so we set the limitations.+ peerSettings <-+ newIORef baseSettings{maxConcurrentStreams = Just defaultMaxStreams}+ oddStreamTable <- newTVarIO emptyOddStreamTable+ evenStreamTable <- newTVarIO (emptyEvenStreamTable cacheSiz)+ continued <- newIORef Nothing+ myStreamId <- newTVarIO sid0+ peerStreamId <- newIORef 0+ peerLastStreamId <- newIORef 0+ outputBufferLimit <- newIORef buflim+ outputQ <- newTQueueIO+ outputQStreamID <- newTVarIO sid0+ controlQ <- newTQueueIO+ -- My SETTINGS_HEADER_TABLE_SIZE+ encodeDynamicTable <- newDynamicTableForEncoding defaultDynamicTableSize+ decodeDynamicTable <-+ newDynamicTableForDecoding (headerTableSize mySettings) 4096+ txFlow <- newTVarIO (newTxFlow defaultWindowSize) -- 64K+ rxFlow <- newIORef (newRxFlow connRxWS)+ pingRate <- newRate+ settingsRate <- newRate+ emptyFrameRate <- newRate+ rstRate <- newRate+ let mySockAddr = confMySockAddr+ let peerSockAddr = confPeerSockAddr+ threadManager <- T.newThreadManager timmgr+ receiverDone <- newTVarIO Nothing+ let workersDone = fromMaybe (T.isAllGone threadManager) mdone+ return Context{..} where- rl = case rinfo of+ role = case roleInfo of RIC{} -> Client _ -> Server sid0- | rl == Client = 1+ | role == Client = 1 | otherwise = 2 dlim = defaultPayloadLength + frameHeaderLength buflim | confBufferSize >= dlim = dlim | otherwise = confBufferSize--makeMySettingsList :: Config -> Int -> WindowSize -> [(SettingsKey, Int)]-makeMySettingsList Config{..} maxConc winSiz = myInitialAlist- where- -- confBufferSize is the size of the write buffer.- -- But we assume that the size of the read buffer is the same size.- -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE.- len = confBufferSize - frameHeaderLength- payloadLen = max defaultPayloadLength len- myInitialAlist =- [ (SettingsMaxFrameSize, payloadLen)- , (SettingsMaxConcurrentStreams, maxConc)- , (SettingsInitialWindowSize, winSiz)- ]+{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- @@ -173,21 +179,30 @@ ---------------------------------------------------------------- +getPeerLastStreamId :: Context -> IO StreamId+getPeerLastStreamId ctx = readIORef $ peerLastStreamId ctx++modifyPeerLastStreamId :: Context -> StreamId -> IO ()+modifyPeerLastStreamId ctx sid = atomicModifyIORef' (peerLastStreamId ctx) $ \n -> if sid > n then (sid, ()) else (n, ())++----------------------------------------------------------------+ {-# INLINE setStreamState #-} setStreamState :: Context -> Stream -> StreamState -> IO () setStreamState _ Stream{streamState} newState = do oldState <- readIORef streamState case (oldState, newState) of- (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) | q == q' ->- -- The stream stays open with the same body; nothing to do- return ()- (Open _ (Body q _ _ _), _) ->- -- The stream is either closed, or is open with a /new/ body- -- We need to close the old queue so that any reads from it won't block- atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed- _otherwise ->- -- The stream wasn't open to start with; nothing to do- return ()+ (Open _ (Body q _ _ _), Open _ (Body q' _ _ _))+ | q == q' ->+ -- The stream stays open with the same body; nothing to do+ return ()+ (Open _ (Body q _ _ _), _) ->+ -- The stream is either closed, or is open with a /new/ body+ -- We need to close the old queue so that any reads from it won't block+ atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed+ _otherwise ->+ -- The stream wasn't open to start with; nothing to do+ return () writeIORef streamState newState opened :: Context -> Stream -> IO ()
Network/HTTP2/H2/EncodeFrame.hs view
@@ -23,10 +23,10 @@ where einfo = encodeInfo func 0 -pingFrame :: ByteString -> ByteString-pingFrame bs = encodeFrame einfo $ PingFrame bs+pingFrame :: Bool -> ByteString -> ByteString+pingFrame ack bs = encodeFrame einfo $ PingFrame bs where- einfo = encodeInfo setAck 0+ einfo = encodeInfo (if ack then setAck else id) 0 windowUpdateFrame :: StreamId -> WindowSize -> ByteString windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz
− Network/HTTP2/H2/File.hs
@@ -1,38 +0,0 @@-module Network.HTTP2.H2.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/H2/HPACK.hs view
@@ -12,11 +12,11 @@ import qualified Control.Exception as E import Network.ByteOrder-import qualified Network.HTTP.Types as H+import Network.HTTP.Semantics+import Network.HTTP.Types import Imports import Network.HPACK-import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.Types@@ -26,17 +26,17 @@ ---------------------------------------------------------------- -fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders+fixHeaders :: ResponseHeaders -> ResponseHeaders fixHeaders hdr = deleteUnnecessaryHeaders hdr -deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders+deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders deleteUnnecessaryHeaders hdr = filter del hdr where del (k, _) = k `notElem` headersToBeRemoved -headersToBeRemoved :: [H.HeaderName]+headersToBeRemoved :: [HeaderName] headersToBeRemoved =- [ H.hConnection+ [ hConnection , "Transfer-Encoding" -- Keep-Alive -- Proxy-Connection@@ -71,7 +71,7 @@ ---------------------------------------------------------------- hpackDecodeHeader- :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+ :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeHeader hdrblk sid ctx = do tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx if isClient ctx || checkRequestHeader vt@@ -79,7 +79,7 @@ else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header" hpackDecodeTrailer- :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+ :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl where handl IllegalHeaderName =@@ -101,14 +101,14 @@ | just mTE (/= "trailers") = False | otherwise = checkAuth mAuthority mHost 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- mAuthority = getHeaderValue tokenAuthority reqvt- mHost = getHeaderValue tokenHost reqvt+ mStatus = getFieldValue tokenStatus reqvt+ mScheme = getFieldValue tokenScheme reqvt+ mPath = getFieldValue tokenPath reqvt+ mMethod = getFieldValue tokenMethod reqvt+ mConnection = getFieldValue tokenConnection reqvt+ mTE = getFieldValue tokenTE reqvt+ mAuthority = getFieldValue tokenAuthority reqvt+ mHost = getFieldValue tokenHost reqvt checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool checkAuth Nothing Nothing = False
− Network/HTTP2/H2/Manager.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | A thread manager.--- The manager has responsibility to spawn and kill--- worker threads.-module Network.HTTP2.H2.Manager (- Manager,- Action,- start,- setAction,- stopAfter,- spawnAction,- forkManaged,- forkManagedUnmask,- timeoutKillThread,- timeoutClose,- KilledByHttp2ThreadManager (..),- incCounter,- decCounter,- waitCounter0,-) where--import Control.Exception-import Data.Foldable-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import qualified System.TimeManager as T-import UnliftIO.Concurrent-import qualified UnliftIO.Exception as E-import UnliftIO.STM--import Imports---------------------------------------------------------------------- | Action to be spawned by the manager.-type Action = IO ()--noAction :: Action-noAction = return ()--data Command = Stop (Maybe SomeException) | Spawn | Add ThreadId | Delete ThreadId---- | Manager to manage the thread and the timer.-data Manager = Manager (TQueue Command) (IORef Action) (TVar Int) T.Manager---- | Starting a thread 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- cnt <- newTVarIO 0- void $ forkIO $ go q Set.empty ref- return $ Manager q ref cnt timmgr- where- go q tset0 ref = do- x <- atomically $ readTQueue q- case x of- Stop err -> kill tset0 err- 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 <- forkFinally action $ \_ -> do- mytid <- myThreadId- atomically $ writeTQueue q $ Delete mytid- 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.-stopAfter :: Manager -> IO a -> (Either SomeException a -> IO b) -> IO b-stopAfter (Manager q _ _ _) action cleanup = do- mask $ \unmask -> do- ma <- try $ unmask action- atomically $ writeTQueue q $ Stop (either Just (const Nothing) ma)- cleanup ma---- | Spawning the action.-spawnAction :: Manager -> IO ()-spawnAction (Manager q _ _ _) = atomically $ writeTQueue q Spawn---------------------------------------------------------------------- | Fork managed thread------ This guarantees that the thread ID is added to the manager's queue before--- the thread starts, and is removed again when the thread terminates--- (normally or abnormally).-forkManaged :: Manager -> IO () -> IO ()-forkManaged mgr io =- forkManagedUnmask mgr $ \unmask -> unmask io---- | Like 'forkManaged', but run action with exceptions masked-forkManagedUnmask :: Manager -> ((forall x. IO x -> IO x) -> IO ()) -> IO ()-forkManagedUnmask mgr io =- void $ mask_ $ forkIOWithUnmask $ \unmask -> do- addMyId mgr- -- We catch the exception and do not rethrow it: we don't want the- -- exception printed to stderr.- io unmask `catch` \(_e :: SomeException) -> return ()- deleteMyId mgr---- | Adding my thread id to the kill-thread list on stopping.------ This is not part of the public API; see 'forkManaged' instead.-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.------ This is /only/ necessary when you want to remove the thread's ID from--- the manager /before/ the thread terminates (thereby assuming responsibility--- for thread cleanup yourself).-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 -> Maybe SomeException -> IO ()-kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadManager err) set---- | Killing the IO action of the second argument on timeout.-timeoutKillThread :: Manager -> (T.Handle -> IO a) -> IO a-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--data KilledByHttp2ThreadManager = KilledByHttp2ThreadManager (Maybe SomeException)- deriving (Show)--instance Exception KilledByHttp2ThreadManager where- toException = asyncExceptionToException- fromException = asyncExceptionFromException--------------------------------------------------------------------incCounter :: Manager -> IO ()-incCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (+ 1)--decCounter :: Manager -> IO ()-decCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (subtract 1)--waitCounter0 :: Manager -> IO ()-waitCounter0 (Manager _ _ cnt _) = atomically $ do- n <- readTVar cnt- checkSTM (n < 1)
Network/HTTP2/H2/Queue.hs view
@@ -1,23 +1,16 @@-{-# LANGUAGE RecordWildCards #-}- module Network.HTTP2.H2.Queue where -import UnliftIO.STM+import Control.Concurrent.STM -import Network.HTTP2.H2.Manager import Network.HTTP2.H2.Types -{-# INLINE forkAndEnqueueWhenReady #-}-forkAndEnqueueWhenReady- :: IO () -> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()-forkAndEnqueueWhenReady wait outQ out mgr =- forkManaged mgr $ do- wait- enqueueOutput outQ out- {-# INLINE enqueueOutput #-}-enqueueOutput :: TQueue (Output Stream) -> Output Stream -> IO ()+enqueueOutput :: TQueue Output -> Output -> IO () enqueueOutput outQ out = atomically $ writeTQueue outQ out++{-# INLINE enqueueOutputSTM #-}+enqueueOutputSTM :: TQueue Output -> Output -> STM ()+enqueueOutputSTM outQ out = writeTQueue outQ out {-# INLINE enqueueControl #-} enqueueControl :: TQueue Control -> Control -> IO ()
− Network/HTTP2/H2/ReadN.hs
@@ -1,40 +0,0 @@-module Network.HTTP2.H2.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/H2/Receiver.hs view
@@ -2,24 +2,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP2.H2.Receiver ( frameReceiver,+ closureClient,+ closureServer,+ sendPing, ) 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 qualified Data.ByteString.Short as Short import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef+import Data.Void import Network.Control-import UnliftIO.Concurrent-import qualified UnliftIO.Exception as E-import UnliftIO.STM+import Network.HTTP.Semantics+import qualified System.ThreadManager as T import Imports hiding (delete, insert)-import Network.HPACK-import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame@@ -39,58 +44,46 @@ headerFragmentLimit :: Int headerFragmentLimit = 51200 -- 50K -settingsRateLimit :: Int-settingsRateLimit = 4--emptyFrameRateLimit :: Int-emptyFrameRateLimit = 4--rstRateLimit :: Int-rstRateLimit = 4- ---------------------------------------------------------------- -frameReceiver :: Context -> Config -> IO ()-frameReceiver ctx@Context{..} conf@Config{..} = loop 0 `E.catch` sendGoaway+frameReceiver :: Context -> Config -> IO E.SomeException+frameReceiver ctx@Context{receiverDone} conf@Config{..} =+ E.mask $ \unmask -> do+ mErr <- E.try $ unmask switch+ case mErr of+ Left err -> do+ atomically $ writeTVar receiverDone $ Just err+ return err+ Right x -> do+ absurd x -- We only terminate due to exceptions where- loop :: Int -> IO ()- loop n- | n == 6 = do- yield- loop 0- | otherwise = do- hd <- confReadN frameHeaderLength- if BS.null hd- then enqueueControl controlQ $ CFinish ConnectionIsClosed- else do- processFrame ctx conf $ decodeFrameHeader hd- loop (n + 1)+ switch :: IO Void+ switch = do+ labelMe "H2 receiver"+ tid <- myThreadId+ if confReadNTimeout+ then+ loop1+ else+ T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2 - sendGoaway se- | Just e@ConnectionIsClosed <- E.fromException se =- enqueueControl controlQ $ CFinish e- | Just e@(ConnectionErrorIsReceived _ _ _) <- E.fromException se =- enqueueControl controlQ $ CFinish e- | Just e@(ConnectionErrorIsSent err sid msg) <- E.fromException se = do- let frame = goawayFrame sid err $ Short.fromShort msg- enqueueControl controlQ $ CFrames Nothing [frame]- enqueueControl controlQ $ CFinish e- | Just e@(StreamErrorIsSent err sid msg) <- E.fromException se = do- let frame = resetFrame err sid- enqueueControl controlQ $ CFrames Nothing [frame]- let frame' = goawayFrame sid err $ Short.fromShort msg- enqueueControl controlQ $ CFrames Nothing [frame']- enqueueControl controlQ $ CFinish e- | Just e@(StreamErrorIsReceived err sid) <- E.fromException se = do- let frame = goawayFrame sid err "treat a stream error as a connection error"- enqueueControl controlQ $ CFrames Nothing [frame]- enqueueControl controlQ $ CFinish e- -- this never happens- | Just e@(BadThingHappen _) <- E.fromException se =- enqueueControl controlQ $ CFinish e- | otherwise =- enqueueControl controlQ $ CFinish $ BadThingHappen se+ loop1 :: IO Void+ loop1 = do+ hd <- confReadN frameHeaderLength -- throwing an exception on timeout+ when (BS.null hd) $ E.throwIO ConnectionIsClosed+ processFrame ctx conf $ decodeFrameHeader hd+ loop1 + loop2 :: T.Handle -> IO Void+ loop2 th = do+ -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown+ -- to destroy the thread trees.+ hd <- confReadN frameHeaderLength+ T.tickle th+ when (BS.null hd) $ E.throwIO ConnectionIsClosed+ processFrame ctx conf $ decodeFrameHeader hd+ loop2 th+ ---------------------------------------------------------------- processFrame :: Context -> Config -> (FrameType, FrameHeader) -> IO ()@@ -173,7 +166,7 @@ processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool -- Transition (process1) processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do- let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent@@ -181,21 +174,22 @@ streamId "no body but content-length is not zero" tlr <- newIORef Nothing- let inpObj = InpObj tbl (Just 0) (return "") tlr+ let inpObj = InpObj tbl (Just 0) (return (mempty, True)) tlr if isServer ctx then do- let si = toServerInfo roleInfo- atomically $ writeTQueue (inputQ si) $ Input strm inpObj+ let ServerInfo{..} = toServerInfo roleInfo+ launch ctx strm inpObj else putMVar streamInput $ Right inpObj halfClosedRemote ctx strm return False -- Transition (process2)-processState (Open hcl (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} _streamId = do- let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+processState (Open hcl (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput, streamRxQ} _streamId = do+ let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) bodyLength <- newIORef 0 tlr <- newIORef Nothing q <- newTQueueIO+ writeIORef streamRxQ $ Just q setStreamState ctx strm $ Open hcl (Body q mcl bodyLength tlr) -- FLOW CONTROL: WINDOW_UPDATE 0: recv: announcing my limit properly -- FLOW CONTROL: WINDOW_UPDATE: recv: announcing my limit properly@@ -203,8 +197,8 @@ let inpObj = InpObj tbl mcl (readSource bodySource) tlr if isServer ctx then do- let si = toServerInfo roleInfo- atomically $ writeTQueue (inputQ si) $ Input strm inpObj+ let ServerInfo{..} = toServerInfo roleInfo+ launch ctx strm inpObj else putMVar streamInput $ Right inpObj return False @@ -281,7 +275,7 @@ let errmsg = Short.toShort ( "this frame is not allowed in an idle stream: "- `BS.append` (C8.pack (show ftyp))+ `BS.append` C8.pack (show ftyp) ) E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId@@ -309,7 +303,7 @@ else do -- Settings Flood - CVE-2019-9515 rate <- getRate settingsRate- when (rate > settingsRateLimit) $+ when (rate > settingsRateLimit mySettings) $ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many settings" let ack = settingsFrame setAck []@@ -325,14 +319,12 @@ setframe = CFrames (Just peerAlist) (frames ++ [ack]) writeIORef myFirstSettings True enqueueControl controlQ setframe-control FramePing FrameHeader{flags, streamId} bs Context{mySettings, controlQ, pingRate} =+control FramePing FrameHeader{flags, streamId} bs ctx@Context{mySettings, pingRate} = unless (testAck flags) $ do rate <- getRate pingRate if rate > pingRateLimit mySettings then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many ping"- else do- let frame = pingFrame bs- enqueueControl controlQ $ CFrames Nothing [frame]+ else sendPing ctx True bs control FrameGoAway header bs _ = do GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs if err == NoError@@ -366,12 +358,12 @@ (_, vt) <- hpackDecodeHeader frag streamId ctx let ClientInfo{..} = toClientInfo $ roleInfo ctx when- ( getHeaderValue tokenAuthority vt == Just (UTF8.fromString authority)- && getHeaderValue tokenScheme vt == Just scheme+ ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority)+ && getFieldValue tokenScheme vt == Just scheme ) $ do- let mmethod = getHeaderValue tokenMethod vt- mpath = getHeaderValue tokenPath vt+ let mmethod = getFieldValue tokenMethod vt+ mpath = getFieldValue tokenPath vt case (mmethod, mpath) of (Just method, Just path) -> -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit@@ -412,7 +404,7 @@ then do -- Empty Frame Flooding - CVE-2019-9518 rate <- getRate $ emptyFrameRate ctx- if rate > emptyFrameRateLimit+ if rate > emptyFrameRateLimit (mySettings ctx) then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty headers"@@ -442,7 +434,7 @@ then do tbl <- hpackDecodeTrailer frag streamId ctx writeIORef tlr (Just tbl)- atomically $ writeTQueue q $ Right ""+ atomically $ writeTQueue q $ Right (mempty, True) return HalfClosedRemote else -- we don't support continuation here. E.throwIO $@@ -456,7 +448,7 @@ FrameData header@FrameHeader{flags, payloadLength, streamId} bs- Context{emptyFrameRate, rxFlow}+ Context{emptyFrameRate, rxFlow, mySettings} s@(Open _ (Body q mcl bodyLength _)) Stream{..} = do DataFrame body <- guardIt $ decodeDataFrame header bs@@ -483,11 +475,11 @@ if body == "" then unless endOfStream $ do rate <- getRate emptyFrameRate- when (rate > emptyFrameRateLimit) $ do+ when (rate > emptyFrameRateLimit mySettings) $ do E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty data" else do writeIORef bodyLength len- atomically $ writeTQueue q $ Right body+ atomically $ writeTQueue q $ Right (body, endOfStream) if endOfStream then do case mcl of@@ -500,7 +492,7 @@ streamId "actual body length is not the same as content-length" -- no trailers- atomically $ writeTQueue q $ Right ""+ atomically $ writeTQueue q $ Right (mempty, True) return HalfClosedRemote else return s @@ -511,7 +503,7 @@ then do -- Empty Frame Flooding - CVE-2019-9518 rate <- getRate $ emptyFrameRate ctx- if rate > emptyFrameRateLimit+ if rate > emptyFrameRateLimit (mySettings ctx) then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation"@@ -547,7 +539,7 @@ stream FrameRSTStream header@FrameHeader{streamId} bs ctx s strm = do -- Rapid Rest: CVE-2023-44487 rate <- getRate $ rstRate ctx- when (rate > rstRateLimit) $+ when (rate > rstRateLimit (mySettings ctx)) $ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many rst_stream" RSTStreamFrame err <- guardIt $ decodeRSTStreamFrame header bs@@ -569,18 +561,26 @@ -- > /Either endpoint/ can send a RST_STREAM frame from this state, causing -- > it to transition immediately to "closed". --- -- (emphasis not in original). This justifies the two non-error cases,- -- below. (Section 8.1 of the spec is also relevant, but it is less explicit- -- about the /either endpoint/ part.)- case (s, err) of- (Open (Just _) _, NoError) ->- -- HalfClosedLocal- return (Closed cc)- (HalfClosedRemote, NoError) ->- return (Closed cc)+ -- (emphasis not in original).+ --+ -- In addition, the spec states (about the open state):+ --+ -- > Either endpoint can send a RST_STREAM frame from this state, causing it+ -- > to transition immediately to "closed".+ --+ -- This justifies the two non-error cases, below. (Section 8.1 of the spec+ -- is also relevant, but it is less explicit about the /either endpoint/+ -- part.)+ case s of+ Open _ _+ | isNonCritical err ->+ -- Open /or/ half-closed (local)+ return (Closed cc)+ HalfClosedRemote+ | isNonCritical err ->+ return (Closed cc) _otherwise -> do E.throwIO $ StreamErrorIsReceived err streamId- -- (No state transition) stream FramePriority header bs _ s Stream{streamNumber} = do -- ignore@@ -610,44 +610,101 @@ StreamErrorIsSent ProtocolError streamId $ fromString ("illegal frame " ++ show x ++ " for " ++ show streamId) +{- FOURMOLU_DISABLE -}+-- Although some stream errors indicate misbehaving peers, such as+-- FLOW_CONTROL_ERROR, not all errors do. We will close the connection only+-- for critical errors.+isNonCritical :: ErrorCode -> Bool+isNonCritical NoError = True+isNonCritical Cancel = True+isNonCritical InternalError = True+isNonCritical _ = False+{- FOURMOLU_ENABLE -}+ ---------------------------------------------------------------- -- | Type for input streaming.-data Source- = Source- (Int -> IO ())- (TQueue (Either E.SomeException ByteString))- (IORef ByteString)- (IORef Bool)+data Source = Source RxQ (Int -> IO ()) (IORef Bool) -mkSource- :: TQueue (Either E.SomeException ByteString) -> (Int -> IO ()) -> IO Source-mkSource q inform = Source inform q <$> newIORef "" <*> newIORef False+mkSource :: RxQ -> (Int -> IO ()) -> IO Source+mkSource q inform = Source q inform <$> newIORef False -readSource :: Source -> IO ByteString-readSource (Source inform q refBS refEOF) = do+readSource :: Source -> IO (ByteString, Bool)+readSource (Source q inform refEOF) = do eof <- readIORef refEOF if eof- then return ""+ then return (mempty, True) else do- bs <- readBS- let len = BS.length bs- inform len- return bs+ mBS <- atomically $ readTQueue q+ case mBS of+ Left err -> do+ writeIORef refEOF True+ E.throwIO err+ Right (bs, isEOF) -> do+ writeIORef refEOF isEOF+ let len = BS.length bs+ inform len+ return (bs, isEOF)++----------------------------------------------------------------++closureClient :: Config -> Context -> Either E.SomeException a -> IO a+closureClient conf ctx (Right x) = do+ frame <- goaway ctx NoError "no error"+ sendGoaway conf frame+ return x+closureClient conf ctx (Left se) = closureServer conf ctx se++closureServer :: Config -> Context -> E.SomeException -> IO a+closureServer conf ctx se+ | isAsyncException se = do+ frame <- goaway ctx NoError "maybe timeout by manager"+ sendGoaway conf frame+ E.throwIO se+ | Just ConnectionIsClosed <- E.fromException se = do+ frame <- goaway ctx NoError "no error"+ sendGoaway conf frame+ E.throwIO ConnectionIsClosed+ | Just ConnectionIsTimeout <- E.fromException se = do+ frame <- goaway ctx NoError "timeout"+ sendGoaway conf frame+ E.throwIO ConnectionIsTimeout+ | Just e@(ConnectionErrorIsReceived _err _sid msg) <- E.fromException se = do+ frame <- goaway ctx NoError $ Short.fromShort msg+ sendGoaway conf frame+ E.throwIO e+ | Just e@(ConnectionErrorIsSent err _sid msg) <- E.fromException se = do+ frame <- goaway ctx err $ Short.fromShort msg+ sendGoaway conf frame+ E.throwIO e+ | Just e@(StreamErrorIsSent err _sid msg) <- E.fromException se = do+ let frame = resetFrame err _sid+ frame' <- goaway ctx err $ Short.fromShort msg+ sendGoaway conf (frame <> frame')+ E.throwIO e+ | Just e@(StreamErrorIsReceived err _sid) <- E.fromException se = do+ frame <- goaway ctx err "treat a stream error as a connection error"+ sendGoaway conf frame+ E.throwIO e+ | Just (_ :: HTTP2Error) <- E.fromException se = E.throwIO se+ | otherwise = E.throwIO $ BadThingHappen se++goaway :: Context -> ErrorCode -> ByteString -> IO ByteString+goaway ctx err msg = do+ sid <- getPeerLastStreamId ctx+ return $ goawayFrame sid err msg++sendGoaway :: Config -> ByteString -> IO ()+sendGoaway Config{..} frame = confSendAll frame `E.catch` ignore++ignore :: E.SomeException -> IO ()+ignore (E.SomeException e)+ | isAsyncException e = E.throwIO e+ | otherwise = return ()++----------------------------------------------------------------++sendPing :: Context -> Bool -> ByteString -> IO ()+sendPing Context{..} ack bs = enqueueControl controlQ $ CFrames Nothing [frame] where- readBS :: IO ByteString- readBS = do- bs0 <- readIORef refBS- if bs0 == ""- then do- mBS <- atomically $ readTQueue q- case mBS of- Left err -> do- writeIORef refEOF True- E.throwIO err- Right bs -> do- when (bs == "") $ writeIORef refEOF True- return bs- else do- writeIORef refBS ""- return bs0+ frame = pingFrame ack bs
Network/HTTP2/H2/Sender.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -5,31 +6,23 @@ module Network.HTTP2.H2.Sender ( frameSender,- fillBuilderBodyGetNext,- fillFileBodyGetNext,- fillStreamBodyGetNext,- runTrailersMaker, ) where -import Control.Concurrent.MVar (putMVar)-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder.Extra as B+import Control.Concurrent.STM+import qualified Control.Exception as E import Data.IORef (modifyIORef', readIORef, writeIORef) import Data.IntMap.Strict (IntMap) import Foreign.Ptr (minusPtr, plusPtr) import Network.ByteOrder-import qualified UnliftIO.Exception as E-import UnliftIO.STM+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.IO import Imports-import Network.HPACK (TokenHeaderList, setLimitForEncoding, toHeaderTable)+import Network.HPACK (setLimitForEncoding, toTokenHeaderTable) import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame-import Network.HTTP2.H2.File import Network.HTTP2.H2.HPACK-import Network.HTTP2.H2.Manager hiding (start) import Network.HTTP2.H2.Queue import Network.HTTP2.H2.Settings import Network.HTTP2.H2.Stream@@ -39,29 +32,11 @@ ---------------------------------------------------------------- -data Leftover- = LZero- | LOne B.BufferWriter- | LTwo ByteString B.BufferWriter--------------------------------------------------------------------{-# INLINE waitStreaming #-}-waitStreaming :: TBQueue a -> IO ()-waitStreaming tbq = atomically $ do- isEmpty <- isEmptyTBQueue tbq- checkSTM (not isEmpty)- data Switch = C Control- | O (Output Stream)+ | O Output | Flush -wrapException :: E.SomeException -> IO ()-wrapException se- | Just (e :: HTTP2Error) <- E.fromException se = E.throwIO e- | otherwise = E.throwIO $ BadThingHappen se- -- Peer SETTINGS_INITIAL_WINDOW_SIZE -- Adjusting initial window size for streams updatePeerSettings :: Context -> SettingsList -> IO ()@@ -83,20 +58,42 @@ updateAllStreamTxFlow siz strms = forM_ strms $ \strm -> increaseStreamWindowSize strm siz -frameSender :: Context -> Config -> Manager -> IO ()+checkDone :: Context -> Int -> IO (Maybe E.SomeException)+checkDone Context{..} 0 = atomically $ do+ isEmptyC <- isEmptyTQueue controlQ+ isEmptyO <- isEmptyTQueue outputQ+ if not isEmptyC || not isEmptyO+ then+ return Nothing+ else do+ recv <- readTVar receiverDone+ case recv of+ Just done ->+ return $ Just done+ _otherwise ->+ retry+checkDone _ _ = return Nothing++frameSender :: Context -> Config -> IO E.SomeException frameSender ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit}- Config{..}- mgr = loop 0 `E.catch` wrapException+ Config{..} = do+ labelMe "H2 sender"+ loop 0 `E.catch` return where ----------------------------------------------------------------- loop :: Offset -> IO ()+ loop :: Offset -> IO E.SomeException loop off = do- x <- atomically $ dequeue off- case x of- C ctl -> flushN off >> control ctl >> loop 0- O out -> outputOrEnqueueAgain out off >>= flushIfNecessary >>= loop- Flush -> flushN off >> loop 0+ mDone <- checkDone ctx off+ case mDone of+ Just done ->+ return done+ Nothing -> do+ x <- atomically $ dequeue off+ case x of+ C ctl -> flushN off >> control ctl >> loop 0+ O out -> outputAndSync out off >>= flushIfNecessary >>= loop+ Flush -> flushN off >> loop 0 -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled.@@ -122,7 +119,7 @@ waitConnectionWindowSize ctx isEmptyO <- isEmptyTQueue outputQ if isEmptyO- then if off /= 0 then return Flush else retrySTM+ then if off /= 0 then return Flush else retry else O <$> readTQueue outputQ else C <$> readTQueue controlQ @@ -132,13 +129,6 @@ -- called with off == 0 control :: Control -> IO ()- control (CFinish e) = E.throwIO e- control (CGoaway bs mvar) = do- buf <- copyAll [bs] confWriteBuffer- let off = buf `minusPtr` confWriteBuffer- flushN off- putMVar mvar ()- E.throwIO GoAwayIsSent control (CFrames ms xs) = do buf <- copyAll xs confWriteBuffer let off = buf `minusPtr` confWriteBuffer@@ -158,119 +148,115 @@ | otherwise = confBufferSize writeIORef outputBufferLimit buflim -- Peer SETTINGS_HEADER_TABLE_SIZE- case lookup SettingsHeaderTableSize peerAlist of+ case lookup SettingsTokenHeaderTableSize peerAlist of Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable ----------------------------------------------------------------- output :: Output Stream -> Offset -> WindowSize -> IO Offset- output out@(Output strm OutObj{} (ONext curr tlrmkr) _ sentinel) off0 lim = do- -- Data frame payload- buflim <- readIORef outputBufferLimit- let payloadOff = off0 + frameHeaderLength- datBuf = confWriteBuffer `plusPtr` payloadOff- datBufSiz = buflim - payloadOff- Next datPayloadLen reqflush mnext <- curr datBuf datBufSiz lim -- checkme- NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen- fillDataHeaderEnqueueNext- strm- off0- datPayloadLen- mnext- tlrmkr'- sentinel- out- reqflush- output out@(Output strm (OutObj hdr body tlrmkr) OObj mtbq _) off0 lim = do+ -- INVARIANT+ --+ -- Both the stream window and the connection window are open.+ ----------------------------------------------------------------+ outputAndSync :: Output -> Offset -> IO Offset+ outputAndSync out@(Output strm otyp sync) off = E.handle (\e -> resetStream strm InternalError e >> return off) $ do+ state <- readStreamState strm+ if isHalfClosedLocal state+ then return off+ else case otyp of+ OHeader hdr mnext tlrmkr -> do+ (off', mout') <- outputHeader strm hdr mnext tlrmkr sync off+ sync mout'+ return off'+ _ -> do+ sws <- getStreamWindowSize strm+ cws <- getConnectionWindowSize ctx -- not 0+ let lim = min cws sws+ (off', mout') <- output out off lim+ sync mout'+ return off'++ resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()+ resetStream strm err e+ | isAsyncException e = E.throwIO e+ | otherwise = do+ closed ctx strm (ResetByMe e)+ let rst = resetFrame err $ streamNumber strm+ enqueueControl controlQ $ CFrames Nothing [rst]++ ----------------------------------------------------------------+ outputHeader+ :: Stream+ -> [Header]+ -> Maybe DynaNext+ -> TrailersMaker+ -> (Maybe Output -> IO ())+ -> Offset+ -> IO (Offset, Maybe Output)+ outputHeader strm hdr mnext tlrmkr sync off0 = do -- Header frame and Continuation frame let sid = streamNumber strm- endOfStream = case body of- OutBodyNone -> True- _ -> False- (ths, _) <- toHeaderTable $ fixHeaders hdr+ endOfStream = isNothing mnext+ (ths, _) <- toTokenHeaderTable $ fixHeaders hdr off' <- headerContinue sid ths endOfStream off0 -- halfClosedLocal calls closed which removes -- the stream from stream table.- when endOfStream $ halfClosedLocal ctx strm Finished off <- flushIfNecessary off'- case body of- OutBodyNone -> 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 _ ->- output (setNextForStreaming mtbq tlrmkr out) off lim- OutBodyStreamingUnmask _ ->- output (setNextForStreaming mtbq tlrmkr out) off lim- output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do+ case mnext of+ Nothing -> do+ -- endOfStream+ halfClosedLocal ctx strm Finished+ return (off, Nothing)+ Just next -> do+ let out' = Output strm (ONext next tlrmkr) sync+ return (off, Just out')++ ----------------------------------------------------------------+ output :: Output -> Offset -> WindowSize -> IO (Offset, Maybe Output)+ output out@(Output strm (ONext curr tlrmkr) _) off0 lim = do+ -- Data frame payload+ buflim <- readIORef outputBufferLimit+ let payloadOff = off0 + frameHeaderLength+ datBuf = confWriteBuffer `plusPtr` payloadOff+ datBufSiz = buflim - payloadOff+ curr datBuf (min datBufSiz lim) >>= \case+ Next datPayloadLen reqflush mnext -> do+ tm <- runTrailersMaker tlrmkr datBuf datPayloadLen+ let tlrmkr' = case tm of+ NextTrailersMaker t -> t+ _ -> defaultTrailersMaker+ fillDataHeader+ strm+ off0+ datPayloadLen+ mnext+ tlrmkr'+ out+ reqflush+ CancelNext mErr -> do+ -- Stream cancelled+ --+ -- At this point, the headers have already been sent.+ -- Therefore, the stream cannot be in the 'Idle' state, so we+ -- are justified in sending @RST_STREAM@.+ --+ -- By the invariant on the 'outputQ', there are no other+ -- outputs for this stream already enqueued. Therefore, we can+ -- safely cancel it knowing that we won't try and send any+ -- more data frames on this stream.+ case mErr of+ Just err ->+ resetStream strm InternalError err+ Nothing ->+ resetStream strm Cancel (E.toException CancelledStream)+ return (off0, Nothing)+ output (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 <- flushIfNecessary $ off0 + frameHeaderLength + len- output out{outputType = OObj} off lim- output _ _ _ = undefined -- never reach-- ----------------------------------------------------------------- setNextForStreaming- :: Maybe (TBQueue StreamingChunk)- -> TrailersMaker- -> Output Stream- -> Output Stream- setNextForStreaming mtbq tlrmkr out =- let tbq = fromJust mtbq- takeQ = atomically $ tryReadTBQueue tbq- next = fillStreamBodyGetNext takeQ- in out{outputType = ONext next tlrmkr}-- ----------------------------------------------------------------- outputOrEnqueueAgain :: Output Stream -> Offset -> IO Offset- 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- -- FLOW CONTROL: WINDOW_UPDATE: send: respecting peer's limit- checkStreamWindowSize = do- sws <- getStreamWindowSize strm- if sws == 0- then do- forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr- return off- else do- cws <- getConnectionWindowSize ctx -- 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 $ CFrames Nothing [rst]- return off+ return (off, Nothing)+ output _ _ _ = undefined -- never reached ---------------------------------------------------------------- headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset@@ -291,7 +277,7 @@ where eos = if endOfStream then setEndStream else id getFlag [] = eos $ setEndHeader defaultFlags- getFlag _ = eos $ defaultFlags+ getFlag _ = eos defaultFlags continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset continue off [] _ = return off@@ -313,70 +299,74 @@ continue off' ths' FrameContinuation ----------------------------------------------------------------- fillDataHeaderEnqueueNext+ fillDataHeader :: Stream -> Offset -> Int -> Maybe DynaNext -> (Maybe ByteString -> IO NextTrailersMaker)- -> IO ()- -> Output Stream+ -> Output -> Bool- -> IO Offset- fillDataHeaderEnqueueNext+ -> IO (Offset, Maybe Output)+ fillDataHeader strm@Stream{streamNumber} off datPayloadLen Nothing tlrmkr- tell _ reqflush = do let buf = confWriteBuffer `plusPtr` off- off' = off + frameHeaderLength + datPayloadLen (mtrailers, flag) <- do- Trailers trailers <- tlrmkr Nothing+ tm <- tlrmkr Nothing+ let trailers = case tm of+ Trailers t -> t+ _ -> [] if null trailers then return (Nothing, setEndStream defaultFlags) else return (Just trailers, defaultFlags)- fillFrameHeader FrameData datPayloadLen streamNumber flag buf+ -- Avoid sending an empty data frame before trailers at the end+ -- of a stream+ off' <-+ if datPayloadLen /= 0 || isNothing mtrailers+ then do+ decreaseWindowSize ctx strm datPayloadLen+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf+ return $ off + frameHeaderLength + datPayloadLen+ else+ return off off'' <- handleTrailers mtrailers off'- void tell halfClosedLocal ctx strm Finished- decreaseWindowSize ctx strm datPayloadLen if reqflush then do flushN off''- return 0- else return off''+ return (0, Nothing)+ else return (off'', Nothing) where handleTrailers Nothing off0 = return off0 handleTrailers (Just trailers) off0 = do- (ths, _) <- toHeaderTable trailers+ (ths, _) <- toTokenHeaderTable trailers headerContinue streamNumber ths True {- endOfStream -} off0- fillDataHeaderEnqueueNext+ fillDataHeader _ off 0 (Just next) tlrmkr- _ out reqflush = do let out' = out{outputType = ONext next tlrmkr}- enqueueOutput outputQ out' if reqflush then do flushN off- return 0- else return off- fillDataHeaderEnqueueNext+ return (0, Just out')+ else return (off, Just out')+ fillDataHeader strm@Stream{streamNumber} off datPayloadLen (Just next) tlrmkr- _ out reqflush = do let buf = confWriteBuffer `plusPtr` off@@ -385,12 +375,11 @@ fillFrameHeader FrameData datPayloadLen streamNumber flag buf decreaseWindowSize ctx strm datPayloadLen let out' = out{outputType = ONext next tlrmkr}- enqueueOutput outputQ out' if reqflush then do flushN off'- return 0- else return off'+ return (0, Just out')+ else return (off', Just out') ---------------------------------------------------------------- pushPromise :: StreamId -> StreamId -> TokenHeaderList -> Offset -> IO Int@@ -419,168 +408,3 @@ , flags = flag , streamId = sid }---- | 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- (cont, len, reqflush, leftover) <- runStreamBuilder buf room takeQ- return $ nextForStream cont len reqflush leftover takeQ--------------------------------------------------------------------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 True Nothing -- let's flush-nextForBuilder len (B.More _ writer) =- Next len False $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer) =- Next len False $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder- :: Buffer- -> BufferSize- -> IO (Maybe StreamingChunk)- -> IO- ( Bool -- continue- , BytesFilled- , Bool -- require flusing- , Leftover- )-runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0- where- loop buf room total = do- mbuilder <- takeQ- case mbuilder of- Nothing -> return (True, total, False, LZero)- 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 (True, total', False, LOne writer)- B.Chunk bs writer -> return (True, total', False, LTwo bs writer)- Just StreamingFlush -> return (True, total, True, LZero)- Just (StreamingFinished dec) -> do- dec- return (False, total, True, LZero)--fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext-fillBufStream leftover0 takeQ buf0 siz0 lim0 = do- let room0 = min siz0 lim0- case leftover0 of- LZero -> do- (cont, len, reqflush, leftover) <- runStreamBuilder buf0 room0 takeQ- getNext cont len reqflush leftover- 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 True room0 False $ LTwo bs2 writer- where- getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next- getNext cont len reqflush l = return $ nextForStream cont len reqflush l takeQ-- write- :: (Buffer -> BufferSize -> IO (Int, B.Next))- -> Buffer- -> BufferSize- -> Int- -> IO Next- write writer1 buf room sofar = do- (len, signal) <- writer1 buf room- case signal of- B.Done -> do- (cont, extra, reqflush, leftover) <-- runStreamBuilder (buf `plusPtr` len) (room - len) takeQ- let total = sofar + len + extra- getNext cont total reqflush leftover- B.More _ writer -> do- let total = sofar + len- getNext True total False $ LOne writer- B.Chunk bs writer -> do- let total = sofar + len- getNext True total False $ LTwo bs writer--nextForStream- :: Bool- -> BytesFilled- -> Bool- -> Leftover- -> IO (Maybe StreamingChunk)- -> Next-nextForStream False len reqflush _ _ = Next len reqflush Nothing-nextForStream True len reqflush leftOrZero takeQ =- Next len reqflush $ 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 True Nothing -- let's flush-nextForFile len _ _ 0 _ = Next len False Nothing-nextForFile len pread start bytes refresh =- Next len False $ Just $ fillBufFile pread start bytes refresh--{-# INLINE mini #-}-mini :: Int -> Int64 -> Int64-mini i n- | fromIntegral i < n = fromIntegral i- | otherwise = n
Network/HTTP2/H2/Settings.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}- module Network.HTTP2.H2.Settings where import Network.Control@@ -27,13 +24,19 @@ -- ^ SETTINGS_MAX_HEADER_LIST_SIZE , pingRateLimit :: Int -- ^ Maximum number of pings allowed per second (CVE-2019-9512)+ , emptyFrameRateLimit :: Int+ -- ^ Maximum number of empty data frames allowed per second (CVE-2019-9518)+ , settingsRateLimit :: Int+ -- ^ Maximum number of settings frames allowed per second (CVE-2019-9515)+ , rstRateLimit :: Int+ -- ^ Maximum number of reset frames allowed per second (CVE-2023-44487) } deriving (Eq, Show) -- | The default settings. -- -- >>> baseSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}+-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} baseSettings :: Settings baseSettings = Settings@@ -44,12 +47,15 @@ , maxFrameSize = defaultPayloadLength -- 2^14 (16,384) , maxHeaderListSize = Nothing , pingRateLimit = 10+ , emptyFrameRateLimit = 4+ , settingsRateLimit = 4+ , rstRateLimit = 4 } -- | The default settings. -- -- >>> defaultSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}+-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} defaultSettings :: Settings defaultSettings = baseSettings@@ -62,12 +68,12 @@ -- | Updating settings. -- -- >>> fromSettingsList defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderListSize,200)]--- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 200, pingRateLimit = 10}+-- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 200, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} {- FOURMOLU_DISABLE -} fromSettingsList :: Settings -> SettingsList -> Settings fromSettingsList settings kvs = foldl' update settings kvs where- update def (SettingsHeaderTableSize,x) = def { headerTableSize = x }+ update def (SettingsTokenHeaderTableSize,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 }@@ -101,7 +107,7 @@ s s0 headerTableSize- SettingsHeaderTableSize+ SettingsTokenHeaderTableSize id , diff s
− Network/HTTP2/H2/Status.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.HTTP2.H2.Status (- getStatus,- setStatus,-) where--import qualified Data.ByteString.Char8 as C8-import Data.ByteString.Internal (unsafeCreate)-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 $ toEnum code
Network/HTTP2/H2/Stream.hs view
@@ -1,15 +1,19 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-} module Network.HTTP2.H2.Stream where +import Control.Concurrent+import Control.Concurrent.STM import Control.Exception import Control.Monad import Data.IORef import Data.Maybe (fromMaybe) import Network.Control-import UnliftIO.Concurrent-import UnliftIO.STM+import Network.HTTP.Semantics+import Network.HTTP.Semantics.IO import Network.HTTP2.Frame import Network.HTTP2.H2.StreamTable@@ -52,6 +56,7 @@ <*> newEmptyMVar <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin)+ <*> newIORef Nothing newEvenStream :: StreamId -> WindowSize -> WindowSize -> IO Stream newEvenStream sid txwin rxwin =@@ -60,6 +65,7 @@ <*> newEmptyMVar <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin)+ <*> newIORef Nothing ---------------------------------------------------------------- @@ -71,27 +77,90 @@ closeAllStreams :: TVar OddStreamTable -> TVar EvenStreamTable -> Maybe SomeException -> IO ()-closeAllStreams ovar evar mErr' = do+closeAllStreams ovar evar mErr = do ostrms <- clearOddStreamTable ovar mapM_ finalize ostrms estrms <- clearEvenStreamTable evar mapM_ finalize estrms where+ -- We treat /every/ exception, including 'ConectionIsClosed', as abnormal+ -- termination: we should only report a clean termination when we receive an+ -- explicit @END_STREAM@ frame. finalize strm = do st <- readStreamState strm- void . tryPutMVar (streamInput strm) $- Left $- fromMaybe (toException ConnectionIsClosed) $- mErr+ void $ tryPutMVar (streamInput strm) err case st of Open _ (Body q _ _ _) ->- atomically $ writeTQueue q $ maybe (Right mempty) Left mErr+ atomically $ writeTQueue q $ maybe (Right (mempty, True)) Left mErr _otherwise -> return ()- mErr :: Maybe SomeException- mErr = case mErr' of- Just err- | Just ConnectionIsClosed <- fromException err ->- Nothing- _otherwise ->- mErr'++ err :: Either SomeException a+ err = Left $ fromMaybe (toException ConnectionIsClosed) mErr++----------------------------------------------------------------++data StreamTerminated+ = StreamPushedFinal+ | StreamCancelled+ | StreamOutOfScope+ deriving (Show)+ deriving anyclass (Exception)++withOutBodyIface+ :: TBQueue StreamingChunk+ -> (forall a. IO a -> IO a)+ -> (OutBodyIface -> IO r)+ -> IO r+withOutBodyIface tbq unmask k = do+ terminated <- newTVarIO Nothing+ let whenNotTerminated act = do+ mTerminated <- readTVar terminated+ maybe act throwSTM mTerminated++ terminateWith reason act = do+ mTerminated <- readTVar terminated+ case mTerminated of+ Just _ ->+ -- Already terminated+ return ()+ Nothing -> do+ writeTVar terminated (Just reason)+ act++ iface =+ OutBodyIface+ { outBodyUnmask = unmask+ , outBodyPush = \b ->+ atomically $+ whenNotTerminated $+ writeTBQueue tbq $+ StreamingBuilder b NotEndOfStream+ , outBodyPushFinal = \b ->+ atomically $ whenNotTerminated $ do+ writeTVar terminated (Just StreamPushedFinal)+ writeTBQueue tbq $ StreamingBuilder b (EndOfStream Nothing)+ writeTBQueue tbq $ StreamingFinished Nothing+ , outBodyFlush =+ atomically $+ whenNotTerminated $+ writeTBQueue tbq StreamingFlush+ , outBodyCancel =+ atomically+ . terminateWith StreamCancelled+ . writeTBQueue tbq+ . StreamingCancelled+ }+ finished = atomically $ do+ terminateWith StreamOutOfScope $+ writeTBQueue tbq $+ StreamingFinished Nothing+ k iface `finally` finished++nextForStreaming+ :: TBQueue StreamingChunk+ -> DynaNext+nextForStreaming tbq =+ let takeQ = atomically $ tryReadTBQueue tbq+ next = fillStreamBodyGetNext takeQ+ in next
Network/HTTP2/H2/StreamTable.hs view
@@ -38,7 +38,6 @@ import qualified Data.IntMap.Strict as IntMap import Network.Control (LRUCache) import qualified Network.Control as LRUCache-import Network.HTTP.Types (Method) import Imports import Network.HTTP2.H2.Types (Stream (..))@@ -59,6 +58,7 @@ , -- Cache must contain Stream instead of StreamId because -- a Stream is deleted when end-of-stream is received. -- After that, cache is looked up.+ -- LRUCache is not used as LRU but as fixed-size map. evenCache :: LRUCache (Method, ByteString) Stream }
+ Network/HTTP2/H2/Sync.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.H2.Sync (+ LoopCheck (..),+ newLoopCheck,+ syncWithSender,+ syncWithSender',+ makeOutput,+ makeOutputIO,+ enqueueOutputSIO,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Network.Control+import Network.HTTP.Semantics.IO++import Network.HTTP2.H2.Context+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.Types++syncWithSender+ :: Context+ -> Stream+ -> OutputType+ -> LoopCheck+ -> IO ()+syncWithSender ctx@Context{..} strm otyp lc = do+ (pop, out) <- makeOutput strm otyp+ enqueueOutput outputQ out+ syncWithSender' ctx pop lc++makeOutput :: Stream -> OutputType -> IO (IO Sync, Output)+makeOutput strm otyp = do+ var <- newEmptyMVar+ let push mout = case mout of+ Nothing -> putMVar var Done+ Just ot -> putMVar var $ Cont ot+ pop = takeMVar var+ out =+ Output+ { outputStream = strm+ , outputType = otyp+ , outputSync = push+ }+ return (pop, out)++makeOutputIO :: Context -> Stream -> OutputType -> Output+makeOutputIO Context{..} strm otyp = out+ where+ push mout = case mout of+ Nothing -> return ()+ -- Sender enqueues output again ignoring+ -- the stream TX window.+ Just ot -> enqueueOutput outputQ ot+ out =+ Output+ { outputStream = strm+ , outputType = otyp+ , outputSync = push+ }++enqueueOutputSIO :: Context -> Stream -> OutputType -> IO ()+enqueueOutputSIO ctx@Context{..} strm otyp = do+ let out = makeOutputIO ctx strm otyp+ enqueueOutput outputQ out++syncWithSender' :: Context -> IO Sync -> LoopCheck -> IO ()+syncWithSender' Context{..} pop lc = loop+ where+ loop = do+ s <- pop+ case s of+ Done -> return ()+ Cont newout -> do+ cont <- checkLoop lc+ when cont $ do+ -- This is justified by the precondition above+ enqueueOutput outputQ newout+ loop++newLoopCheck :: Stream -> Maybe (TBQueue StreamingChunk) -> IO LoopCheck+newLoopCheck strm mtbq = do+ tovar <- newTVarIO False+ return $+ LoopCheck+ { lcTBQ = mtbq+ , lcTimeout = tovar+ , lcWindow = streamTxFlow strm+ }++data LoopCheck = LoopCheck+ { lcTBQ :: Maybe (TBQueue StreamingChunk)+ , lcTimeout :: TVar Bool+ , lcWindow :: TVar TxFlow+ }++checkLoop :: LoopCheck -> IO Bool+checkLoop LoopCheck{..} = atomically $ do+ tout <- readTVar lcTimeout+ if tout+ then return False+ else do+ waitStreaming' lcTBQ+ waitStreamWindowSizeSTM lcWindow+ return True++waitStreaming' :: Maybe (TBQueue a) -> STM ()+waitStreaming' Nothing = return ()+waitStreaming' (Just tbq) = do+ isEmpty <- isEmptyTBQueue tbq+ check (not isEmpty)++waitStreamWindowSizeSTM :: TVar TxFlow -> STM ()+waitStreamWindowSizeSTM txf = do+ w <- txWindowSize <$> readTVar txf+ check (w > 0)
Network/HTTP2/H2/Types.hs view
@@ -1,138 +1,33 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Types where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (+ Exception,+ SomeAsyncException (..),+ SomeException (..),+ ) import qualified Control.Exception as E-import Data.ByteString.Builder (Builder) import Data.IORef-import Data.Typeable+import Foreign.Ptr (nullPtr) import Network.Control-import qualified Network.HTTP.Types as H+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.IO import Network.Socket hiding (Stream) import System.IO.Unsafe import qualified System.TimeManager as T-import UnliftIO.Concurrent-import UnliftIO.Exception (SomeException)-import UnliftIO.STM import Imports import Network.HPACK import Network.HTTP2.Frame-import Network.HTTP2.H2.File ---------------------------------------------------------------- --- | "http" or "https".-type Scheme = ByteString---- | Authority.-type Authority = String---- | 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 ())- | -- | Like 'OutBodyStreaming', but with a callback to unmask expections- --- -- This is used in the client: we spawn the new thread for the request body- -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask'- -- with a callback to unmask them again (typically after installing an exception- -- handler).- --- -- We do /NOT/ support this in the server, as here the scope of the thread- -- that is spawned for the server is the entire handler, not just the response- -- streaming body.- --- -- TODO: The analogous change for the server-side would be to provide a similar- -- @unmask@ callback as the first argument in the 'Server' type alias.- OutBodyStreamingUnmask- ((forall x. IO x -> IO x) -> (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)------------------------------------------------------------------- {- == Stream state@@ -216,14 +111,14 @@ Int -- Total size Int -- The number of continuation frames Bool -- End of stream- | NoBody HeaderTable- | HasBody HeaderTable+ | NoBody TokenHeaderTable+ | HasBody TokenHeaderTable | Body- (TQueue (Either SomeException ByteString))+ (TQueue (Either SomeException (ByteString, Bool))) (Maybe Int) -- received Content-Length -- compared the body length for error checking (IORef Int) -- actual body length- (IORef (Maybe HeaderTable)) -- trailers+ (IORef (Maybe TokenHeaderTable)) -- trailers data ClosedCode = Finished@@ -232,6 +127,11 @@ | ResetByMe SomeException deriving (Show) +-- | Used for streams which are cancelled by calling+-- 'Network.HTTP.Semantics.outBodyCancel'.+data CancelledStream = CancelledStream+ deriving (Show, E.Exception)+ closedCodeToError :: StreamId -> ClosedCode -> HTTP2Error closedCodeToError sid cc = case cc of@@ -259,12 +159,15 @@ ---------------------------------------------------------------- +type RxQ = TQueue (Either E.SomeException (ByteString, Bool))+ data Stream = Stream { streamNumber :: StreamId , streamState :: IORef StreamState , streamInput :: MVar (Either SomeException InpObj) -- Client only , streamTxFlow :: TVar TxFlow , streamRxFlow :: IORef RxFlow+ , streamRxQ :: IORef (Maybe RxQ) } instance Show Stream where@@ -277,47 +180,22 @@ ---------------------------------------------------------------- -data Input a = Input a InpObj--data Output a = Output- { outputStream :: a- , outputObject :: OutObj+data Output = Output+ { outputStream :: Stream , outputType :: OutputType- , outputStrmQ :: Maybe (TBQueue StreamingChunk)- , outputSentinel :: IO ()+ , outputSync :: Maybe Output -> IO () } data OutputType- = OObj- | OWait (IO ())+ = OHeader [Header] (Maybe DynaNext) TrailersMaker | 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 -- payload length- Bool -- require flushing- (Maybe DynaNext)--------------------------------------------------------------------data Control- = CFinish HTTP2Error- | CFrames (Maybe SettingsList) [ByteString]- | CGoaway ByteString (MVar ())+data Sync = Done | Cont Output ---------------------------------------------------------------- -data StreamingChunk- = StreamingFinished (IO ())- | StreamingFlush- | StreamingBuilder Builder+data Control = CFrames (Maybe SettingsList) [ByteString] ---------------------------------------------------------------- @@ -337,8 +215,7 @@ | StreamErrorIsReceived ErrorCode StreamId | StreamErrorIsSent ErrorCode StreamId ReasonPhrase | BadThingHappen E.SomeException- | GoAwayIsSent- deriving (Show, Typeable)+ deriving (Show) instance E.Exception HTTP2Error @@ -393,4 +270,27 @@ -- ^ This is copied into 'Aux', if exist, on server. , confPeerSockAddr :: SockAddr -- ^ This is copied into 'Aux', if exist, on server.+ , confReadNTimeout :: Bool }++-- | Default config. This is just a template to modify via+-- field names. Don't use this without modifications.+defaultConfig :: Config+defaultConfig =+ Config+ { confWriteBuffer = nullPtr+ , confBufferSize = 0+ , confSendAll = \_ -> return ()+ , confReadN = \_ -> return ""+ , confPositionReadMaker = defaultPositionReadMaker+ , confTimeoutManager = T.defaultManager+ , confMySockAddr = SockAddrInet 0 0+ , confPeerSockAddr = SockAddrInet 0 0+ , confReadNTimeout = False+ }++isAsyncException :: Exception e => e -> Bool+isAsyncException e =+ case E.fromException (E.toException e) of+ Just (SomeAsyncException _) -> True+ Nothing -> False
Network/HTTP2/H2/Window.hs view
@@ -1,12 +1,13 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Window where +import Control.Concurrent.STM+import qualified Control.Exception as E+import qualified Data.ByteString as BS import Data.IORef import Network.Control-import qualified UnliftIO.Exception as E-import UnliftIO.STM import Imports import Network.HTTP2.Frame@@ -26,12 +27,12 @@ waitStreamWindowSize :: Stream -> IO () waitStreamWindowSize Stream{streamTxFlow} = atomically $ do w <- txWindowSize <$> readTVar streamTxFlow- checkSTM (w > 0)+ check (w > 0) waitConnectionWindowSize :: Context -> STM () waitConnectionWindowSize Context{txFlow} = do w <- txWindowSize <$> readTVar txFlow- checkSTM (w > 0)+ check (w > 0) ---------------------------------------------------------------- -- Receiving window update@@ -79,3 +80,26 @@ let frame = windowUpdateFrame streamNumber ws cframe = CFrames Nothing [frame] enqueueControl controlQ cframe++-- This must be called after an application is finished+-- to adjust RX window.+adjustRxWindow :: Context -> Stream -> IO ()+adjustRxWindow ctx stream@Stream{streamRxQ} = do+ mq <- readIORef streamRxQ+ case mq of+ Nothing -> return ()+ Just q -> do+ len <- readQ q+ informWindowUpdate ctx stream len+ where+ readQ q = atomically $ loop 0+ where+ loop !total = do+ meb <- tryReadTQueue q+ case meb of+ Just (Right (bs, _)) -> loop (total + BS.length bs)+ Just le@(Left _) -> do+ -- reserving HTTP2Error+ writeTQueue q le+ return total+ _ -> return total
− Network/HTTP2/Internal.hs
@@ -1,39 +0,0 @@-module Network.HTTP2.Internal (- -- * File- module Network.HTTP2.H2.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,-- -- * Thread Manager- module Network.HTTP2.H2.Manager,-) where--import Network.HTTP2.H2.File-import Network.HTTP2.H2.Manager-import Network.HTTP2.H2.Sender-import Network.HTTP2.H2.Types
Network/HTTP2/Server.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | HTTP\/2 server library. -- -- Example:@@ -46,181 +44,35 @@ maxFrameSize, maxHeaderListSize, + -- ** Rate limits+ pingRateLimit,+ settingsRateLimit,+ emptyFrameRateLimit,+ rstRateLimit,+ -- * Common configuration- Config (..),+ Config,+ defaultConfig,+ confWriteBuffer,+ confBufferSize,+ confSendAll,+ confReadN,+ confPositionReadMaker,+ confTimeoutManager,+ confMySockAddr,+ confPeerSockAddr,+ confReadNTimeout, allocSimpleConfig,+ allocSimpleConfig', freeSimpleConfig,-- -- * HTTP\/2 server- Server,-- -- * Request- Request,-- -- ** Accessing request- requestMethod,- requestPath,- requestAuthority,- requestScheme,- requestHeaders,- requestBodySize,- getRequestBodyChunk,- getRequestTrailers,-- -- * Aux- Aux,- auxTimeHandle,- auxMySockAddr,- auxPeerSockAddr,-- -- * Response- Response,-- -- ** Creating response- responseNoBody,- responseFile,- responseStreaming,- responseBuilder,-- -- ** Accessing response- responseBodySize,-- -- ** Trailers maker- TrailersMaker,- NextTrailersMaker (..),- defaultTrailersMaker,- setResponseTrailersMaker,-- -- * Push promise- PushPromise,- pushPromise,- promiseRequestPath,- promiseResponse,-- -- * Types- Path,- Authority,- Scheme,- FileSpec (..),- FileOffset,- ByteCount,-- -- * RecvN- defaultReadN,-- -- * Position read for files- PositionReadMaker,- PositionRead,- Sentinel (..),- defaultPositionReadMaker,+ module Network.HTTP.Semantics.Server, ) where -import Data.ByteString.Builder (Builder)-import Data.IORef (readIORef)-import qualified Network.HTTP.Types as H-import qualified Data.ByteString.UTF8 as UTF8+import Network.HTTP.Semantics.Server -import Imports-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Frame.Types import Network.HTTP2.H2 import Network.HTTP2.Server.Run ( ServerConfig (..), defaultServerConfig, run, )-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) = UTF8.toString <$> 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 (Request req) = inpObjBody req---- | Reading request trailers.--- This function must be called after 'getRequestBodyChunk'--- returns an empty.-getRequestTrailers :: Request -> IO (Maybe HeaderTable)-getRequestTrailers (Request req) = readIORef (inpObjTrailers req)---------------------------------------------------------------------- | Creating response without body.-responseNoBody :: H.Status -> H.ResponseHeaders -> Response-responseNoBody st hdr = Response $ OutObj hdr' OutBodyNone defaultTrailersMaker- where- hdr' = setStatus st hdr---- | Creating response with file.-responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response-responseFile st hdr fileSpec = Response $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker- where- hdr' = setStatus st hdr---- | Creating response with builder.-responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response-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 $ 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 (OutObj _ (OutBodyFile (FileSpec _ _ len)) _)) = Just (fromIntegral len)-responseBodySize _ = Nothing---- | Setting 'TrailersMaker' to 'Response'.-setResponseTrailersMaker :: Response -> TrailersMaker -> Response-setResponseTrailersMaker (Response rsp) tm = Response rsp{outObjTrailers = tm}---------------------------------------------------------------------- | Creating push promise.--- The third argument is traditional, not used.-pushPromise :: ByteString -> Response -> Weight -> PushPromise-pushPromise path rsp _ = PushPromise path rsp
Network/HTTP2/Server/Internal.hs view
@@ -1,6 +1,8 @@ module Network.HTTP2.Server.Internal ( Request (..), Response (..),+ Config (..),+ ServerConfig (..), Aux (..), -- * Low level@@ -9,6 +11,8 @@ runIO, ) where +import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal+ import Network.HTTP2.H2 import Network.HTTP2.Server.Run-import Network.HTTP2.Server.Types
Network/HTTP2/Server/Run.hs view
@@ -1,25 +1,26 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Server.Run where +import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception import Imports import Network.Control (defaultMaxData)+import Network.HTTP.Semantics.IO+import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal import Network.Socket (SockAddr)-import UnliftIO.Async (concurrently_)+import qualified System.ThreadManager as T import Network.HTTP2.Frame import Network.HTTP2.H2-import Network.HTTP2.Server.Types import Network.HTTP2.Server.Worker -- | Server configuration data ServerConfig = ServerConfig { numberOfWorkers :: Int- -- ^ The number of workers+ -- ^ Deprecated field. , connectionWindowSize :: WindowSize -- ^ The window size of incoming streams , settings :: Settings@@ -27,10 +28,12 @@ } deriving (Eq, Show) +{-# DEPRECATED numberOfWorkers "No effect anymore" #-}+ -- | The default server config. -- -- >>> defaultServerConfig--- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}}+-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig@@ -43,23 +46,23 @@ -- | Running HTTP/2 server. run :: ServerConfig -> Config -> Server -> IO ()-run sconf@ServerConfig{numberOfWorkers} conf server = do+run sconf conf server = do ok <- checkPreface conf when ok $ do- (ctx, mgr) <- setup sconf conf- let wc = fromContext ctx- setAction mgr $ worker wc mgr server- replicateM_ numberOfWorkers $ spawnAction mgr- runH2 conf ctx mgr+ let lnch = runServer conf server+ ctx <- setup sconf conf lnch Nothing+ runH2 conf ctx ---------------------------------------------------------------- -data ServerIO = ServerIO+data ServerIO a = ServerIO { sioMySockAddr :: SockAddr , sioPeerSockAddr :: SockAddr- , sioReadRequest :: IO (StreamId, Stream, Request)- , sioWriteResponse :: Stream -> Response -> IO ()- , sioWriteBytes :: ByteString -> IO ()+ , sioReadRequest :: IO (a, Request)+ , sioWriteResponse :: a -> Response -> IO ()+ -- ^ 'Response' MUST be created with 'responseBuilder'.+ -- Others are not supported.+ , sioDone :: IO () } -- | Launching a receiver and a sender without workers.@@ -67,22 +70,35 @@ runIO :: ServerConfig -> Config- -> (ServerIO -> IO (IO ()))+ -> (ServerIO Stream -> IO (IO ())) -> IO () runIO sconf conf@Config{..} action = do ok <- checkPreface conf when ok $ do- (ctx@Context{..}, mgr) <- setup sconf conf- let ServerInfo{..} = toServerInfo roleInfo- get = do- Input strm inObj <- atomically $ readTQueue inputQ- return (streamNumber strm, strm, Request inObj)- putR strm (Response outObj) = do- let out = Output strm outObj OObj Nothing (return ())- enqueueOutput outputQ out- putB bs = enqueueControl controlQ $ CFrames Nothing [bs]- io <- action $ ServerIO confMySockAddr confPeerSockAddr get putR putB- concurrently_ io $ runH2 conf ctx mgr+ inpQ <- newTQueueIO+ let lnch _ strm inpObj = atomically $ writeTQueue inpQ (strm, inpObj)+ done <- newTVarIO False+ ctx <- setup sconf conf lnch $ Just $ readTVar done+ let get = do+ (strm, inpObj) <- atomically $ readTQueue inpQ+ return (strm, Request inpObj)+ putR strm (Response OutObj{..}) = do+ case outObjBody of+ OutBodyBuilder builder -> do+ let next = fillBuilderBodyGetNext builder+ otyp = OHeader outObjHeaders (Just next) outObjTrailers+ enqueueOutputSIO ctx strm otyp+ _ -> error "Response other than OutBodyBuilder is not supported"+ serverIO =+ ServerIO+ { sioMySockAddr = confMySockAddr+ , sioPeerSockAddr = confPeerSockAddr+ , sioReadRequest = get+ , sioWriteResponse = putR+ , sioDone = atomically $ writeTVar done True+ }+ io <- action serverIO+ concurrently_ io $ runH2 conf ctx checkPreface :: Config -> IO Bool checkPreface conf@Config{..} = do@@ -93,33 +109,28 @@ return False else return True -setup :: ServerConfig -> Config -> IO (Context, Manager)-setup ServerConfig{..} conf@Config{..} = do- serverInfo <- newServerInfo- ctx <-- newContext- serverInfo- conf- 0- connectionWindowSize- settings- -- Workers, worker manager and timer manager- mgr <- start confTimeoutManager- return (ctx, mgr)+setup :: ServerConfig -> Config -> Launch -> Maybe (STM Bool) -> IO Context+setup ServerConfig{..} conf@Config{..} lnch mIsDone = do+ let serverInfo = newServerInfo lnch+ newContext+ serverInfo+ conf+ 0+ connectionWindowSize+ settings+ confTimeoutManager+ mIsDone -runH2 :: Config -> Context -> Manager -> IO ()-runH2 conf ctx mgr = do- let runReceiver = frameReceiver ctx conf- runSender = frameSender ctx conf mgr- runBackgroundThreads = concurrently_ runReceiver runSender- stopAfter mgr runBackgroundThreads $ \res -> do- closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $- either Just (const Nothing) res- case res of- Left err ->- throwIO err- Right x ->- return x+runH2 :: Config -> Context -> IO ()+runH2 conf ctx = do+ let mgr = threadManager ctx+ runReceiver = frameReceiver ctx conf+ runSender = frameSender ctx conf+ runBackgroundThreads = do+ e <- snd <$> concurrently runReceiver runSender+ closureServer conf ctx e+ T.stopAfter mgr runBackgroundThreads $ \res ->+ closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res -- connClose must not be called here since Run:fork calls it goaway :: Config -> ErrorCode -> ByteString -> IO ()
− Network/HTTP2/Server/Types.hs
@@ -1,43 +0,0 @@-module Network.HTTP2.Server.Types where--import Network.Socket (SockAddr)-import qualified System.TimeManager as T--import Imports-import Network.HTTP2.H2---------------------------------------------------------------------- | 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)---- | 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- { promiseRequestPath :: ByteString- -- ^ Accessor for a URL path in a push promise (a virtual request from a server).- -- E.g. \"\/style\/default.css\".- , promiseResponse :: Response- -- ^ Accessor for response actually pushed from a server.- }---- | Additional information.-data Aux = Aux- { auxTimeHandle :: T.Handle- -- ^ Time handle for the worker processing this request and response.- , auxMySockAddr :: SockAddr- -- ^ Local socket address copied from 'Config'.- , auxPeerSockAddr :: SockAddr- -- ^ Remove socket address copied from 'Config'.- }
Network/HTTP2/Server/Worker.hs view
@@ -1,249 +1,191 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Server.Worker (- worker,- WorkerConf (..),- fromContext,+ runServer, ) where +import Control.Concurrent.STM import Data.IORef-import qualified Network.HTTP.Types as H-import Network.Socket (SockAddr)-import qualified System.TimeManager as T-import UnliftIO.Exception (SomeException (..))-import qualified UnliftIO.Exception as E-import UnliftIO.STM+import Network.HTTP.Semantics+import Network.HTTP.Semantics.IO+import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal+import Network.HTTP.Types+import qualified System.ThreadManager as T import Imports hiding (insert)-import Network.HPACK-import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2-import Network.HTTP2.Server.Types ---------------------------------------------------------------- -data WorkerConf a = WorkerConf- { readInputQ :: IO (Input a)- , writeOutputQ :: Output a -> IO ()- , workerCleanup :: a -> IO ()- , isPushable :: IO Bool- , makePushStream :: a -> PushPromise -> IO (StreamId, a)- , mySockAddr :: SockAddr- , peerSockAddr :: SockAddr- }+runServer :: Config -> Server -> Launch+runServer conf server ctx@Context{..} strm req =+ T.forkManagedTimeout threadManager label $ \th -> do+ let req' = pauseRequestBody th+ aux =+ defaultAux+ { auxTimeHandle = th+ , auxMySockAddr = mySockAddr+ , auxPeerSockAddr = peerSockAddr+ }+ request = Request req'+ lc <- newLoopCheck strm Nothing+ server request aux $ sendResponse conf ctx lc strm request+ adjustRxWindow ctx strm+ modifyPeerLastStreamId ctx $ streamNumber strm+ where+ label = "H2 response sender for stream " ++ show (streamNumber strm)+ pauseRequestBody th = req{inpObjBody = readBody'}+ where+ readBody = inpObjBody req+ readBody' = do+ T.pause th+ bs <- readBody+ T.resume th -- this is the same as 'tickle'+ return bs -fromContext :: Context -> WorkerConf Stream-fromContext ctx@Context{..} =- WorkerConf- { readInputQ = atomically $ readTQueue $ inputQ $ toServerInfo roleInfo- , writeOutputQ = enqueueOutput outputQ- , workerCleanup = \strm -> do- closed ctx strm Killed- let frame = resetFrame InternalError $ streamNumber strm- enqueueControl controlQ $ CFrames Nothing [frame]- , -- Peer SETTINGS_ENABLE_PUSH- isPushable = enablePush <$> readIORef peerSettings- , -- Peer SETTINGS_INITIAL_WINDOW_SIZE- makePushStream = \pstrm _ -> do- -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit- (_, newstrm) <- openEvenStreamWait ctx- let pid = streamNumber pstrm- return (pid, newstrm)- , mySockAddr = mySockAddr- , peerSockAddr = peerSockAddr- }+---------------------------------------------------------------- +-- | 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.+sendResponse+ :: Config+ -> Context+ -> LoopCheck+ -> Stream+ -> Request+ -> Response+ -> [PushPromise]+ -> IO ()+sendResponse conf ctx lc strm (Request req) (Response rsp) pps = do+ mwait <- pushStream conf ctx strm reqvt pps+ case mwait of+ Nothing -> return ()+ Just wait -> wait -- all pushes are sent+ sendHeaderBody conf ctx lc strm rsp+ where+ (_, reqvt) = inpObjHeaders req+ ---------------------------------------------------------------- pushStream- :: WorkerConf a- -> a -- parent stream+ :: Config+ -> Context+ -> Stream -- parent stream -> ValueTable -- request -> [PushPromise]- -> IO OutputType-pushStream _ _ _ [] = return OObj-pushStream WorkerConf{..} pstrm reqvt pps0- | len == 0 = return OObj+ -> IO (Maybe (IO ()))+pushStream _ _ _ _ [] = return Nothing+pushStream conf ctx@Context{..} pstrm reqvt pps0+ | len == 0 = return Nothing | otherwise = do- pushable <- isPushable+ pushable <- enablePush <$> readIORef peerSettings if pushable then do tvar <- newTVarIO 0 lim <- push tvar pps0 0 if lim == 0- then return OObj- else return $ OWait (waiter lim tvar)- else return OObj+ then return Nothing+ else return $ Just $ waiter lim tvar+ else return Nothing where len = length pps0 increment tvar = atomically $ modifyTVar' tvar (+ 1)+ -- Checking if all push are done. waiter lim tvar = atomically $ do n <- readTVar tvar- checkSTM (n >= lim)+ check (n >= lim) push _ [] n = return (n :: Int) push tvar (pp : pps) n = do- (pid, newstrm) <- makePushStream pstrm pp- let scheme = fromJust $ getHeaderValue tokenScheme reqvt- -- fixme: this value can be Nothing- auth =- fromJust- ( getHeaderValue tokenAuthority reqvt- <|> getHeaderValue tokenHost reqvt- )- 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+ T.forkManaged threadManager "H2 server push" $ do+ (pid, newstrm) <- makePushStream ctx pstrm+ let scheme = fromJust $ getFieldValue tokenScheme reqvt+ -- fixme: this value can be Nothing+ auth =+ fromJust+ ( getFieldValue tokenAuthority reqvt+ <|> getFieldValue tokenHost reqvt+ )+ path = promiseRequestPath pp+ promiseRequest =+ [ (tokenMethod, methodGet)+ , (tokenScheme, scheme)+ , (tokenAuthority, auth)+ , (tokenPath, path)+ ]+ ot = OPush promiseRequest pid+ Response rsp = promiseResponse pp+ increment tvar+ lc <- newLoopCheck newstrm Nothing+ syncWithSender ctx newstrm ot lc+ sendHeaderBody conf ctx lc newstrm rsp 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- :: 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- writeOutputQ $ Output strm rsp OObj Nothing (return ())- OutBodyBuilder _ -> do- otyp <- pushStream wc strm reqvt pps- setThreadContinue tconf True- writeOutputQ $ Output strm rsp otyp Nothing (return ())- OutBodyFile _ -> do- otyp <- pushStream wc strm reqvt pps- setThreadContinue tconf True- 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.- --- -- We need to increase the number of workers.- spawnAction mgr- -- After this work, this thread stops to decease- -- the number of workers.- setThreadContinue tconf False- -- Since streaming body is loop, we cannot control it.- -- So, let's serialize 'Builder' with a designated queue.- tbq <- newTBQueueIO 10 -- fixme: hard coding: 10- writeOutputQ $ Output strm rsp otyp (Just tbq) (return ())- let push b = do- T.pause th- atomically $ writeTBQueue tbq (StreamingBuilder b)- T.resume th- flush = atomically $ writeTBQueue tbq StreamingFlush- finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr)- incCounter mgr- strmbdy push flush `E.finally` finished- OutBodyStreamingUnmask _ ->- error "response: server does not support OutBodyStreamingUnmask"- where- (_, reqvt) = inpObjHeaders req---- | 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- where- go sinfo tcont th = do- setThreadContinue tcont True- ex <- E.trySyncOrAsync $ do- T.pause th- Input strm req <- readInputQ- let req' = pauseRequestBody req th- setStreamInfo sinfo strm- T.resume th- T.tickle th- let aux = Aux th mySockAddr peerSockAddr- server (Request req') aux $ response wc mgr th tcont strm (Request req')- cont1 <- case ex of- Right () -> return True- Left e@(SomeException _)- -- killed by the local worker manager- | Just KilledByHttp2ThreadManager{} <- E.fromException e -> return False- -- killed by the local timeout manager- | Just T.TimeoutThread <- E.fromException e -> do- cleanup sinfo- return True- | otherwise -> do- cleanup sinfo- return True- cont2 <- getThreadContinue tcont- clearStreamInfo sinfo- when (cont1 && cont2) $ go sinfo tcont th- pauseRequestBody req th = req{inpObjBody = readBody'}- where- readBody = inpObjBody req- readBody' = do- T.pause th- bs <- readBody- T.resume th- return bs- cleanup sinfo = do- minp <- getStreamInfo sinfo- case minp of- Nothing -> return ()- Just strm -> workerCleanup strm- ---------------------------------------------------------------- --- A reference is shared by a responder and its worker.--- The reference refers a value of this type as a return value.--- If 'True', the worker continue to serve requests.--- Otherwise, the worker get finished.-newtype ThreadContinue = ThreadContinue (IORef Bool)--{-# INLINE newThreadContinue #-}-newThreadContinue :: IO ThreadContinue-newThreadContinue = ThreadContinue <$> newIORef True--{-# INLINE setThreadContinue #-}-setThreadContinue :: ThreadContinue -> Bool -> IO ()-setThreadContinue (ThreadContinue ref) x = writeIORef ref x--{-# INLINE getThreadContinue #-}-getThreadContinue :: ThreadContinue -> IO Bool-getThreadContinue (ThreadContinue ref) = readIORef ref+makePushStream :: Context -> Stream -> IO (StreamId, Stream)+makePushStream ctx pstrm = do+ -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit+ (_, newstrm) <- openEvenStreamWait ctx+ let pid = streamNumber pstrm+ return (pid, newstrm) ---------------------------------------------------------------- --- | The type for cleaning up.-newtype StreamInfo a = StreamInfo (IORef (Maybe a))--{-# INLINE newStreamInfo #-}-newStreamInfo :: IO (StreamInfo a)-newStreamInfo = StreamInfo <$> newIORef Nothing--{-# INLINE clearStreamInfo #-}-clearStreamInfo :: StreamInfo a -> IO ()-clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing+sendHeaderBody+ :: Config+ -> Context+ -> LoopCheck+ -> Stream+ -> OutObj+ -> IO ()+sendHeaderBody Config{..} ctx lc strm OutObj{..} = do+ (mnext, mtbq) <- case outObjBody of+ OutBodyNone -> return (Nothing, Nothing)+ OutBodyFile (FileSpec path fileoff bytecount) -> do+ (pread, sentinel) <- confPositionReadMaker path+ let next = fillFileBodyGetNext pread fileoff bytecount sentinel+ return (Just next, Nothing)+ OutBodyBuilder builder -> do+ let next = fillBuilderBodyGetNext builder+ return (Just next, Nothing)+ OutBodyStreaming strmbdy -> do+ q <- sendStreaming ctx strm $ \OutBodyIface{..} -> strmbdy outBodyPush outBodyFlush+ let next = nextForStreaming q+ return (Just next, Just q)+ OutBodyStreamingIface strmbdy -> do+ q <- sendStreaming ctx strm strmbdy+ let next = nextForStreaming q+ return (Just next, Just q)+ let lc' = lc{lcTBQ = mtbq}+ syncWithSender ctx strm (OHeader outObjHeaders mnext outObjTrailers) lc' -{-# INLINE setStreamInfo #-}-setStreamInfo :: StreamInfo a -> a -> IO ()-setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp+---------------------------------------------------------------- -{-# INLINE getStreamInfo #-}-getStreamInfo :: StreamInfo a -> IO (Maybe a)-getStreamInfo (StreamInfo ref) = readIORef ref+sendStreaming+ :: Context+ -> Stream+ -> (OutBodyIface -> IO ())+ -> IO (TBQueue StreamingChunk)+sendStreaming Context{..} strm strmbdy = do+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10+ T.forkManagedTimeout threadManager label $ \th ->+ withOutBodyIface tbq id $ \iface -> do+ let iface' =+ iface+ { outBodyPush = \b -> do+ T.pause th+ outBodyPush iface b+ T.resume th -- this is the same as 'tickle'+ , outBodyPushFinal = \b -> do+ T.pause th+ outBodyPushFinal iface b+ T.resume th -- this is the same as 'tickle'+ }+ strmbdy iface'+ return tbq+ where+ label = "H2 response streaming sender for " ++ show (streamNumber strm)
bench-hpack/Main.hs view
@@ -3,8 +3,8 @@ module Main where import Control.Exception+import Criterion.Main import Data.ByteString (ByteString)-import Gauge.Main import Network.HPACK ----------------------------------------------------------------@@ -39,7 +39,7 @@ ] -----------------------------------------------------------------prepare :: [HeaderList] -> IO [ByteString]+prepare :: [[Header]] -> IO [ByteString] prepare hdrs = do tbl <- newDynamicTableForEncoding defaultDynamicTableSize go tbl hdrs id@@ -59,7 +59,7 @@ !_ <- decodeHeader tbl f go tbl fs -enc :: EncodeStrategy -> [HeaderList] -> IO ()+enc :: EncodeStrategy -> [[Header]] -> IO () enc stgy hdrs = do tbl <- newDynamicTableForEncoding defaultDynamicTableSize go tbl hdrs
http2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-version: 5.1.4+version: 5.4.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -8,7 +8,7 @@ homepage: https://github.com/kazu-yamamoto/http2 synopsis: HTTP/2 library description:- HTTP/2 library including frames, priority queues, HPACK, client and server.+ HTTP/2 library including frames, HPACK, client and server. category: Network build-type: Simple@@ -60,14 +60,12 @@ Network.HTTP2.Client Network.HTTP2.Client.Internal Network.HTTP2.Frame- Network.HTTP2.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@@ -90,24 +88,20 @@ Network.HTTP2.H2.Config Network.HTTP2.H2.Context Network.HTTP2.H2.EncodeFrame- Network.HTTP2.H2.File Network.HTTP2.H2.HPACK- Network.HTTP2.H2.Manager Network.HTTP2.H2.Queue- Network.HTTP2.H2.ReadN Network.HTTP2.H2.Receiver Network.HTTP2.H2.Sender Network.HTTP2.H2.Settings- Network.HTTP2.H2.Status Network.HTTP2.H2.Stream Network.HTTP2.H2.StreamTable+ Network.HTTP2.H2.Sync Network.HTTP2.H2.Types Network.HTTP2.H2.Window Network.HTTP2.Frame.Decode Network.HTTP2.Frame.Encode Network.HTTP2.Frame.Types Network.HTTP2.Server.Run- Network.HTTP2.Server.Types Network.HTTP2.Server.Worker default-language: Haskell2010@@ -115,25 +109,27 @@ ghc-options: -Wall build-depends: base >=4.9 && <5,- array >= 0.5 && < 0.6,- async >= 2.2 && < 2.3,- bytestring >= 0.10,- containers >= 0.6 && < 0.7,- stm >= 2.5 && < 2.6,- case-insensitive >= 1.2 && < 1.3,- http-types >= 0.12 && < 0.13,- network >= 3.1,- network-byte-order >= 0.1.7 && < 0.2,- network-control >= 0.1 && < 0.2,- unix-time >= 0.4.11 && < 0.5,- time-manager >= 0.0.1 && < 0.1,- unliftio >= 0.2 && < 0.3,- utf8-string >= 1.0 && < 1.1+ array >=0.5 && <0.6,+ async >=2.2 && <2.3,+ bytestring >=0.10,+ case-insensitive >=1.2 && <1.3,+ containers >=0.6,+ http-semantics >= 0.4 && <0.5,+ http-types >=0.12 && <0.13,+ iproute >= 1.7 && < 1.8,+ network >=3.1,+ network-byte-order >=0.1.7 && <0.2,+ network-control >=0.1 && <0.2,+ stm >=2.5 && <2.6,+ time-manager >=0.2.3 && <0.4,+ unix-time >=0.4.11 && <0.6,+ utf8-string >=1.0 && <1.1 -executable client- main-is: client.hs+executable h2c-client+ main-is: h2c-client.hs hs-source-dirs: util default-language: Haskell2010+ other-modules: Client Monitor default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts build-depends:@@ -142,16 +138,19 @@ bytestring, http-types, http2,- network-run+ network,+ network-run >= 0.5 && <0.6,+ unix-time if flag(devel) else buildable: False -executable server- main-is: server.hs+executable h2c-server+ main-is: h2c-server.hs hs-source-dirs: util+ other-modules: Server Monitor default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded@@ -185,7 +184,6 @@ array, base16-bytestring >=1.0, bytestring,- case-insensitive, containers, http2, network-byte-order,@@ -215,7 +213,6 @@ array, base16-bytestring >=1.0, bytestring,- case-insensitive, containers, http2, network-byte-order,@@ -242,7 +239,6 @@ aeson-pretty, array, bytestring,- case-insensitive, containers, directory, filepath,@@ -308,10 +304,11 @@ bytestring, crypton, hspec >=1.3,+ http-semantics, http-types, http2, network,- network-run >=0.1.0,+ network-run >= 0.5 && <0.6, random, typed-process @@ -330,7 +327,7 @@ hspec >=1.3, http-types, http2,- network-run >=0.1.0,+ network-run >= 0.5 && <0.6, typed-process if flag(h2spec)@@ -405,7 +402,7 @@ bytestring, case-insensitive, containers,- gauge,+ criterion,+ http2, network-byte-order,- stm,- http2+ stm
test-frame/FrameSpec.hs view
@@ -10,7 +10,7 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL import Network.HTTP2.Frame-import System.FilePath.Glob (compile, globDir)+import System.FilePath.Glob (compile, globDir1) import Test.Hspec import JSON@@ -19,7 +19,7 @@ testDir = "test-frame/http2-frame-test-case" getTestFiles :: FilePath -> IO [FilePath]-getTestFiles dir = head <$> globDir [compile "*/*.json"] dir+getTestFiles dir = globDir1 (compile "*/*.json") dir check :: FilePath -> IO () check file = do
test-frame/frame-encode.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Main where import Data.Aeson
test-hpack/HPACKDecode.hs view
@@ -87,12 +87,12 @@ inp = B16.decodeLenient wirehex hs = headers c --- | Printing 'HeaderList'.-printHeaderList :: HeaderList -> IO ()+-- | Printing '[Header]'.+printHeaderList :: [Header] -> IO () printHeaderList hs = mapM_ printHeader hs where printHeader (k, v) = do- B8.putStr k+ B8.putStr $ original k putStr ": " B8.putStr v putStr "\n"
test-hpack/HPACKEncode.hs view
@@ -20,7 +20,7 @@ data Conf = Conf { debug :: Bool- , enc :: DynamicTable -> HeaderList -> IO ByteString+ , enc :: DynamicTable -> [Header] -> IO ByteString } run :: Bool -> EncodeStrategy -> Test -> IO [ByteString]
test-hpack/JSON.hs view
@@ -6,7 +6,7 @@ module JSON ( Test (..), Case (..),- HeaderList,+ Header, ) where #if __GLASGOW_HASKELL__ < 709@@ -44,7 +44,7 @@ data Case = Case { size :: Maybe Int , wire :: ByteString- , headers :: HeaderList+ , headers :: [Header] , seqno :: Maybe Int } deriving (Show)@@ -87,24 +87,27 @@ , "seqno" .= no ] -instance {-# OVERLAPPING #-} FromJSON HeaderList where+instance {-# OVERLAPPING #-} FromJSON [Header] where parseJSON (Array a) = mapM parseJSON $ V.toList a parseJSON _ = mzero -instance {-# OVERLAPPING #-} ToJSON HeaderList where+instance {-# OVERLAPPING #-} ToJSON [Header] where toJSON hs = toJSON $ map toJSON hs instance {-# OVERLAPPING #-} FromJSON Header where- parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old+ parseJSON (Array a) = pure (mk $ toKey (a ! 0), toValue (a ! 1)) -- old where toKey = toValue- parseJSON (Object o) = pure (textToByteString (Key.toText k), toValue v) -- new+ parseJSON (Object o) = pure (mk $ textToByteString $ Key.toText k, toValue v) -- new where- (k, v) = head $ H.toList o+ (k, v) = case H.toList o of+ [] -> error "parseJSON"+ x : _ -> x parseJSON _ = mzero instance {-# OVERLAPPING #-} ToJSON Header where- toJSON (k, v) = object [Key.fromText (byteStringToText k) .= byteStringToText v]+ toJSON (k, v) =+ object [Key.fromText (byteStringToText $ foldedCase k) .= byteStringToText v] textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack
test-hpack/hpack-stat.hs view
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.List import Data.Maybe (fromJust)+import Network.HPACK import System.Directory import System.FilePath @@ -81,7 +82,7 @@ let len = sum $ map toT $ cases tc return len where- toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length x + BS.length y) hs+ toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length (foldedCase x) + BS.length y) hs getHeaderLen :: FilePath -> IO Int getHeaderLen file = do
test/HPACK/DecodeSpec.hs view
@@ -11,7 +11,7 @@ spec :: Spec spec = do describe "fromHeaderBlock" $ do- it "decodes HeaderList in request" $ do+ it "decodes [Header] in request" $ do withDynamicTableForDecoding 4096 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d41b h1 `shouldBe` d41h@@ -19,7 +19,7 @@ h2 `shouldBe` d42h h3 <- decodeHeader dyntabl d43b h3 `shouldBe` d43h- it "decodes HeaderList in response" $ do+ it "decodes [Header] in response" $ do withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d61b h1 `shouldBe` d61h@@ -27,11 +27,11 @@ h2 `shouldBe` d62h h3 <- decodeHeader dyntabl d63b h3 `shouldBe` d63h- it "decodes HeaderList in response (deny max table size update to 0)" $+ it "decodes [Header] in response (deny max table size update to 0)" $ withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d81b h1 `shouldBe` d81h- it "decodes HeaderList even if an entry is larger than DynamicTable" $+ it "decodes [Header] even if an entry is larger than DynamicTable" $ withDynamicTableForEncoding 64 $ \etbl -> withDynamicTableForDecoding 64 4096 $ \dtbl -> do hs <- encodeHeader defaultEncodeStrategy 4096 etbl hl1@@ -40,7 +40,7 @@ isDynamicTableEmpty etbl `shouldReturn` True isDynamicTableEmpty dtbl `shouldReturn` True -hl1 :: HeaderList+hl1 :: [Header] hl1 = [ ("custom-key", "custom-value") ,
test/HPACK/EncodeSpec.hs view
@@ -41,7 +41,7 @@ withDynamicTableForDecoding sz 4096 $ \dtbl -> go etbl dtbl hdrs lens0 `shouldReturn` True where- go :: DynamicTable -> DynamicTable -> [HeaderList] -> [Int] -> IO Bool+ go :: DynamicTable -> DynamicTable -> [[Header]] -> [Int] -> IO Bool go _ _ [] _ = return True go etbl dtbl (h : hs) lens = do bs <-@@ -74,7 +74,7 @@ hdrs <- read <$> readFile "bench-hpack/headers.hs" withDynamicTableForEncoding 0 $ \etbl -> withDynamicTableForDecoding 0 4096 $ \dtbl ->- mapM_ (go etbl dtbl) (hdrs :: [HeaderList])+ mapM_ (go etbl dtbl) (hdrs :: [[Header]]) where go etbl _dtbl h = do print h
test/HPACK/HeaderBlock.hs view
@@ -4,14 +4,14 @@ import Data.ByteString (ByteString) import Data.ByteString.Base16-import Network.HPACK+import Network.HTTP.Types fromHexString :: ByteString -> ByteString fromHexString = decodeLenient ---------------------------------------------------------------- -d41h :: HeaderList+d41h :: [Header] d41h = [ (":method", "GET") , (":scheme", "http")@@ -22,7 +22,7 @@ d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" -d42h :: HeaderList+d42h :: [Header] d42h = [ (":method", "GET") , (":scheme", "http")@@ -34,7 +34,7 @@ d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" -d43h :: HeaderList+d43h :: [Header] d43h = [ (":method", "GET") , (":scheme", "https")@@ -48,7 +48,7 @@ ---------------------------------------------------------------- -d61h :: HeaderList+d61h :: [Header] d61h = [ (":status", "302") , ("cache-control", "private")@@ -61,7 +61,7 @@ fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" -d62h :: HeaderList+d62h :: [Header] d62h = [ (":status", "307") , ("cache-control", "private")@@ -72,7 +72,7 @@ d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" -d63h :: HeaderList+d63h :: [Header] d63h = [ (":status", "200") , ("cache-control", "private")@@ -89,7 +89,7 @@ ---------------------------------------------------------------- -d81h :: HeaderList+d81h :: [Header] d81h = [ (":status", "403") , ("server", "nginx/1.14.0")
test/HTTP2/ClientSpec.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -module HTTP2.ClientSpec where+module HTTP2.ClientSpec (spec) where import Control.Concurrent import qualified Control.Exception as E@@ -12,8 +11,9 @@ import Data.Foldable (for_) import Data.Maybe import Data.Traversable (for)+import Network.HTTP.Semantics import Network.HTTP.Types-import Network.Run.TCP+import Network.Run.TCP hiding (defaultSettings) import System.IO.Unsafe (unsafePerformIO) import System.Random import System.Timeout (timeout)@@ -36,18 +36,18 @@ it "receives an error if scheme is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000- runClient "" host (defaultClient []) `shouldThrow` connectionError+ runClient "" host (defaultClient []) `shouldThrow` streamError it "receives an error if authority is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000- runClient "http" "" (defaultClient []) `shouldThrow` connectionError+ runClient "http" "" (defaultClient []) `shouldThrow` streamError it "receives an error if authority and host are different" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 runClient "http" host (defaultClient [("Host", "foo")])- `shouldThrow` connectionError+ `shouldThrow` streamError it "does not deadlock (in concurrent setting)" $ E.bracket (forkIO $ runServer irresponsiveServer) killThread $ \_ -> do@@ -67,7 +67,7 @@ let maxConc = fromJust $ maxConcurrentStreams defaultSettings resultVars <- runClient "http" "localhost" $ \sendReq aux -> do- for [1 .. (maxConc + 1) :: Int] $ \_ -> do+ replicateM ((maxConc + 1) :: Int) $ do resultVar <- newEmptyMVar concurrentClient resultVar sendReq aux pure resultVar@@ -110,7 +110,7 @@ body = byteString "Hello, world!\n" runClient :: Scheme -> Authority -> Client a -> IO a-runClient sc au client = runTCPClient host port $ runHTTP2Client+runClient sc au client = runTCPClient host port runHTTP2Client where cliconf = defaultClientConfig{scheme = sc, authority = au} runHTTP2Client s =@@ -136,6 +136,7 @@ putMVar resultVar result threadDelay 10000 -connectionError :: Selector HTTP2Error-connectionError ConnectionErrorIsReceived{} = True-connectionError _ = False+streamError :: Selector HTTP2Error+streamError StreamErrorIsReceived{} = True+streamError ConnectionErrorIsReceived{} = True+streamError _ = False
test/HTTP2/ServerSpec.hs view
@@ -3,19 +3,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -module HTTP2.ServerSpec where+module HTTP2.ServerSpec (spec) where import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad-import Crypto.Hash (Context, SHA1) -- cryptonite+import Crypto.Hash (Context, SHA1) import qualified Crypto.Hash as CH import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Builder (Builder, byteString) import qualified Data.ByteString.Char8 as C8 import Data.IORef+import Network.HTTP.Semantics import Network.HTTP.Types import Network.Run.TCP import Network.Socket@@ -27,7 +28,6 @@ import Network.HPACK import Network.HPACK.Internal-import Network.HPACK.Token import qualified Network.HTTP2.Client as C import qualified Network.HTTP2.Client.Internal as C import Network.HTTP2.Frame@@ -47,7 +47,7 @@ it "handles normal cases" $ E.bracket (forkIO runServer) killThread $ \_ -> do threadDelay 10000- (runClient allocSimpleConfig)+ runClient allocSimpleConfig it "should always send the connection preface first" $ do prefaceVar <- newEmptyMVar@@ -151,7 +151,7 @@ where h2rsp = responseStreaming ok200 header streamingBody header = [("Content-Type", "text/plain")]- mhx = getHeaderValue (toToken "X-Tag") (snd (requestHeaders req))+ mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req)) streamingBody write _flush = do loop mt <- getRequestTrailers req@@ -175,7 +175,7 @@ runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig =- runTCPClient host port $ runHTTP2Client+ runTCPClient host port runHTTP2Client where auth = host cliconf = C.defaultClientConfig{C.authority = auth}@@ -187,7 +187,8 @@ client :: C.Client () client sendRequest aux =- foldr1 concurrently_ $+ foldr1+ concurrently_ [ client0 sendRequest aux , client1 sendRequest aux , client2 sendRequest aux@@ -237,10 +238,10 @@ FileSpec "test/inputFile" 0 1012731 req = C.setRequestTrailersMaker req0 maker sendRequest req $ \rsp -> do- let comsumeBody = do+ let consumeBody = do bs <- C.getResponseBodyChunk rsp- when (bs /= "") comsumeBody- comsumeBody+ when (bs /= "") consumeBody+ consumeBody mt <- C.getResponseTrailers rsp firstTrailerValue <$> mt `shouldBe` Just hx where@@ -258,10 +259,10 @@ withFile "test/inputFile" ReadMode sendFile req = C.setRequestTrailersMaker req0 maker sendRequest req $ \rsp -> do- let comsumeBody = do+ let consumeBody = do bs <- C.getResponseBodyChunk rsp- when (bs /= "") comsumeBody- comsumeBody+ when (bs /= "") consumeBody+ consumeBody mt <- C.getResponseTrailers rsp firstTrailerValue <$> mt `shouldBe` Just hx where@@ -278,10 +279,10 @@ write $ byteString tag req = C.setRequestTrailersMaker req0 maker sendRequest req $ \rsp -> do- let comsumeBody = do+ let consumeBody = do bs <- C.getResponseBodyChunk rsp- when (bs /= "") comsumeBody- comsumeBody+ when (bs /= "") consumeBody+ consumeBody mt <- C.getResponseTrailers rsp firstTrailerValue <$> mt `shouldBe` Just hx where@@ -308,12 +309,14 @@ | otherwise = pure () go (100 :: Int) -firstTrailerValue :: HeaderTable -> HeaderValue-firstTrailerValue = snd . Prelude.head . fst+firstTrailerValue :: TokenHeaderTable -> FieldValue+firstTrailerValue tbl = case fst tbl of+ [] -> error "firstTrailerValue"+ x : _ -> snd x runAttack :: (C.ClientIO -> IO ()) -> IO () runAttack attack =- runTCPClient host port $ runHTTP2Client+ runTCPClient host port runHTTP2Client where auth = host cliconf = C.defaultClientConfig{C.authority = auth}
test2/ServerSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module ServerSpec (spec) where@@ -34,7 +33,7 @@ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig- (`run` server)+ (\conf -> run defaultServerConfig conf server) server :: Server server req _aux sendResponse = case requestMethod req of
+ util/Client.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Client where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.UnixTime+import Foreign.C.Types+import Network.HTTP.Types+import System.IO+import Text.Printf++import Network.HTTP2.Client++import Monitor++data Options = Options+ { optPerformance :: Int+ , optNumOfReqs :: Int+ , optMonitor :: Bool+ , optInteractive :: Bool+ }+ deriving (Show)++client :: Options -> [Path] -> Client ()+client Options{..} paths sendRequest _aux = do+ labelMe "h2c client"+ let cli+ | optPerformance /= 0 = clientPF optPerformance sendRequest+ | otherwise = clientNReqs optNumOfReqs sendRequest+ ex <- E.try $ mapConcurrently_ cli paths+ case ex of+ Right () -> return ()+ Left e -> print (e :: HTTP2Error)++clientNReqs :: Int -> SendRequest -> Path -> IO ()+clientNReqs n0 sendRequest path = do+ labelMe "h2c clinet N requests"+ loop n0+ where+ req = requestNoBody methodGet path []+ loop 0 = return ()+ loop n = do+ sendRequest req $ \rsp -> do+ print $ responseStatus rsp+ getResponseBodyChunk rsp >>= C8.putStrLn+ loop (n - 1)++-- Path is dummy+clientPF :: Int -> SendRequest -> Path -> IO ()+clientPF n sendRequest _ = do+ labelMe "h2c clinet performance"+ t1 <- getUnixTime+ sendRequest req loop+ t2 <- getUnixTime+ printThroughput t1 t2 n+ where+ req = requestNoBody methodGet path []+ path = "/perf/" <> C8.pack (show n)+ loop rsp = do+ bs <- getResponseBodyChunk rsp+ when (bs /= "") $ loop rsp++printThroughput :: UnixTime -> UnixTime -> Int -> IO ()+printThroughput t1 t2 n =+ printf+ "Throughput %.2f Mbps (%d bytes in %d msecs)\n"+ bytesPerSeconds+ n+ millisecs+ where+ UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1+ millisecs :: Int+ millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000+ bytesPerSeconds :: Double+ bytesPerSeconds =+ fromIntegral n+ * (1000 :: Double)+ * 8+ / fromIntegral millisecs+ / 1024+ / 1024++console+ :: Options -> [ByteString] -> IO () -> Aux -> IO ()+console _opt paths cli aux = do+ putStrLn "q -- quit"+ putStrLn "g -- get"+ putStrLn "p -- ping"+ mvar <- newEmptyMVar+ loop mvar `E.catch` \(E.SomeException _) -> return ()+ where+ loop mvar = do+ hSetBuffering stdout NoBuffering+ putStr "> "+ hSetBuffering stdout LineBuffering+ l <- getLine+ case l of+ "q" -> putStrLn "bye"+ "g" -> do+ mapM_ (\p -> putStrLn $ "GET " ++ C8.unpack p) paths+ _ <- forkIO $ cli >> putMVar mvar ()+ takeMVar mvar+ loop mvar+ "p" -> do+ putStrLn "Ping"+ auxSendPing aux+ loop mvar+ _ -> do+ putStrLn "No such command"+ loop mvar
+ util/Monitor.hs view
@@ -0,0 +1,30 @@+module Monitor (monitor, labelMe) where++import Control.Monad+import Data.List+import Data.Maybe+import GHC.Conc.Sync++monitor :: IO () -> IO ()+monitor action = do+ labelMe "monitor"+ forever $ do+ action+ threadSummary >>= mapM_ (putStrLn . showT)+ putStr "\n"+ where+ showT (i, l, s) = i ++ " " ++ l ++ ": " ++ show s++threadSummary :: IO [(String, String, ThreadStatus)]+threadSummary = listThreads >>= mapM summary . sort+ where+ summary t = do+ let idstr = drop 9 $ show t+ l <- fromMaybe "(no name)" <$> threadLabel t+ s <- threadStatus t+ return (idstr, l, s)++labelMe :: String -> IO ()+labelMe lbl = do+ tid <- myThreadId+ labelThread tid lbl
+ util/Server.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module Server where++import Control.Monad+import Crypto.Hash (Context, SHA1) -- crypton+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.Builder as BB+import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import Network.HTTP2.Server++server :: Server+server req _aux sendResponse = case requestMethod req of+ Just "GET" -> case requestPath req of+ Nothing -> sendResponse response404 []+ Just path+ | path == "/" -> sendResponse responseHello []+ | "/perf/" `B.isPrefixOf` path -> do+ case C8.readInt (B.drop 6 path) of+ Nothing -> sendResponse responseHello []+ Just (n, _) -> sendResponse (responsePerf n) []+ | otherwise -> sendResponse response404 []+ Just "POST" -> sendResponse (responseEcho req) []+ _ -> sendResponse response404 []++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++responsePerf :: Int -> Response+responsePerf n0 = responseStreaming ok200 header streaming+ where+ header = [("Content-Type", "text/plain")]+ bs1024 = BB.byteString $ B.replicate 1024 65+ streaming write _flush = loop n0+ where+ loop 0 = return ()+ loop n+ | n < 1024 = write $ BB.byteString $ B.replicate (fromIntegral n) 65+ | otherwise = do+ write bs1024+ loop (n - 1024)++response404 :: Response+response404 = responseBuilder notFound404 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Not found\n"++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
− util/client.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Main where--import Control.Concurrent.Async-import qualified Control.Exception as E-import qualified Data.ByteString.Char8 as C8-import Network.HTTP.Types-import Network.Run.TCP (runTCPClient) -- network-run-import System.Environment-import System.Exit--import Network.HTTP2.Client--serverName :: String-serverName = "127.0.0.1"--main :: IO ()-main = do- args <- getArgs- (host, port) <- case args of- [h, p] -> return (h, p)- _ -> do- putStrLn "client <addr> <port>"- exitFailure- runTCPClient serverName port $ runHTTP2Client host- where- cliconf host = defaultClientConfig{authority = C8.pack host}- runHTTP2Client host s =- E.bracket- (allocSimpleConfig s 4096)- freeSimpleConfig- (\conf -> run (cliconf host) conf client)- client :: Client ()- client sendRequest _aux = do- let req0 = requestNoBody methodGet "/" []- client0 = sendRequest req0 $ \rsp -> do- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn- req1 = requestNoBody methodGet "/foo" []- client1 = sendRequest req1 $ \rsp -> do- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn- ex <- E.try $ concurrently_ client0 client1- case ex of- Left e -> print (e :: HTTP2Error)- Right () -> putStrLn "OK"
+ util/h2c-client.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import qualified Data.ByteString.Char8 as C8+import Network.HTTP2.Client+import Network.Run.TCP (runTCPClient)+import Network.Socket+import System.Console.GetOpt+import System.Environment+import System.Exit++import Client+import Monitor++defaultOptions :: Options+defaultOptions =+ Options+ { optPerformance = 0+ , optNumOfReqs = 1+ , optMonitor = False+ , optInteractive = False+ }++usage :: String+usage = "Usage: h2c-client [OPTION] addr port [path]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['t']+ ["performance"]+ (ReqArg (\n o -> o{optPerformance = read n}) "<size>")+ "measure performance"+ , Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")+ "specify the number of requests"+ , Option+ ['m']+ ["monitor"]+ (NoArg (\opts -> opts{optMonitor = True}))+ "run thread monitor"+ , Option+ ['i']+ ["interactive"]+ (NoArg (\o -> o{optInteractive = True}))+ "enter interactive mode"+ ]++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ labelMe "h2c-client main"+ args <- getArgs+ (opts, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> ps)+ when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000+ let cliconf = defaultClientConfig{authority = host}+ run' cliconf host port $ client' opts paths++run' :: ClientConfig -> HostName -> ServiceName -> Client a -> IO a+run' cliconf host port f = runTCPClient host port $ \s ->+ E.bracket+ (allocSimpleConfig' s 4096 10000000)+ freeSimpleConfig+ (\conf -> run cliconf conf f)++client' :: Options -> [Path] -> Client ()+client' opts paths sendRequest _aux+ | optInteractive opts = do+ let action = client opts paths sendRequest _aux+ console opts paths action _aux+ return ()+ | otherwise = client opts paths sendRequest _aux
+ util/h2c-server.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import Network.HTTP2.Server+import Network.Run.TCP+import System.Console.GetOpt+import System.Environment+import System.Exit++import Monitor+import Server++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['m']+ ["monitor"]+ (NoArg (\opts -> opts{optMonitor = True}))+ "run thread monitor"+ ]++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++newtype Options = Options+ { optMonitor :: Bool+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optMonitor = False+ }++usage :: String+usage = "Usage: h2c-server [OPTION] <addr> <port>"++main :: IO ()+main = do+ labelMe "h2c-server main"+ args <- getArgs+ (opts, ips) <- serverOpts args+ (host, port) <- case ips of+ [h, p] -> return (h, p)+ _ -> showUsageAndExit usage+ when (optMonitor opts) $ void $ forkIO $ monitor $ threadDelay 1000000+ runTCPServer (Just host) port $ \s -> do+ E.bracket+ (allocSimpleConfig' s 4096 5000000)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf server)
− util/server.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--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.Run.TCP -- network-run-import System.Environment-import System.Exit--import Network.HTTP2.Server--main :: IO ()-main = do- args <- getArgs- (host, port) <- case args of- [h, p] -> return (h, p)- _ -> do- putStrLn "server <addr> <port>"- exitFailure- runTCPServer (Just host) port runHTTP2Server- where- runHTTP2Server s =- E.bracket- (allocSimpleConfig s 4096)- freeSimpleConfig- (\conf -> run defaultServerConfig conf 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