packages feed

http2 3.0.3 → 5.4.1

raw patch · 111 files changed

Files

ChangeLog.md view
@@ -1,18 +1,276 @@+# 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.+  [#111](https://github.com/kazu-yamamoto/http2/pull/111)++## 5.1.2++* Make ping rate limit configurable+  [#108](https://github.com/kazu-yamamoto/http2/pull/108)++## 5.1.1++* Deal with RST_STREAM in HalfClosedLocal state+  [#107](https://github.com/kazu-yamamoto/http2/pull/107)++## 5.1.0++* Drop frames after reset+  [#106](https://github.com/kazu-yamamoto/http2/pull/106)+* BREAKING CHANGE: Use String for Authority+  [#105](https://github.com/kazu-yamamoto/http2/pull/105)+* Properly close streams+  [#104](https://github.com/kazu-yamamoto/http2/pull/104)++## 5.0.1++* Allowing bytestring 0.12.++## 5.0.0++* Using the network-control package.+* The limits of resources can be specified in ServerConfig and ClientConfig.+* Open streams based on peer's MaxStreams.+* Rejecting Data if it is over the receiving limit.+* Informing MaxStreams properly.+* Informing WindowUpdate properly.+* New API: Server.Internal.runIO and Client.Internal.runIO.++## 4.2.2++* Adding rate limit for RST_STREAM to work around CVE-2023-44487.+  [#94](https://github.com/kazu-yamamoto/http2/pull/94)++## 4.2.1++* This version is identical to v4.2.0 by accident.++## 4.2.0++* Treating HALF_CLOSED_LOCAL correctly.+  [#90](https://github.com/kazu-yamamoto/http2/pull/90)+* Ensuring that GOAWAY is sent after DATA in the client side.+  [#89](https://github.com/kazu-yamamoto/http2/pull/90)+* Test uses a random port instead of 8080.+* Breaking change: adding two optional `SockAddr`s to `Config` to be copied into `Aux`.+* Close all streams on termination.+  [#83](https://github.com/kazu-yamamoto/http2/pull/83)+* Introducing `OutBodyStreamingUnmask`+  [#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/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)+* Internal changes:+  [#74](https://github.com/kazu-yamamoto/http2/pull/74)+* Breaking change: `Client` is generalized into `(forall b. Request -> (Response -> IO b) -> IO b) -> IO a`. The `RankNTypes` language extension is required.+  [#72](https://github.com/kazu-yamamoto/http2/pull/72)++## 4.1.3++* Using crypton instead of cryptonite.++## 4.1.2++* Removing the race of frameSender and frameReceiver in the server side.+  This fixes the loss of RST_Stream and TLS bad MAC error.+  [#67](https://github.com/kazu-yamamoto/http2/pull/67)++## 4.1.1++* Fixing memory-blow-up due to no flow control.+  [#62](https://github.com/kazu-yamamoto/http2/issues/62)+  [#66](https://github.com/kazu-yamamoto/http2/issues/66)++## 4.1.0++* Implementing streaming from the client side.+  [#41](https://github.com/kazu-yamamoto/http2/pull/41)+* Making use of SettingsMaxFrameSize+  [#44](https://github.com/kazu-yamamoto/http2/pull/44)+  [#57](https://github.com/kazu-yamamoto/http2/pull/57)+* Disabling flow control+  [#55](https://github.com/kazu-yamamoto/http2/pull/55)+* Fixing buffer overrun by trailers+  [#52](https://github.com/kazu-yamamoto/http2/pull/52)+* Proper use of settings+* Breaking change: the data structure of `Next` was changed.+  The `http3` package is influenced.++## 4.0.0++* Breaking change: `HTTP2Error` is redefined.+* Breaking change: `FrameTypeId`, `SettingsKeyId` and `ErrorCodeId` are removed.+  Use `FrameType`, `SettingsKey` and `ErrorCode` instead.+* A client can receive a concrete `HTTP2Error`.+* Catching up RFC 9113. Host: and :authority cannot disagree.+* Breaking change: `Network.HTTP2` and `Network.HTTP2.Priority` are removed.+* Breaking change: obsoleted stuff are removed.+ ## 3.0.3  * Return correct status messages in HTTP2 client-  (#31)[https://github.com/kazu-yamamoto/http2/pull/31]+  [#31](https://github.com/kazu-yamamoto/http2/pull/31) * Follow changes in Aeson 2-  (#32)[https://github.com/kazu-yamamoto/http2/pull/32]+  [#32](https://github.com/kazu-yamamoto/http2/pull/32) * Make sure connection preface is always sent first-  (#33)[https://github.com/kazu-yamamoto/http2/pull/33]+  [#33](https://github.com/kazu-yamamoto/http2/pull/33) * Avoid empty data-  (#34)[https://github.com/kazu-yamamoto/http2/pull/34]+  [#34](https://github.com/kazu-yamamoto/http2/pull/34)  ## 3.0.2  * Skip inserting entries that do not fit in the encoding table-  (#28)[https://github.com/kazu-yamamoto/http2/pull/28]+  [#28](https://github.com/kazu-yamamoto/http2/pull/28)  ## 3.0.1
Imports.hs view
@@ -1,34 +1,53 @@ module Imports (-    ByteString(..)-  , module Control.Applicative-  , module Control.Monad-  , module Data.Bits-  , module Data.List-  , module Data.Foldable-  , module Data.Int-  , module Data.Monoid-  , module Data.Ord-  , module Data.Word-  , module Data.Maybe-  , module Numeric-  , GCBuffer-  , withForeignPtr-  , mallocPlainForeignPtrBytes-  ) where+    ByteString (..),+    ShortByteString,+    module Control.Applicative,+    module Control.Monad,+    module Data.Bits,+    module Data.Either,+    module Data.List,+    module Data.Foldable,+    module Data.Int,+    module Data.Maybe,+    module Data.Monoid,+    module Data.Ord,+    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 import Control.Monad import Data.Bits hiding (Bits)-import Data.ByteString.Internal (ByteString(..))+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 import Data.List import Data.Maybe import Data.Monoid import Data.Ord+import Data.String import Data.Word import Foreign.ForeignPtr-import Numeric+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
@@ -2,55 +2,60 @@  -- | HPACK(<https://tools.ietf.org/html/rfc7541>) encoding and decoding a header list. module Network.HPACK (-  -- * Encoding and decoding-    encodeHeader-  , decodeHeader-  -- * Encoding and decoding with token-  , encodeTokenHeader-  , decodeTokenHeader-  -- * DynamicTable-  , DynamicTable-  , defaultDynamicTableSize-  , newDynamicTableForEncoding-  , newDynamicTableForDecoding-  , withDynamicTableForEncoding-  , withDynamicTableForDecoding-  , setLimitForEncoding-  -- * Strategy for encoding-  , CompressionAlgo(..)-  , EncodeStrategy(..)-  , defaultEncodeStrategy-  -- * Errors-  , DecodeError(..)-  , BufferOverrun(..)-  -- * Headers-  , HeaderList-  , Header-  , HeaderName-  , HeaderValue-  , TokenHeaderList-  , TokenHeader-  -- * Value table-  , ValueTable-  , HeaderTable-  , getHeaderValue-  , toHeaderTable-  -- * Basic types-  , Size-  , Index-  , Buffer-  , BufferSize-  -- * Re-exports-  , original-  , foldedCase-  , mk-  ) where+    -- * Encoding and decoding+    encodeHeader,+    decodeHeader,+    Header,+    original,+    foldedCase,+    mk, +    -- * Encoding and decoding with token+    encodeTokenHeader,+    decodeTokenHeader,++    -- * DynamicTable+    DynamicTable,+    defaultDynamicTableSize,+    newDynamicTableForEncoding,+    newDynamicTableForDecoding,+    withDynamicTableForEncoding,+    withDynamicTableForDecoding,+    setLimitForEncoding,++    -- * Strategy for encoding+    CompressionAlgo (..),+    EncodeStrategy (..),+    defaultEncodeStrategy,++    -- * Errors+    DecodeError (..),+    BufferOverrun (..),++    -- * Token header+    FieldValue,+    TokenHeader,+    TokenHeaderList,+    toTokenHeaderTable,++    -- * Value table+    ValueTable,+    TokenHeaderTable,+    getFieldValue,+    getHeaderValue,++    -- * Basic types+    Size,+    Index,+    Buffer,+    BufferSize,+) 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
@@ -1,13 +1,13 @@ module Network.HPACK.HeaderBlock (-    decodeHeader-  , decodeTokenHeader-  , ValueTable-  , HeaderTable-  , toHeaderTable-  , getHeaderValue-  , encodeHeader-  , encodeTokenHeader-  ) where+    decodeHeader,+    decodeTokenHeader,+    ValueTable,+    TokenHeaderTable,+    toTokenHeaderTable,+    getFieldValue,+    encodeHeader,+    encodeTokenHeader,+) where  import Network.HPACK.HeaderBlock.Decode import Network.HPACK.HeaderBlock.Encode
Network/HPACK/HeaderBlock/Decode.hs view
@@ -1,57 +1,48 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Network.HPACK.HeaderBlock.Decode (-    decodeHeader-  , decodeTokenHeader-  , ValueTable-  , HeaderTable-  , toHeaderTable-  , getHeaderValue-  , decodeString-  , decodeS-  , decodeSophisticated-  , decodeSimple -- testing-  ) where+    decodeHeader,+    decodeTokenHeader,+    ValueTable,+    TokenHeaderTable,+    toTokenHeaderTable,+    getFieldValue,+    decodeString,+    decodeS,+    decodeSophisticated,+    decodeSimple, -- testing+) where -import Control.Exception (throwIO, catch)-import Data.Array (Array)-import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite)+import Control.Exception (catch, throwIO)+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 'Token' 'ix'.-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. --   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.-decodeHeader :: DynamicTable-             -> ByteString -- ^ An HPACK format-             -> IO HeaderList+decodeHeader+    :: DynamicTable+    -> ByteString+    -- ^ An HPACK format+    -> IO [Header] decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl))  -- | Converting the HPACK format to 'TokenHeaderList'@@ -68,48 +59,54 @@ --     'IllegalHeaderName' is thrown. --   * 'DecodeError' would be thrown if the HPACK format is broken. --   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.-decodeTokenHeader :: DynamicTable-                  -> ByteString -- ^ An HPACK format-                  -> IO HeaderTable+decodeTokenHeader+    :: DynamicTable+    -> ByteString+    -- ^ An HPACK format+    -> IO TokenHeaderTable decodeTokenHeader dyntbl inp =     decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `catch` \BufferOverrun -> throwIO HeaderBlockTruncated -decodeHPACK :: DynamicTable-            -> ByteString-            -> (ReadBuffer -> IO a)-            -> IO a+decodeHPACK+    :: DynamicTable+    -> ByteString+    -> (ReadBuffer -> IO a)+    -> IO a decodeHPACK dyntbl inp dec = withReadBuffer inp chkChange   where     chkChange rbuf = do         w <- read8 rbuf-        if isTableSizeUpdate w then do-            tableSizeUpdate dyntbl w rbuf-            chkChange rbuf-          else do-            ff rbuf (-1)-            dec rbuf+        if isTableSizeUpdate w+            then do+                tableSizeUpdate dyntbl w rbuf+                chkChange rbuf+            else do+                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. --   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.-decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader)-             -> ReadBuffer-             -> IO HeaderList+decodeSimple+    :: (Word8 -> ReadBuffer -> IO TokenHeader)+    -> ReadBuffer+    -> IO [Header] decodeSimple decTokenHeader rbuf = go empty   where     go builder = do         leftover <- remainingSize rbuf-        if leftover >= 1 then do-            w <- read8 rbuf-            tv <- decTokenHeader w rbuf-            let builder' = builder << tv-            go builder'-          else do-            let tvs = run builder-                kvs = map (\(t,v) -> let k = tokenFoldedKey t in (k,v)) tvs-            return kvs+        if leftover >= 1+            then do+                w <- read8 rbuf+                tv <- decTokenHeader w rbuf+                let builder' = builder << tv+                go builder'+            else do+                let tvs = run builder+                    kvs = map (\(t, v) -> let k = tokenKey t in (k, v)) tvs+                return kvs  headerLimit :: Int headerLimit = 200@@ -129,79 +126,80 @@ --     'TooLargeHeader' is thrown --   * 'DecodeError' would be thrown if the HPACK format is broken. --   * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.-decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader)-                    -> ReadBuffer-                    -> IO HeaderTable+decodeSophisticated+    :: (Word8 -> ReadBuffer -> IO TokenHeader)+    -> ReadBuffer+    -> IO TokenHeaderTable decodeSophisticated decTokenHeader rbuf = do     -- using maxTokenIx to reduce condition-    arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing+    arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing     tvs <- pseudoNormal arr     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             leftover <- remainingSize rbuf-            if leftover >= 1 then do-                w <- read8 rbuf-                tv@(Token{..},v) <- decTokenHeader w rbuf-                if isPseudo then do-                    mx <- unsafeRead arr tokenIx-                    -- duplicated-                    when (isJust mx) $ throwIO IllegalHeaderName-                    -- unknown-                    when (isMaxTokenIx tokenIx) $ throwIO IllegalHeaderName-                    unsafeWrite arr tokenIx (Just v)-                    pseudo-                  else do-                    -- 0-Length Headers Leak - CVE-2019-9516-                    when (tokenKey == "") $ throwIO IllegalHeaderName-                    when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $-                        throwIO IllegalHeaderName-                    unsafeWrite arr tokenIx (Just v)-                    if isCookieTokenIx tokenIx then-                        normal 0 empty (empty << v)-                      else-                        normal 0 (empty << tv) empty-              else-                return []+            if leftover >= 1+                then do+                    w <- read8 rbuf+                    tv@(Token{..}, v) <- decTokenHeader w rbuf+                    if isPseudo+                        then do+                            mx <- unsafeRead arr tokenIx+                            -- duplicated+                            when (isJust mx) $ throwIO IllegalHeaderName+                            -- unknown+                            when (isMaxTokenIx tokenIx) $ throwIO IllegalHeaderName+                            unsafeWrite arr tokenIx (Just v)+                            pseudo+                        else do+                            -- 0-Length Headers Leak - CVE-2019-9516+                            when (tokenKey == "") $ throwIO IllegalHeaderName+                            when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $+                                throwIO IllegalHeaderName+                            unsafeWrite arr tokenIx (Just v)+                            if isCookieTokenIx tokenIx+                                then normal 0 empty (empty << v)+                                else normal 0 (empty << tv) empty+                else return []         normal n builder cookie-          | n > headerLimit = throwIO TooLargeHeader-          | otherwise       = do-            leftover <- remainingSize rbuf-            if leftover >= 1 then do-                w <- read8 rbuf-                tv@(Token{..},v) <- decTokenHeader w rbuf-                when isPseudo $ throwIO IllegalHeaderName-                -- 0-Length Headers Leak - CVE-2019-9516-                when (tokenKey == "") $ throwIO IllegalHeaderName-                when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $-                    throwIO IllegalHeaderName-                unsafeWrite arr tokenIx (Just v)-                if isCookieTokenIx tokenIx then-                    normal (n+1) builder (cookie << v)-                  else-                    normal (n+1) (builder << tv) cookie-              else do-                let tvs0 = run builder-                    cook = run cookie-                if null cook then-                    return tvs0-                  else do-                    let v = BS.intercalate "; " cook-                        tvs = (tokenCookie, v) : tvs0-                    unsafeWrite arr cookieTokenIx (Just v)-                    return tvs+            | n > headerLimit = throwIO TooLargeHeader+            | otherwise = do+                leftover <- remainingSize rbuf+                if leftover >= 1+                    then do+                        w <- read8 rbuf+                        tv@(Token{..}, v) <- decTokenHeader w rbuf+                        when isPseudo $ throwIO IllegalHeaderName+                        -- 0-Length Headers Leak - CVE-2019-9516+                        when (tokenKey == "") $ throwIO IllegalHeaderName+                        when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $+                            throwIO IllegalHeaderName+                        unsafeWrite arr tokenIx (Just v)+                        if isCookieTokenIx tokenIx+                            then normal (n + 1) builder (cookie << v)+                            else normal (n + 1) (builder << tv) cookie+                    else do+                        let tvs0 = run builder+                            cook = run cookie+                        if null cook+                            then return tvs0+                            else do+                                let v = BS.intercalate "; " cook+                                    tvs = (tokenCookie, v) : tvs0+                                unsafeWrite arr cookieTokenIx (Just v)+                                return tvs  toTokenHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader toTokenHeader dyntbl w rbuf-  | w `testBit` 7 = indexed             dyntbl w rbuf-  | w `testBit` 6 = incrementalIndexing dyntbl w rbuf-  | w `testBit` 5 = throwIO IllegalTableSizeUpdate-  | w `testBit` 4 = neverIndexing       dyntbl w rbuf-  | otherwise     = withoutIndexing     dyntbl w rbuf+    | w `testBit` 7 = indexed dyntbl w rbuf+    | w `testBit` 6 = incrementalIndexing dyntbl w rbuf+    | w `testBit` 5 = throwIO IllegalTableSizeUpdate+    | w `testBit` 4 = neverIndexing dyntbl w rbuf+    | otherwise = withoutIndexing dyntbl w rbuf  tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO () tableSizeUpdate dyntbl w rbuf = do@@ -221,35 +219,39 @@  incrementalIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader incrementalIndexing dyntbl w rbuf = do-    tv@(t,v) <- if isIndexedName1 w then-                    indexedName dyntbl w rbuf 6 mask6-                else-                    newName dyntbl rbuf+    tv@(t, v) <-+        if isIndexedName1 w+            then indexedName dyntbl w rbuf 6 mask6+            else newName dyntbl rbuf     let e = toEntryToken t v     insertEntry e dyntbl     return tv  withoutIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader withoutIndexing dyntbl w rbuf-  | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4-  | otherwise        = newName dyntbl rbuf+    | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4+    | otherwise = newName dyntbl rbuf  neverIndexing :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader neverIndexing dyntbl w rbuf-  | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4-  | otherwise        = newName dyntbl rbuf+    | isIndexedName2 w = indexedName dyntbl w rbuf 4 mask4+    | otherwise = newName dyntbl rbuf  ---------------------------------------------------------------- -indexedName :: DynamicTable -> Word8 -> ReadBuffer-            -> Int -> (Word8 -> Word8)-            -> IO TokenHeader+indexedName+    :: DynamicTable+    -> Word8+    -> ReadBuffer+    -> Int+    -> (Word8 -> Word8)+    -> IO TokenHeader indexedName dyntbl w rbuf n mask = do     let p = mask w     idx <- decodeI n p rbuf     t <- entryToken <$> toIndexedEntry dyntbl idx     val <- decStr (huffmanDecoder dyntbl) rbuf-    let tv = (t,val)+    let tv = (t, val)     return tv  newName :: DynamicTable -> ReadBuffer -> IO TokenHeader@@ -257,7 +259,7 @@     let hufdec = huffmanDecoder dyntbl     t <- toToken <$> decStr hufdec rbuf     val <- decStr hufdec rbuf-    let tv = (t,val)+    let tv = (t, val)     return tv  ----------------------------------------------------------------@@ -279,21 +281,24 @@ decStr = decodeS dropHuffman isHuffman 7  -- | String decoding with Huffman decoder.-decodeS :: (Word8 -> Word8) -- ^ Dropping prefix and Huffman-        -> (Word8 -> Bool)  -- ^ Checking Huffman flag-        -> Int              -- ^ N+-        -> HuffmanDecoder-        -> ReadBuffer-        -> IO ByteString+decodeS+    :: (Word8 -> Word8)+    -- ^ Dropping prefix and Huffman+    -> (Word8 -> Bool)+    -- ^ Checking Huffman flag+    -> Int+    -- ^ N++    -> HuffmanDecoder+    -> ReadBuffer+    -> IO ByteString decodeS mask isH n hufdec rbuf = do     w <- read8 rbuf     let p = mask w         huff = isH w     len <- decodeI n p rbuf-    if huff then-        hufdec rbuf len-      else-        extractByteString rbuf len+    if huff+        then hufdec rbuf len+        else extractByteString rbuf len  ---------------------------------------------------------------- @@ -317,26 +322,23 @@  ---------------------------------------------------------------- --- | 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-    arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing+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 []         builder = return $ run builder-        go ((k,v):xs) builder = do+        go :: [Header] -> Builder TokenHeader -> IO TokenHeaderList+        go [] builder = return $ run builder+        go ((k, v) : xs) builder = do             let t = toToken (foldedCase k)             unsafeWrite arr (tokenIx t) (Just v)-            let tv = (t,v)+            let tv = (t, v)                 builder' = builder << tv             go xs builder'
Network/HPACK/HeaderBlock/Encode.hs view
@@ -1,27 +1,27 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}  module Network.HPACK.HeaderBlock.Encode (-    encodeHeader-  , encodeTokenHeader-  , encodeString-  , encodeS-  ) where+    encodeHeader,+    encodeTokenHeader,+    encodeString,+    encodeS,+) where  import Control.Exception (bracket, throwIO) import qualified Control.Exception as E import qualified Data.ByteString as BS-import Data.ByteString.Internal (create, memcpy)+import Data.ByteString.Internal (create) import Data.IORef-import Foreign.Marshal.Alloc (mallocBytes, free)+import Foreign.Marshal.Alloc (free, mallocBytes)+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  ----------------------------------------------------------------@@ -40,33 +40,41 @@  ---------------------------------------------------------------- --- | 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 :: EncodeStrategy-             -> Size -- ^ The size of a temporary buffer.-             -> DynamicTable-             -> HeaderList-             -> IO ByteString -- ^ An HPACK format+encodeHeader+    :: EncodeStrategy+    -> Size+    -- ^ The size of a temporary buffer.+    -> DynamicTable+    -> [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-              -> Size -- ^ The size of a temporary buffer.-              -> DynamicTable-              -> TokenHeaderList-              -> IO ByteString -- ^ An HPACK format+encodeHeader'+    :: EncodeStrategy+    -> Size+    -- ^ The size of a temporary buffer.+    -> DynamicTable+    -> TokenHeaderList+    -> IO ByteString+    -- ^ An HPACK format encodeHeader' stgy siz dyntbl hs = bracket (mallocBytes siz) free enc   where     enc buf = do-        (hs',len) <- encodeTokenHeader buf siz stgy True dyntbl hs+        (hs', len) <- encodeTokenHeader buf siz stgy True dyntbl hs         case hs' of-            [] -> create len $ \p -> memcpy p buf len-            _  -> throwIO BufferOverrun+            [] -> create len $ \p -> copyBytes p buf len+            _ -> throwIO BufferOverrun  ---------------------------------------------------------------- @@ -85,14 +93,16 @@ --   If 'True' and the limit is set by 'setLimitForEncoding', --   dynamic table size update is generated at the beginning of --   the HPACK format.----encodeTokenHeader :: Buffer-                  -> BufferSize-                  -> EncodeStrategy-                  -> Bool -- ^ 'True' at the first time, 'False' when continued.-                  -> DynamicTable-                  -> TokenHeaderList-                  -> IO (TokenHeaderList, Int) -- ^ Leftover, filled length+encodeTokenHeader+    :: Buffer+    -> BufferSize+    -> EncodeStrategy+    -> Bool+    -- ^ 'True' at the first time, 'False' when continued.+    -> DynamicTable+    -> TokenHeaderList+    -> IO (TokenHeaderList, Int)+    -- ^ Leftover, filled length encodeTokenHeader buf siz EncodeStrategy{..} first dyntbl hs0 = do     wbuf <- newWriteBuffer buf siz     when first $ changeTableSize dyntbl wbuf@@ -104,7 +114,7 @@         fe' = literalHeaderFieldWithoutIndexingNewName' dyntbl wbuf useHuffman         rev = getRevIndex dyntbl         step0 = case compressionAlgo of-            Naive  -> naiveStep  fe'+            Naive -> naiveStep fe'             Static -> staticStep fa fd fe             Linear -> linearStep rev fa fb fc fd     ref1 <- currentOffset wbuf >>= newIORef@@ -118,7 +128,7 @@     loop wbuf ref1 ref2 step hsx = go hsx       where         go [] = return ()-        go ((t,v):hs) = do+        go ((t, v) : hs) = do             _ <- step t v             currentOffset wbuf >>= writeIORef ref1             writeIORef ref2 hs@@ -126,26 +136,27 @@  ---------------------------------------------------------------- -naiveStep :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO ()+naiveStep+    :: (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@@ -185,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 @@ -201,14 +212,15 @@  -- Using Huffman encoding {-# INLINE indexedName #-}-indexedName :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()+indexedName+    :: 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@@ -220,9 +232,9 @@  -- Assuming MSBs are 0. set1, set01, set001, set0000 :: Setter-set1    x = x `setBit` 7-set01   x = x `setBit` 6-set001  x = x `setBit` 5+set1 x = x `setBit` 7+set01 x = x `setBit` 6+set001 x = x `setBit` 5 -- set0001 x = x `setBit` 4 -- Never indexing set0000 = id @@ -231,47 +243,59 @@ -- | String encoding. --   The algorithm based on copy avoidance and --   selection of better result of huffman or raw.-encodeS :: WriteBuffer-        -> Bool             -- ^ Use Huffman if efficient-        -> (Word8 -> Word8) -- ^ Setting prefix-        -> (Word8 -> Word8) -- ^ Setting huffman flag-        -> Int              -- ^ N+-        -> ByteString       -- ^ Target-        -> IO ()+encodeS+    :: WriteBuffer+    -> Bool+    -- ^ Use Huffman if efficient+    -> (Word8 -> Word8)+    -- ^ Setting prefix+    -> (Word8 -> Word8)+    -- ^ Setting huffman flag+    -> Int+    -- ^ N++    -> ByteString+    -- ^ Target+    -> IO () encodeS wbuf False set _ n bs = do     let len = BS.length bs     encodeI wbuf set n len     copyByteString wbuf bs-encodeS wbuf True  set setH n bs = do+encodeS wbuf True set setH n bs = do     let origLen = BS.length bs         expectedLen = (origLen `div` 10) * 8 -- 80%: decided by examples         expectedIntLen = integerLength n expectedLen     ff wbuf expectedIntLen     len <- encodeH wbuf bs     let intLen = integerLength n len-    if origLen < len then do-        ff wbuf (negate (expectedIntLen + len))-        encodeI wbuf set n origLen-        copyByteString wbuf bs-      else if intLen == expectedIntLen then do-        ff wbuf (negate (expectedIntLen + len))-        encodeI wbuf (set . setH) n len-        ff wbuf len-      else do-        let gap = intLen - expectedIntLen-        shiftLastN wbuf gap len-        ff wbuf (negate (intLen + len))-        encodeI wbuf (set . setH) n  len-        ff wbuf len+    if origLen < len+        then do+            ff wbuf (negate (expectedIntLen + len))+            encodeI wbuf set n origLen+            copyByteString wbuf bs+        else+            if intLen == expectedIntLen+                then do+                    ff wbuf (negate (expectedIntLen + len))+                    encodeI wbuf (set . setH) n len+                    ff wbuf len+                else do+                    let gap = intLen - expectedIntLen+                    shiftLastN wbuf gap len+                    ff wbuf (negate (intLen + len))+                    encodeI wbuf (set . setH) n len+                    ff wbuf len  {-# INLINE encStr #-} encStr :: WriteBuffer -> Bool -> ByteString -> IO () encStr wbuf h bs = encodeS wbuf h id (`setBit` 7) 7 bs  -- | String encoding (7+) with a temporary buffer whose size is 4096.-encodeString :: Bool       -- ^ Use Huffman if efficient-             -> ByteString -- ^ Target-             -> IO ByteString+encodeString+    :: Bool+    -- ^ Use Huffman if efficient+    -> ByteString+    -- ^ Target+    -> IO ByteString encodeString h bs = withWriteBuffer 4096 $ \wbuf -> encStr wbuf h bs  {-@@ -289,34 +313,34 @@ {-# INLINE integerLength #-} integerLength :: Int -> Int -> Int integerLength 8 l-  | l <= 254  = 1-  | l <= 382  = 2-  | otherwise = 3+    | l <= 254 = 1+    | l <= 382 = 2+    | otherwise = 3 integerLength 7 l-  | l <= 126  = 1-  | l <= 254  = 2-  | otherwise = 3+    | l <= 126 = 1+    | l <= 254 = 2+    | otherwise = 3 integerLength 6 l-  | l <=  62  = 1-  | l <= 190  = 2-  | otherwise = 3+    | l <= 62 = 1+    | l <= 190 = 2+    | otherwise = 3 integerLength 5 l-  | l <=  30  = 1-  | l <= 158  = 2-  | otherwise = 3+    | l <= 30 = 1+    | l <= 158 = 2+    | otherwise = 3 integerLength 4 l-  | l <=  14  = 1-  | l <= 142  = 2-  | otherwise = 3+    | l <= 14 = 1+    | l <= 142 = 2+    | otherwise = 3 integerLength 3 l-  | l <=   6  = 1-  | l <= 134  = 2-  | otherwise = 3+    | l <= 6 = 1+    | l <= 134 = 2+    | otherwise = 3 integerLength 2 l-  | l <=   2  = 1-  | l <= 130  = 2-  | otherwise = 3+    | l <= 2 = 1+    | l <= 130 = 2+    | otherwise = 3 integerLength _ l-  | l <=   0  = 1-  | l <= 128  = 2-  | otherwise = 3+    | l <= 0 = 1+    | l <= 128 = 2+    | otherwise = 3
Network/HPACK/HeaderBlock/Integer.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.HPACK.HeaderBlock.Integer (-    encodeI-  , encodeInteger-  , decodeI-  , decodeInteger-  ) where+    encodeI,+    encodeInteger,+    decodeI,+    decodeInteger,+) where  import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt)@@ -17,7 +15,7 @@ -- >>> import qualified Data.ByteString as BS  powerArray :: Array Int Int-powerArray = listArray (1,8) [1,3,7,15,31,63,127,255]+powerArray = listArray (1, 8) [1, 3, 7, 15, 31, 63, 127, 255]  ---------------------------------------------------------------- @@ -41,35 +39,43 @@ -- [31,154,10] -- >>> BS.unpack <$> encodeInteger 8 42 -- [42]-encodeInteger :: Int -- ^ N+-              -> Int -- ^ Target-              -> IO ByteString+encodeInteger+    :: Int+    -- ^ N++    -> Int+    -- ^ Target+    -> IO ByteString encodeInteger n i = withWriteBuffer 4096 $ \wbuf -> encodeI wbuf id n i  -- Using write8 is faster than using internals directly. --+ -- | Integer encoding with a write buffer.-{-# INLINABLE encodeI #-}-encodeI :: WriteBuffer-        -> (Word8 -> Word8) -- ^ Setting prefix-        -> Int -- ^ N+-        -> Int -- ^ Target-        -> IO ()+{-# INLINEABLE encodeI #-}+encodeI+    :: WriteBuffer+    -> (Word8 -> Word8)+    -- ^ Setting prefix+    -> Int+    -- ^ N++    -> Int+    -- ^ Target+    -> IO () encodeI wbuf set n i-  | i < p     = write8 wbuf $ set $ fromIntegral i-  | otherwise = do+    | i < p = write8 wbuf $ set $ fromIntegral i+    | otherwise = do         write8 wbuf $ set $ fromIntegral p         encode' (i - p)   where     p = powerArray `unsafeAt` (n - 1)     encode' :: Int -> IO ()     encode' j-      | j < 128   = write8 wbuf $ fromIntegral j-      | otherwise = do-          let q = j `shiftR` 7-              r = j .&. 0x7f-          write8 wbuf $ fromIntegral (r + 128)-          encode' q+        | j < 128 = write8 wbuf $ fromIntegral j+        | otherwise = do+            let q = j `shiftR` 7+                r = j .&. 0x7f+            write8 wbuf $ fromIntegral (r + 128)+            encode' q  ---------------------------------------------------------------- @@ -94,21 +100,29 @@ -- 1337 -- >>> decodeInteger 8 42 $ BS.empty -- 42-decodeInteger :: Int        -- ^ N+-              -> Word8      -- ^ The head of encoded integer whose prefix is already dropped-              -> ByteString -- ^ The tail of encoded integer-              -> IO Int+decodeInteger+    :: Int+    -- ^ N++    -> Word8+    -- ^ The head of encoded integer whose prefix is already dropped+    -> ByteString+    -- ^ The tail of encoded integer+    -> IO Int decodeInteger n w bs = withReadBuffer bs $ \rbuf -> decodeI n w rbuf -{-# INLINABLE decodeI #-}+{-# INLINEABLE decodeI #-}+ -- | Integer decoding with a read buffer. The first argument is N of prefix.-decodeI :: Int        -- ^ N+-        -> Word8      -- ^ The head of encoded integer whose prefix is already dropped-        -> ReadBuffer-        -> IO Int+decodeI+    :: Int+    -- ^ N++    -> Word8+    -- ^ The head of encoded integer whose prefix is already dropped+    -> ReadBuffer+    -> IO Int decodeI n w rbuf-  | i < p     = return i-  | otherwise = decode 0 i+    | i < p = return i+    | otherwise = decode 0 i   where     p = powerArray `unsafeAt` (n - 1)     i = fromIntegral w
Network/HPACK/Huffman.hs view
@@ -1,13 +1,13 @@ module Network.HPACK.Huffman (-  -- * Huffman encoding/decoding-    encodeH-  , encodeHuffman-  , decodeH-  , decodeHuffman-  , HuffmanDecoder-  , decH-  , GCBuffer-  ) where+    -- * Huffman encoding/decoding+    encodeH,+    encodeHuffman,+    decodeH,+    decodeHuffman,+    HuffmanDecoder,+    decH,+    GCBuffer,+) where  import Network.HPACK.Huffman.Decode import Network.HPACK.Huffman.Encode
Network/HPACK/Huffman/Bit.hs view
@@ -1,16 +1,19 @@ module Network.HPACK.Huffman.Bit (-  -- * Bits-    B(..)-  , Bits-  , fromBits-  ) where+    -- * Bits+    B (..),+    Bits,+    fromBits,+) where  import Imports  -- | Data type for Bit.-data B = F -- ^ Zero-       | T -- ^ One-       deriving (Eq,Ord,Show)+data B+    = -- | Zero+      F+    | -- | One+      T+    deriving (Eq, Ord, Show)  -- | Bit stream. type Bits = [B]
Network/HPACK/Huffman/ByteString.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface #-}  module Network.HPACK.Huffman.ByteString (-    unpack4bits-  , copy-  ) where+    unpack4bits,+    copy,+) where -import Foreign.C.Types (CSize(..))+import Foreign.C.Types (CSize (..)) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafeDupablePerformIO)@@ -22,30 +22,29 @@ -- [1,2,3,4,15,3,10,11] -- >>> unpack4bits $ BS.tail bs -- [3,4,15,3,10,11]- unpack4bits :: ByteString -> [Word8] unpack4bits (PS fptr off len) = unsafeDupablePerformIO $-  withForeignPtr fptr $ \ptr -> do-    let lim = ptr `plusPtr` (off - 1)-        end = ptr `plusPtr` (off + len - 1)-    go lim end []+    withForeignPtr fptr $ \ptr -> do+        let lim = ptr `plusPtr` (off - 1)+            end = ptr `plusPtr` (off + len - 1)+        go lim end []   where     go lim p ws-      | lim == p = return ws-      | otherwise = do-          w <- peek p-          let w0 = w `shiftR` 4-              w1 = w .&. 0xf-          go lim (p `plusPtr` (-1)) (w0:w1:ws)-+        | lim == p = return ws+        | otherwise = do+            w <- peek p+            let w0 = w `shiftR` 4+                w1 = w .&. 0xf+            go lim (p `plusPtr` (-1)) (w0 : w1 : ws)  copy :: Ptr Word8 -> ByteString -> IO () copy dst (PS fptr off len) = withForeignPtr fptr $ \ptr -> do     let beg = ptr `plusPtr` off     memcpy dst beg (fromIntegral len) -foreign import ccall unsafe "string.h memcpy" c_memcpy-    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)+foreign import ccall unsafe "string.h memcpy"+    c_memcpy+        :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)  memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () memcpy dst src s = void $ c_memcpy dst src (fromIntegral s)
Network/HPACK/Huffman/Decode.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.HPACK.Huffman.Decode (-  -- * Huffman decoding-    decodeH-  , decodeHuffman-  , HuffmanDecoder-  , decH-  , GCBuffer-  ) where+    -- * Huffman decoding+    decodeH,+    decodeHuffman,+    HuffmanDecoder,+    decH,+    GCBuffer,+) where  import Control.Exception (throwIO) import Data.Array (Array, listArray)@@ -20,7 +20,7 @@ import Network.HPACK.Huffman.Params import Network.HPACK.Huffman.Table import Network.HPACK.Huffman.Tree-import Network.HPACK.Types (DecodeError(..))+import Network.HPACK.Types (DecodeError (..))  ---------------------------------------------------------------- @@ -29,14 +29,17 @@  ---------------------------------------------------------------- -data Pin = EndOfString-         | Forward {-# UNPACK #-} Word8 -- node no.-         | GoBack  {-# UNPACK #-} Word8 -- node no.-                   {-# UNPACK #-} Word8 -- a decoded value-         | GoBack2 {-# UNPACK #-} Word8 -- node no.-                   {-# UNPACK #-} Word8 -- a decoded value-                   {-# UNPACK #-} Word8 -- a decoded value-         deriving Show+data Pin+    = EndOfString+    | Forward {-# UNPACK #-} Word8 -- node no.+    | GoBack+        {-# UNPACK #-} Word8 -- node no.+        {-# UNPACK #-} Word8 -- a decoded value+    | GoBack2+        {-# UNPACK #-} Word8 -- node no.+        {-# UNPACK #-} Word8 -- a decoded value+        {-# UNPACK #-} Word8 -- a decoded value+    deriving (Show)  data WayStep = WayStep (Maybe Int) (Array Word8 Pin) type Way256 = Array Word8 WayStep@@ -47,11 +50,15 @@ ----------------------------------------------------------------  -- | Huffman decoding.-decodeH :: GCBuffer    -- ^ A working space-        -> BufferSize-        -> ReadBuffer  -- ^ A read buffer which contains the target-        -> Int         -- ^ The target length-        -> IO ByteString+decodeH+    :: GCBuffer+    -- ^ A working space+    -> BufferSize+    -> ReadBuffer+    -- ^ A read buffer which contains the target+    -> Int+    -- ^ The target length+    -> IO ByteString decodeH gcbuf bufsiz rbuf len = withForeignPtr gcbuf $ \buf -> do     wbuf <- newWriteBuffer buf bufsiz     decH wbuf rbuf len@@ -62,18 +69,18 @@ decH wbuf rbuf len = go len (way256 `unsafeAt` 0)   where     go 0 way0 = case way0 of-        WayStep Nothing  _ -> throwIO IllegalEos+        WayStep Nothing _ -> throwIO IllegalEos         WayStep (Just i) _-          | i <= 8         -> return ()-          | otherwise      -> throwIO TooLongEos+            | i <= 8 -> return ()+            | otherwise -> throwIO TooLongEos     go n way0 = do         w <- read8 rbuf         way <- doit way0 w         go (n - 1) way     doit way w = case next way w of         EndOfString -> throwIO EosInTheMiddle-        Forward n   -> return $ way256 `unsafeAt` fromIntegral n-        GoBack  n v -> do+        Forward n -> return $ way256 `unsafeAt` fromIntegral n+        GoBack n v -> do             write8 wbuf v             return $ way256 `unsafeAt` fromIntegral n         GoBack2 n v1 v2 -> do@@ -93,17 +100,19 @@ way256 = construct $ toHTree huffmanTable  construct :: HTree -> Way256-construct decoder = listArray (0,255) $ map to16ways $ flatten decoder+construct decoder = listArray (0, 255) $ map to16ways $ flatten decoder   where     to16ways x = WayStep ei a16       where         ei = eosInfo x-        a16 = listArray (0,255) $ map (step decoder x Non) bits8s+        a16 = listArray (0, 255) $ map (step decoder x Non) bits8s -data Chara = Non-           | One Word8-           | Two Word8 Word8+data Chara+    = Non+    | One Word8+    | Two Word8 Word8 +{- FOURMOLU_DISABLE -} inc :: Chara -> Word8 -> Chara inc Non w     = One w inc (One v) w = Two v w@@ -380,4 +389,4 @@   , [T,T,T,T,T,T,T,F]   , [T,T,T,T,T,T,T,T]   ]-+{- FOURMOLU_ENABLE -}
Network/HPACK/Huffman/Encode.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE RecordWildCards #-}  module Network.HPACK.Huffman.Encode (-  -- * Huffman encoding-    encodeH-  , encodeHuffman-  ) where+    -- * Huffman encoding+    encodeH,+    encodeHuffman,+) where  import Control.Exception (throwIO) import Data.Array.Base (unsafeAt) import Data.Array.IArray (listArray) import Data.Array.Unboxed (UArray) import Data.IORef-import Foreign.Ptr (plusPtr, minusPtr)+import Foreign.Ptr (minusPtr, plusPtr) import Foreign.Storable (poke) import Network.ByteOrder hiding (copy) @@ -22,17 +22,20 @@ ----------------------------------------------------------------  huffmanLength :: UArray Int Int-huffmanLength = listArray (0,idxEos) $ map length huffmanTable+huffmanLength = listArray (0, idxEos) $ map length huffmanTable  huffmanCode :: UArray Int Word64-huffmanCode = listArray (0,idxEos) huffmanTable'+huffmanCode = listArray (0, idxEos) huffmanTable'  ----------------------------------------------------------------  -- | Huffman encoding.-encodeH :: WriteBuffer-        -> ByteString -- ^ Target-        -> IO Int     -- ^ The length of the encoded string.+encodeH+    :: WriteBuffer+    -> ByteString+    -- ^ Target+    -> IO Int+    -- ^ The length of the encoded string. encodeH dst bs = withReadBuffer bs $ enc dst  -- The maximum length of Huffman code is 30.@@ -46,20 +49,21 @@ enc :: WriteBuffer -> ReadBuffer -> IO Int enc WriteBuffer{..} rbuf = do     beg <- readIORef offset-    end <- go (beg,0,initialOffset)+    end <- go (beg, 0, initialOffset)     writeIORef offset end     let len = end `minusPtr` beg     return len   where-    go (dst,encoded,off) = do+    go (dst, encoded, off) = do         i <- readInt8 rbuf-        if i >= 0 then-            cpy dst (bond i) >>= go-          else if off == initialOffset then-            return dst-          else do-            let (encoded1,_) = bond idxEos-            write dst encoded1+        if i >= 0+            then cpy dst (bond i) >>= go+            else+                if off == initialOffset+                    then return dst+                    else do+                        let (encoded1, _) = bond idxEos+                        write dst encoded1       where         {-# INLINE bond #-}         bond i = (encoded', off')@@ -77,13 +81,13 @@             let p' = p `plusPtr` 1             return p'         {-# INLINE cpy #-}-        cpy p (w,o)-          | o > shiftForWrite = return (p,w,o)-          | otherwise = do-              p' <- write p w-              let w' = w `shiftL` 8-                  o' = o + 8-              cpy p' (w',o')+        cpy p (w, o)+            | o > shiftForWrite = return (p, w, o)+            | otherwise = do+                p' <- write p w+                let w' = w `shiftL` 8+                    o' = o + 8+                cpy p' (w', o')  -- | Huffman encoding with a temporary buffer whose size is 4096. encodeHuffman :: ByteString -> IO ByteString
Network/HPACK/Huffman/Table.hs view
@@ -3,6 +3,7 @@ import Imports import Network.HPACK.Huffman.Bit +{- FOURMOLU_DISABLE -} huffmanTable :: [Bits] huffmanTable = [     [T,T,T,T,T,T,T,T,T,T,F,F,F]@@ -524,3 +525,4 @@   , 0x3ffffee   , 0x3fffffff   ]+{- FOURMOLU_ENABLE -}
Network/HPACK/Huffman/Tree.hs view
@@ -1,12 +1,12 @@ module Network.HPACK.Huffman.Tree (-  -- * Huffman decoding-    HTree(..)-  , eosInfo-  , toHTree-  , showTree-  , printTree-  , flatten-  ) where+    -- * Huffman decoding+    HTree (..),+    eosInfo,+    toHTree,+    showTree,+    printTree,+    flatten,+) where  import Control.Arrow (second) @@ -19,18 +19,19 @@ type EOSInfo = Maybe Int  -- | Type for Huffman decoding.-data HTree = Tip-             EOSInfo            -- EOS info from 1-             {-# UNPACK #-} Int -- Decoded value. Essentially Word8-           | Bin-             EOSInfo            -- EOS info from 1-             {-# UNPACK #-} Int -- Sequence no from 0-             HTree              -- Left-             HTree              -- Right-           deriving Show+data HTree+    = Tip+        EOSInfo -- EOS info from 1+        {-# UNPACK #-} Int -- Decoded value. Essentially Word8+    | Bin+        EOSInfo -- EOS info from 1+        {-# UNPACK #-} Int -- Sequence no from 0+        HTree -- Left+        HTree -- Right+    deriving (Show)  eosInfo :: HTree -> EOSInfo-eosInfo (Tip mx _)     = mx+eosInfo (Tip mx _) = mx eosInfo (Bin mx _ _ _) = mx  ----------------------------------------------------------------@@ -39,10 +40,17 @@ showTree = showTree' ""  showTree' :: String -> HTree -> String-showTree' _    (Tip _ i)     = show i ++ "\n"-showTree' pref (Bin _ n l r) = "No " ++ show n ++ "\n"-                            ++ pref ++ "+ " ++ showTree' pref' l-                            ++ pref ++ "+ " ++ showTree' pref' r+showTree' _ (Tip _ i) = show i ++ "\n"+showTree' pref (Bin _ n l r) =+    "No "+        ++ show n+        ++ "\n"+        ++ pref+        ++ "+ "+        ++ showTree' pref' l+        ++ pref+        ++ "+ "+        ++ showTree' pref' r   where     pref' = "  " ++ pref @@ -53,29 +61,34 @@  -- | Creating 'HTree'. toHTree :: [Bits] -> HTree-toHTree bs = mark 1 eos $ snd $ build 0 $ zip [0..idxEos] bs+toHTree bs = mark 1 eos $ snd $ build 0 $ zip [0 .. idxEos] bs   where     eos = bs !! idxEos -build :: Int -> [(Int,Bits)] -> (Int, HTree)-build cnt0 [(v,[])] = (cnt0,Tip Nothing v)-build cnt0 xs       = let (cnt1,l) = build (cnt0 + 1) fs-                          (cnt2,r) = build cnt1 ts-                      in (cnt2, Bin Nothing cnt0 l r)+build :: Int -> [(Int, Bits)] -> (Int, HTree)+build cnt0 [(v, [])] = (cnt0, Tip Nothing v)+build cnt0 xs =+    let (cnt1, l) = build (cnt0 + 1) fs+        (cnt2, r) = build cnt1 ts+     in (cnt2, Bin Nothing cnt0 l r)   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-mark i []     (Tip Nothing v)     = Tip (Just i) v-mark i (F:bs) (Bin Nothing n l r) = Bin (Just i) n (mark (i+1) bs l) r-mark i (T:bs) (Bin Nothing n l r) = Bin (Just i) n l (mark (i+1) bs r)-mark _ _      _                   = error "mark"+mark i [] (Tip Nothing v) = Tip (Just i) v+mark i (F : bs) (Bin Nothing n l r) = Bin (Just i) n (mark (i + 1) bs l) r+mark i (T : bs) (Bin Nothing n l r) = Bin (Just i) n l (mark (i + 1) bs r)+mark _ _ _ = error "mark"  ----------------------------------------------------------------  flatten :: HTree -> [HTree]-flatten (Tip _ _)       = []+flatten (Tip _ _) = [] flatten t@(Bin _ _ l r) = t : (flatten l ++ flatten r)
Network/HPACK/Internal.hs view
@@ -1,15 +1,26 @@ module Network.HPACK.Internal (-  -- * Integer encoding/decoding-    module Network.HPACK.HeaderBlock.Integer-  -- * String encoding/decoding-  , module Network.HPACK.HeaderBlock.Encode-  , module Network.HPACK.HeaderBlock.Decode-  , module Network.HPACK.Huffman-  , module Network.HPACK.Table.Entry-  ) where+    -- * Integer encoding/decoding+    module Network.HPACK.HeaderBlock.Integer, -import Network.HPACK.HeaderBlock.Decode (decodeString, decodeS, decodeSophisticated, decodeSimple)-import Network.HPACK.HeaderBlock.Encode (encodeString, encodeS)+    -- * String encoding/decoding+    module Network.HPACK.HeaderBlock.Encode,+    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 (+    decodeS,+    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.hs view
@@ -1,32 +1,36 @@ {-# OPTIONS_HADDOCK hide #-}  module Network.HPACK.Table (-  -- * dynamic table-    DynamicTable-  , newDynamicTableForEncoding-  , newDynamicTableForDecoding-  , withDynamicTableForEncoding-  , withDynamicTableForDecoding-  , huffmanDecoder-  , renewDynamicTable-  , printDynamicTable-  , isDynamicTableEmpty-  , isSuitableSize-  , TableSizeAction(..)-  , needChangeTableSize-  , setLimitForEncoding-  , resetLimitForEncoding-  -- * Insertion-  , insertEntry-  -- * Entry-  , module Network.HPACK.Table.Entry-  -- * Reverse index-  , getRevIndex-  , module Network.HPACK.Table.RevIndex-  -- * Index to entry-  , toIndexedEntry-  , fromHIndexToIndex-  ) where+    -- * dynamic table+    DynamicTable,+    newDynamicTableForEncoding,+    newDynamicTableForDecoding,+    withDynamicTableForEncoding,+    withDynamicTableForDecoding,+    huffmanDecoder,+    renewDynamicTable,+    printDynamicTable,+    isDynamicTableEmpty,+    isSuitableSize,+    TableSizeAction (..),+    needChangeTableSize,+    setLimitForEncoding,+    resetLimitForEncoding,++    -- * Insertion+    insertEntry,++    -- * Entry+    module Network.HPACK.Table.Entry,++    -- * Reverse index+    getRevIndex,+    module Network.HPACK.Table.RevIndex,++    -- * Index to entry+    toIndexedEntry,+    fromHIndexToIndex,+) where  import Network.HPACK.Table.Dynamic import Network.HPACK.Table.Entry
Network/HPACK/Table/Dynamic.hs view
@@ -2,27 +2,27 @@ {-# LANGUAGE RecordWildCards #-}  module Network.HPACK.Table.Dynamic (-    DynamicTable(..)-  , newDynamicTableForEncoding-  , newDynamicTableForDecoding-  , renewDynamicTable-  , huffmanDecoder-  , printDynamicTable-  , isDynamicTableEmpty-  , isSuitableSize-  , TableSizeAction(..)-  , needChangeTableSize-  , setLimitForEncoding-  , resetLimitForEncoding-  , insertEntry-  , toDynamicEntry-  , CodeInfo(..)-  , withDynamicTableForEncoding-  , withDynamicTableForDecoding-  , toIndexedEntry-  , fromHIndexToIndex-  , getRevIndex-  ) where+    DynamicTable (..),+    newDynamicTableForEncoding,+    newDynamicTableForDecoding,+    renewDynamicTable,+    huffmanDecoder,+    printDynamicTable,+    isDynamicTableEmpty,+    isSuitableSize,+    TableSizeAction (..),+    needChangeTableSize,+    setLimitForEncoding,+    resetLimitForEncoding,+    insertEntry,+    toDynamicEntry,+    CodeInfo (..),+    withDynamicTableForEncoding,+    withDynamicTableForDecoding,+    toIndexedEntry,+    fromHIndexToIndex,+    getRevIndex,+) where  import Control.Exception (throwIO) import Data.Array.Base (unsafeRead, unsafeWrite)@@ -43,9 +43,9 @@ {-# INLINE toIndexedEntry #-} toIndexedEntry :: DynamicTable -> Index -> IO Entry toIndexedEntry dyntbl idx-  | idx <= 0               = throwIO $ IndexOverrun idx-  | idx <= staticTableSize = return $ toStaticEntry idx-  | otherwise              = toDynamicEntry dyntbl idx+    | idx <= 0 = throwIO $ IndexOverrun idx+    | idx <= staticTableSize = return $ toStaticEntry idx+    | otherwise = toDynamicEntry dyntbl idx  -- For encoder {-# INLINE fromHIndexToIndex #-}@@ -79,44 +79,57 @@         1 2 3 4      (numOfEntries = 4) -} -data CodeInfo =-    EncodeInfo RevIndex -- Reverse index-               -- The value informed by SETTINGS_HEADER_TABLE_SIZE.-               -- If 'Nothing', dynamic table size update is not necessary.-               -- Otherwise, dynamic table size update is sent-               -- and this value should be set to 'Nothing'.-               (IORef (Maybe Size))-  | DecodeInfo HuffmanDecoder-               (IORef Size)  -- The limit size+data CodeInfo = CIE EncodeInfo | CID DecodeInfo+data EncodeInfo+    = EncodeInfo+        RevIndex -- Reverse index+        -- The value informed by SETTINGS_HEADER_TABLE_SIZE.+        -- If 'Nothing', dynamic table size update is not necessary.+        -- Otherwise, dynamic table size update is sent+        -- and this value should be set to 'Nothing'.+        (IORef (Maybe Size))+data DecodeInfo+    = DecodeInfo+        HuffmanDecoder+        (IORef Size) -- The limit size +toEncodeInfo :: CodeInfo -> EncodeInfo+toEncodeInfo (CIE x) = x+toEncodeInfo _ = error "toEncodeInfo"++toDecodeInfo :: CodeInfo -> DecodeInfo+toDecodeInfo (CID x) = x+toDecodeInfo _ = error "toDecodeInfo"+ -- | Type for dynamic table.-data DynamicTable = DynamicTable {-    codeInfo :: CodeInfo-  -- | An array-  , circularTable :: IORef Table-  -- | Start point-  , offset :: IORef Index-  -- | The current number of entries-  , numOfEntries :: IORef Int-  -- | The size of the array-  , maxNumOfEntries :: IORef Int-  -- | The current dynamic table size (defined in HPACK)-  , dynamicTableSize :: IORef Size-  -- | The max dynamic table size (defined in HPACK)-  , maxDynamicTableSize :: IORef Size-  }+data DynamicTable = DynamicTable+    { codeInfo :: CodeInfo+    , circularTable :: IORef Table+    -- ^ An array+    , offset :: IORef Index+    -- ^ Start point+    , numOfEntries :: IORef Int+    -- ^ The current number of entries+    , maxNumOfEntries :: IORef Int+    -- ^ The size of the array+    , dynamicTableSize :: IORef Size+    -- ^ The current dynamic table size (defined in HPACK)+    , maxDynamicTableSize :: IORef Size+    -- ^ The max dynamic table size (defined in HPACK)+    }  {-# INLINE adj #-} adj :: Int -> Int -> IO Int adj maxN x-  | maxN == 0 = throwIO TooSmallTableSize-  | otherwise = let ret = (x + maxN) `mod` maxN-                in return ret+    | maxN == 0 = throwIO TooSmallTableSize+    | otherwise =+        let ret = (x + maxN) `mod` maxN+         in return ret  huffmanDecoder :: DynamicTable -> HuffmanDecoder huffmanDecoder DynamicTable{..} = dec   where-    DecodeInfo dec _ = codeInfo+    DecodeInfo dec _ = toDecodeInfo codeInfo  ---------------------------------------------------------------- @@ -130,22 +143,22 @@         end = off + n     tbl <- readIORef circularTable     es <- mapM (adj maxN >=> unsafeRead tbl) [beg .. end]-    let ts = zip [1..] es+    let ts = zip [1 ..] es     mapM_ printEntry ts     dsize <- readIORef dynamicTableSize     maxdsize <- readIORef maxDynamicTableSize     putStrLn $ "      Table size: " ++ show dsize ++ "/" ++ show maxdsize -printEntry :: (Index,Entry) -> IO ()-printEntry (i,e) = do+printEntry :: (Index, Entry) -> IO ()+printEntry (i, e) = do     putStr "[ "     putStr $ show i     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  ---------------------------------------------------------------- @@ -156,7 +169,7 @@  isSuitableSize :: Size -> DynamicTable -> IO Bool isSuitableSize siz DynamicTable{..} = do-    let DecodeInfo _ limref = codeInfo+    let DecodeInfo _ limref = toDecodeInfo codeInfo     lim <- readIORef limref     return $ siz <= lim @@ -164,58 +177,64 @@  needChangeTableSize :: DynamicTable -> IO TableSizeAction needChangeTableSize DynamicTable{..} = do-    let EncodeInfo _ limref = codeInfo+    let EncodeInfo _ limref = toEncodeInfo codeInfo     mlim <- readIORef limref     maxsiz <- readIORef maxDynamicTableSize     return $ case mlim of-        Nothing          -> Keep+        Nothing -> Keep         Just lim-          | lim < maxsiz -> Change lim-          | otherwise    -> Ignore maxsiz+            | lim < maxsiz -> Change lim+            | otherwise -> Ignore maxsiz  -- | When SETTINGS_HEADER_TABLE_SIZE is received from a peer, --   its value should be set by this function. setLimitForEncoding :: Size -> DynamicTable -> IO () setLimitForEncoding siz DynamicTable{..} = do-    let EncodeInfo _ limref = codeInfo+    let EncodeInfo _ limref = toEncodeInfo codeInfo     writeIORef limref $ Just siz  resetLimitForEncoding :: DynamicTable -> IO () resetLimitForEncoding DynamicTable{..} = do-    let EncodeInfo _ limref = codeInfo+    let EncodeInfo _ limref = toEncodeInfo codeInfo     writeIORef limref Nothing  ----------------------------------------------------------------  -- | Creating 'DynamicTable' for encoding.-newDynamicTableForEncoding :: Size -- ^ The dynamic table size-                           -> IO DynamicTable+newDynamicTableForEncoding+    :: Size+    -- ^ The dynamic table size+    -> IO DynamicTable newDynamicTableForEncoding maxsiz = do     rev <- newRevIndex     lim <- newIORef Nothing-    let info = EncodeInfo rev lim+    let info = CIE $ EncodeInfo rev lim     newDynamicTable maxsiz info  -- | Creating 'DynamicTable' for decoding.-newDynamicTableForDecoding :: Size -- ^ The dynamic table size-                           -> Size -- ^ The size of temporary buffer for Huffman decoding-                           -> IO DynamicTable+newDynamicTableForDecoding+    :: Size+    -- ^ The dynamic table size+    -> Size+    -- ^ The size of temporary buffer for Huffman decoding+    -> IO DynamicTable newDynamicTableForDecoding maxsiz huftmpsiz = do     lim <- newIORef maxsiz     buf <- mallocPlainForeignPtrBytes huftmpsiz     let decoder = decodeH buf huftmpsiz-        info = DecodeInfo decoder lim+        info = CID $ DecodeInfo decoder lim     newDynamicTable maxsiz info  newDynamicTable :: Size -> CodeInfo -> IO DynamicTable newDynamicTable maxsiz info = do-    tbl <- newArray (0,end) dummyEntry-    DynamicTable info <$> newIORef tbl     -- circularTable-                      <*> newIORef end     -- offset-                      <*> newIORef 0       -- numOfEntries-                      <*> newIORef maxN    -- maxNumOfEntries-                      <*> newIORef 0       -- dynamicTableSize-                      <*> newIORef maxsiz  -- maxDynamicTableSize+    tbl <- newArray (0, end) dummyEntry+    DynamicTable info+        <$> newIORef tbl -- circularTable+        <*> newIORef end -- offset+        <*> newIORef 0 -- numOfEntries+        <*> newIORef maxN -- maxNumOfEntries+        <*> newIORef 0 -- dynamicTableSize+        <*> newIORef maxsiz -- maxDynamicTableSize   where     maxN = maxNumbers maxsiz     end = maxN - 1@@ -228,7 +247,7 @@         entries <- getEntries dyntbl         let maxN = maxNumbers maxsiz             end = maxN - 1-        newtbl <- newArray (0,end) dummyEntry+        newtbl <- newArray (0, end) dummyEntry         writeIORef circularTable newtbl         writeIORef offset end         writeIORef numOfEntries 0@@ -236,8 +255,8 @@         writeIORef dynamicTableSize 0         writeIORef maxDynamicTableSize maxsiz         case codeInfo of-            EncodeInfo rev _ -> renewRevIndex rev-            _                -> return ()+            CIE (EncodeInfo rev _) -> renewRevIndex rev+            _ -> return ()         copyEntries dyntbl entries  getEntries :: DynamicTable -> IO [Entry]@@ -250,8 +269,8 @@     forM [1 .. n] readTable  copyEntries :: DynamicTable -> [Entry] -> IO ()-copyEntries _                           [] = return ()-copyEntries dyntbl@DynamicTable{..} (e:es) = do+copyEntries _ [] = return ()+copyEntries dyntbl@DynamicTable{..} (e : es) = do     dsize <- readIORef dynamicTableSize     maxdsize <- readIORef maxDynamicTableSize     when (dsize + entrySize e <= maxdsize) $ do@@ -269,35 +288,41 @@ -- | Creating 'DynamicTable' for encoding, --   performing the action and --   clearing the 'DynamicTable'.-withDynamicTableForEncoding :: Size -- ^ The dynamic table size-                            -> (DynamicTable -> IO a)-                            -> IO a+withDynamicTableForEncoding+    :: Size+    -- ^ The dynamic table size+    -> (DynamicTable -> IO a)+    -> IO a withDynamicTableForEncoding maxsiz action =     newDynamicTableForEncoding maxsiz >>= action  -- | Creating 'DynamicTable' for decoding, --   performing the action and --   clearing the 'DynamicTable'.-withDynamicTableForDecoding :: Size -- ^ The dynamic table size-                            -> Size -- ^ The size of temporary buffer for Huffman-                            -> (DynamicTable -> IO a)-                            -> IO a+withDynamicTableForDecoding+    :: Size+    -- ^ The dynamic table size+    -> Size+    -- ^ The size of temporary buffer for Huffman+    -> (DynamicTable -> IO a)+    -> IO a withDynamicTableForDecoding maxsiz huftmpsiz action =     newDynamicTableForDecoding maxsiz huftmpsiz >>= action  ----------------------------------------------------------------  -- | 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-        EncodeInfo rev _ -> deleteRevIndexList es rev-        _                -> return ()+        CIE (EncodeInfo rev _) -> deleteRevIndexList es rev+        _ -> return ()  insertFront :: Entry -> DynamicTable -> IO () insertFront e DynamicTable{..} = do@@ -309,16 +334,16 @@     let i = off         dsize' = dsize + entrySize e     if maxN == 0-    then return ()-    else do-      off' <- adj maxN (off - 1)-      unsafeWrite table i e-      writeIORef offset off'-      writeIORef numOfEntries $ n + 1-      writeIORef dynamicTableSize dsize'-      case codeInfo of-          EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev-          _                -> return ()+        then return ()+        else do+            off' <- adj maxN (off - 1)+            unsafeWrite table i e+            writeIORef offset off'+            writeIORef numOfEntries $ n + 1+            writeIORef dynamicTableSize dsize'+            case codeInfo of+                CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev+                _ -> return ()  adjustTableSize :: DynamicTable -> IO [Entry] adjustTableSize dyntbl@DynamicTable{..} = adjust []@@ -327,14 +352,15 @@     adjust es = do         dsize <- readIORef dynamicTableSize         maxdsize <- readIORef maxDynamicTableSize-        if dsize <= maxdsize then-            return es-          else do-            e <- removeEnd dyntbl-            adjust (e:es)+        if dsize <= maxdsize+            then return es+            else do+                e <- removeEnd dyntbl+                adjust (e : es)  ---------------------------------------------------------------- +-- Used in copyEntries. insertEnd :: Entry -> DynamicTable -> IO () insertEnd e DynamicTable{..} = do     maxN <- readIORef maxNumOfEntries@@ -348,8 +374,8 @@     writeIORef numOfEntries $ n + 1     writeIORef dynamicTableSize dsize'     case codeInfo of-        EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev-        _                -> return ()+        CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev+        _ -> return ()  ---------------------------------------------------------------- @@ -384,7 +410,7 @@ ----------------------------------------------------------------  {-# INLINE getRevIndex #-}-getRevIndex :: DynamicTable-> RevIndex+getRevIndex :: DynamicTable -> RevIndex getRevIndex DynamicTable{..} = rev   where-    EncodeInfo rev _ = codeInfo+    EncodeInfo rev _ = toEncodeInfo codeInfo
Network/HPACK/Table/Entry.hs view
@@ -1,38 +1,41 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.HPACK.Table.Entry (-  -- * Type-    Size-  , Entry(..)-  , Header      -- re-exporting-  , HeaderName  -- re-exporting-  , HeaderValue -- re-exporting-  , Index       -- re-exporting-  -- * Header and Entry-  , toEntry-  , toEntryToken-  -- * Getters-  , entrySize-  , entryTokenHeader-  , entryToken-  , entryHeaderName-  , entryHeaderValue-  -- * For initialization-  , dummyEntry-  , maxNumbers-  ) where+    -- * Type+    Size,+    Entry (..),+    FieldValue, -- re-exporting+    Index, -- re-exporting +    -- * Header and Entry+    toEntry,+    toEntryToken,++    -- * Getters+    entrySize,+    entryTokenHeader,+    entryToken,+    entryHeaderName,+    entryFieldValue,++    -- * For initialization+    dummyEntry,+    maxNumbers,+) 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)  ---------------------------------------------------------------- @@ -40,25 +43,27 @@ headerSizeMagicNumber = 32  headerSize :: Header -> Size-headerSize (k,v) = BS.length k-                 + BS.length v-                 + headerSizeMagicNumber+headerSize (k, v) =+    BS.length (foldedCase k)+        + BS.length v+        + headerSizeMagicNumber -headerSize' :: Token -> HeaderValue -> Size-headerSize' t v = BS.length (tokenFoldedKey t)-                + BS.length v-                + headerSizeMagicNumber+headerSize' :: Token -> FieldValue -> Size+headerSize' t v =+    BS.length (tokenFoldedKey t)+        + BS.length v+        + headerSizeMagicNumber  ----------------------------------------------------------------  -- | From 'Header' to 'Entry'. toEntry :: Header -> Entry-toEntry kv@(k,v) = Entry siz t v+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@@ -79,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
@@ -3,28 +3,29 @@ {-# LANGUAGE RecordWildCards #-}  module Network.HPACK.Table.RevIndex (-    RevIndex-  , newRevIndex-  , renewRevIndex-  , lookupRevIndex-  , lookupRevIndex'-  , insertRevIndex-  , deleteRevIndexList-  ) where+    RevIndex,+    newRevIndex,+    renewRevIndex,+    lookupRevIndex,+    lookupRevIndex',+    insertRevIndex,+    deleteRevIndexList,+) where  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,83 +34,94 @@  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}. type OtherRevIdex = IORef (Map KeyValue HIndex) -{-# SPECIALIZE INLINE M.lookup :: KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex #-}-{-# SPECIALIZE INLINE M.delete :: KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}-{-# SPECIALIZE INLINE M.insert :: KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex #-}+{-# SPECIALIZE INLINE M.lookup ::+    KeyValue -> M.Map KeyValue HIndex -> Maybe HIndex+    #-}+{-# SPECIALIZE INLINE M.delete ::+    KeyValue -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex+    #-}+{-# SPECIALIZE INLINE M.insert ::+    KeyValue -> HIndex -> M.Map KeyValue HIndex -> M.Map KeyValue HIndex+    #-}  ----------------------------------------------------------------  type StaticRevIndex = Array Int StaticEntry -data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving Show+data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show) -type ValueMap = Map HeaderValue HIndex+type ValueMap = Map FieldValue HIndex  ----------------------------------------------------------------  staticRevIndex :: StaticRevIndex-staticRevIndex = A.array (minTokenIx,maxStaticTokenIx) $ map toEnt zs+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-                        in StaticEntry i (Just vs)-    zs = map extract $ groupBy ((==) `on` fst) lst+            ("", i) :| [] -> StaticEntry i Nothing+            (_, i) :| _ ->+                let vs = M.fromList $ NE.toList xs+                 in StaticEntry i (Just vs)+    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)+        lst = zipWith (\(k, v) i -> (k, (v, i))) staticTableList $ map SIndex [1 ..] +        extract xs = (fst (NE.head xs), NE.map snd xs)+ {-# INLINE lookupStaticRevIndex #-}-lookupStaticRevIndex :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()+lookupStaticRevIndex+    :: Int -> FieldValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO () lookupStaticRevIndex ix v fa' fbd' = case staticRevIndex `unsafeAt` ix of-    StaticEntry i Nothing  -> fbd' i+    StaticEntry i Nothing -> fbd' i     StaticEntry i (Just m) -> case M.lookup v m of-            Nothing -> fbd' i-            Just j  -> fa' j-+        Nothing -> fbd' i+        Just j -> fa' j  ----------------------------------------------------------------  newDynamicRevIndex :: IO DynamicRevIndex-newDynamicRevIndex = A.listArray (minTokenIx,maxStaticTokenIx) <$> mapM mk lst+newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk' lst   where-    mk _ = newIORef M.empty-    lst = [minTokenIx..maxStaticTokenIx]+    mk' _ = newIORef M.empty+    lst = [minTokenIx .. maxStaticTokenIx]  renewDynamicRevIndex :: DynamicRevIndex -> IO ()-renewDynamicRevIndex drev = mapM_ clear [minTokenIx..maxStaticTokenIx]+renewDynamicRevIndex drev = mapM_ clear [minTokenIx .. maxStaticTokenIx]   where     clear t = writeIORef (drev `unsafeAt` t) M.empty  {-# INLINE lookupDynamicStaticRevIndex #-}-lookupDynamicStaticRevIndex :: Int -> HeaderValue -> DynamicRevIndex-                            -> (HIndex -> IO ())-                            -> (HIndex -> IO ())-                            -> IO ()+lookupDynamicStaticRevIndex+    :: Int+    -> FieldValue+    -> DynamicRevIndex+    -> (HIndex -> IO ())+    -> (HIndex -> IO ())+    -> IO () lookupDynamicStaticRevIndex ix v drev fa' fbd' = do     let ref = drev `unsafeAt` ix     m <- readIORef ref     case M.lookup v m of-        Just i  -> fa' i+        Just i -> fa' i         Nothing -> lookupStaticRevIndex ix v fa' fbd'  {-# INLINE insertDynamicRevIndex #-}-insertDynamicRevIndex :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()+insertDynamicRevIndex+    :: 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@@ -123,19 +135,20 @@ renewOtherRevIndex ref = writeIORef ref M.empty  {-# INLINE lookupOtherRevIndex #-}-lookupOtherRevIndex :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()-lookupOtherRevIndex (k,v) ref fa' fc' = do-      oth <- readIORef ref-      maybe fc' fa' $ M.lookup (KeyValue k v) oth+lookupOtherRevIndex+    :: (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@@ -151,19 +164,21 @@     renewOtherRevIndex oth  {-# INLINE lookupRevIndex #-}-lookupRevIndex :: Token-               -> HeaderValue-               -> (HIndex -> IO ())-               -> (HeaderValue -> Entry -> HIndex -> IO ())-               -> (HeaderName -> HeaderValue -> Entry -> IO ())-               -> (HeaderValue -> HIndex -> IO ())-               -> RevIndex-               -> IO ()+lookupRevIndex+    :: Token+    -> FieldValue+    -> (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)-  | not (isStaticTokenIx tokenIx) = lookupOtherRevIndex (k,v) oth fa' fc'-  | shouldBeIndexed               = lookupDynamicStaticRevIndex tokenIx v dyn fa' fb'-  -- path: is not indexed but ":path /" should be used, sigh.-  | otherwise                     = lookupStaticRevIndex tokenIx v fa' fd'+    | not (isStaticTokenIx tokenIx) = lookupOtherRevIndex (k, v) oth fa' fc'+    | shouldBeIndexed =+        lookupDynamicStaticRevIndex tokenIx v dyn fa' fb'+    -- path: is not indexed but ":path /" should be used, sigh.+    | otherwise = lookupStaticRevIndex tokenIx v fa' fd'   where     k = foldedCase tokenKey     ent = toEntryToken t v@@ -173,15 +188,16 @@     fd' = fd v  {-# INLINE lookupRevIndex' #-}-lookupRevIndex' :: Token-                -> HeaderValue-                -> (HIndex -> IO ())-                -> (HeaderValue -> HIndex -> IO ())-                -> (HeaderName -> HeaderValue -> IO ())-                -> IO ()+lookupRevIndex'+    :: Token+    -> FieldValue+    -> (HIndex -> IO ())+    -> (FieldValue -> HIndex -> IO ())+    -> (FieldName -> FieldValue -> IO ())+    -> IO () lookupRevIndex' Token{..} v fa fd fe-  | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'-  | otherwise               = fe'+    | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'+    | otherwise = fe'   where     k = foldedCase tokenKey     fa' = fa@@ -193,14 +209,14 @@ {-# INLINE insertRevIndex #-} insertRevIndex :: Entry -> HIndex -> RevIndex -> IO () insertRevIndex (Entry _ t v) i (RevIndex dyn oth)-  | isStaticToken t = insertDynamicRevIndex t v i dyn-  | otherwise       = insertOtherRevIndex   t v i oth+    | isStaticToken t = insertDynamicRevIndex t v i dyn+    | otherwise = insertOtherRevIndex t v i oth  {-# INLINE deleteRevIndex #-} deleteRevIndex :: RevIndex -> Entry -> IO () deleteRevIndex (RevIndex dyn oth) (Entry _ t v)-  | isStaticToken t = deleteDynamicRevIndex t v dyn-  | otherwise       = deleteOtherRevIndex   t v oth+    | isStaticToken t = deleteDynamicRevIndex t v dyn+    | otherwise = deleteOtherRevIndex t v oth  {-# INLINE deleteRevIndexList #-} deleteRevIndexList :: [Entry] -> RevIndex -> IO ()
Network/HPACK/Table/Static.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.HPACK.Table.Static (-    toStaticEntry-  , staticTableSize-  , staticTableList-  ) where+    toStaticEntry,+    staticTableSize,+    staticTableList,+) where  import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry+import Network.HTTP.Types (Header)  ---------------------------------------------------------------- @@ -17,6 +18,7 @@ staticTableSize = length staticTableList  {-# INLINE toStaticEntry #-}+ -- | Get 'Entry' from the static table. -- -- >>> toStaticEntry 1@@ -30,71 +32,71 @@  -- | Pre-defined static table. staticTable :: Array Index Entry-staticTable = listArray (1,staticTableSize) $ map toEntry staticTableList+staticTable = listArray (1, staticTableSize) $ map toEntry staticTableList  ----------------------------------------------------------------  staticTableList :: [Header]-staticTableList = [-    (":authority", "")-  , (":method", "GET")-  , (":method", "POST")-  , (":path", "/")-  , (":path", "/index.html")-  , (":scheme", "http")-  , (":scheme", "https")-  , (":status", "200")-  , (":status", "204")-  , (":status", "206")-  , (":status", "304")-  , (":status", "400")-  , (":status", "404")-  , (":status", "500")-  , ("accept-charset", "")-  , ("accept-encoding", "gzip, deflate")-  , ("accept-language", "")-  , ("accept-ranges", "")-  , ("accept", "")-  , ("access-control-allow-origin", "")-  , ("age", "")-  , ("allow", "")-  , ("authorization", "")-  , ("cache-control", "")-  , ("content-disposition", "")-  , ("content-encoding", "")-  , ("content-language", "")-  , ("content-length", "")-  , ("content-location", "")-  , ("content-range", "")-  , ("content-type", "")-  , ("cookie", "")-  , ("date", "")-  , ("etag", "")-  , ("expect", "")-  , ("expires", "")-  , ("from", "")-  , ("host", "")-  , ("if-match", "")-  , ("if-modified-since", "")-  , ("if-none-match", "")-  , ("if-range", "")-  , ("if-unmodified-since", "")-  , ("last-modified", "")-  , ("link", "")-  , ("location", "")-  , ("max-forwards", "")-  , ("proxy-authenticate", "")-  , ("proxy-authorization", "")-  , ("range", "")-  , ("referer", "")-  , ("refresh", "")-  , ("retry-after", "")-  , ("server", "")-  , ("set-cookie", "")-  , ("strict-transport-security", "")-  , ("transfer-encoding", "")-  , ("user-agent", "")-  , ("vary", "")-  , ("via", "")-  , ("www-authenticate", "")-  ]+staticTableList =+    [ (":authority", "")+    , (":method", "GET")+    , (":method", "POST")+    , (":path", "/")+    , (":path", "/index.html")+    , (":scheme", "http")+    , (":scheme", "https")+    , (":status", "200")+    , (":status", "204")+    , (":status", "206")+    , (":status", "304")+    , (":status", "400")+    , (":status", "404")+    , (":status", "500")+    , ("accept-charset", "")+    , ("accept-encoding", "gzip, deflate")+    , ("accept-language", "")+    , ("accept-ranges", "")+    , ("accept", "")+    , ("access-control-allow-origin", "")+    , ("age", "")+    , ("allow", "")+    , ("authorization", "")+    , ("cache-control", "")+    , ("content-disposition", "")+    , ("content-encoding", "")+    , ("content-language", "")+    , ("content-length", "")+    , ("content-location", "")+    , ("content-range", "")+    , ("content-type", "")+    , ("cookie", "")+    , ("date", "")+    , ("etag", "")+    , ("expect", "")+    , ("expires", "")+    , ("from", "")+    , ("host", "")+    , ("if-match", "")+    , ("if-modified-since", "")+    , ("if-none-match", "")+    , ("if-range", "")+    , ("if-unmodified-since", "")+    , ("last-modified", "")+    , ("link", "")+    , ("location", "")+    , ("max-forwards", "")+    , ("proxy-authenticate", "")+    , ("proxy-authorization", "")+    , ("range", "")+    , ("referer", "")+    , ("refresh", "")+    , ("retry-after", "")+    , ("server", "")+    , ("set-cookie", "")+    , ("strict-transport-security", "")+    , ("transfer-encoding", "")+    , ("user-agent", "")+    , ("vary", "")+    , ("via", "")+    , ("www-authenticate", "")+    ]
Network/HPACK/Token.hs view
@@ -1,467 +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-  ) where--import qualified Data.ByteString as B-import Data.ByteString.Internal (ByteString(..), memcmp)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (plusPtr)-import System.IO.Unsafe (unsafeDupablePerformIO)-import Data.CaseInsensitive (original, mk, CI(..))---- $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--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"---- | 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+    module Network.HTTP.Semantics.Token,+) where -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,53 +1,29 @@-{-# LANGUAGE DeriveDataTypeable #-}- module Network.HPACK.Types (-  -- * Header-    HeaderName-  , HeaderValue-  , Header-  , HeaderList-  , TokenHeader-  , TokenHeaderList-  -- * Misc-  , Index-  , HIndex(..)-  -- * Encoding and decoding-  , CompressionAlgo(..)-  , EncodeStrategy(..)-  , defaultEncodeStrategy-  , DecodeError(..)-  -- * Buffer-  , Buffer-  , BufferSize-  , BufferOverrun(..)-  ) where--import Control.Exception as E-import Data.Typeable-import Network.ByteOrder (Buffer, BufferSize, BufferOverrun(..))--import Imports-import Network.HPACK.Token (Token)---------------------------------------------------------------------- | Header name.-type HeaderName = ByteString+    -- * Header+    FieldValue,+    TokenHeader,+    TokenHeaderList, --- | Header value.-type HeaderValue = ByteString+    -- * Misc+    Index,+    HIndex (..), --- | Header.-type Header = (HeaderName, HeaderValue)+    -- * Encoding and decoding+    CompressionAlgo (..),+    EncodeStrategy (..),+    defaultEncodeStrategy,+    DecodeError (..), --- | Header list.-type HeaderList = [Header]+    -- * Buffer+    Buffer,+    BufferSize,+    BufferOverrun (..),+) where --- | TokenBased header.-type TokenHeader = (Token, HeaderValue)+import Control.Exception as E+import Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize) --- | TokenBased header list.-type TokenHeaderList = [TokenHeader]+import Imports  ---------------------------------------------------------------- @@ -59,42 +35,56 @@ ----------------------------------------------------------------  -- | Compression algorithms for HPACK encoding.-data CompressionAlgo = Naive  -- ^ No compression-                     | Static -- ^ Using indices in the static table only-                     | Linear -- ^ Using indices-                     deriving (Eq, Show)+data CompressionAlgo+    = -- | No compression+      Naive+    | -- | Using indices in the static table only+      Static+    | -- | Using indices+      Linear+    deriving (Eq, Show)  -- | Strategy for HPACK encoding.-data EncodeStrategy = EncodeStrategy {-  -- | Which compression algorithm is used.-    compressionAlgo :: CompressionAlgo-  -- | Whether or not to use Huffman encoding for strings.-  , useHuffman :: Bool-  } deriving (Eq, Show)+data EncodeStrategy = EncodeStrategy+    { compressionAlgo :: CompressionAlgo+    -- ^ Which compression algorithm is used.+    , useHuffman :: Bool+    -- ^ Whether or not to use Huffman encoding for strings.+    }+    deriving (Eq, Show)  -- | Default 'EncodeStrategy'. -- -- >>> defaultEncodeStrategy -- EncodeStrategy {compressionAlgo = Linear, useHuffman = False} defaultEncodeStrategy :: EncodeStrategy-defaultEncodeStrategy = EncodeStrategy {-    compressionAlgo = Linear-  , useHuffman = False-  }+defaultEncodeStrategy =+    EncodeStrategy+        { compressionAlgo = Linear+        , useHuffman = False+        }  ----------------------------------------------------------------  -- | Errors for decoder.-data DecodeError = IndexOverrun Index -- ^ Index is out of range-                 | EosInTheMiddle -- ^ Eos appears in the middle of huffman string-                 | IllegalEos -- ^ Non-eos appears in the end of huffman string-                 | TooLongEos -- ^ Eos of huffman string is more than 7 bits-                 | TooSmallTableSize -- ^ A peer set the dynamic table size less than 32-                 | TooLargeTableSize -- ^ A peer tried to change the dynamic table size over the limit-                 | IllegalTableSizeUpdate -- ^ Table size update at the non-beginning-                 | HeaderBlockTruncated-                 | IllegalHeaderName-                 | TooLargeHeader-                 deriving (Eq,Show,Typeable)+data DecodeError+    = -- | Index is out of range+      IndexOverrun Index+    | -- | Eos appears in the middle of huffman string+      EosInTheMiddle+    | -- | Non-eos appears in the end of huffman string+      IllegalEos+    | -- | Eos of huffman string is more than 7 bits+      TooLongEos+    | -- | A peer set the dynamic table size less than 32+      TooSmallTableSize+    | -- | A peer tried to change the dynamic table size over the limit+      TooLargeTableSize+    | -- | Table size update at the non-beginning+      IllegalTableSizeUpdate+    | HeaderBlockTruncated+    | IllegalHeaderName+    | TooLargeHeader+    deriving (Eq, Show)  instance Exception DecodeError
− Network/HTTP2.hs 
@@ -1,7 +0,0 @@--- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).-module Network.HTTP2 {-# DEPRECATED "Use Network.HTTP2.Frame instead" #-}-  (-    module Network.HTTP2.Frame-  ) where--import Network.HTTP2.Frame
− Network/HTTP2/Arch.hs 
@@ -1,29 +0,0 @@-module Network.HTTP2.Arch (-    module Network.HTTP2.Arch.Config-  , module Network.HTTP2.Arch.Context-  , module Network.HTTP2.Arch.EncodeFrame-  , module Network.HTTP2.Arch.File-  , module Network.HTTP2.Arch.HPACK-  , module Network.HTTP2.Arch.Manager-  , module Network.HTTP2.Arch.Queue-  , module Network.HTTP2.Arch.ReadN-  , module Network.HTTP2.Arch.Receiver-  , module Network.HTTP2.Arch.Sender-  , module Network.HTTP2.Arch.Status-  , module Network.HTTP2.Arch.Stream-  , module Network.HTTP2.Arch.Types-  ) where--import Network.HTTP2.Arch.Config-import Network.HTTP2.Arch.Context-import Network.HTTP2.Arch.EncodeFrame-import Network.HTTP2.Arch.File-import Network.HTTP2.Arch.HPACK-import Network.HTTP2.Arch.Manager-import Network.HTTP2.Arch.Queue-import Network.HTTP2.Arch.ReadN-import Network.HTTP2.Arch.Receiver-import Network.HTTP2.Arch.Sender-import Network.HTTP2.Arch.Stream-import Network.HTTP2.Arch.Status-import Network.HTTP2.Arch.Types
− Network/HTTP2/Arch/Cache.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Cache where--import Data.OrdPSQ (OrdPSQ)-import qualified Data.OrdPSQ as PSQ--type Priority = Int--data Cache k v = Cache {-    cLimit :: Int-  , cSize  :: Int-  , cTick  :: Priority-  , cQueue :: OrdPSQ k Priority v-  }--emptyCache :: Int -> Cache k v-emptyCache lim = Cache lim 0 0 PSQ.empty--insert :: Ord k => k -> v -> Cache k v -> Cache k v-insert k v c@Cache{..}-  | cSize == cLimit = let q = PSQ.insert k cTick v $ PSQ.deleteMin cQueue-                      in c { cTick = cTick + 1, cQueue = q }-  | otherwise       = let q = PSQ.insert k cTick v cQueue-                      in c { cTick = cTick + 1, cQueue = q, cSize = cSize + 1 }--lookup :: Ord k => k -> Cache k v -> Maybe v-lookup k Cache{..} = snd <$> PSQ.lookup k cQueue
− Network/HTTP2/Arch/Config.hs 
@@ -1,47 +0,0 @@-module Network.HTTP2.Arch.Config where--import Data.ByteString (ByteString)-import Data.IORef-import Foreign.Marshal.Alloc (mallocBytes, free)-import Network.Socket-import Network.Socket.ByteString (sendAll)-import qualified System.TimeManager as T--import Network.HPACK-import Network.HTTP2.Arch.File-import Network.HTTP2.Arch.ReadN---- | HTTP/2 configuration.-data Config = Config {-    -- confWriteBuffer is used only by frameSender.-    -- This MUST be freed after frameSender is terminated.-      confWriteBuffer :: Buffer-    , confBufferSize  :: BufferSize-    , confSendAll     :: ByteString -> IO ()-    , confReadN       :: Int -> IO ByteString-    , confPositionReadMaker :: PositionReadMaker-    , confTimeoutManager :: T.Manager-    }---- | Making simple configuration whose IO is not efficient.---   A write buffer is allocated internally.-allocSimpleConfig :: Socket -> BufferSize -> IO Config-allocSimpleConfig s bufsiz = do-    buf <- mallocBytes bufsiz-    ref <- newIORef Nothing-    timmgr <- T.initialize $ 30 * 1000000-    let config = Config {-            confWriteBuffer = buf-          , confBufferSize = bufsiz-          , confSendAll = sendAll s-          , confReadN = defaultReadN s ref-          , confPositionReadMaker = defaultPositionReadMaker-          , confTimeoutManager = timmgr-          }-    return config---- | Deallocating the resource of the simple configuration.-freeSimpleConfig :: Config -> IO ()-freeSimpleConfig conf = do-    free $ confWriteBuffer conf-    T.killManager $ confTimeoutManager conf
− Network/HTTP2/Arch/Context.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Network.HTTP2.Arch.Context where--import Control.Concurrent.STM-import Data.IORef-import Network.HTTP.Types (Method)--import Imports hiding (insert)-import Network.HPACK-import Network.HTTP2.Arch.Cache (Cache, emptyCache)-import qualified Network.HTTP2.Arch.Cache as Cache-import Network.HTTP2.Arch.Rate-import Network.HTTP2.Arch.Stream-import Network.HTTP2.Arch.Types-import Network.HTTP2.Frame--data Role = Client | Server deriving (Eq,Show)--------------------------------------------------------------------data RoleInfo = ServerInfo {-                    inputQ :: TQueue (Input Stream)-                  }-              | ClientInfo {-                    scheme    :: ByteString-                  , authority :: ByteString-                  , cache     :: IORef (Cache (Method,ByteString) Stream)-                  }--newServerInfo :: IO RoleInfo-newServerInfo = ServerInfo <$> newTQueueIO--newClientInfo :: ByteString -> ByteString -> Int -> IO RoleInfo-newClientInfo scm auth lim =  ClientInfo scm auth <$> newIORef (emptyCache lim)--insertCache :: Method -> ByteString -> Stream -> RoleInfo -> IO ()-insertCache m path v (ClientInfo _ _ ref) = atomicModifyIORef' ref $ \c ->-  (Cache.insert (m,path) v c, ())-insertCache _ _ _ _ = error "insertCache"--lookupCache :: Method -> ByteString -> RoleInfo -> IO (Maybe Stream)-lookupCache m path (ClientInfo _ _ ref) = Cache.lookup (m,path) <$> readIORef ref-lookupCache _ _ _ = error "lookupCache"---------------------------------------------------------------------- | The context for HTTP/2 connection.-data Context = Context {-    role               :: Role-  , roleInfo           :: RoleInfo-  -- HTTP/2 settings received from a browser-  , http2settings      :: IORef Settings-  , firstSettings      :: IORef Bool-  , streamTable        :: StreamTable-  , concurrency        :: IORef Int-  -- | RFC 7540 says "Other frames (from any stream) MUST NOT-  --   occur between the HEADERS frame and any CONTINUATION-  --   frames that might follow". This field is used to implement-  --   this requirement.-  , continued          :: IORef (Maybe StreamId)-  , myStreamId         :: IORef StreamId-  , peerStreamId       :: IORef StreamId-  , outputQ            :: TQueue (Output Stream)-  , controlQ           :: TQueue Control-  , encodeDynamicTable :: DynamicTable-  , decodeDynamicTable :: DynamicTable-  -- the connection window for data from a server to a browser.-  , connectionWindow   :: TVar WindowSize-  , pingRate           :: Rate-  , settingsRate       :: Rate-  , emptyFrameRate     :: Rate-  }--------------------------------------------------------------------newContext :: RoleInfo -> IO Context-newContext rinfo =-    Context rl rinfo-               <$> newIORef defaultSettings-               <*> newIORef False-               <*> newStreamTable-               <*> newIORef 0-               <*> newIORef Nothing-               <*> newIORef sid0-               <*> newIORef 0-               <*> newTQueueIO-               <*> newTQueueIO-               <*> newDynamicTableForEncoding defaultDynamicTableSize-               <*> newDynamicTableForDecoding defaultDynamicTableSize 4096-               <*> newTVarIO defaultInitialWindowSize-               <*> newRate-               <*> newRate-               <*> newRate-   where-     rl = case rinfo of-       ClientInfo{} -> Client-       _            -> Server-     sid0 | rl == Client = 1-          | otherwise    = 2--------------------------------------------------------------------isClient :: Context -> Bool-isClient ctx = role ctx == Client--isServer :: Context -> Bool-isServer ctx = role ctx == Server--------------------------------------------------------------------getMyNewStreamId :: Context -> IO StreamId-getMyNewStreamId ctx = atomicModifyIORef' (myStreamId ctx) inc2-  where-    inc2 n = let n' = n + 2 in (n', n)--getPeerStreamID :: Context -> IO StreamId-getPeerStreamID ctx = readIORef $ peerStreamId ctx--setPeerStreamID :: Context -> StreamId -> IO ()-setPeerStreamID ctx sid =  writeIORef (peerStreamId ctx) sid--------------------------------------------------------------------{-# INLINE setStreamState #-}-setStreamState :: Context -> Stream -> StreamState -> IO ()-setStreamState _ Stream{streamState} val = writeIORef streamState val--opened :: Context -> Stream -> IO ()-opened ctx@Context{concurrency} strm = do-    atomicModifyIORef' concurrency (\x -> (x+1,()))-    setStreamState ctx strm (Open JustOpened)--halfClosedRemote :: Context -> Stream -> IO ()-halfClosedRemote ctx stream@Stream{streamState} = do-    closingCode <- atomicModifyIORef streamState closeHalf-    traverse_ (closed ctx stream) closingCode-  where-    closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)-    closeHalf x@(Closed _)         = (x, Nothing)-    closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)-    closeHalf _                    = (HalfClosedRemote, Nothing)--halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()-halfClosedLocal ctx stream@Stream{streamState} cc = do-    shouldFinalize <- atomicModifyIORef streamState closeHalf-    when shouldFinalize $-        closed ctx stream cc-  where-    closeHalf :: StreamState -> (StreamState, Bool)-    closeHalf x@(Closed _)     = (x, False)-    closeHalf HalfClosedRemote = (Closed cc, True)-    closeHalf _                = (HalfClosedLocal cc, False)--closed :: Context -> Stream -> ClosedCode -> IO ()-closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do-    remove streamTable streamNumber-    -- TODO: prevent double-counting-    atomicModifyIORef' concurrency (\x -> (x-1,()))-    setStreamState ctx strm (Closed cc) -- anyway--openStream :: Context -> StreamId -> FrameTypeId -> IO Stream-openStream ctx@Context{streamTable, http2settings} sid ftyp = do-    ws <- initialWindowSize <$> readIORef http2settings-    newstrm <- newStream sid $ fromIntegral ws-    when (ftyp == FrameHeaders || ftyp == FramePushPromise) $ opened ctx newstrm-    insert streamTable sid newstrm-    return newstrm
− Network/HTTP2/Arch/EncodeFrame.hs 
@@ -1,34 +0,0 @@-module Network.HTTP2.Arch.EncodeFrame where--import Network.HTTP2.Frame--import Imports--------------------------------------------------------------------goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString-goawayFrame sid etype debugmsg = encodeFrame einfo frame-  where-    einfo = encodeInfo id 0-    frame = GoAwayFrame sid etype debugmsg--resetFrame :: ErrorCodeId -> StreamId -> ByteString-resetFrame etype sid = encodeFrame einfo frame-  where-    einfo = encodeInfo id sid-    frame = RSTStreamFrame etype--settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString-settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist-  where-    einfo = encodeInfo func 0--pingFrame :: ByteString -> ByteString-pingFrame bs = encodeFrame einfo $ PingFrame bs-  where-    einfo = encodeInfo setAck 0--windowUpdateFrame :: StreamId -> WindowSize -> ByteString-windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz-  where-    einfo = encodeInfo id sid
− Network/HTTP2/Arch/File.hs 
@@ -1,36 +0,0 @@-module Network.HTTP2.Arch.File where--import System.IO--import Imports-import Network.HPACK---- | Offset for file.-type FileOffset = Int64--- | How many bytes to read-type ByteCount = Int64---- | Position read for files.-type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount---- | Manipulating a file resource.-data Sentinel =-    -- | Closing a file resource. Its refresher is automatiaclly generated by-    --   the internal timer.-    Closer (IO ())-    -- | Refreshing a file resource while reading.-    --   Closing the file must be done by its own timer or something.-  | Refresher (IO ())---- | Making a position read and its closer.-type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel)--- | Position read based on 'Handle'.-defaultPositionReadMaker :: PositionReadMaker-defaultPositionReadMaker file = do-    hdl <- openBinaryFile file ReadMode-    return (pread hdl, Closer $ hClose hdl)-  where-    pread :: Handle -> PositionRead-    pread hdl off bytes buf = do-        hSeek hdl AbsoluteSeek $ fromIntegral off-        fromIntegral <$> hGetBufSome hdl buf (fromIntegral bytes)
− Network/HTTP2/Arch/HPACK.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.HPACK (-    hpackEncodeHeader-  , hpackEncodeHeaderLoop-  , hpackDecodeHeader-  , hpackDecodeTrailer-  , just-  , fixHeaders-  ) where--import qualified Control.Exception as E-import Network.ByteOrder-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Arch.Context-import Network.HTTP2.Frame---- $setup--- >>> :set -XOverloadedStrings--------------------------------------------------------------------fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders-fixHeaders hdr = deleteUnnecessaryHeaders hdr--deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders-deleteUnnecessaryHeaders hdr = filter del hdr-  where-    del (k,_) = k `notElem` headersToBeRemoved--headersToBeRemoved :: [H.HeaderName]-headersToBeRemoved = [ H.hConnection-                     , "Transfer-Encoding"-                     -- Keep-Alive-                     -- Proxy-Connection-                     -- Upgrade-                     ]--------------------------------------------------------------------strategy :: EncodeStrategy-strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }---- Set-Cookie: contains only one cookie value.--- So, we don't need to split it.-hpackEncodeHeader :: Context -> Buffer -> BufferSize-                  -> TokenHeaderList-                  -> IO (TokenHeaderList, Int)-hpackEncodeHeader Context{..} buf siz ths =-    encodeTokenHeader buf siz strategy True encodeDynamicTable ths--hpackEncodeHeaderLoop :: Context -> Buffer -> BufferSize-                      -> TokenHeaderList-                      -> IO (TokenHeaderList, Int)-hpackEncodeHeaderLoop Context{..} buf siz hs =-    encodeTokenHeader buf siz strategy False encodeDynamicTable hs--------------------------------------------------------------------hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeHeader hdrblk ctx = do-    tbl@(_,vt) <- hpackDecodeTrailer hdrblk ctx-    if isClient ctx || checkRequestHeader vt then-        return tbl-      else-        E.throwIO $ ConnectionError ProtocolError "the header key is illegal"--hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeTrailer hdrblk Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl-  where-    handl IllegalHeaderName =-        E.throwIO $ ConnectionError ProtocolError "the header key is illegal"-    handl _ =-        E.throwIO $ ConnectionError CompressionError "cannot decompress the header"--{-# INLINE checkRequestHeader #-}-checkRequestHeader :: ValueTable -> Bool-checkRequestHeader reqvt-  | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme-  | isJust mStatus              = False-  | isNothing mMethod           = False-  | isNothing mScheme           = False-  | isNothing mPath             = False-  | mPath       == Just ""      = False-  | isJust mConnection          = False-  | just mTE (/= "trailers")    = False-  | otherwise                   = True-  where-    mStatus     = getHeaderValue tokenStatus reqvt-    mScheme     = getHeaderValue tokenScheme reqvt-    mPath       = getHeaderValue tokenPath reqvt-    mMethod     = getHeaderValue tokenMethod reqvt-    mConnection = getHeaderValue tokenConnection reqvt-    mTE         = getHeaderValue tokenTE reqvt--{-# INLINE just #-}-just :: Maybe a -> (a -> Bool) -> Bool-just Nothing  _    = False-just (Just x) p-  | p x            = True-  | otherwise      = False
− Network/HTTP2/Arch/Manager.hs 
@@ -1,118 +0,0 @@--- | A thread pool manager.---   The manager has responsibility to spawn and kill---   worker threads.-module Network.HTTP2.Arch.Manager (-    Manager-  , Action-  , start-  , setAction-  , stop-  , spawnAction-  , addMyId-  , deleteMyId-  , timeoutKillThread-  , timeoutClose-  ) where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import Data.Foldable-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import qualified System.TimeManager as T--import Imports---------------------------------------------------------------------- | Action to be spawned by the manager.-type Action = IO ()--noAction :: Action-noAction = return ()--data Command = Stop | Spawn | Add ThreadId | Delete ThreadId---- | Manager to manage the thread pool and the timer.-data Manager = Manager (TQueue Command) (IORef Action) T.Manager---- | Starting a thread pool manager.---   Its action is initially set to 'return ()' and should be set---   by 'setAction'. This allows that the action can include---   the manager itself.-start :: T.Manager -> IO Manager-start timmgr = do-    q <- newTQueueIO-    ref <- newIORef noAction-    void $ forkIO $ go q Set.empty ref-    return $ Manager q ref timmgr-  where-    go q tset0 ref = do-        x <- atomically $ readTQueue q-        case x of-            Stop          -> kill tset0-            Spawn         -> next tset0-            Add    newtid -> let tset = add newtid tset0-                             in go q tset ref-            Delete oldtid -> let tset = del oldtid tset0-                             in go q tset ref-      where-        next tset = do-            action <- readIORef ref-            newtid <- forkIO action-            let tset' = add newtid tset-            go q tset' ref---- | Setting the action to be spawned.-setAction :: Manager -> Action -> IO ()-setAction (Manager _ ref _) action = writeIORef ref action---- | Stopping the manager.-stop :: Manager -> IO ()-stop (Manager q _ _) = atomically $ writeTQueue q Stop---- | Spawning the action.-spawnAction :: Manager -> IO ()-spawnAction (Manager q _ _) = atomically $ writeTQueue q Spawn---- | Adding my thread id to the kill-thread list on stopping.-addMyId :: Manager -> IO ()-addMyId (Manager q _ _) = do-    tid <- myThreadId-    atomically $ writeTQueue q $ Add tid---- | Deleting my thread id from the kill-thread list on stopping.-deleteMyId :: Manager -> IO ()-deleteMyId (Manager q _ _) = do-    tid <- myThreadId-    atomically $ writeTQueue q $ Delete tid--------------------------------------------------------------------add :: ThreadId -> Set ThreadId -> Set ThreadId-add tid set = set'-  where-    set' = Set.insert tid set--del :: ThreadId -> Set ThreadId -> Set ThreadId-del tid set = set'-  where-    set' = Set.delete tid set--kill :: Set ThreadId -> IO ()-kill set = traverse_ killThread set---- | Killing the IO action of the second argument on timeout.-timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()-timeoutKillThread (Manager _ _ tmgr) action = E.bracket register T.cancel action-  where-    register = T.registerKillThread tmgr noAction---- | Registering closer for a resource and---   returning a timer refresher.-timeoutClose :: Manager -> IO () -> IO (IO ())-timeoutClose (Manager _ _ tmgr) closer = do-    th <- T.register tmgr closer-    return $ T.tickle th
− Network/HTTP2/Arch/Queue.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Queue where--import Control.Concurrent (forkIO)-import Control.Concurrent.STM-import Control.Exception (bracket)--import Imports-import Network.HTTP2.Arch.Manager-import Network.HTTP2.Arch.Types--{-# INLINE forkAndEnqueueWhenReady #-}-forkAndEnqueueWhenReady :: IO () -> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()-forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->-    void . forkIO $ do-        wait-        enqueueOutput outQ out-  where-    setup = addMyId mgr-    teardown _ = deleteMyId mgr--{-# INLINE enqueueOutput #-}-enqueueOutput :: TQueue (Output Stream) -> Output Stream -> IO ()-enqueueOutput outQ out = atomically $ writeTQueue outQ out--{-# INLINE enqueueControl #-}-enqueueControl :: TQueue Control -> Control -> IO ()-enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl------------------------------------------------------------------
− Network/HTTP2/Arch/Rate.hs 
@@ -1,30 +0,0 @@-module Network.HTTP2.Arch.Rate (-    Rate-  , newRate-  , getRate-  ) where--import Data.IORef-import Data.UnixTime--newtype Rate = Rate (IORef Counter)--data Counter = Counter Int UnixTime--newRate :: IO Rate-newRate = do-    cntr <- Counter 0 <$> getUnixTime-    Rate <$> newIORef cntr--getRate :: Rate -> IO Int-getRate (Rate ref) = do-    Counter n beg <- readIORef ref-    cur <- getUnixTime-    if (cur `diffUnixTime` beg) > 1 then do-        let n' = 1-        writeIORef ref $ Counter n' cur-        return n'-      else do-        let n' = n + 1-        writeIORef ref $ Counter n' beg-        return n'
− Network/HTTP2/Arch/ReadN.hs 
@@ -1,41 +0,0 @@-module Network.HTTP2.Arch.ReadN where--import qualified Data.ByteString as B-import Data.IORef-import Network.Socket-import qualified Network.Socket.ByteString as N---- | Naive implementation for readN.-defaultReadN :: Socket -> IORef (Maybe B.ByteString) -> Int -> IO B.ByteString-defaultReadN _ _   0 = return B.empty-defaultReadN s ref n = do-    mbs <- readIORef ref-    writeIORef ref Nothing-    case mbs of-      Nothing -> do-          bs <- N.recv s n-          if B.null bs then-              return B.empty-          else if B.length bs == n then-              return bs-            else-              loop bs-      Just bs-        | B.length bs == n -> return bs-        | B.length bs > n  -> do-              let (bs0, bs1) = B.splitAt n bs-              writeIORef ref (Just bs1)-              return bs0-        | otherwise        -> loop bs-  where-    loop bs = do-        let n' = n - B.length bs-        bs1 <- N.recv s n'-        if B.null bs1 then-            return B.empty-          else do-            let bs2 = bs `B.append` bs1-            if B.length bs2 == n then-                return bs2-              else-                loop bs2
− Network/HTTP2/Arch/Receiver.hs 
@@ -1,505 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Receiver (-    frameReceiver-  , maxConcurrency-  , initialFrame-  ) where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import Data.IORef--import Imports hiding (delete, insert)-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Arch.Context-import Network.HTTP2.Arch.EncodeFrame-import Network.HTTP2.Arch.HPACK-import Network.HTTP2.Arch.Queue-import Network.HTTP2.Arch.Rate-import Network.HTTP2.Arch.Stream-import Network.HTTP2.Arch.Types-import Network.HTTP2.Frame--------------------------------------------------------------------maxConcurrency :: Int-maxConcurrency = recommendedConcurrency--continuationLimit :: Int-continuationLimit = 10--headerFragmentLimit :: Int-headerFragmentLimit = 51200 -- 50K--pingRateLimit :: Int-pingRateLimit = 4--settingsRateLimit :: Int-settingsRateLimit = 4--emptyFrameRateLimit :: Int-emptyFrameRateLimit = 4--------------------------------------------------------------------initialFrame :: ByteString-initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]--------------------------------------------------------------------type RecvN = Int -> IO ByteString--frameReceiver :: Context -> RecvN -> IO ()-frameReceiver ctx@Context{..} recvN = loop 0 `E.catch` sendGoaway-  where-    loop :: Int -> IO ()-    loop n-      | n == 6 = do-          yield-          loop 0-      | otherwise = do-        hd <- recvN frameHeaderLength-        if BS.null hd then-            enqueueControl controlQ CFinish-          else do-            cont <- processFrame ctx recvN $ decodeFrameHeader hd-            when cont $ loop (n + 1)--    sendGoaway e-      | Just (ConnectionError err msg) <- E.fromException e = do-          psid <- getPeerStreamID ctx-          let frame = goawayFrame psid err msg-          enqueueControl controlQ $ CGoaway frame-      | otherwise = return ()--------------------------------------------------------------------processFrame :: Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool-processFrame ctx _recvN (fid, FrameHeader{streamId})-  | isServer ctx &&-    isServerInitiated streamId &&-    (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =-    E.throwIO $ ConnectionError ProtocolError "stream id should be odd"-processFrame Context{..} recvN (FrameUnknown _, FrameHeader{payloadLength}) = do-    mx <- readIORef continued-    case mx of-        Nothing -> do-            -- ignoring unknown frame-            void $ recvN payloadLength-            return True-        Just _  -> E.throwIO $ ConnectionError ProtocolError "unknown frame"-processFrame ctx recvN (FramePushPromise, header@FrameHeader{payloadLength})-  | isServer ctx = E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"-  | otherwise = do-      pl <- recvN payloadLength-      PushPromiseFrame sid frag <- guardIt $ decodePushPromiseFrame header pl-      unless (isServerInitiated sid) $-          E.throwIO $ ConnectionError ProtocolError "wrong sid for push promise"-      when (frag == "") $-          E.throwIO $ ConnectionError ProtocolError "wrong header fragment for push promise"-      (_,vt) <- hpackDecodeHeader frag ctx-      let ClientInfo{..} = roleInfo ctx-      when (getHeaderValue tokenAuthority vt == Just authority-         && getHeaderValue tokenScheme    vt == Just scheme) $ do-          let mmethod = getHeaderValue tokenMethod vt-              mpath   = getHeaderValue tokenPath   vt-          case (mmethod, mpath) of-            (Just method, Just path) -> do-                strm <- openStream ctx sid FramePushPromise-                insertCache method path strm $ roleInfo ctx-            _ -> return ()-      return True-processFrame ctx@Context{..} recvN typhdr@(ftyp, header@FrameHeader{payloadLength}) = do-    settings <- readIORef http2settings-    case checkFrameHeader settings typhdr of-      Left h2err -> case h2err of-          StreamError err sid -> do-              resetStream err sid-              void $ recvN payloadLength-              return True-          connErr -> E.throwIO connErr-      Right _ -> do-          ex <- E.try $ controlOrStream ctx recvN ftyp header-          case ex of-              Left (StreamError err sid) -> do-                  resetStream err sid-                  return True-              Left connErr -> E.throw connErr-              Right cont -> return cont-  where-    resetStream err sid = do-        let frame = resetFrame err sid-        enqueueControl controlQ $ CFrame frame--------------------------------------------------------------------controlOrStream :: Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool-controlOrStream ctx@Context{..} recvN ftyp header@FrameHeader{streamId, payloadLength}-  | isControl streamId = do-      pl <- recvN payloadLength-      control ftyp header pl ctx-  | otherwise = do-      checkContinued-      mstrm <- getStream ctx ftyp streamId-      pl <- recvN payloadLength-      case mstrm of-        Just strm -> do-            state0 <- readStreamState strm-            state <- stream ftyp header pl ctx state0 strm-            resetContinued-            set <- processState state ctx strm streamId-            when set setContinued-        Nothing-          | ftyp == FramePriority -> do-                -- for h2spec only-                PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl-                checkPriority newpri streamId-          | otherwise -> return ()-      return True-  where-    setContinued   = writeIORef continued $ Just streamId-    resetContinued = writeIORef continued Nothing-    checkContinued = do-        mx <- readIORef continued-        case mx of-            Nothing  -> return ()-            Just sid-              | sid == streamId && ftyp == FrameContinuation -> return ()-              | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"--------------------------------------------------------------------processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool-processState (Open (NoBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do-    let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)-    when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamError ProtocolError streamId-    halfClosedRemote ctx strm-    tlr <- newIORef Nothing-    let inpObj = InpObj tbl (Just 0) (return "") tlr-    if isServer ctx then-        atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj-      else-        putMVar streamInput inpObj-    return False-processState (Open (HasBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do-    let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)-    bodyLength <- newIORef 0-    tlr <- newIORef Nothing-    q <- newTQueueIO-    setStreamState ctx strm $ Open (Body q mcl bodyLength tlr)-    bodySource <- mkSource (updateWindow controlQ streamId) q-    let inpObj = InpObj tbl mcl (readSource bodySource) tlr-    if isServer ctx then-        atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj-      else-        putMVar streamInput inpObj-    return False-processState s@(Open Continued{}) ctx strm _streamId = do-    setStreamState ctx strm s-    return True-processState HalfClosedRemote ctx strm _streamId = do-    halfClosedRemote ctx strm-    return False-processState s ctx strm _streamId = do-    -- Idle, Open Body, Closed-    setStreamState ctx strm s-    return False--------------------------------------------------------------------getStream :: Context -> FrameTypeId -> StreamId -> IO (Maybe Stream)-getStream ctx@Context{..} ftyp streamId =-    search streamTable streamId >>= getStream' ctx ftyp streamId--getStream' :: Context -> FrameTypeId -> StreamId -> Maybe Stream -> IO (Maybe Stream)-getStream' ctx ftyp _streamId js@(Just strm0) = do-    when (ftyp == FrameHeaders) $ do-        st <- readStreamState strm0-        when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"-        -- Priority made an idle stream-        when (isIdle st) $ opened ctx strm0-    return js-getStream' ctx@Context{..} ftyp streamId Nothing-  | isServerInitiated streamId = return Nothing-  | isServer ctx = do-        csid <- getPeerStreamID ctx-        if streamId <= csid then -- consider the stream closed-          if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then-              return Nothing -- will be ignored-            else-              E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"-          else do -- consider the stream idle-            when (ftyp `notElem` [FrameHeaders,FramePriority]) $-                E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)-            when (ftyp == FrameHeaders) $ do-                setPeerStreamID ctx streamId-                cnt <- readIORef concurrency-                -- Checking the limitation of concurrency-                when (cnt >= maxConcurrency) $ E.throwIO $ StreamError RefusedStream streamId-            Just <$> openStream ctx streamId ftyp-  | otherwise = undefined -- never reach--------------------------------------------------------------------control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool-control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable, settingsRate} = do-    SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs-    traverse_ E.throwIO $ checkSettingsList alist-    -- HTTP/2 Setting from a browser-    if testAck flags then-        return True-      else do-        -- Settings Flood - CVE-2019-9515-        rate <- getRate settingsRate-        if rate > settingsRateLimit then-            E.throwIO $ ConnectionError ProtocolError "too many settings"-          else do-            oldws <- initialWindowSize <$> readIORef http2settings-            modifyIORef' http2settings $ \old -> updateSettings old alist-            newws <- initialWindowSize <$> readIORef http2settings-            let diff = newws - oldws-            when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable-            let frame = settingsFrame setAck []-            sent <- readIORef firstSettings-            let setframe-                  | sent      = CSettings               frame alist-                  | otherwise = CSettings0 initialFrame frame alist-            unless sent $ writeIORef firstSettings True-            enqueueControl controlQ setframe-            return True--control FramePing FrameHeader{flags} bs Context{controlQ,pingRate} =-    if testAck flags then-        return True-      else do-        -- Ping Flood - CVE-2019-9512-        rate <- getRate pingRate-        if rate > pingRateLimit then-            E.throwIO $ ConnectionError ProtocolError "too many ping"-          else do-            let frame = pingFrame bs-            enqueueControl controlQ $ CFrame frame-            return True--control FrameGoAway _ _ Context{controlQ} = do-    enqueueControl controlQ CFinish-    return False--control FrameWindowUpdate header bs Context{connectionWindow} = do-    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs-    w <- atomically $ do-      w0 <- readTVar connectionWindow-      let w1 = w0 + n-      writeTVar connectionWindow w1-      return w1-    when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"-    return True--control _ _ _ _ =-    -- must not reach here-    return False--------------------------------------------------------------------{-# INLINE guardIt #-}-guardIt :: Either HTTP2Error a -> IO a-guardIt x = case x of-    Left err    -> E.throwIO err-    Right frame -> return frame---{-# INLINE checkPriority #-}-checkPriority :: Priority -> StreamId -> IO ()-checkPriority p me-  | dep == me = E.throwIO $ StreamError ProtocolError me-  | otherwise = return ()-  where-    dep = streamDependency p--stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState-stream FrameHeaders header@FrameHeader{flags} bs ctx s@(Open JustOpened) Stream{streamNumber} = do-    HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs-    let endOfStream = testEndStream flags-        endOfHeader = testEndHeader flags-    if frag == "" && not endOfStream && not endOfHeader then do-        -- Empty Frame Flooding - CVE-2019-9518-        rate <- getRate $ emptyFrameRate ctx-        if rate > emptyFrameRateLimit then-            E.throwIO $ ConnectionError ProtocolError "too many empty headers"-          else-            return s-      else do-        case mp of-          Nothing -> return ()-          Just p  -> checkPriority p streamNumber-        if endOfHeader then do-            tbl <- hpackDecodeHeader frag ctx-            return $ if endOfStream then-                        Open (NoBody tbl)-                       else-                        Open (HasBody tbl)-          else do-            let siz = BS.length frag-            return $ Open $ Continued [frag] siz 1 endOfStream--stream FrameHeaders header@FrameHeader{flags} bs ctx (Open (Body q _ _ tlr)) _ = do-    HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs-    let endOfStream = testEndStream flags-    -- checking frag == "" is not necessary-    if endOfStream then do-        tbl <- hpackDecodeTrailer frag ctx-        writeIORef tlr (Just tbl)-        atomically $ writeTQueue q ""-        return HalfClosedRemote-      else-        -- we don't support continuation here.-        E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"---- ignore data-frame except for flow-control when we're done locally-stream FrameData-       FrameHeader{flags,payloadLength}-       _bs-       Context{controlQ} s@(HalfClosedLocal _)-       _ = do-    when (payloadLength /= 0) $ do-        let frame = windowUpdateFrame 0 payloadLength-        enqueueControl controlQ $ CFrame frame-    let endOfStream = testEndStream flags-    if endOfStream then do-        return HalfClosedRemote-      else-        return s--stream FrameData-       header@FrameHeader{flags,payloadLength,streamId}-       bs-       Context{emptyFrameRate} s@(Open (Body q mcl bodyLength _))-       _ = do-    DataFrame body <- guardIt $ decodeDataFrame header bs-    len0 <- readIORef bodyLength-    let len = len0 + payloadLength-        endOfStream = testEndStream flags-    -- Empty Frame Flooding - CVE-2019-9518-    if body == "" then-        unless endOfStream $ do-            rate <- getRate emptyFrameRate-            when (rate > emptyFrameRateLimit) $ do-                E.throwIO $ ConnectionError ProtocolError "too many empty data"-      else do-        writeIORef bodyLength len-        atomically $ writeTQueue q body-    if endOfStream then do-        case mcl of-            Nothing -> return ()-            Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId-        -- no trailers-        atomically $ writeTQueue q ""-        return HalfClosedRemote-      else-        return s--stream FrameContinuation FrameHeader{flags} frag ctx s@(Open (Continued rfrags siz n endOfStream)) _ = do-    let endOfHeader = testEndHeader flags-    if frag == "" && not endOfHeader then do-        -- Empty Frame Flooding - CVE-2019-9518-        rate <- getRate $ emptyFrameRate ctx-        if rate > emptyFrameRateLimit then-            E.throwIO $ ConnectionError ProtocolError "too many empty continuation"-          else-            return s-      else do-        let rfrags' = frag : rfrags-            siz' = siz + BS.length frag-            n' = n + 1-        when (siz' > headerFragmentLimit) $-          E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"-        when (n' > continuationLimit) $-          E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"-        if endOfHeader then do-            let hdrblk = BS.concat $ reverse rfrags'-            tbl <- hpackDecodeHeader hdrblk ctx-            return $ if endOfStream then-                        Open (NoBody tbl)-                       else-                        Open (HasBody tbl)-          else-            return $ Open $ Continued rfrags' siz' n' endOfStream--stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do-    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs-    w <- atomically $ do-      w0 <- readTVar streamWindow-      let w1 = w0 + n-      writeTVar streamWindow w1-      return w1-    when (isWindowOverflow w) $ E.throwIO $ StreamError FlowControlError streamId-    return s--stream FrameRSTStream header bs ctx _ strm = do-    RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs-    let cc = Reset e-    closed ctx strm cc-    return $ Closed cc -- will be written to streamState again--stream FramePriority header bs _ s Stream{streamNumber} = do-    -- ignore-    -- Resource Loop - CVE-2019-9513-    PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs-    checkPriority newpri streamNumber-    return s---- this ordering is important-stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"-stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"--- Ignore frames to streams we have just reset, per section 5.1.-stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId-stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId---------------------------------------------------------------------- | Type for input streaming.-data Source = Source (Int -> IO ())-                     (TQueue ByteString)-                     (IORef ByteString)-                     (IORef Bool)--mkSource :: (Int -> IO ()) -> TQueue ByteString -> IO Source-mkSource update q = Source update q <$> newIORef "" <*> newIORef False--updateWindow :: TQueue Control -> StreamId -> Int -> IO ()-updateWindow _        _   0   = return ()-updateWindow controlQ sid len = enqueueControl controlQ $ CFrame frame-  where-    frame1 = windowUpdateFrame 0 len-    frame2 = windowUpdateFrame sid len-    frame = frame1 `BS.append` frame2--readSource :: Source -> IO ByteString-readSource (Source update q refBS refEOF) = do-    eof <- readIORef refEOF-    if eof then-        return ""-      else do-        bs <- readBS-        let len = BS.length bs-        update len-        return bs-  where-    readBS = do-        bs0 <- readIORef refBS-        if bs0 == "" then do-            bs <- atomically $ readTQueue q-            when (bs == "") $ writeIORef refEOF True-            return bs-          else do-            writeIORef refBS ""-            return bs0
− Network/HTTP2/Arch/Sender.hs 
@@ -1,454 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Sender (-    frameSender-  , fillBuilderBodyGetNext-  , fillFileBodyGetNext-  , fillStreamBodyGetNext-  , runTrailersMaker-  ) where--import Control.Concurrent.STM-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder.Extra as B-import Foreign.Ptr (plusPtr)-import Network.ByteOrder--import Imports-import Network.HPACK (setLimitForEncoding, toHeaderTable)-import Network.HTTP2.Arch.Config-import Network.HTTP2.Arch.Context-import Network.HTTP2.Arch.EncodeFrame-import Network.HTTP2.Arch.File-import Network.HTTP2.Arch.HPACK-import Network.HTTP2.Arch.Manager hiding (start)-import Network.HTTP2.Arch.Queue-import Network.HTTP2.Arch.Stream-import Network.HTTP2.Arch.Types-import Network.HTTP2.Frame--------------------------------------------------------------------data Leftover = LZero-              | LOne B.BufferWriter-              | LTwo ByteString B.BufferWriter--------------------------------------------------------------------{-# INLINE getStreamWindowSize #-}-getStreamWindowSize :: Stream -> IO WindowSize-getStreamWindowSize Stream{streamWindow} = readTVarIO streamWindow--{-# INLINE waitStreamWindowSize #-}-waitStreamWindowSize :: Stream -> IO ()-waitStreamWindowSize Stream{streamWindow} = atomically $ do-    w <- readTVar streamWindow-    check (w > 0)--{-# INLINE waitStreaming #-}-waitStreaming :: TBQueue a -> IO ()-waitStreaming tbq = atomically $ do-    isEmpty <- isEmptyTBQueue tbq-    check (not isEmpty)--data Switch = C Control-            | O (Output Stream)-            | Flush--frameSender :: Context -> Config -> Manager -> IO ()-frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}-            Config{..}-            mgr = loop 0 `E.catch` ignore-  where-    dequeue off = do-        isEmpty <- isEmptyTQueue controlQ-        if isEmpty then do-            w <- readTVar connectionWindow-            check (w > 0)-            emp <- isEmptyTQueue outputQ-            if emp then-                if off /= 0 then return Flush else retry-              else-                O <$> readTQueue outputQ-          else-            C <$> readTQueue controlQ--    hardLimit = confBufferSize - 512--    loop off = do-        x <- atomically $ dequeue off-        case x of-            C ctl -> do-                when (off /= 0) $ flushN off-                off' <- control ctl off-                when (off' >= 0) $ loop off'-            O out -> do-                off' <- outputOrEnqueueAgain out off-                case off' of-                    0                    -> loop 0-                    _ | off' > hardLimit -> flushN off' >> loop 0-                      | otherwise        -> loop off'-            Flush -> flushN off >> loop 0--    control CFinish         _ = return (-1)-    control (CGoaway frame) _ = confSendAll frame >> return (-1)-    control (CFrame frame)  _ = confSendAll frame >> return 0-    control (CSettings frame alist) _ = do-        confSendAll frame-        setLimit alist-        return 0-    control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case-        let buf = confWriteBuffer `plusPtr` off-            off' = off + BS.length frame1 + BS.length frame2-        buf' <- copy buf frame1-        void $ copy buf' frame2-        setLimit alist-        return off'--    {-# INLINE setLimit #-}-    setLimit alist = case lookup SettingsHeaderTableSize alist of-        Nothing  -> return ()-        Just siz -> setLimitForEncoding siz encodeDynamicTable--    output out@(Output strm OutObj{} (ONext curr tlrmkr) _ sentinel) off0 lim = do-        -- Data frame payload-        let payloadOff = off0 + frameHeaderLength-            datBuf     = confWriteBuffer `plusPtr` payloadOff-            datBufSiz  = confBufferSize - payloadOff-        Next datPayloadLen mnext <- curr datBuf datBufSiz lim -- checkme-        NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen-        fillDataHeaderEnqueueNext strm off0 datPayloadLen mnext tlrmkr' sentinel out--    output out@(Output strm (OutObj hdr body tlrmkr) OObj mtbq _) off0 lim = do-        -- Header frame and Continuation frame-        let sid = streamNumber strm-            endOfStream = case body of-                OutBodyNone -> True-                _           -> False-        (ths,_) <- toHeaderTable $ fixHeaders hdr-        kvlen <- headerContinue sid ths endOfStream off0-        off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen-        case body of-            OutBodyNone -> do-                -- halfClosedLocal calls closed which removes-                -- the stream from stream table.-                when (isServer ctx) $ halfClosedLocal ctx strm Finished-                return off-            OutBodyFile (FileSpec path fileoff bytecount) -> do-                (pread, sentinel') <- confPositionReadMaker path-                refresh <- case sentinel' of-                             Closer closer       -> timeoutClose mgr closer-                             Refresher refresher -> return refresher-                let next = fillFileBodyGetNext pread fileoff bytecount refresh-                    out' = out { outputType = ONext next tlrmkr }-                output out' off lim-            OutBodyBuilder builder -> do-                let next = fillBuilderBodyGetNext builder-                    out' = out { outputType = ONext next tlrmkr }-                output out' off lim-            OutBodyStreaming _ -> do-                let tbq = fromJust mtbq-                    takeQ = atomically $ tryReadTBQueue tbq-                    next = fillStreamBodyGetNext takeQ-                    out' = out { outputType = ONext next tlrmkr }-                output out' off lim--    output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do-        -- Creating a push promise header-        -- Frame id should be associated stream id from the client.-        let sid = streamNumber strm-        len <- pushPromise pid sid ths off0-        off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len-        output out{outputType=OObj} off lim--    output _ _ _ = undefined -- never reach--    outputOrEnqueueAgain :: Output Stream -> Int -> IO Int-    outputOrEnqueueAgain out@(Output strm _ otyp _ _) off = E.handle resetStream $ do-        state <- readStreamState strm-        if isHalfClosedLocal state then-            return off-          else case otyp of-                 OWait wait -> do-                     -- Checking if all push are done.-                     forkAndEnqueueWhenReady wait outputQ out{outputType=OObj} mgr-                     return off-                 _ -> case mtbq of-                        Just tbq -> checkStreaming tbq-                        _        -> checkStreamWindowSize-      where-        mtbq = outputStrmQ out-        checkStreaming tbq = do-            isEmpty <- atomically $ isEmptyTBQueue tbq-            if isEmpty then do-                forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr-                return off-              else-                checkStreamWindowSize-        checkStreamWindowSize = do-            sws <- getStreamWindowSize strm-            if sws == 0 then do-                forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr-                return off-              else do-                cws <- readTVarIO connectionWindow -- not 0-                let lim = min cws sws-                output out off lim-        resetStream e = do-            closed ctx strm (ResetByMe e)-            let rst = resetFrame InternalError $ streamNumber strm-            enqueueControl controlQ $ CFrame rst-            return off--    {-# INLINE flushN #-}-    -- Flush the connection buffer to the socket, where the first 'n' bytes of-    -- the buffer are filled.-    flushN :: Int -> IO ()-    flushN n = bufferIO confWriteBuffer n confSendAll--    headerContinue sid ths endOfStream off = do-        let offkv = off + frameHeaderLength-        let bufkv = confWriteBuffer `plusPtr` offkv-            limkv = confBufferSize - offkv-        (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths-        let flag0 = case hs of-                [] -> setEndHeader defaultFlags-                _  -> defaultFlags-            flag = if endOfStream then setEndStream flag0 else flag0-        let buf = confWriteBuffer `plusPtr` off-        fillFrameHeader FrameHeaders kvlen sid flag buf-        continue sid kvlen hs--    bufHeaderPayload = confWriteBuffer `plusPtr` frameHeaderLength-    headerPayloadLim = confBufferSize - frameHeaderLength--    continue _   kvlen [] = return kvlen-    continue sid kvlen ths = do-        flushN $ kvlen + frameHeaderLength-        -- Now off is 0-        (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths-        when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"-        let flag = case ths' of-                [] -> setEndHeader defaultFlags-                _  -> defaultFlags-        fillFrameHeader FrameContinuation kvlen' sid flag confWriteBuffer-        continue sid kvlen' ths'--    {-# INLINE sendHeadersIfNecessary #-}-    -- Send headers if there is not room for a 1-byte data frame, and return-    -- the offset of the next frame's first header byte.-    sendHeadersIfNecessary off-      -- True if the connection buffer has room for a 1-byte data frame.-      | off + frameHeaderLength < confBufferSize = return off-      | otherwise = do-          flushN off-          return 0--    fillDataHeaderEnqueueNext strm@Stream{streamWindow,streamNumber}-                   off datPayloadLen Nothing tlrmkr tell _ = do-        let buf  = confWriteBuffer `plusPtr` off-            off' = off + frameHeaderLength + datPayloadLen-        (mtrailers, flag) <- do-              Trailers trailers <- tlrmkr Nothing-              if null trailers then-                  return (Nothing, setEndStream defaultFlags)-                else-                  return (Just trailers, defaultFlags)-        fillFrameHeader FrameData datPayloadLen streamNumber flag buf-        off'' <- handleTrailers mtrailers off'-        void tell-        when (isServer ctx) $ halfClosedLocal ctx strm Finished-        atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)-        atomically $ modifyTVar' streamWindow (subtract datPayloadLen)-        return off''-      where-        handleTrailers Nothing off0 = return off0-        handleTrailers (Just trailers) off0 = do-            (ths,_) <- toHeaderTable trailers-            kvlen <- headerContinue streamNumber ths True off0-            sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen--    fillDataHeaderEnqueueNext _-                   off 0 (Just next) tlrmkr _ out = do-        let out' = out { outputType = ONext next tlrmkr }-        enqueueOutput outputQ out'-        return off--    fillDataHeaderEnqueueNext Stream{streamWindow,streamNumber}-                   off datPayloadLen (Just next) tlrmkr _ out = do-        let buf  = confWriteBuffer `plusPtr` off-            off' = off + frameHeaderLength + datPayloadLen-            flag  = defaultFlags-        fillFrameHeader FrameData datPayloadLen streamNumber flag buf-        atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)-        atomically $ modifyTVar' streamWindow (subtract datPayloadLen)-        let out' = out { outputType = ONext next tlrmkr }-        enqueueOutput outputQ out'-        return off'--    pushPromise pid sid ths off = do-        let offsid = off + frameHeaderLength -- checkme-            bufsid = confWriteBuffer `plusPtr` offsid-        poke32 (fromIntegral sid) bufsid 0-        let offkv  = offsid + 4-            bufkv  = confWriteBuffer `plusPtr` offkv-            limkv  = confBufferSize - offkv-        (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths-        let flag = setEndHeader defaultFlags -- No EndStream flag-            buf = confWriteBuffer `plusPtr` off-            len = kvlen + 4-        fillFrameHeader FramePushPromise len pid flag buf-        return len--    {-# INLINE fillFrameHeader #-}-    fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf-      where-        hinfo = FrameHeader len flag sid--    {-# INLINE ignore #-}-    ignore :: E.SomeException -> IO ()-    ignore _ = return ()---- | Running trailers-maker.------ > bufferIO buf siz $ \bs -> tlrmkr (Just bs)-runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker-runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs)--------------------------------------------------------------------fillBuilderBodyGetNext :: Builder -> DynaNext-fillBuilderBodyGetNext bb buf siz lim = do-    let room = min siz lim-    (len, signal) <- B.runBuilder bb buf room-    return $ nextForBuilder len signal--fillFileBodyGetNext :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillFileBodyGetNext pread start bytecount refresh buf siz lim = do-    let room = min siz lim-    len <- pread start (mini room bytecount) buf-    let len' = fromIntegral len-    return $ nextForFile len' pread (start + len) (bytecount - len) refresh--fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext-fillStreamBodyGetNext takeQ buf siz lim = do-    let room = min siz lim-    (leftover, cont, len) <- runStreamBuilder buf room takeQ-    return $ nextForStream takeQ leftover cont len--------------------------------------------------------------------fillBufBuilder :: Leftover -> DynaNext-fillBufBuilder leftover buf0 siz0 lim = do-    let room = min siz0 lim-    case leftover of-        LZero -> error "fillBufBuilder: LZero"-        LOne writer -> do-            (len, signal) <- writer buf0 room-            getNext len signal-        LTwo bs writer-          | BS.length bs <= room -> do-              buf1 <- copy buf0 bs-              let len1 = BS.length bs-              (len2, signal) <- writer buf1 (room - len1)-              getNext (len1 + len2) signal-          | otherwise -> do-              let (bs1,bs2) = BS.splitAt room bs-              void $ copy buf0 bs1-              getNext room (B.Chunk bs2 writer)-  where-    getNext l s = return $ nextForBuilder l s--nextForBuilder :: BytesFilled -> B.Next -> Next-nextForBuilder len B.Done-    = Next len Nothing-nextForBuilder len (B.More _ writer)-    = Next len $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer)-    = Next len $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder :: Buffer -> BufferSize -> IO (Maybe StreamingChunk)-                 -> IO (Leftover, Bool, BytesFilled)-runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0-  where-    loop buf room total = do-        mbuilder <- takeQ-        case mbuilder of-            Nothing      -> return (LZero, True, total)-            Just (StreamingBuilder builder) -> do-                (len, signal) <- B.runBuilder builder buf room-                let total' = total + len-                case signal of-                    B.Done -> loop (buf `plusPtr` len) (room - len) total'-                    B.More  _ writer  -> return (LOne writer, True, total')-                    B.Chunk bs writer -> return (LTwo bs writer, True, total')-            Just StreamingFlush       -> return (LZero, True, total)-            Just StreamingFinished    -> return (LZero, False, total)--fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext-fillBufStream leftover0 takeQ buf0 siz0 lim0 = do-    let room0 = min siz0 lim0-    case leftover0 of-        LZero -> do-            (leftover, cont, len) <- runStreamBuilder buf0 room0 takeQ-            getNext leftover cont len-        LOne writer -> write writer buf0 room0 0-        LTwo bs writer-          | BS.length bs <= room0 -> do-              buf1 <- copy buf0 bs-              let len = BS.length bs-              write writer buf1 (room0 - len) len-          | otherwise -> do-              let (bs1,bs2) = BS.splitAt room0 bs-              void $ copy buf0 bs1-              getNext (LTwo bs2 writer) True room0-  where-    getNext l b r = return $ nextForStream takeQ l b r-    write writer1 buf room sofar = do-        (len, signal) <- writer1 buf room-        case signal of-            B.Done -> do-                (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) takeQ-                let total = sofar + len + extra-                getNext leftover cont total-            B.More  _ writer -> do-                let total = sofar + len-                getNext (LOne writer) True total-            B.Chunk bs writer -> do-                let total = sofar + len-                getNext (LTwo bs writer) True total--nextForStream :: IO (Maybe StreamingChunk)-              -> Leftover -> Bool -> BytesFilled-              -> Next-nextForStream _ _ False len = Next len Nothing-nextForStream takeQ leftOrZero True len =-    Next len $ Just (fillBufStream leftOrZero takeQ)--------------------------------------------------------------------fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillBufFile pread start bytes refresh buf siz lim = do-    let room = min siz lim-    len <- pread start (mini room bytes) buf-    refresh-    let len' = fromIntegral len-    return $ nextForFile len' pread (start + len) (bytes - len) refresh--nextForFile :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next-nextForFile 0   _  _     _     _       = Next 0   Nothing-nextForFile len _  _     0     _       = Next len Nothing-nextForFile len pread start bytes refresh =-    Next len $ Just (fillBufFile pread start bytes refresh)--{-# INLINE mini #-}-mini :: Int -> Int64 -> Int64-mini i n-  | fromIntegral i < n = fromIntegral i-  | otherwise          = n
− Network/HTTP2/Arch/Status.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.HTTP2.Arch.Status (-    getStatus-  , setStatus-  ) where--import Data.ByteString.Internal (unsafeCreate)-import qualified Data.ByteString.Char8 as C8-import Foreign.Ptr (plusPtr)-import Foreign.Storable (poke)-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HPACK.Token--------------------------------------------------------------------getStatus :: HeaderTable -> Maybe H.Status-getStatus (_,vt) = getHeaderValue tokenStatus vt >>= toStatus--setStatus :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders-setStatus st hdr = (":status", fromStatus st) : hdr--------------------------------------------------------------------fromStatus :: H.Status -> ByteString-fromStatus status = unsafeCreate 3 $ \p -> do-    poke p               (toW8 r2)-    poke (p `plusPtr` 1) (toW8 r1)-    poke (p `plusPtr` 2) (toW8 r0)-  where-    toW8 :: Int -> Word8-    toW8 n = 48 + fromIntegral n-    s = H.statusCode status-    (q0,r0) = s `divMod` 10-    (q1,r1) = q0 `divMod` 10-    r2 = q1 `mod` 10--toStatus :: ByteString -> Maybe H.Status-toStatus bs = case C8.readInt bs of-  Nothing       -> Nothing-  Just (code,_) -> Just $ toEnum code
− Network/HTTP2/Arch/Stream.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Network.HTTP2.Arch.Stream where--import Control.Concurrent-import Control.Concurrent.STM-import Data.IORef-import qualified Data.IntMap.Strict as M--import Imports-import Network.HTTP2.Arch.Types-import Network.HTTP2.Frame--------------------------------------------------------------------isIdle :: StreamState -> Bool-isIdle Idle = True-isIdle _    = False--isOpen :: StreamState -> Bool-isOpen Open{} = True-isOpen _      = False--isHalfClosedRemote :: StreamState -> Bool-isHalfClosedRemote HalfClosedRemote = True-isHalfClosedRemote (Closed _)       = True-isHalfClosedRemote _                = False--isHalfClosedLocal :: StreamState -> Bool-isHalfClosedLocal (HalfClosedLocal _) = True-isHalfClosedLocal (Closed _)       = True-isHalfClosedLocal _                = False--isClosed :: StreamState -> Bool-isClosed Closed{} = True-isClosed _        = False--------------------------------------------------------------------newStream :: StreamId -> WindowSize -> IO Stream-newStream sid win = Stream sid <$> newIORef Idle-                               <*> newTVarIO win-                               <*> newEmptyMVar--newPushStream :: StreamId -> WindowSize -> IO Stream-newPushStream sid win = Stream sid <$> newIORef Reserved-                                   <*> newTVarIO win-                                   <*> newEmptyMVar--------------------------------------------------------------------{-# INLINE readStreamState #-}-readStreamState :: Stream -> IO StreamState-readStreamState Stream{streamState} = readIORef streamState--------------------------------------------------------------------newStreamTable :: IO StreamTable-newStreamTable = StreamTable <$> newIORef M.empty--insert :: StreamTable -> M.Key -> Stream -> IO ()-insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->-    let m' = M.insert k v m-    in (m', ())--remove :: StreamTable -> M.Key -> IO ()-remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->-    let m' = M.delete k m-    in (m', ())--search :: StreamTable -> M.Key -> IO (Maybe Stream)-search (StreamTable ref) k = M.lookup k <$> readIORef ref--updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()-updateAllStreamWindow adst (StreamTable ref) = do-    strms <- M.elems <$> readIORef ref-    forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst
− Network/HTTP2/Arch/Types.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.HTTP2.Arch.Types where--import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (SomeException)-import Data.ByteString.Builder (Builder)-import Data.IORef-import Data.IntMap.Strict (IntMap)-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HTTP2.Arch.File-import Network.HTTP2.Frame---------------------------------------------------------------------- | "http" or "https".-type Scheme = ByteString---- | For so-called "Host:" header.-type Authority = ByteString---- | Path.-type Path = ByteString--------------------------------------------------------------------type InpBody = IO ByteString--data OutBody = OutBodyNone-             -- | Streaming body takes a write action and a flush action.-             | OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ())-             | OutBodyBuilder Builder-             | OutBodyFile FileSpec---- | Input object-data InpObj = InpObj {-    inpObjHeaders  :: HeaderTable   -- ^ Accessor for headers.-  , inpObjBodySize :: Maybe Int     -- ^ Accessor for body length specified in content-length:.-  , inpObjBody     :: InpBody       -- ^ Accessor for body.-  , inpObjTrailers :: IORef (Maybe HeaderTable) -- ^ Accessor for trailers.-  }--instance Show InpObj where-    show (InpObj (thl,_) _ _body _tref) = show thl---- | Output object-data OutObj = OutObj {-    outObjHeaders  :: [H.Header]    -- ^ Accessor for header.-  , outObjBody     :: OutBody       -- ^ Accessor for outObj body.-  , outObjTrailers :: TrailersMaker -- ^ Accessor for trailers maker.-  }--instance Show OutObj where-    show (OutObj hdr _ _) = show hdr---- | Trailers maker. A chunks of the response body is passed---   with 'Just'. The maker should update internal state---   with the 'ByteString' and return the next trailers maker.---   When response body reaches its end,---   'Nothing' is passed and the maker should generate---   trailers. An example:------   > {-# LANGUAGE BangPatterns #-}---   > import Data.ByteString (ByteString)---   > import qualified Data.ByteString.Char8 as C8---   > import Crypto.Hash (Context, SHA1) -- cryptonite---   > import qualified Crypto.Hash as CH---   >---   > -- Strictness is important for Context.---   > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker---   > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]---   >   where---   >     !sha1 = C8.pack $ show $ CH.hashFinalize ctx---   > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'---   >   where---   >     !ctx' = CH.hashUpdate ctx bs------   Usage example:------   > let h2rsp = responseFile ...---   >     maker = trailersMaker (CH.hashInit :: Context SHA1)---   >     h2rsp' = setResponseTrailersMaker h2rsp maker----type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker---- | TrailersMake to create no trailers.-defaultTrailersMaker :: TrailersMaker-defaultTrailersMaker Nothing = return $ Trailers []-defaultTrailersMaker _       = return $ NextTrailersMaker defaultTrailersMaker---- | Either the next trailers maker or final trailers.-data NextTrailersMaker = NextTrailersMaker TrailersMaker-                       | Trailers [H.Header]---------------------------------------------------------------------- | File specification.-data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)--------------------------------------------------------------------data OpenState =-    JustOpened-  | Continued [HeaderBlockFragment]-              Int  -- Total size-              Int  -- The number of continuation frames-              Bool -- End of stream-  | NoBody HeaderTable-  | HasBody HeaderTable-  | Body (TQueue ByteString)-         (Maybe Int) -- received Content-Length-                     -- compared the body length for error checking-         (IORef Int) -- actual body length-         (IORef (Maybe HeaderTable)) -- trailers--data ClosedCode = Finished-                | Killed-                | Reset ErrorCodeId-                | ResetByMe SomeException-                deriving Show--------------------------------------------------------------------data StreamState =-    Idle-  | Open OpenState-  | HalfClosedRemote-  | HalfClosedLocal ClosedCode-  | Closed ClosedCode-  | Reserved--instance Show StreamState where-    show Idle                = "Idle"-    show Open{}              = "Open"-    show HalfClosedRemote    = "HalfClosedRemote"-    show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e-    show (Closed e)          = "Closed: " ++ show e-    show Reserved            = "Reserved"--------------------------------------------------------------------data Stream = Stream {-    streamNumber     :: StreamId-  , streamState      :: IORef StreamState-  , streamWindow     :: TVar WindowSize-  , streamInput      :: MVar InpObj -- Client only-  }--instance Show Stream where-  show s = show (streamNumber s)--------------------------------------------------------------------newtype StreamTable = StreamTable (IORef (IntMap Stream))--------------------------------------------------------------------data Input a = Input a InpObj--data Output a = Output {-    outputStream   :: a-  , outputObject   :: OutObj-  , outputType     :: OutputType-  , outputStrmQ    :: Maybe (TBQueue StreamingChunk)-  , outputSentinel :: IO ()-  }--data OutputType = OObj-                | OWait (IO ())-                | OPush TokenHeaderList StreamId -- associated stream id from client-                | ONext DynaNext TrailersMaker--------------------------------------------------------------------type DynaNext = Buffer -> BufferSize -> WindowSize -> IO Next--type BytesFilled = Int--data Next = Next BytesFilled (Maybe DynaNext)--------------------------------------------------------------------data Control = CFinish-             | CGoaway    ByteString-             | CFrame     ByteString-             | CSettings  ByteString SettingsList-             | CSettings0 ByteString ByteString SettingsList--------------------------------------------------------------------data StreamingChunk = StreamingFinished-                    | StreamingFlush-                    | StreamingBuilder Builder
Network/HTTP2/Client.hs view
@@ -1,17 +1,19 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -- | HTTP\/2 client library. -- --  Example: -- -- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE RankNTypes #-}+-- > -- > module Main where -- >--- > import qualified Control.Exception as E--- > import Control.Concurrent (forkIO, threadDelay) -- > import qualified Data.ByteString.Char8 as C8 -- > import Network.HTTP.Types -- > import Network.Run.TCP (runTCPClient) -- network-run+-- > import Control.Concurrent.Async+-- > import qualified Control.Exception as E -- > -- > import Network.HTTP2.Client -- >@@ -19,136 +21,96 @@ -- > serverName = "127.0.0.1" -- > -- > main :: IO ()--- > main = runTCPClient serverName "80" runHTTP2Client+-- > main = runTCPClient serverName "80" $ runHTTP2Client serverName -- >   where--- >     cliconf = ClientConfig "http" (C8.pack serverName) 20--- >     runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)--- >                                  freeSimpleConfig--- >                                  (\conf -> run cliconf conf client)--- >     client sendRequest = do--- >         let req = requestNoBody methodGet "/" []--- >         _ <- forkIO $ sendRequest req $ \rsp -> do--- >             print rsp--- >             getResponseBodyChunk rsp >>= C8.putStrLn--- >         sendRequest req $ \rsp -> do--- >             threadDelay 100000--- >             print rsp--- >             getResponseBodyChunk rsp >>= C8.putStrLn-+-- >     cliconf host = defaultClientConfig { authority = 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" module Network.HTTP2.Client (-  -- * Runner-    run-  , Scheme-  , Authority-  -- * Runner arguments-  , ClientConfig(..)-  , Config(..)-  , allocSimpleConfig-  , freeSimpleConfig-  -- * HTTP\/2 client-  , Client-  -- * Request-  , Request-  -- * Creating request-  , requestNoBody-  , requestFile-  , requestStreaming-  , requestBuilder-  -- ** Trailers maker-  , TrailersMaker-  , NextTrailersMaker(..)-  , defaultTrailersMaker-  , setRequestTrailersMaker-  -- * Response-  , Response-  -- ** Accessing response-  , responseStatus-  , responseHeaders-  , responseBodySize-  , getResponseBodyChunk-  , getResponseTrailers-  -- * Types-  , Method-  , Path-  , FileSpec(..)-  , FileOffset-  , ByteCount-  -- * RecvN-  , defaultReadN-  -- * Position read for files-  , PositionReadMaker-  , PositionRead-  , Sentinel(..)-  , defaultPositionReadMaker-  ) where--import Data.ByteString (ByteString)-import Data.ByteString.Builder (Builder)-import Data.IORef (readIORef)-import Network.HTTP.Types--import Network.HPACK-import Network.HTTP2.Arch-import Network.HTTP2.Client.Types-import Network.HTTP2.Client.Run---------------------------------------------------------------------- | Creating request without body.-requestNoBody :: Method -> Path -> RequestHeaders -> Request-requestNoBody m p hdr = Request $ OutObj hdr' OutBodyNone defaultTrailersMaker-  where-    hdr' = addHeaders m p hdr---- | Creating request with file.-requestFile :: Method -> Path -> RequestHeaders -> FileSpec -> Request-requestFile m p hdr fileSpec = Request $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker-  where-    hdr' = addHeaders m p hdr---- | Creating request with builder.-requestBuilder :: Method -> Path -> RequestHeaders -> Builder -> Request-requestBuilder m p hdr builder = Request $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker-  where-    hdr' = addHeaders m p hdr---- | Creating request with streaming.-requestStreaming :: Method -> Path -> RequestHeaders-                 -> ((Builder -> IO ()) -> IO () -> IO ())-                 -> Request-requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker-  where-    hdr' = addHeaders m p hdr---addHeaders :: Method -> Path -> RequestHeaders -> RequestHeaders-addHeaders m p hdr = (":method", m) : (":path", p) : hdr+    -- * Runner+    run, --- | Setting 'TrailersMaker' to 'Response'.-setRequestTrailersMaker :: Request -> TrailersMaker -> Request-setRequestTrailersMaker (Request req) tm = Request req { outObjTrailers = tm }+    -- * Client configuration+    ClientConfig,+    defaultClientConfig,+    scheme,+    authority,+    cacheLimit,+    connectionWindowSize,+    settings, -----------------------------------------------------------------+    -- * HTTP\/2 setting+    Settings,+    defaultSettings,+    headerTableSize,+    enablePush,+    maxConcurrentStreams,+    initialWindowSize,+    maxFrameSize,+    maxHeaderListSize, --- | Getting the status of a response.-responseStatus :: Response -> Maybe Status-responseStatus (Response rsp) = getStatus $ inpObjHeaders rsp+    -- ** Rate limits+    pingRateLimit,+    settingsRateLimit,+    emptyFrameRateLimit,+    rstRateLimit, --- | Getting the headers from a response.-responseHeaders :: Response -> HeaderTable-responseHeaders (Response rsp) = inpObjHeaders rsp+    -- * Common configuration+    Config,+    defaultConfig,+    confWriteBuffer,+    confBufferSize,+    confSendAll,+    confReadN,+    confPositionReadMaker,+    confTimeoutManager,+    confMySockAddr,+    confPeerSockAddr,+    confReadNTimeout,+    allocSimpleConfig,+    allocSimpleConfig',+    freeSimpleConfig,+    module Network.HTTP.Semantics.Client, --- | Getting the body size from a response.-responseBodySize :: Response -> Maybe Int-responseBodySize (Response rsp) = inpObjBodySize rsp+    -- * Error+    HTTP2Error (..),+    ReasonPhrase,+    ErrorCode (+        ErrorCode,+        NoError,+        ProtocolError,+        InternalError,+        FlowControlError,+        SettingsTimeout,+        StreamClosed,+        FrameSizeError,+        RefusedStream,+        Cancel,+        CompressionError,+        ConnectError,+        EnhanceYourCalm,+        InadequateSecurity,+        HTTP11Required+    ),+) where --- | Reading a chunk of the response body.---   An empty 'ByteString' returned when finished.-getResponseBodyChunk :: Response -> IO ByteString-getResponseBodyChunk (Response rsp) = inpObjBody rsp+import Network.HTTP.Semantics.Client --- | Reading response trailers.---   This function must be called after 'getResponseBodyChunk'---   returns an empty.-getResponseTrailers :: Response -> IO (Maybe HeaderTable)-getResponseTrailers (Response rsp) = readIORef (inpObjTrailers rsp)+import Network.HTTP2.Client.Run+import Network.HTTP2.Frame+import Network.HTTP2.H2 hiding (authority, scheme)
Network/HTTP2/Client/Internal.hs view
@@ -1,6 +1,19 @@ module Network.HTTP2.Client.Internal (-    Request(..)-  , Response(..)-  ) where+    Request (..),+    Response (..),+    Config (..),+    ClientConfig (..),+    Settings (..),+    Aux (..), -import Network.HTTP2.Client.Types+    -- * Low level+    Stream,+    ClientIO (..),+    runIO,+) where++import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.Client.Internal++import Network.HTTP2.Client.Run+import Network.HTTP2.H2
Network/HTTP2/Client/Run.hs view
@@ -1,64 +1,269 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}  module Network.HTTP2.Client.Run where -import Control.Concurrent.Async import Control.Concurrent-import qualified Control.Exception as E-import Data.IORef (writeIORef)+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+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 qualified System.ThreadManager as T+import Text.Read (readMaybe) -import Network.HTTP2.Arch-import Network.HTTP2.Client.Types+import Imports import Network.HTTP2.Frame+import Network.HTTP2.H2  -- | Client configuration-data ClientConfig = ClientConfig {-    scheme     :: Scheme    -- ^ https or http-  , authority  :: Authority -- ^ Server name-  , cacheLimit :: Int       -- ^ How many pushed responses are contained in the cache-  }+data ClientConfig = ClientConfig+    { scheme :: Scheme+    -- ^ https or http+    , authority :: Authority+    -- ^ Server name+    , cacheLimit :: Int+    -- ^ The maximum number of incoming streams on the net+    , connectionWindowSize :: WindowSize+    -- ^ The window size of connection.+    , settings :: Settings+    -- ^ Settings+    }+    deriving (Eq, Show) +-- | The default client config.+--+-- The @authority@ field will be used to set the HTTP2 @:authority@+-- pseudo-header. In most cases you will want to override it to be equal to+-- @host@.+--+-- Further background on @authority@:+-- [RFC 3986](https://datatracker.ietf.org/doc/html/rfc3986#section-3.2) also+-- allows @host:port@, and most servers will accept this too. However, when+-- using TLS, many servers will expect the TLS SNI server name and the+-- @:authority@ pseudo-header to be equal, and for TLS SNI the server name+-- should not include the port. Note that HTTP2 explicitly /disallows/ using+-- @userinfo\@@ as part of the authority.+--+-- >>> defaultClientConfig+-- 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+        { scheme = "http"+        , authority = "localhost"+        , cacheLimit = 64+        , connectionWindowSize = defaultMaxData+        , settings = defaultSettings+        }+ -- | Running HTTP/2 client. run :: ClientConfig -> Config -> Client a -> IO a-run ClientConfig{..} conf@Config{..} client = do-    clientInfo <- newClientInfo scheme authority cacheLimit-    ctx <- newContext clientInfo-    mgr <- start confTimeoutManager-    let runBackgroundThreads = do-            race_-                (frameReceiver ctx confReadN)-                (frameSender ctx conf mgr)-            E.throwIO (ConnectionError ProtocolError "connection terminated")-    exchangeSettings conf ctx-    fmap (either id id) $-        race runBackgroundThreads (client (sendRequest ctx scheme authority))-            `E.finally` stop mgr+run cconf@ClientConfig{..} conf client = do+    ctx <- setup cconf conf+    runH2 conf ctx $ runClient ctx+  where+    serverMaxStreams ctx = do+        mx <- maxConcurrentStreams <$> readIORef (peerSettings ctx)+        case mx of+            Nothing -> return maxBound+            Just x -> return x+    possibleClientStream ctx = do+        x <- serverMaxStreams ctx+        n <- oddConc <$> readTVarIO (oddStreamTable ctx)+        return (x - n)+    aux ctx =+        defaultAux+            { auxPossibleClientStreams = possibleClientStream ctx+            , auxSendPing =+                sendPing+                    ctx+                    False+                    "Haskell!" -- 8 bytes+            }+    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+        x <- processResponse rsp+        adjustRxWindow ctx strm+        return x+    runClient ctx = client (clientCore ctx) $ aux ctx -sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a-sendRequest ctx@Context{..} scheme auth (Request req) processResponse = do-    let hdr = outObjHeaders req-        Just method = lookup ":method" hdr-        Just path   = lookup ":path" hdr-    mstrm0 <- lookupCache method path roleInfo-    strm <- case mstrm0 of-      Nothing -> do-          let hdr' = (":scheme", scheme)-                   : (":authority", auth)-                   : hdr-              req' = req { outObjHeaders = hdr' }-          sid <- getMyNewStreamId ctx-          newstrm <- openStream ctx sid FrameHeaders-          enqueueOutput outputQ $ Output newstrm req' OObj Nothing (return ())-          return newstrm-      Just strm0 -> return strm0-    rsp <- takeMVar $ streamInput strm-    processResponse $ Response rsp+-- | Launching a receiver and a sender.+runIO :: ClientConfig -> Config -> (ClientIO -> IO (IO a)) -> IO a+runIO cconf@ClientConfig{..} conf@Config{..} action = do+    ctx@Context{..} <- setup cconf conf+    let putB bs = enqueueControl controlQ $ CFrames Nothing [bs]+        putR req = do+            (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 runClient -exchangeSettings :: Config -> Context -> IO ()-exchangeSettings Config{..} Context{..} = do-    confSendAll connectionPreface-    let setframe = CSettings initialFrame [] -- fixme alist-    writeIORef firstSettings True+getResponse :: Stream -> IO Response+getResponse strm = do+    mRsp <- takeMVar $ streamInput strm+    case mRsp of+        Left err -> throwIO err+        Right rsp -> return $ Response rsp++setup :: ClientConfig -> Config -> IO Context+setup ClientConfig{..} conf@Config{..} = do+    let clientInfo = newClientInfo scheme authority+    ctx <-+        newContext+            clientInfo+            conf+            cacheLimit+            connectionWindowSize+            settings+            confTimeoutManager+            Nothing+    exchangeSettings ctx+    return ctx++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+    runClientReceiver = do+        labelMe "H2 ClientReceiver"+        er <- race runReceiver runClient+        case er of+            Right r -> return r+            Left err -> throwIO err++    -- 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+    -> Scheme+    -> Authority+    -> Request+    -> IO (Stream, Maybe OutObj)+makeStream ctx@Context{..} scheme auth (Request req) = do+    -- Checking push promises+    let hdr0 = outObjHeaders req+        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, 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.+            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", auth') : hdr1+                    | otherwise = hdr1+                req' = req{outObjHeaders = hdr2}+            -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit+            (_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+    -> Stream+    -> (OutBodyIface -> IO ())+    -> IO (TBQueue StreamingChunk)+sendStreaming Context{..} strm strmbdy = do+    tbq <- newTBQueueIO 10 -- fixme: hard coding: 10+    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+    connRxWS <- rxfBufSize <$> readIORef rxFlow+    let frames = makeNegotiationFrames mySettings connRxWS+        setframe = CFrames Nothing (connectionPreface : frames)+    writeIORef myFirstSettings True     enqueueControl controlQ setframe +data ClientIO = ClientIO+    { cioMySockAddr :: SockAddr+    , cioPeerSockAddr :: SockAddr+    , cioWriteRequest :: Request -> IO (StreamId, Stream)+    , cioReadResponse :: Stream -> IO Response+    , cioWriteBytes :: ByteString -> IO ()+    , cioCreateStream :: IO (StreamId, Stream)+    }
− Network/HTTP2/Client/Types.hs 
@@ -1,14 +0,0 @@-module Network.HTTP2.Client.Types where--import Network.HTTP2.Arch---------------------------------------------------------------------- | Client type.-type Client a = (Request -> (Response -> IO a) -> IO a) -> IO a---- | Request from client.-newtype Request = Request OutObj deriving (Show)---- | Response from server.-newtype Response = Response InpObj deriving (Show)
Network/HTTP2/Frame.hs view
@@ -1,93 +1,134 @@ {-# LANGUAGE OverloadedStrings #-} --- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).+-- | Framing in HTTP\/2(<https://www.rfc-editor.org/rfc/rfc9113>). module Network.HTTP2.Frame (-  -- * Frame-    Frame(..)-  , FrameHeader(..)-  , FramePayload(..)-  , HeaderBlockFragment-  , Padding-  , isPaddingDefined-  -- * Encoding-  , encodeFrame-  , encodeFrameChunks-  , encodeFrameHeader-  , encodeFrameHeaderBuf-  , encodeFramePayload-  , EncodeInfo(..)-  , encodeInfo-  , module Network.HTTP2.Frame.Decode-  -- * Frame type ID-  , FrameTypeId(..)-  , framePayloadToFrameTypeId-  -- * Frame type-  , FrameType-  , fromFrameTypeId-  , toFrameTypeId-  -- * Priority-  , Priority(..)-  , Weight-  , defaultPriority-  , highestPriority-  , defaultWeight-  -- * Stream identifier-  , StreamId-  , isControl-  , isClientInitiated-  , isServerInitiated-  , isRequest-  , isResponse-  -- * Stream identifier related-  , testExclusive-  , setExclusive-  , clearExclusive-  -- * Flags-  , FrameFlags-  , defaultFlags-  , testEndStream-  , testAck-  , testEndHeader-  , testPadded-  , testPriority-  , setEndStream-  , setAck-  , setEndHeader-  , setPadded-  , setPriority-  -- * SettingsList-  , SettingsList-  , SettingsKeyId(..)-  , SettingsValue-  , fromSettingsKeyId-  , toSettingsKeyId-  , checkSettingsList-  -- * Settings-  , Settings(..)-  , defaultSettings-  , updateSettings-  -- * Window-  , WindowSize-  , defaultInitialWindowSize-  , maxWindowSize-  , isWindowOverflow-  -- * Error code-  , ErrorCode-  , ErrorCodeId(..)-  , fromErrorCodeId-  , toErrorCodeId-  -- * Error-  , HTTP2Error(..)-  , errorCodeId-  -- * Predefined values-  , connectionPreface-  , connectionPrefaceLength-  , frameHeaderLength-  , maxPayloadLength-  , recommendedConcurrency-  ) where+    -- * Frame+    Frame (..),+    FrameHeader (..),+    FramePayload (..),+    HeaderBlockFragment,+    Padding,+    isPaddingDefined, +    -- * Encoding+    encodeFrame,+    encodeFrameChunks,+    encodeFrameHeader,+    encodeFrameHeaderBuf,+    encodeFramePayload,+    EncodeInfo (..),+    encodeInfo,+    module Network.HTTP2.Frame.Decode,++    -- * Frame type+    FrameType (+        FrameType,+        FrameData,+        FrameHeaders,+        FramePriority,+        FrameRSTStream,+        FrameSettings,+        FramePushPromise,+        FramePing,+        FrameGoAway,+        FrameWindowUpdate,+        FrameContinuation+    ),+    fromFrameType,+    toFrameType,+    minFrameType,+    maxFrameType,+    framePayloadToFrameType,++    -- * Priority+    Priority (..),+    Weight,++    -- * Stream identifier+    StreamId,+    isControl,+    isClientInitiated,+    isServerInitiated,++    -- * Stream identifier related+    testExclusive,+    setExclusive,+    clearExclusive,++    -- * Flags+    FrameFlags,+    defaultFlags,+    testEndStream,+    testAck,+    testEndHeader,+    testPadded,+    testPriority,+    setEndStream,+    setAck,+    setEndHeader,+    setPadded,+    setPriority,++    -- * SettingsList+    SettingsList,+    SettingsKey (+        SettingsKey,+        SettingsTokenHeaderTableSize,+        SettingsEnablePush,+        SettingsMaxConcurrentStreams,+        SettingsInitialWindowSize,+        SettingsMaxFrameSize,+        SettingsMaxHeaderListSize+    ),+    SettingsValue,+    fromSettingsKey,+    toSettingsKey,++    -- * Payload length+    defaultPayloadLength,+    maxPayloadLength,++    -- * Window+    WindowSize,+    defaultWindowSize,+    maxWindowSize,+    isWindowOverflow,++    -- * Error code+    ErrorCode (+        ErrorCode,+        NoError,+        ProtocolError,+        InternalError,+        FlowControlError,+        SettingsTimeout,+        StreamClosed,+        FrameSizeError,+        RefusedStream,+        Cancel,+        CompressionError,+        ConnectError,+        EnhanceYourCalm,+        InadequateSecurity,+        HTTP11Required+    ),+    fromErrorCode,+    toErrorCode,++    -- * Predefined values+    connectionPreface,+    connectionPrefaceLength,+    frameHeaderLength,+    recommendedConcurrency,++    -- * Deprecated+    ErrorCodeId,+    SettingsKeyId,+    FrameTypeId,+) where+ import qualified Data.ByteString as BS+import Network.Control (WindowSize)  import Imports import Network.HTTP2.Frame.Decode
Network/HTTP2/Frame/Decode.hs view
@@ -1,26 +1,29 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Network.HTTP2.Frame.Decode (-  -- * Decoding-    decodeFrame-  , decodeFrameHeader-  , checkFrameHeader-  -- * Decoding payload-  , decodeFramePayload-  , FramePayloadDecoder-  , decodeDataFrame-  , decodeHeadersFrame-  , decodePriorityFrame-  , decoderstStreamFrame-  , decodeSettingsFrame-  , decodePushPromiseFrame-  , decodePingFrame-  , decodeGoAwayFrame-  , decodeWindowUpdateFrame-  , decodeContinuationFrame-  ) where+    -- * Decoding+    decodeFrame,+    decodeFrameHeader,+    checkFrameHeader,+    FrameDecodeError (..), +    -- * Decoding payload+    decodeFramePayload,+    FramePayloadDecoder,+    decodeDataFrame,+    decodeHeadersFrame,+    decodePriorityFrame,+    decodeRSTStreamFrame,+    decodeSettingsFrame,+    decodePushPromiseFrame,+    decodePingFrame,+    decodeGoAwayFrame,+    decodeWindowUpdateFrame,+    decodeContinuationFrame,+) where++import Control.Exception (Exception) import Data.Array (Array, listArray, (!)) import qualified Data.ByteString as BS import Foreign.Ptr (Ptr, plusPtr)@@ -32,30 +35,41 @@  ---------------------------------------------------------------- +data FrameDecodeError = FrameDecodeError ErrorCode StreamId ShortByteString+    deriving (Eq, Show)++instance Exception FrameDecodeError++----------------------------------------------------------------+ -- | Decoding an HTTP/2 frame to 'ByteString'. -- The second argument must be include the entire of frame. -- So, this function is not useful for real applications -- but useful for testing.-decodeFrame :: Settings    -- ^ HTTP/2 settings-            -> ByteString  -- ^ Input byte-stream-            -> Either HTTP2Error Frame -- ^ Decoded frame-decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0)-                      >>= \(typ,header) -> decodeFramePayload typ header bs1-                      >>= \payload -> return $ Frame header payload+decodeFrame+    :: ByteString+    -- ^ Input byte-stream+    -> Either FrameDecodeError Frame+    -- ^ Decoded frame+decodeFrame bs =+    checkFrameHeader (decodeFrameHeader bs0)+        >>= \(typ, header) ->+            decodeFramePayload typ header bs1+                >>= \payload -> return $ Frame header payload   where-    (bs0,bs1) = BS.splitAt 9 bs+    (bs0, bs1) = BS.splitAt 9 bs  ----------------------------------------------------------------  -- | Decoding an HTTP/2 frame header. --   Must supply 9 bytes.-decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)+decodeFrameHeader :: ByteString -> (FrameType, FrameHeader) decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do     let p = ptr +. off-    len <- fromIntegral  <$> N.peek24 p 0-    typ <- toFrameTypeId <$> N.peek8  p 3-    flg <-                   N.peek8  p 4-    w32 <-                   N.peek32 p 5+    len <- fromIntegral <$> N.peek24 p 0+    typ <- toFrameType <$> N.peek8 p 3+    flg <- N.peek8 p 4+    w32 <- N.peek32 p 5     let sid = streamIdentifier w32     return (typ, FrameHeader len flg sid) @@ -66,110 +80,151 @@  -- | Checking a frame header and reporting an error if any. ----- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0))--- Left (ConnectionError ProtocolError "cannot used in control stream")-checkFrameHeader :: Settings-                 -> (FrameTypeId, FrameHeader)-                 -> Either HTTP2Error (FrameTypeId, FrameHeader)-checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..})-  | payloadLength > maxFrameSize =-      Left $ ConnectionError FrameSizeError "exceeds maximum frame size"-  | typ `elem` nonZeroFrameTypes && isControl streamId =-      Left $ ConnectionError ProtocolError "cannot used in control stream"-  | typ `elem` zeroFrameTypes && not (isControl streamId) =-      Left $ ConnectionError ProtocolError "cannot used in non-zero stream"-  | otherwise = checkType typ+-- >>> checkFrameHeader (FrameData,(FrameHeader 100 0 0))+-- Left (FrameDecodeError ProtocolError 0 "cannot used in control stream")+checkFrameHeader+    :: (FrameType, FrameHeader)+    -> Either FrameDecodeError (FrameType, FrameHeader)+checkFrameHeader typfrm@(typ, FrameHeader{..})+    | typ `elem` nonZeroFrameTypes && isControl streamId =+        Left $ FrameDecodeError ProtocolError streamId "cannot used in control stream"+    | typ `elem` zeroFrameTypes && not (isControl streamId) =+        Left $ FrameDecodeError ProtocolError streamId "cannot used in non-zero stream"+    | otherwise = checkType typ   where     checkType FrameHeaders-      | testPadded flags && payloadLength < 1 =-        Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length"-      | testPriority flags && payloadLength < 5 =-        Left $ ConnectionError FrameSizeError "insufficient payload for priority fields"-      | testPadded flags && testPriority flags && payloadLength < 6 =-        Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length and priority fields"-    checkType FramePriority | payloadLength /= 5 =-        Left $ StreamError FrameSizeError streamId-    checkType FrameRSTStream | payloadLength /= 4 =-        Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame"+        | testPadded flags && payloadLength < 1 =+            Left $+                FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length"+        | testPriority flags && payloadLength < 5 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "insufficient payload for priority fields"+        | testPadded flags && testPriority flags && payloadLength < 6 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "insufficient payload for Pad Length and priority fields"+    checkType FramePriority+        | payloadLength /= 5 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "payload length is not 5 in priority frame"+    checkType FrameRSTStream+        | payloadLength /= 4 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "payload length is not 4 in rst stream frame"     checkType FrameSettings-      | payloadLength `mod` 6 /= 0 =-        Left $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame"-      | testAck flags && payloadLength /= 0 =-        Left $ ConnectionError FrameSizeError "payload length must be 0 if ack flag is set"+        | payloadLength `mod` 6 /= 0 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "payload length is not multiple of 6 in settings frame"+        | testAck flags && payloadLength /= 0 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "payload length must be 0 if ack flag is set"     checkType FramePushPromise-      | not enablePush =-        Left $ ConnectionError ProtocolError "push not enabled" -- checkme-      | isClientInitiated streamId =-        Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier"-    checkType FramePing | payloadLength /= 8 =-        Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame"-    checkType FrameGoAway | payloadLength < 8 =-        Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger"-    checkType FrameWindowUpdate | payloadLength /= 4 =-        Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame"+        | isServerInitiated streamId =+            Left $+                FrameDecodeError+                    ProtocolError+                    streamId+                    "push promise must be used with an odd stream identifier"+    checkType FramePing+        | payloadLength /= 8 =+            Left $+                FrameDecodeError FrameSizeError streamId "payload length is 8 in ping frame"+    checkType FrameGoAway+        | payloadLength < 8 =+            Left $+                FrameDecodeError FrameSizeError streamId "goaway body must be 8 bytes or larger"+    checkType FrameWindowUpdate+        | payloadLength /= 4 =+            Left $+                FrameDecodeError+                    FrameSizeError+                    streamId+                    "payload length is 4 in window update frame"     checkType _ = Right typfrm -zeroFrameTypes :: [FrameTypeId]-zeroFrameTypes = [-    FrameSettings-  , FramePing-  , FrameGoAway-  ]+zeroFrameTypes :: [FrameType]+zeroFrameTypes =+    [ FrameSettings+    , FramePing+    , FrameGoAway+    ] -nonZeroFrameTypes :: [FrameTypeId]-nonZeroFrameTypes = [-    FrameData-  , FrameHeaders-  , FramePriority-  , FrameRSTStream-  , FramePushPromise-  , FrameContinuation-  ]+nonZeroFrameTypes :: [FrameType]+nonZeroFrameTypes =+    [ FrameData+    , FrameHeaders+    , FramePriority+    , FrameRSTStream+    , FramePushPromise+    , FrameContinuation+    ]  ----------------------------------------------------------------  -- | The type for frame payload decoder.-type FramePayloadDecoder = FrameHeader -> ByteString-                        -> Either HTTP2Error FramePayload+type FramePayloadDecoder =+    FrameHeader+    -> ByteString+    -> Either FrameDecodeError FramePayload -payloadDecoders :: Array Word8 FramePayloadDecoder-payloadDecoders = listArray (minFrameType, maxFrameType)-    [ decodeDataFrame-    , decodeHeadersFrame-    , decodePriorityFrame-    , decoderstStreamFrame-    , decodeSettingsFrame-    , decodePushPromiseFrame-    , decodePingFrame-    , decodeGoAwayFrame-    , decodeWindowUpdateFrame-    , decodeContinuationFrame-    ]+payloadDecoders :: Array FrameType FramePayloadDecoder+payloadDecoders =+    listArray+        (minFrameType, maxFrameType)+        [ decodeDataFrame+        , decodeHeadersFrame+        , decodePriorityFrame+        , decodeRSTStreamFrame+        , decodeSettingsFrame+        , decodePushPromiseFrame+        , decodePingFrame+        , decodeGoAwayFrame+        , decodeWindowUpdateFrame+        , decodeContinuationFrame+        ]  -- | Decoding an HTTP/2 frame payload. --   This function is considered to return a frame payload decoder --   according to a frame type.-decodeFramePayload :: FrameTypeId -> FramePayloadDecoder-decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ-decodeFramePayload ftyp               = checkFrameSize decoder+decodeFramePayload :: FrameType -> FramePayloadDecoder+decodeFramePayload ftyp+    | ftyp > maxFrameType = checkFrameSize $ decodeUnknownFrame ftyp+decodeFramePayload ftyp = checkFrameSize decoder   where-    decoder = payloadDecoders ! fromFrameTypeId ftyp+    decoder = payloadDecoders ! ftyp  ----------------------------------------------------------------  -- | 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' ->-    if hasPriority then-        let (bs0,bs1) = BS.splitAt 5 bs'-            p = priority bs0-        in HeadersFrame (Just p) bs1-    else-        HeadersFrame Nothing bs'+decodeHeadersFrame header _bs = decodeWithPadding header _bs $ \bs' ->+    if hasPriority+        then+            let (bs0, bs1) = BS.splitAt 5 bs'+                p = priority bs0+             in HeadersFrame (Just p) bs1+        else HeadersFrame Nothing bs'   where     hasPriority = testPriority $ flags header @@ -178,14 +233,15 @@ decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs  -- | Frame payload decoder for RST_STREAM frame.-decoderstStreamFrame :: FramePayloadDecoder-decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (N.word32 bs)+decodeRSTStreamFrame :: FramePayloadDecoder+decodeRSTStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode $ N.word32 bs  -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder decodeSettingsFrame FrameHeader{..} (PS fptr off _)-  | num > 10  = Left $ ConnectionError EnhanceYourCalm "Settings is too large"-  | otherwise = Right $ SettingsFrame alist+    | num > 10 =+        Left $ FrameDecodeError EnhanceYourCalm streamId "Settings is too large"+    | otherwise = Right $ SettingsFrame alist   where     num = payloadLength `div` 6     alist = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do@@ -194,73 +250,83 @@     settings 0 _ builder = return $ builder []     settings n p builder = do         rawSetting <- N.peek16 p 0-        let msettings = toSettingsKeyId rawSetting+        let k = toSettingsKey rawSetting             n' = n - 1-        case msettings of-            Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2)-            Just k  -> do-                w32 <- N.peek32 p 2-                let v = fromIntegral w32-                settings n' (p +. 6) (builder. ((k,v):))+        w32 <- N.peek32 p 2+        let v = fromIntegral w32+        settings n' (p +. 6) (builder . ((k, v) :))  -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder-decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' ->-    let (bs0,bs1) = BS.splitAt 4 bs'+decodePushPromiseFrame header _bs = decodeWithPadding header _bs $ \bs' ->+    let (bs0, bs1) = BS.splitAt 4 bs'         sid = streamIdentifier (N.word32 bs0)-    in PushPromiseFrame sid bs1+     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-    (bs0,bs1') = BS.splitAt 4 bs-    (bs1,bs2)  = BS.splitAt 4 bs1'+    bs = BS.copy _bs+    (bs0, bs1') = BS.splitAt 4 bs+    (bs1, bs2) = BS.splitAt 4 bs1'     sid = streamIdentifier (N.word32 bs0)-    ecid = toErrorCodeId (N.word32 bs1)+    ecid = toErrorCode (N.word32 bs1)  -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder-decodeWindowUpdateFrame _ bs-  | wsi == 0  = Left $ ConnectionError ProtocolError "window update must not be 0"-  | otherwise = Right $ WindowUpdateFrame wsi+decodeWindowUpdateFrame FrameHeader{..} bs+    | wsi == 0 =+        Left $ FrameDecodeError ProtocolError streamId "window update must not be 0"+    | otherwise = Right $ WindowUpdateFrame wsi   where     wsi = fromIntegral (N.word32 bs `clearBit` 31)  -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder-decodeContinuationFrame _ bs = Right $ ContinuationFrame bs+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  ----------------------------------------------------------------  checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder checkFrameSize func header@FrameHeader{..} body-  | payloadLength > BS.length body =-      Left $ ConnectionError FrameSizeError "payload is too short"-  | otherwise = func header body+    | payloadLength > BS.length body =+        Left $ FrameDecodeError FrameSizeError streamId "payload is too short"+    | otherwise = func header body  -- | Helper function to pull off the padding if its there, and will -- eat up the trailing padding automatically. Calls the decoder func -- passed in with the length of the unpadded portion between the -- padding octet and the actual padding-decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either HTTP2Error FramePayload+decodeWithPadding+    :: FrameHeader+    -> ByteString+    -> (ByteString -> FramePayload)+    -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body-  | padded = let Just (w8,rest) = BS.uncons bs-                 padlen = intFromWord8 w8-                 bodylen = payloadLength - padlen - 1-             in if bodylen < 0 then-                    Left $ ConnectionError ProtocolError "padding is not enough"-                  else-                    Right . body $ BS.take bodylen rest-  | otherwise = Right $ body bs+    | padded =+        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'   where+    bs' = BS.copy bs     padded = testPadded flags  streamIdentifier :: Word32 -> StreamId
Network/HTTP2/Frame/Encode.hs view
@@ -1,19 +1,20 @@ {-# LANGUAGE RecordWildCards #-}  module Network.HTTP2.Frame.Encode (-    encodeFrame-  , encodeFrameChunks-  , encodeFrameHeader-  , encodeFrameHeaderBuf-  , encodeFramePayload-  , EncodeInfo(..)-  , encodeInfo-  ) where+    encodeFrame,+    encodeFrameChunks,+    encodeFrameHeader,+    encodeFrameHeaderBuf,+    encodeFramePayload,+    EncodeInfo (..),+    encodeInfo,+) where  import qualified Data.ByteString as BS import Data.ByteString.Internal (unsafeCreate) import Foreign.Ptr (Ptr, plusPtr) import qualified Network.ByteOrder as N+import Network.Control (WindowSize)  import Imports import Network.HTTP2.Frame.Types@@ -23,14 +24,15 @@ type Builder = [ByteString] -> [ByteString]  -- | Auxiliary information for frame encoding.-data EncodeInfo = EncodeInfo {-    -- | Flags to be set in a frame header-      encodeFlags    :: FrameFlags-    -- | Stream id to be set in a frame header+data EncodeInfo = EncodeInfo+    { encodeFlags :: FrameFlags+    -- ^ Flags to be set in a frame header     , encodeStreamId :: StreamId-    -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set.-    , encodePadding  :: Maybe Padding-    } deriving (Show,Read)+    -- ^ Stream id to be set in a frame header+    , encodePadding :: Maybe Padding+    -- ^ Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set.+    }+    deriving (Show, Read)  ---------------------------------------------------------------- @@ -38,9 +40,11 @@ -- -- >>> encodeInfo setAck 0 -- EncodeInfo {encodeFlags = 1, encodeStreamId = 0, encodePadding = Nothing}-encodeInfo :: (FrameFlags -> FrameFlags)-           -> Int -- ^ stream identifier-           -> EncodeInfo+encodeInfo+    :: (FrameFlags -> FrameFlags)+    -> Int+    -- ^ stream identifier+    -> EncodeInfo encodeInfo set sid = EncodeInfo (set defaultFlags) sid Nothing  ----------------------------------------------------------------@@ -59,26 +63,26 @@ encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString] encodeFrameChunks einfo payload = bs : bss   where-    ftid = framePayloadToFrameTypeId payload+    ftid = framePayloadToFrameType payload     bs = encodeFrameHeader ftid header     (header, bss) = encodeFramePayload einfo payload  -- | Encoding an HTTP/2 frame header. --   The frame header must be completed.-encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString+encodeFrameHeader :: FrameType -> FrameHeader -> ByteString encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr  -- | Writing an encoded HTTP/2 frame header to the buffer. --   The length of the buffer must be larger than or equal to 9 bytes.-encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO ()+encodeFrameHeaderBuf :: FrameType -> FrameHeader -> Ptr Word8 -> IO () encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do-    N.poke24 plen  ptr 0-    N.poke8  typ   ptr 3-    N.poke8  flags ptr 4-    N.poke32 sid   ptr 5+    N.poke24 plen ptr 0+    N.poke8 typ ptr 3+    N.poke8 flags ptr 4+    N.poke32 sid ptr 5   where     plen = fromIntegral payloadLength-    typ = fromFrameTypeId ftid+    typ = fromFrameType ftid     sid = fromIntegral streamId  -- | Encoding an HTTP/2 frame payload.@@ -116,15 +120,17 @@  ---------------------------------------------------------------- -buildPadding :: EncodeInfo-             -> Builder-             -> Int -- ^ Payload length.-             -> (FrameHeader, Builder)-buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len =+buildPadding+    :: EncodeInfo+    -> Builder+    -> Int+    -- ^ Payload length.+    -> (FrameHeader, Builder)+buildPadding EncodeInfo{encodePadding = Nothing, ..} builder len =     (header, builder)   where     header = FrameHeader len encodeFlags encodeStreamId-buildPadding EncodeInfo{ encodePadding = Just padding, ..} btarget targetLength =+buildPadding EncodeInfo{encodePadding = Just padding, ..} btarget targetLength =     (header, builder)   where     header = FrameHeader len newflags encodeStreamId@@ -139,13 +145,13 @@   where     builder = (priority :)     estream-      | exclusive = setExclusive streamDependency-      | otherwise = streamDependency+        | exclusive = setExclusive streamDependency+        | otherwise = streamDependency     priority = unsafeCreate 5 $ \ptr -> do         let esid = fromIntegral estream-            w    = fromIntegral $ weight - 1+            w = fromIntegral $ weight - 1         N.poke32 esid ptr 0-        N.poke8  w    ptr 4+        N.poke8 w ptr 4  ---------------------------------------------------------------- @@ -155,8 +161,11 @@     builder = (body :)     len = BS.length body -buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment-                         -> (FrameHeader, Builder)+buildFramePayloadHeaders+    :: EncodeInfo+    -> Maybe Priority+    -> HeaderBlockFragment+    -> (FrameHeader, Builder) buildFramePayloadHeaders einfo Nothing hdr =     buildPadding einfo builder len   where@@ -167,7 +176,7 @@   where     builder = buildPriority pri . (hdr :)     len = BS.length hdr + 5-    einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) }+    einfo' = einfo{encodeFlags = setPriority (encodeFlags einfo)}  buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder) buildFramePayloadPriority EncodeInfo{..} p = (header, builder)@@ -175,27 +184,29 @@     builder = buildPriority p     header = FrameHeader 5 encodeFlags encodeStreamId -buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder)+buildFramePayloadRSTStream :: EncodeInfo -> ErrorCode -> (FrameHeader, Builder) buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder)   where     builder = (b4 :)-    b4 = N.bytestring32 $ fromErrorCodeId e+    b4 = N.bytestring32 $ fromErrorCode e     header = FrameHeader 4 encodeFlags encodeStreamId -buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder)+buildFramePayloadSettings+    :: EncodeInfo -> SettingsList -> (FrameHeader, Builder) buildFramePayloadSettings EncodeInfo{..} alist = (header, builder)   where     builder = (settings :)     settings = unsafeCreate len $ \ptr -> go ptr alist-    go _ []          = return ()-    go p ((k,v):kvs) = do-        N.poke16 (fromSettingsKeyId k) p 0-        N.poke32 (fromIntegral v)      p 2+    go _ [] = return ()+    go p ((k, v) : kvs) = do+        N.poke16 (fromSettingsKey k) p 0+        N.poke32 (fromIntegral v) p 2         go (p `plusPtr` 6) kvs     len = length alist * 6     header = FrameHeader len encodeFlags encodeStreamId -buildFramePayloadPushPromise :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadPushPromise+    :: EncodeInfo -> StreamId -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len   where     builder = (b4 :) . (hdr :)@@ -208,18 +219,20 @@     builder = (odata :)     header = FrameHeader 8 encodeFlags encodeStreamId -buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)+buildFramePayloadGoAway+    :: EncodeInfo -> StreamId -> ErrorCode -> ByteString -> (FrameHeader, Builder) buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder)   where     builder = (b8 :) . (debug :)     len0 = 8     b8 = unsafeCreate len0 $ \ptr -> do-        N.poke32 (fromIntegral sid)  ptr 0-        N.poke32 (fromErrorCodeId e) ptr 4+        N.poke32 (fromIntegral sid) ptr 0+        N.poke32 (fromErrorCode e) ptr 4     len = len0 + BS.length debug     header = FrameHeader len encodeFlags encodeStreamId -buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSize -> (FrameHeader, Builder)+buildFramePayloadWindowUpdate+    :: EncodeInfo -> WindowSize -> (FrameHeader, Builder) buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder)   where     -- fixme: reserve bit@@ -227,7 +240,8 @@     b4 = N.bytestring32 $ fromIntegral size     header = FrameHeader 4 encodeFlags encodeStreamId -buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadContinuation+    :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder)   where     builder = (hdr :)
Network/HTTP2/Frame/Types.hs view
@@ -1,84 +1,12 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} -module Network.HTTP2.Frame.Types (-  -- * Constant-    frameHeaderLength-  , maxPayloadLength-  -- * SettingsList-  , SettingsKeyId(..)-  , checkSettingsList-  , fromSettingsKeyId-  , SettingsValue-  , SettingsList-  , toSettingsKeyId-  -- * Settings-  , Settings(..)-  , defaultSettings-  , updateSettings-  -- * Error-  , HTTP2Error(..)-  , errorCodeId-  -- * Error code-  , ErrorCode-  , ErrorCodeId(..)-  , fromErrorCodeId-  , toErrorCodeId-  -- * Frame type-  , FrameType-  , minFrameType-  , maxFrameType-  , FrameTypeId(..)-  , fromFrameTypeId-  , toFrameTypeId-  -- * Frame-  , Frame(..)-  , FrameHeader(..)-  , FramePayload(..)-  , framePayloadToFrameTypeId-  , isPaddingDefined-  -- * Stream identifier-  , StreamId-  , isControl-  , isClientInitiated-  , isServerInitiated-  , isRequest-  , isResponse-  , testExclusive-  , setExclusive-  , clearExclusive-  -- * Flags-  , FrameFlags-  , defaultFlags-  , testEndStream-  , testAck-  , testEndHeader-  , testPadded-  , testPriority-  , setEndStream-  , setAck-  , setEndHeader-  , setPadded-  , setPriority-  -- * Window-  , WindowSize-  , defaultInitialWindowSize-  , maxWindowSize-  , isWindowOverflow-  -- * Misc-  , recommendedConcurrency-  -- * Types-  , HeaderBlockFragment-  , Weight-  , defaultWeight-  , Priority(..)-  , defaultPriority-  , highestPriority-  , Padding-  ) where+module Network.HTTP2.Frame.Types where -import qualified Control.Exception as E-import Data.Typeable+import Data.Ix+import Network.Control (WindowSize)+import Text.Read+import qualified Text.Read.Lex as L  import Imports @@ -94,208 +22,156 @@ ----------------------------------------------------------------  -- | The type for raw error code.-type ErrorCode = Word32+newtype ErrorCode = ErrorCode Word32 deriving (Eq, Ord, Read) --- | The type for error code. See <https://tools.ietf.org/html/rfc7540#section-7>.-data ErrorCodeId = NoError-                 | ProtocolError-                 | InternalError-                 | FlowControlError-                 | SettingsTimeout-                 | StreamClosed-                 | FrameSizeError-                 | RefusedStream-                 | Cancel-                 | CompressionError-                 | ConnectError-                 | EnhanceYourCalm-                 | InadequateSecurity-                 | HTTP11Required-                   -- our extensions-                 | UnknownErrorCode ErrorCode-                 deriving (Show, Read, Eq, Ord)+fromErrorCode :: ErrorCode -> Word32+fromErrorCode (ErrorCode w) = w --- | Converting 'ErrorCodeId' to 'ErrorCode'.------ >>> fromErrorCodeId NoError--- 0--- >>> fromErrorCodeId InadequateSecurity--- 12-fromErrorCodeId :: ErrorCodeId -> ErrorCode-fromErrorCodeId NoError              = 0x0-fromErrorCodeId ProtocolError        = 0x1-fromErrorCodeId InternalError        = 0x2-fromErrorCodeId FlowControlError     = 0x3-fromErrorCodeId SettingsTimeout      = 0x4-fromErrorCodeId StreamClosed         = 0x5-fromErrorCodeId FrameSizeError       = 0x6-fromErrorCodeId RefusedStream        = 0x7-fromErrorCodeId Cancel               = 0x8-fromErrorCodeId CompressionError     = 0x9-fromErrorCodeId ConnectError         = 0xa-fromErrorCodeId EnhanceYourCalm      = 0xb-fromErrorCodeId InadequateSecurity   = 0xc-fromErrorCodeId HTTP11Required       = 0xd-fromErrorCodeId (UnknownErrorCode w) = w+toErrorCode :: Word32 -> ErrorCode+toErrorCode = ErrorCode --- | Converting 'ErrorCode' to 'ErrorCodeId'.------ >>> toErrorCodeId 0--- NoError--- >>> toErrorCodeId 0xc--- InadequateSecurity--- >>> toErrorCodeId 0xe--- UnknownErrorCode 14-toErrorCodeId :: ErrorCode -> ErrorCodeId-toErrorCodeId 0x0 = NoError-toErrorCodeId 0x1 = ProtocolError-toErrorCodeId 0x2 = InternalError-toErrorCodeId 0x3 = FlowControlError-toErrorCodeId 0x4 = SettingsTimeout-toErrorCodeId 0x5 = StreamClosed-toErrorCodeId 0x6 = FrameSizeError-toErrorCodeId 0x7 = RefusedStream-toErrorCodeId 0x8 = Cancel-toErrorCodeId 0x9 = CompressionError-toErrorCodeId 0xa = ConnectError-toErrorCodeId 0xb = EnhanceYourCalm-toErrorCodeId 0xc = InadequateSecurity-toErrorCodeId 0xd = HTTP11Required-toErrorCodeId w   = UnknownErrorCode w+-- | The type for error code. See <https://www.rfc-editor.org/rfc/rfc9113#ErrorCodes>. -----------------------------------------------------------------+{- FOURMOLU_DISABLE -}+pattern NoError            :: ErrorCode+pattern NoError             = ErrorCode 0x0 --- | The connection error or the stream error.-data HTTP2Error = ConnectionError ErrorCodeId ByteString-                | StreamError ErrorCodeId StreamId-                deriving (Eq, Show, Typeable, Read)+pattern ProtocolError      :: ErrorCode+pattern ProtocolError       = ErrorCode 0x1 -instance E.Exception HTTP2Error+pattern InternalError      :: ErrorCode+pattern InternalError       = ErrorCode 0x2 --- | Obtaining 'ErrorCodeId' from 'HTTP2Error'.-errorCodeId :: HTTP2Error -> ErrorCodeId-errorCodeId (ConnectionError err _) = err-errorCodeId (StreamError     err _) = err+pattern FlowControlError   :: ErrorCode+pattern FlowControlError    = ErrorCode 0x3 +pattern SettingsTimeout    :: ErrorCode+pattern SettingsTimeout     = ErrorCode 0x4++pattern StreamClosed       :: ErrorCode+pattern StreamClosed        = ErrorCode 0x5++pattern FrameSizeError     :: ErrorCode+pattern FrameSizeError      = ErrorCode 0x6++pattern RefusedStream      :: ErrorCode+pattern RefusedStream       = ErrorCode 0x7++pattern Cancel             :: ErrorCode+pattern Cancel              = ErrorCode 0x8++pattern CompressionError   :: ErrorCode+pattern CompressionError    = ErrorCode 0x9++pattern ConnectError       :: ErrorCode+pattern ConnectError        = ErrorCode 0xa++pattern EnhanceYourCalm    :: ErrorCode+pattern EnhanceYourCalm     = ErrorCode 0xb++pattern InadequateSecurity :: ErrorCode+pattern InadequateSecurity  = ErrorCode 0xc++pattern HTTP11Required     :: ErrorCode+pattern HTTP11Required      = ErrorCode 0xd+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+instance Show ErrorCode where+    show NoError            = "NoError"+    show ProtocolError      = "ProtocolError"+    show InternalError      = "InternalError"+    show FlowControlError   = "FlowControlError"+    show SettingsTimeout    = "SettingsTimeout"+    show StreamClosed       = "StreamClosed"+    show FrameSizeError     = "FrameSizeError"+    show RefusedStream      = "RefusedStream"+    show Cancel             = "Cancel"+    show CompressionError   = "CompressionError"+    show ConnectError       = "ConnectError"+    show EnhanceYourCalm    = "EnhanceYourCalm"+    show InadequateSecurity = "InadequateSecurity"+    show HTTP11Required     = "HTTP11Required"+    show (ErrorCode x)      = "ErrorCode " ++ show x+{- FOURMOLU_ENABLE -}+ ----------------------------------------------------------------  -- | The type for SETTINGS key.-data SettingsKeyId = SettingsHeaderTableSize-                   | SettingsEnablePush-                   | SettingsMaxConcurrentStreams-                   | SettingsInitialWindowSize-                   | SettingsMaxFrameSize -- this means payload size-                   | SettingsMaxHeaderBlockSize-                   deriving (Show, Read, Eq, Ord, Enum, Bounded)+newtype SettingsKey = SettingsKey Word16 deriving (Eq, Ord) --- | The type for raw SETTINGS value.-type SettingsValue = Int -- Word32+fromSettingsKey :: SettingsKey -> Word16+fromSettingsKey (SettingsKey x) = x --- | Converting 'SettingsKeyId' to raw value.------ >>> fromSettingsKeyId SettingsHeaderTableSize--- 1--- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize--- 6-fromSettingsKeyId :: SettingsKeyId -> Word16-fromSettingsKeyId x = fromIntegral (fromEnum x) + 1+toSettingsKey :: Word16 -> SettingsKey+toSettingsKey = SettingsKey -minSettingsKeyId :: Word16-minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId)+minSettingsKey :: SettingsKey+minSettingsKey = SettingsKey 1 -maxSettingsKeyId :: Word16-maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId)+maxSettingsKey :: SettingsKey+maxSettingsKey = SettingsKey 6 --- | Converting raw value to 'SettingsKeyId'.------ >>> toSettingsKeyId 0--- Nothing--- >>> toSettingsKeyId 1--- Just SettingsHeaderTableSize--- >>> toSettingsKeyId 6--- Just SettingsMaxHeaderBlockSize--- >>> toSettingsKeyId 7--- Nothing-toSettingsKeyId :: Word16 -> Maybe SettingsKeyId-toSettingsKeyId x-  | minSettingsKeyId <= n && n <= maxSettingsKeyId = Just . toEnum . fromIntegral $ n-  | otherwise                                = Nothing-  where-    n = x - 1+{- FOURMOLU_DISABLE -}+pattern SettingsTokenHeaderTableSize :: SettingsKey+pattern SettingsTokenHeaderTableSize  = SettingsKey 1 -----------------------------------------------------------------+pattern SettingsEnablePush           :: SettingsKey+pattern SettingsEnablePush            = SettingsKey 2 --- | Association list of SETTINGS.-type SettingsList = [(SettingsKeyId,SettingsValue)]+pattern SettingsMaxConcurrentStreams :: SettingsKey+pattern SettingsMaxConcurrentStreams  = SettingsKey 3 --- | Checking 'SettingsList' and reporting an error if any.------ >>> checkSettingsList [(SettingsEnablePush,2)]--- Just (ConnectionError ProtocolError "enable push must be 0 or 1")-checkSettingsList :: SettingsList -> Maybe HTTP2Error-checkSettingsList settings = case mapMaybe checkSettingsValue settings of-    []    -> Nothing-    (x:_) -> Just x+pattern SettingsInitialWindowSize    :: SettingsKey+pattern SettingsInitialWindowSize     = SettingsKey 4 -checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error-checkSettingsValue (SettingsEnablePush,v)-  | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1"-checkSettingsValue (SettingsInitialWindowSize,v)-  | v > 2147483647   = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535"-checkSettingsValue (SettingsMaxFrameSize,v)-  | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215"-checkSettingsValue _ = Nothing+pattern SettingsMaxFrameSize         :: SettingsKey+pattern SettingsMaxFrameSize          = SettingsKey 5 -- this means payload size -----------------------------------------------------------------+pattern SettingsMaxHeaderListSize    :: SettingsKey+pattern SettingsMaxHeaderListSize     = SettingsKey 6+{- FOURMOLU_ENABLE -} --- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context.-data Settings = Settings {-    headerTableSize :: Int-  , enablePush :: Bool-  , maxConcurrentStreams :: Maybe Int-  , initialWindowSize :: WindowSize-  , maxFrameSize :: Int-  , maxHeaderBlockSize :: Maybe Int-  } deriving (Show)+{- FOURMOLU_DISABLE -}+instance Show SettingsKey where+    show SettingsTokenHeaderTableSize = "SettingsTokenHeaderTableSize"+    show SettingsEnablePush           = "SettingsEnablePush"+    show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams"+    show SettingsInitialWindowSize    = "SettingsInitialWindowSize"+    show SettingsMaxFrameSize         = "SettingsMaxFrameSize"+    show SettingsMaxHeaderListSize    = "SettingsMaxHeaderListSize"+    show (SettingsKey x)              = "SettingsKey " ++ show x+{- FOURMOLU_ENABLE -} --- | The default settings.------ >>> defaultSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Nothing}-defaultSettings :: Settings-defaultSettings = Settings {-    headerTableSize = 4096-  , enablePush = True-  , maxConcurrentStreams = Nothing-  , initialWindowSize = defaultInitialWindowSize-  , maxFrameSize = 16384-  , maxHeaderBlockSize = Nothing-  }+instance Read SettingsKey where+    readListPrec = readListPrecDefault+    readPrec = do+        Ident idnt <- lexP+        readSK idnt+      where+        readSK "SettingsTokenHeaderTableSize" = return SettingsTokenHeaderTableSize+        readSK "SettingsEnablePush" = return SettingsEnablePush+        readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams+        readSK "SettingsInitialWindowSize" = return SettingsInitialWindowSize+        readSK "SettingsMaxFrameSize" = return SettingsMaxFrameSize+        readSK "SettingsMaxHeaderListSize" = return SettingsMaxHeaderListSize+        readSK "SettingsKey" = do+            Number ftyp <- lexP+            return $ SettingsKey $ fromIntegral $ fromJust $ L.numberToInteger ftyp+        readSK _ = error "Read for SettingsKey" --- | Updating settings.------ >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)]--- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200}-updateSettings :: Settings -> SettingsList -> Settings-updateSettings settings kvs = foldl' update settings kvs-  where-    update def (SettingsHeaderTableSize,x)      = def { headerTableSize = x }-    -- fixme: x should be 0 or 1-    update def (SettingsEnablePush,x)           = def { enablePush = x > 0 }-    update def (SettingsMaxConcurrentStreams,x) = def { maxConcurrentStreams = Just x }-    update def (SettingsInitialWindowSize,x)    = def { initialWindowSize = x }-    update def (SettingsMaxFrameSize,x)         = def { maxFrameSize = x }-    update def (SettingsMaxHeaderBlockSize,x)   = def { maxHeaderBlockSize = Just x }+-- | The type for raw SETTINGS value.+type SettingsValue = Int -- Word32 --- | The type for window size.-type WindowSize = Int+-- | Association list of SETTINGS.+type SettingsList = [(SettingsKey, SettingsValue)]  -- | The default initial window size. ----- >>> defaultInitialWindowSize+-- >>> defaultWindowSize -- 65535-defaultInitialWindowSize :: WindowSize-defaultInitialWindowSize = 65535+defaultWindowSize :: WindowSize+defaultWindowSize = 65535  -- | The maximum window size. --@@ -313,8 +189,7 @@ -- >>> isWindowOverflow (maxWindowSize + 1) -- True isWindowOverflow :: WindowSize -> Bool-isWindowOverflow w = testBit w 31-+isWindowOverflow w = w > maxWindowSize  -- | Default concurrency. --@@ -326,113 +201,126 @@ ----------------------------------------------------------------  -- | The type for weight in priority. Its values are from 1 to 256.+--   Deprecated in RFC 9113. type Weight = Int --- | Default weight.------ >>> defaultWeight--- 16-defaultWeight :: Weight-defaultWeight = 16-{-# DEPRECATED defaultWeight "Don't use this" #-}+-- | Type for stream priority. Deprecated in RFC 9113 but provided for 'FrameHeaders'.+data Priority = Priority+    { exclusive :: Bool+    , streamDependency :: StreamId+    , weight :: Weight+    }+    deriving (Show, Read, Eq) --- | Type for stream priority-data Priority = Priority {-    exclusive :: Bool-  , streamDependency :: StreamId-  , weight :: Weight-  } deriving (Show, Read, Eq)+---------------------------------------------------------------- --- | Default priority which depends on stream 0.------ >>> defaultPriority--- Priority {exclusive = False, streamDependency = 0, weight = 16}-defaultPriority :: Priority-defaultPriority = Priority False 0 defaultWeight+-- | The type for raw frame type.+newtype FrameType = FrameType Word8 deriving (Eq, Ord, Ix) --- | Highest priority which depends on stream 0.+-- | Converting 'FrameType' to 'Word8'. ----- >>> highestPriority--- Priority {exclusive = False, streamDependency = 0, weight = 256}-highestPriority :: Priority-highestPriority = Priority False 0 256------------------------------------------------------------------+-- >>> fromFrameType FrameData+-- 0+-- >>> fromFrameType FrameContinuation+-- 9+fromFrameType :: FrameType -> Word8+fromFrameType (FrameType x) = x --- | The type for raw frame type.-type FrameType = Word8+toFrameType :: Word8 -> FrameType+toFrameType = FrameType  minFrameType :: FrameType-minFrameType = 0+minFrameType = FrameType 0  maxFrameType :: FrameType-maxFrameType = 9+maxFrameType = FrameType 9 --- | The type for frame type.-data FrameTypeId = FrameData-                 | FrameHeaders-                 | FramePriority-                 | FrameRSTStream-                 | FrameSettings-                 | FramePushPromise-                 | FramePing-                 | FrameGoAway-                 | FrameWindowUpdate-                 | FrameContinuation-                 | FrameUnknown FrameType-                 deriving (Show, Eq, Ord)+{- FOURMOLU_DISABLE -}+pattern FrameData         :: FrameType+pattern FrameData          = FrameType 0 --- | Converting 'FrameTypeId' to 'FrameType'.------ >>> fromFrameTypeId FrameData--- 0--- >>> fromFrameTypeId FrameContinuation--- 9--- >>> fromFrameTypeId (FrameUnknown 10)--- 10-fromFrameTypeId :: FrameTypeId -> FrameType-fromFrameTypeId FrameData         = 0-fromFrameTypeId FrameHeaders      = 1-fromFrameTypeId FramePriority     = 2-fromFrameTypeId FrameRSTStream    = 3-fromFrameTypeId FrameSettings     = 4-fromFrameTypeId FramePushPromise  = 5-fromFrameTypeId FramePing         = 6-fromFrameTypeId FrameGoAway       = 7-fromFrameTypeId FrameWindowUpdate = 8-fromFrameTypeId FrameContinuation = 9-fromFrameTypeId (FrameUnknown x)  = x+pattern FrameHeaders      :: FrameType+pattern FrameHeaders       = FrameType 1 --- | Converting 'FrameType' to 'FrameTypeId'.------ >>> toFrameTypeId 0--- FrameData--- >>> toFrameTypeId 9--- FrameContinuation--- >>> toFrameTypeId 10--- FrameUnknown 10-toFrameTypeId :: FrameType -> FrameTypeId-toFrameTypeId  0 = FrameData-toFrameTypeId  1 = FrameHeaders-toFrameTypeId  2 = FramePriority-toFrameTypeId  3 = FrameRSTStream-toFrameTypeId  4 = FrameSettings-toFrameTypeId  5 = FramePushPromise-toFrameTypeId  6 = FramePing-toFrameTypeId  7 = FrameGoAway-toFrameTypeId  8 = FrameWindowUpdate-toFrameTypeId  9 = FrameContinuation-toFrameTypeId  x = FrameUnknown x+pattern FramePriority     :: FrameType+pattern FramePriority      = FrameType 2 +pattern FrameRSTStream    :: FrameType+pattern FrameRSTStream     = FrameType 3++pattern FrameSettings     :: FrameType+pattern FrameSettings      = FrameType 4++pattern FramePushPromise  :: FrameType+pattern FramePushPromise   = FrameType 5++pattern FramePing         :: FrameType+pattern FramePing          = FrameType 6++pattern FrameGoAway       :: FrameType+pattern FrameGoAway        = FrameType 7++pattern FrameWindowUpdate :: FrameType+pattern FrameWindowUpdate  = FrameType 8++pattern FrameContinuation :: FrameType+pattern FrameContinuation  = FrameType 9+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+instance Show FrameType where+    show FrameData         = "FrameData"+    show FrameHeaders      = "FrameHeaders"+    show FramePriority     = "FramePriority"+    show FrameRSTStream    = "FrameRSTStream"+    show FrameSettings     = "FrameSettings"+    show FramePushPromise  = "FramePushPromise"+    show FramePing         = "FramePing"+    show FrameGoAway       = "FrameGoAway"+    show FrameWindowUpdate = "FrameWindowUpdate"+    show FrameContinuation = "FrameContinuation"+    show (FrameType x)     = "FrameType " ++ show x+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+instance Read FrameType where+    readListPrec = readListPrecDefault+    readPrec = do+        Ident idnt <- lexP+        readFT idnt+      where+        readFT "FrameData"         = return FrameData+        readFT "FrameHeaders"      = return FrameHeaders+        readFT "FramePriority"     = return FramePriority+        readFT "FrameRSTStream"    = return FrameRSTStream+        readFT "FrameSettings"     = return FrameSettings+        readFT "FramePushPromise"  = return FramePushPromise+        readFT "FramePing"         = return FramePing+        readFT "FrameGoAway"       = return FrameGoAway+        readFT "FrameWindowUpdate" = return FrameWindowUpdate+        readFT "FrameContinuation" = return FrameContinuation+        readFT "FrameType"         = do+              Number ftyp <- lexP+              return $ FrameType $ fromIntegral $ fromJust $ L.numberToInteger ftyp+        readFT _                   = error "Read for FrameType"+{- FOURMOLU_ENABLE -}+ ---------------------------------------------------------------- --- | The maximum length of HTTP/2 payload.+-- | The maximum payload length of HTTP/2 payload. -- -- >>> maxPayloadLength--- 16384+-- 16777215 maxPayloadLength :: Int-maxPayloadLength = 2^(14::Int)+maxPayloadLength = 2 ^ (24 :: Int) - 1 +-- | The default payload length of HTTP/2 payload.+--+-- >>> defaultPayloadLength+-- 16384+defaultPayloadLength :: Int+defaultPayloadLength = 2 ^ (14 :: Int)+ ---------------------------------------------------------------- -- Flags @@ -548,27 +436,6 @@ isServerInitiated 0 = False isServerInitiated n = even n --- | Checking if the stream identifier for request.------ >>> isRequest 0--- False--- >>> isRequest 1--- True-isRequest :: StreamId -> Bool-isRequest = odd-{-# DEPRECATED isRequest "Use isClientInitiated instead" #-}---- | Checking if the stream identifier for response.------ >>> isResponse 0--- False--- >>> isResponse 2--- True-isResponse :: StreamId -> Bool-isResponse 0 = False-isResponse n = even n-{-# DEPRECATED isResponse "Use isServerInitiated instead" #-}- -- | Checking if the exclusive flag is set. testExclusive :: StreamId -> Bool testExclusive n = n `testBit` 31@@ -593,50 +460,54 @@  -- | The data type for HTTP/2 frames. data Frame = Frame-    { frameHeader  :: FrameHeader+    { frameHeader :: FrameHeader     , framePayload :: FramePayload-    } deriving (Show, Read, Eq)+    }+    deriving (Show, Read, Eq)  -- | The data type for HTTP/2 frame headers. data FrameHeader = FrameHeader     { payloadLength :: Int-    , flags         :: FrameFlags-    , streamId      :: StreamId-    } deriving (Show, Read, Eq)+    , flags :: FrameFlags+    , streamId :: StreamId+    }+    deriving (Show, Read, Eq)  -- | The data type for HTTP/2 frame payloads.-data FramePayload =-    DataFrame ByteString-  | HeadersFrame (Maybe Priority) HeaderBlockFragment-  | PriorityFrame Priority-  | RSTStreamFrame ErrorCodeId-  | SettingsFrame SettingsList-  | PushPromiseFrame StreamId HeaderBlockFragment-  | PingFrame ByteString-  | GoAwayFrame StreamId ErrorCodeId ByteString-  | WindowUpdateFrame WindowSize-  | ContinuationFrame HeaderBlockFragment-  | UnknownFrame FrameType ByteString-  deriving (Show, Read, Eq)+data FramePayload+    = DataFrame ByteString+    | HeadersFrame (Maybe Priority) HeaderBlockFragment+    | PriorityFrame Priority+    | RSTStreamFrame ErrorCode+    | SettingsFrame SettingsList+    | PushPromiseFrame StreamId HeaderBlockFragment+    | PingFrame ByteString+    | GoAwayFrame {- the last -} StreamId ErrorCode ByteString+    | WindowUpdateFrame WindowSize+    | ContinuationFrame HeaderBlockFragment+    | UnknownFrame FrameType ByteString+    deriving (Show, Read, Eq)  ----------------------------------------------------------------  -- | Getting 'FrameType' from 'FramePayload'. ----- >>> framePayloadToFrameTypeId (DataFrame "body")+-- >>> framePayloadToFrameType (DataFrame "body") -- FrameData-framePayloadToFrameTypeId :: FramePayload -> FrameTypeId-framePayloadToFrameTypeId DataFrame{}          = FrameData-framePayloadToFrameTypeId HeadersFrame{}       = FrameHeaders-framePayloadToFrameTypeId PriorityFrame{}      = FramePriority-framePayloadToFrameTypeId RSTStreamFrame{}     = FrameRSTStream-framePayloadToFrameTypeId SettingsFrame{}      = FrameSettings-framePayloadToFrameTypeId PushPromiseFrame{}   = FramePushPromise-framePayloadToFrameTypeId PingFrame{}          = FramePing-framePayloadToFrameTypeId GoAwayFrame{}        = FrameGoAway-framePayloadToFrameTypeId WindowUpdateFrame{}  = FrameWindowUpdate-framePayloadToFrameTypeId ContinuationFrame{}  = FrameContinuation-framePayloadToFrameTypeId (UnknownFrame w8 _)  = FrameUnknown w8+{- FOURMOLU_DISABLE -}+framePayloadToFrameType :: FramePayload -> FrameType+framePayloadToFrameType DataFrame{}          = FrameData+framePayloadToFrameType HeadersFrame{}       = FrameHeaders+framePayloadToFrameType PriorityFrame{}      = FramePriority+framePayloadToFrameType RSTStreamFrame{}     = FrameRSTStream+framePayloadToFrameType SettingsFrame{}      = FrameSettings+framePayloadToFrameType PushPromiseFrame{}   = FramePushPromise+framePayloadToFrameType PingFrame{}          = FramePing+framePayloadToFrameType GoAwayFrame{}        = FrameGoAway+framePayloadToFrameType WindowUpdateFrame{}  = FrameWindowUpdate+framePayloadToFrameType ContinuationFrame{}  = FrameContinuation+framePayloadToFrameType (UnknownFrame ft _)  = ft+{- FOURMOLU_ENABLE -}  ---------------------------------------------------------------- @@ -646,6 +517,7 @@ -- True -- >>> isPaddingDefined $ PingFrame "" -- False+{- FOURMOLU_DISABLE -} isPaddingDefined :: FramePayload -> Bool isPaddingDefined DataFrame{}         = True isPaddingDefined HeadersFrame{}      = True@@ -658,3 +530,16 @@ isPaddingDefined WindowUpdateFrame{} = False isPaddingDefined ContinuationFrame{} = False isPaddingDefined UnknownFrame{}      = False+{- FOURMOLU_ENABLE -}++----------------------------------------------------------------+-- Deprecated++{- FOURMOLU_DISABLE -}+type ErrorCodeId   = ErrorCode+type SettingsKeyId = SettingsKey+type FrameTypeId   = FrameType+{- FOURMOLU_ENABLE -}+{-# DEPRECATED ErrorCodeId "Use ErrorCode instead" #-}+{-# DEPRECATED SettingsKeyId "Use SettingsKey instead" #-}+{-# DEPRECATED FrameTypeId "Use FrameType instead" #-}
+ Network/HTTP2/H2.hs view
@@ -0,0 +1,29 @@+module Network.HTTP2.H2 (+    module Network.HTTP2.H2.Config,+    module Network.HTTP2.H2.Context,+    module Network.HTTP2.H2.EncodeFrame,+    module Network.HTTP2.H2.HPACK,+    module Network.HTTP2.H2.Queue,+    module Network.HTTP2.H2.Receiver,+    module Network.HTTP2.H2.Sender,+    module Network.HTTP2.H2.Settings,+    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++import Network.HTTP2.H2.Config+import Network.HTTP2.H2.Context+import Network.HTTP2.H2.EncodeFrame+import Network.HTTP2.H2.HPACK+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.Receiver+import Network.HTTP2.H2.Sender+import Network.HTTP2.H2.Settings+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
@@ -0,0 +1,42 @@+{-# 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.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 = 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 ()+freeSimpleConfig conf = do+    free $ confWriteBuffer conf+    T.killManager $ confTimeoutManager conf
+ Network/HTTP2/H2/Context.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++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.Socket (SockAddr)+import qualified System.ThreadManager as T++import Imports hiding (insert)+import Network.HPACK+import Network.HTTP2.Frame+import Network.HTTP2.H2.Settings+import Network.HTTP2.H2.Stream+import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Types++data Role = Client | Server deriving (Eq, Show)++----------------------------------------------------------------++data RoleInfo = RIS ServerInfo | RIC ClientInfo++type Launch = Context -> Stream -> InpObj -> IO ()++newtype ServerInfo = ServerInfo+    { launch :: Launch+    }++data ClientInfo = ClientInfo+    { scheme :: ByteString+    , authority :: Authority+    }++toServerInfo :: RoleInfo -> ServerInfo+toServerInfo (RIS x) = x+toServerInfo _ = error "toServerInfo"++toClientInfo :: RoleInfo -> ClientInfo+toClientInfo (RIC x) = x+toClientInfo _ = error "toClientInfo"++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+    , -- Settings+      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+    , 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+    , 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 roleInfo Config{..} cacheSiz connRxWS mySettings timmgr mdone = do+    -- My: Use this even if ack has not been received yet.+    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+    role = case roleInfo of+        RIC{} -> Client+        _ -> Server+    sid0+        | role == Client = 1+        | otherwise = 2+    dlim = defaultPayloadLength + frameHeaderLength+    buflim+        | confBufferSize >= dlim = dlim+        | otherwise = confBufferSize+{- FOURMOLU_ENABLE -}++----------------------------------------------------------------++isClient :: Context -> Bool+isClient ctx = role ctx == Client++isServer :: Context -> Bool+isServer ctx = role ctx == Server++----------------------------------------------------------------++getMyNewStreamId :: Context -> STM StreamId+getMyNewStreamId Context{..} = do+    n <- readTVar myStreamId+    let n' = n + 2+    writeTVar myStreamId n'+    return n++getPeerStreamID :: Context -> IO StreamId+getPeerStreamID ctx = readIORef $ peerStreamId ctx++setPeerStreamID :: Context -> StreamId -> IO ()+setPeerStreamID ctx sid = writeIORef (peerStreamId ctx) sid++----------------------------------------------------------------++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 ()+    writeIORef streamState newState++opened :: Context -> Stream -> IO ()+opened ctx strm = setStreamState ctx strm (Open Nothing JustOpened)++halfClosedRemote :: Context -> Stream -> IO ()+halfClosedRemote ctx stream@Stream{streamState} = do+    closingCode <- atomicModifyIORef streamState closeHalf+    traverse_ (closed ctx stream) closingCode+  where+    closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)+    closeHalf x@(Closed _) = (x, Nothing)+    closeHalf (Open (Just cc) _) = (Closed cc, Just cc)+    closeHalf _ = (HalfClosedRemote, Nothing)++halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()+halfClosedLocal ctx stream@Stream{streamState} cc = do+    shouldFinalize <- atomicModifyIORef streamState closeHalf+    when shouldFinalize $+        closed ctx stream cc+  where+    closeHalf :: StreamState -> (StreamState, Bool)+    closeHalf x@(Closed _) = (x, False)+    closeHalf HalfClosedRemote = (Closed cc, True)+    closeHalf (Open Nothing o) = (Open (Just cc) o, False)+    closeHalf _ = (Open (Just cc) JustOpened, False)++closed :: Context -> Stream -> ClosedCode -> IO ()+closed ctx@Context{oddStreamTable, evenStreamTable} strm@Stream{streamNumber} cc = do+    if isServerInitiated streamNumber+        then deleteEven evenStreamTable streamNumber err+        else deleteOdd oddStreamTable streamNumber err+    setStreamState ctx strm (Closed cc) -- anyway+  where+    err :: SomeException+    err = toException (closedCodeToError streamNumber cc)++----------------------------------------------------------------+-- From peer++-- Server+openOddStreamCheck :: Context -> StreamId -> FrameType -> IO Stream+openOddStreamCheck ctx@Context{oddStreamTable, peerSettings, mySettings} sid ftyp = do+    -- My SETTINGS_MAX_CONCURRENT_STREAMS+    when (ftyp == FrameHeaders) $ do+        conc <- getOddConcurrency oddStreamTable+        checkMyConcurrency sid mySettings (conc + 1)+    txws <- initialWindowSize <$> readIORef peerSettings+    let rxws = initialWindowSize mySettings+    newstrm <- newOddStream sid txws rxws+    when (ftyp == FrameHeaders || ftyp == FramePushPromise) $ opened ctx newstrm+    insertOdd oddStreamTable sid newstrm+    return newstrm++-- Client+openEvenStreamCacheCheck :: Context -> StreamId -> Method -> ByteString -> IO ()+openEvenStreamCacheCheck Context{evenStreamTable, peerSettings, mySettings} sid method path = do+    -- My SETTINGS_MAX_CONCURRENT_STREAMS+    conc <- getEvenConcurrency evenStreamTable+    checkMyConcurrency sid mySettings (conc + 1)+    txws <- initialWindowSize <$> readIORef peerSettings+    let rxws = initialWindowSize mySettings+    newstrm <- newEvenStream sid txws rxws+    insertEvenCache evenStreamTable method path newstrm++checkMyConcurrency+    :: StreamId -> Settings -> Int -> IO ()+checkMyConcurrency sid settings conc = do+    let mMaxConc = maxConcurrentStreams settings+    case mMaxConc of+        Nothing -> return ()+        Just maxConc ->+            when (conc > maxConc) $+                E.throwIO $+                    StreamErrorIsSent RefusedStream sid "exceeds max concurrent"++----------------------------------------------------------------+-- From me++-- Clinet+openOddStreamWait :: Context -> IO (StreamId, Stream)+openOddStreamWait ctx@Context{oddStreamTable, mySettings, peerSettings} = do+    -- Peer SETTINGS_MAX_CONCURRENT_STREAMS+    mMaxConc <- maxConcurrentStreams <$> readIORef peerSettings+    let rxws = initialWindowSize mySettings+    case mMaxConc of+        Nothing -> do+            sid <- atomically $ getMyNewStreamId ctx+            txws <- initialWindowSize <$> readIORef peerSettings+            newstrm <- newOddStream sid txws rxws+            insertOdd oddStreamTable sid newstrm+            return (sid, newstrm)+        Just maxConc -> do+            sid <- atomically $ do+                waitIncOdd oddStreamTable maxConc+                getMyNewStreamId ctx+            txws <- initialWindowSize <$> readIORef peerSettings+            newstrm <- newOddStream sid txws rxws+            insertOdd' oddStreamTable sid newstrm+            return (sid, newstrm)++-- Server+openEvenStreamWait :: Context -> IO (StreamId, Stream)+openEvenStreamWait ctx@Context{..} = do+    -- Peer SETTINGS_MAX_CONCURRENT_STREAMS+    mMaxConc <- maxConcurrentStreams <$> readIORef peerSettings+    let rxws = initialWindowSize mySettings+    case mMaxConc of+        Nothing -> do+            sid <- atomically $ getMyNewStreamId ctx+            txws <- initialWindowSize <$> readIORef peerSettings+            newstrm <- newEvenStream sid txws rxws+            insertEven evenStreamTable sid newstrm+            return (sid, newstrm)+        Just maxConc -> do+            sid <- atomically $ do+                waitIncEven evenStreamTable maxConc+                getMyNewStreamId ctx+            txws <- initialWindowSize <$> readIORef peerSettings+            newstrm <- newEvenStream sid txws rxws+            insertEven' evenStreamTable sid newstrm+            return (sid, newstrm)
+ Network/HTTP2/H2/EncodeFrame.hs view
@@ -0,0 +1,34 @@+module Network.HTTP2.H2.EncodeFrame where++import Network.HTTP2.Frame++import Imports++----------------------------------------------------------------++goawayFrame :: StreamId -> ErrorCode -> ByteString -> ByteString+goawayFrame sid etype debugmsg = encodeFrame einfo frame+  where+    einfo = encodeInfo id 0+    frame = GoAwayFrame sid etype debugmsg++resetFrame :: ErrorCode -> StreamId -> ByteString+resetFrame etype sid = encodeFrame einfo frame+  where+    einfo = encodeInfo id sid+    frame = RSTStreamFrame etype++settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist+  where+    einfo = encodeInfo func 0++pingFrame :: Bool -> ByteString -> ByteString+pingFrame ack bs = encodeFrame einfo $ PingFrame bs+  where+    einfo = encodeInfo (if ack then setAck else id) 0++windowUpdateFrame :: StreamId -> WindowSize -> ByteString+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz+  where+    einfo = encodeInfo id sid
+ Network/HTTP2/H2/HPACK.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.H2.HPACK (+    hpackEncodeHeader,+    hpackEncodeHeaderLoop,+    hpackDecodeHeader,+    hpackDecodeTrailer,+    just,+    fixHeaders,+) where++import qualified Control.Exception as E+import Network.ByteOrder+import Network.HTTP.Semantics+import Network.HTTP.Types++import Imports+import Network.HPACK+import Network.HTTP2.Frame+import Network.HTTP2.H2.Context+import Network.HTTP2.H2.Types++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++fixHeaders :: ResponseHeaders -> ResponseHeaders+fixHeaders hdr = deleteUnnecessaryHeaders hdr++deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders+deleteUnnecessaryHeaders hdr = filter del hdr+  where+    del (k, _) = k `notElem` headersToBeRemoved++headersToBeRemoved :: [HeaderName]+headersToBeRemoved =+    [ hConnection+    , "Transfer-Encoding"+    -- Keep-Alive+    -- Proxy-Connection+    -- Upgrade+    ]++----------------------------------------------------------------++strategy :: EncodeStrategy+strategy = EncodeStrategy{compressionAlgo = Linear, useHuffman = False}++-- Set-Cookie: contains only one cookie value.+-- So, we don't need to split it.+hpackEncodeHeader+    :: Context+    -> Buffer+    -> BufferSize+    -> TokenHeaderList+    -> IO (TokenHeaderList, Int)+hpackEncodeHeader Context{..} buf siz ths =+    encodeTokenHeader buf siz strategy True encodeDynamicTable ths++hpackEncodeHeaderLoop+    :: Context+    -> Buffer+    -> BufferSize+    -> TokenHeaderList+    -> IO (TokenHeaderList, Int)+hpackEncodeHeaderLoop Context{..} buf siz hs =+    encodeTokenHeader buf siz strategy False encodeDynamicTable hs++----------------------------------------------------------------++hpackDecodeHeader+    :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable+hpackDecodeHeader hdrblk sid ctx = do+    tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx+    if isClient ctx || checkRequestHeader vt+        then return tbl+        else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header"++hpackDecodeTrailer+    :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable+hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl+  where+    handl IllegalHeaderName =+        E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal trailer"+    handl e = do+        let msg = fromString $ show e+        E.throwIO $ StreamErrorIsSent CompressionError sid msg++{-# INLINE checkRequestHeader #-}+checkRequestHeader :: ValueTable -> Bool+checkRequestHeader reqvt+    | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme+    | isJust mStatus = False+    | isNothing mMethod = False+    | isNothing mScheme = False+    | isNothing mPath = False+    | mPath == Just "" = False+    | isJust mConnection = False+    | just mTE (/= "trailers") = False+    | otherwise = checkAuth mAuthority mHost+  where+    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+checkAuth (Just a) (Just h) | a /= h = False+checkAuth _ _ = True++{-# INLINE just #-}+just :: Maybe a -> (a -> Bool) -> Bool+just Nothing _ = False+just (Just x) p+    | p x = True+    | otherwise = False
+ Network/HTTP2/H2/Queue.hs view
@@ -0,0 +1,19 @@+module Network.HTTP2.H2.Queue where++import Control.Concurrent.STM++import Network.HTTP2.H2.Types++{-# INLINE enqueueOutput #-}+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 ()+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl++----------------------------------------------------------------
+ Network/HTTP2/H2/Receiver.hs view
@@ -0,0 +1,710 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# 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 Network.HTTP.Semantics+import qualified System.ThreadManager as T++import Imports hiding (delete, insert)+import Network.HTTP2.Frame+import Network.HTTP2.H2.Context+import Network.HTTP2.H2.EncodeFrame+import Network.HTTP2.H2.HPACK+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.Settings+import Network.HTTP2.H2.Stream+import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Types+import Network.HTTP2.H2.Window++----------------------------------------------------------------++continuationLimit :: Int+continuationLimit = 10++headerFragmentLimit :: Int+headerFragmentLimit = 51200 -- 50K++----------------------------------------------------------------++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+    switch :: IO Void+    switch = do+        labelMe "H2 receiver"+        tid <- myThreadId+        if confReadNTimeout+            then+                loop1+            else+                T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2++    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 ()+processFrame ctx _conf (fid, FrameHeader{streamId})+    | isServer ctx+        && isServerInitiated streamId+        && (fid `notElem` [FramePriority, FrameRSTStream, FrameWindowUpdate]) =+        E.throwIO $+            ConnectionErrorIsSent ProtocolError streamId "stream id should be odd"+processFrame ctx _conf (FramePushPromise, FrameHeader{streamId})+    | isServer ctx =+        E.throwIO $+            ConnectionErrorIsSent ProtocolError streamId "push promise is not allowed"+processFrame Context{..} Config{..} (ftyp, FrameHeader{payloadLength, streamId})+    | ftyp > maxFrameType = do+        mx <- readIORef continued+        case mx of+            Nothing -> do+                -- ignoring unknown frame+                void $ confReadN payloadLength+            Just _ -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "unknown frame"+processFrame ctx@Context{..} conf typhdr@(ftyp, header) = do+    -- My SETTINGS_MAX_FRAME_SIZE+    -- My SETTINGS_ENABLE_PUSH+    case checkFrameHeader typhdr of+        Left (FrameDecodeError ec sid msg) -> E.throwIO $ ConnectionErrorIsSent ec sid msg+        Right _ -> do+            let Settings{maxFrameSize, enablePush} = mySettings+                sid = streamId header+            when (payloadLength header > maxFrameSize) $+                E.throwIO $+                    ConnectionErrorIsSent FrameSizeError sid "exceeds maximum frame size"+            when (not enablePush && ftyp == FramePushPromise) $+                E.throwIO $+                    ConnectionErrorIsSent ProtocolError sid "push not enabled"+            controlOrStream ctx conf ftyp header++----------------------------------------------------------------++controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()+controlOrStream ctx@Context{..} Config{..} ftyp header@FrameHeader{streamId, payloadLength}+    | isControl streamId = do+        bs <- confReadN payloadLength+        control ftyp header bs ctx+    | ftyp == FramePushPromise = do+        bs <- confReadN payloadLength+        push header bs ctx+    | otherwise = do+        checkContinued+        mstrm <- getStream ctx ftyp streamId+        bs <- confReadN payloadLength+        case mstrm of+            Just strm -> do+                state0 <- readStreamState strm+                state <- stream ftyp header bs ctx state0 strm+                resetContinued+                set <- processState state ctx strm streamId+                when set setContinued+            Nothing+                | ftyp == FramePriority -> do+                    -- for h2spec only+                    PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs+                    checkPriority newpri streamId+                | otherwise -> return ()+  where+    setContinued = writeIORef continued $ Just streamId+    resetContinued = writeIORef continued Nothing+    checkContinued = do+        mx <- readIORef continued+        case mx of+            Nothing -> return ()+            Just sid+                | sid == streamId && ftyp == FrameContinuation -> return ()+                | otherwise ->+                    E.throwIO $+                        ConnectionErrorIsSent ProtocolError streamId "continuation frame must follow"++----------------------------------------------------------------++processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool+-- Transition (process1)+processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do+    let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt)+    when (just mcl (/= (0 :: Int))) $+        E.throwIO $+            StreamErrorIsSent+                ProtocolError+                streamId+                "no body but content-length is not zero"+    tlr <- newIORef Nothing+    let inpObj = InpObj tbl (Just 0) (return (mempty, True)) tlr+    if isServer ctx+        then do+            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, 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+    bodySource <- mkSource q $ informWindowUpdate ctx strm+    let inpObj = InpObj tbl mcl (readSource bodySource) tlr+    if isServer ctx+        then do+            let ServerInfo{..} = toServerInfo roleInfo+            launch ctx strm inpObj+        else putMVar streamInput $ Right inpObj+    return False++-- Transition (process3)+processState s@(Open _ Continued{}) ctx strm _streamId = do+    setStreamState ctx strm s+    return True++-- Transition (process4)+processState HalfClosedRemote ctx strm _streamId = do+    halfClosedRemote ctx strm+    return False++-- Transition (process5)+processState (Closed cc) ctx strm _streamId = do+    closed ctx strm cc+    return False++-- Transition (process6)+processState s ctx strm _streamId = do+    -- Idle, Open Body, Closed+    setStreamState ctx strm s+    return False++----------------------------------------------------------------++{- FOURMOLU_DISABLE -}+getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)+getStream ctx@Context{..} ftyp streamId+  | isEven    = lookupEven evenStreamTable streamId >>= getEvenStream ctx ftyp+  | otherwise = lookupOdd oddStreamTable  streamId >>= getOddStream  ctx ftyp streamId+  where+    isEven = isServerInitiated streamId+{- FOURMOLU_ENABLE -}++getEvenStream :: Context -> FrameType -> Maybe Stream -> IO (Maybe Stream)+getEvenStream ctx ftyp js@(Just strm) = do+    when (ftyp == FrameHeaders) $ do+        st <- readStreamState strm+        when (isReserved st) $ halfClosedLocal ctx strm Finished+    return js+getEvenStream _ _ Nothing = return Nothing++getOddStream+    :: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)+getOddStream ctx ftyp streamId js@(Just strm0) = do+    when (ftyp == FrameHeaders) $ do+        st <- readStreamState strm0+        when (isHalfClosedRemote st) $+            E.throwIO $+                ConnectionErrorIsSent+                    StreamClosed+                    streamId+                    "header must not be sent to half or fully closed stream"+        -- Priority made an idle stream+        when (isIdle st) $ opened ctx strm0+    return js+getOddStream ctx ftyp streamId Nothing+    | isServer ctx = do+        csid <- getPeerStreamID ctx+        if streamId <= csid -- consider the stream closed+            then+                if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority]+                    then return Nothing -- will be ignored+                    else+                        E.throwIO $+                            ConnectionErrorIsSent+                                ProtocolError+                                streamId+                                "stream identifier must not decrease"+            else do+                -- consider the stream idle+                when (ftyp `notElem` [FrameHeaders, FramePriority]) $ do+                    let errmsg =+                            Short.toShort+                                ( "this frame is not allowed in an idle stream: "+                                    `BS.append` C8.pack (show ftyp)+                                )+                    E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg+                when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId+                -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit+                Just <$> openOddStreamCheck ctx streamId ftyp+    | otherwise =+        -- We received a frame from the server on an unknown stream+        -- (likely a previously created and then subsequently reset stream).+        -- We just drop it.+        return Nothing++----------------------------------------------------------------++type Payload = ByteString++control :: FrameType -> FrameHeader -> Payload -> Context -> IO ()+control FrameSettings header@FrameHeader{flags, streamId} bs Context{myFirstSettings, controlQ, settingsRate, mySettings, rxFlow} = do+    SettingsFrame peerAlist <- guardIt $ decodeSettingsFrame header bs+    traverse_ E.throwIO $ checkSettingsList peerAlist+    if testAck flags+        then do+            when (peerAlist /= []) $+                E.throwIO $+                    ConnectionErrorIsSent FrameSizeError streamId "ack settings has a body"+        else do+            -- Settings Flood - CVE-2019-9515+            rate <- getRate settingsRate+            when (rate > settingsRateLimit mySettings) $+                E.throwIO $+                    ConnectionErrorIsSent EnhanceYourCalm streamId "too many settings"+            let ack = settingsFrame setAck []+            sent <- readIORef myFirstSettings+            if sent+                then do+                    let setframe = CFrames (Just peerAlist) [ack]+                    enqueueControl controlQ setframe+                else do+                    -- Server side only+                    connRxWS <- rxfBufSize <$> readIORef rxFlow+                    let frames = makeNegotiationFrames mySettings connRxWS+                        setframe = CFrames (Just peerAlist) (frames ++ [ack])+                    writeIORef myFirstSettings True+                    enqueueControl controlQ setframe+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 sendPing ctx True bs+control FrameGoAway header bs _ = do+    GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs+    if err == NoError+        then E.throwIO ConnectionIsClosed+        else E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg+control FrameWindowUpdate header bs ctx = do+    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs+    increaseConnectionWindowSize ctx n+control _ _ _ _ =+    -- must not reach here+    return ()++----------------------------------------------------------------++-- Called in client only+push :: FrameHeader -> ByteString -> Context -> IO ()+push header@FrameHeader{streamId} bs ctx = do+    PushPromiseFrame sid frag <- guardIt $ decodePushPromiseFrame header bs+    unless (isServerInitiated sid) $+        E.throwIO $+            ConnectionErrorIsSent+                ProtocolError+                streamId+                "push promise must specify an even stream identifier"+    when (frag == "") $+        E.throwIO $+            ConnectionErrorIsSent+                ProtocolError+                streamId+                "wrong header fragment for push promise"+    (_, vt) <- hpackDecodeHeader frag streamId ctx+    let ClientInfo{..} = toClientInfo $ roleInfo ctx+    when+        ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority)+            && getFieldValue tokenScheme vt == Just scheme+        )+        $ do+            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+                    openEvenStreamCacheCheck ctx sid method path+                _ -> return ()++----------------------------------------------------------------++{-# INLINE guardIt #-}+guardIt :: Either FrameDecodeError a -> IO a+guardIt x = case x of+    Left (FrameDecodeError ec sid msg) -> E.throwIO $ ConnectionErrorIsSent ec sid msg+    Right frame -> return frame++{-# INLINE checkPriority #-}+checkPriority :: Priority -> StreamId -> IO ()+checkPriority p me+    | dep == me =+        E.throwIO $ StreamErrorIsSent ProtocolError me "priority depends on itself"+    | otherwise = return ()+  where+    dep = streamDependency p++stream+    :: FrameType+    -> FrameHeader+    -> ByteString+    -> Context+    -> StreamState+    -> Stream+    -> IO StreamState+-- Transition (stream1)+stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx s@(Open hcl JustOpened) Stream{streamNumber} = do+    HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs+    let endOfStream = testEndStream flags+        endOfHeader = testEndHeader flags+    if frag == "" && not endOfStream && not endOfHeader+        then do+            -- Empty Frame Flooding - CVE-2019-9518+            rate <- getRate $ emptyFrameRate ctx+            if rate > emptyFrameRateLimit (mySettings ctx)+                then+                    E.throwIO $+                        ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty headers"+                else return s+        else do+            case mp of+                Nothing -> return ()+                Just p -> checkPriority p streamNumber+            if endOfHeader+                then do+                    tbl <- hpackDecodeHeader frag streamId ctx+                    return $+                        if endOfStream+                            then -- turned into HalfClosedRemote in processState+                                Open hcl (NoBody tbl)+                            else Open hcl (HasBody tbl)+                else do+                    let siz = BS.length frag+                    return $ Open hcl $ Continued [frag] siz 1 endOfStream++-- Transition (stream2)+stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx (Open _ (Body q _ _ tlr)) _ = do+    HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs+    let endOfStream = testEndStream flags+    -- checking frag == "" is not necessary+    if endOfStream+        then do+            tbl <- hpackDecodeTrailer frag streamId ctx+            writeIORef tlr (Just tbl)+            atomically $ writeTQueue q $ Right (mempty, True)+            return HalfClosedRemote+        else -- we don't support continuation here.+            E.throwIO $+                ConnectionErrorIsSent+                    ProtocolError+                    streamId+                    "continuation in trailer is not supported"++-- Transition (stream4)+stream+    FrameData+    header@FrameHeader{flags, payloadLength, streamId}+    bs+    Context{emptyFrameRate, rxFlow, mySettings}+    s@(Open _ (Body q mcl bodyLength _))+    Stream{..} = do+        DataFrame body <- guardIt $ decodeDataFrame header bs+        -- FLOW CONTROL: WINDOW_UPDATE 0: recv: rejecting if over my limit+        okc <- atomicModifyIORef' rxFlow $ checkRxLimit payloadLength+        unless okc $+            E.throwIO $+                ConnectionErrorIsSent+                    EnhanceYourCalm+                    streamId+                    "exceeds connection flow-control limit"+        -- FLOW CONTROL: WINDOW_UPDATE: recv: rejecting if over my limit+        oks <- atomicModifyIORef' streamRxFlow $ checkRxLimit payloadLength+        unless oks $+            E.throwIO $+                ConnectionErrorIsSent+                    EnhanceYourCalm+                    streamId+                    "exceeds stream flow-control limit"+        len0 <- readIORef bodyLength+        let len = len0 + payloadLength+            endOfStream = testEndStream flags+        -- Empty Frame Flooding - CVE-2019-9518+        if body == ""+            then unless endOfStream $ do+                rate <- getRate emptyFrameRate+                when (rate > emptyFrameRateLimit mySettings) $ do+                    E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty data"+            else do+                writeIORef bodyLength len+                atomically $ writeTQueue q $ Right (body, endOfStream)+        if endOfStream+            then do+                case mcl of+                    Nothing -> return ()+                    Just cl ->+                        when (cl /= len) $+                            E.throwIO $+                                StreamErrorIsSent+                                    ProtocolError+                                    streamId+                                    "actual body length is not the same as content-length"+                -- no trailers+                atomically $ writeTQueue q $ Right (mempty, True)+                return HalfClosedRemote+            else return s++-- Transition (stream5)+stream FrameContinuation FrameHeader{flags, streamId} frag ctx s@(Open hcl (Continued rfrags siz n endOfStream)) _ = do+    let endOfHeader = testEndHeader flags+    if frag == "" && not endOfHeader+        then do+            -- Empty Frame Flooding - CVE-2019-9518+            rate <- getRate $ emptyFrameRate ctx+            if rate > emptyFrameRateLimit (mySettings ctx)+                then+                    E.throwIO $+                        ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation"+                else return s+        else do+            let rfrags' = frag : rfrags+                siz' = siz + BS.length frag+                n' = n + 1+            when (siz' > headerFragmentLimit) $+                E.throwIO $+                    ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big"+            when (n' > continuationLimit) $+                E.throwIO $+                    ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented"+            if endOfHeader+                then do+                    let hdrblk = BS.concat $ reverse rfrags'+                    tbl <- hpackDecodeHeader hdrblk streamId ctx+                    return $+                        if endOfStream+                            then -- turned into HalfClosedRemote in processState+                                Open hcl (NoBody tbl)+                            else Open hcl (HasBody tbl)+                else return $ Open hcl $ Continued rfrags' siz' n' endOfStream++-- (No state transition)+stream FrameWindowUpdate header bs _ s strm = do+    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs+    increaseStreamWindowSize strm n+    return s++-- Transition (stream6)+stream FrameRSTStream header@FrameHeader{streamId} bs ctx s strm = do+    -- Rapid Rest: CVE-2023-44487+    rate <- getRate $ rstRate ctx+    when (rate > rstRateLimit (mySettings ctx)) $+        E.throwIO $+            ConnectionErrorIsSent EnhanceYourCalm streamId "too many rst_stream"+    RSTStreamFrame err <- guardIt $ decodeRSTStreamFrame header bs+    let cc = Reset err+    closed ctx strm cc++    -- HTTP2 spec, section 5.1, "Stream States":+    --+    -- > A stream in the "open" state may be used by both peers to send frames+    -- > of any type. (..) From this state, either endpoint can send a frame+    -- > with an END_STREAM flag set, which causes the stream to transition into+    -- > one of the "half-closed" states.  An endpoint sending an END_STREAM+    -- > flag causes the stream state to become "half-closed (local)"; an+    -- > endpoint receiving an END_STREAM flag causes the stream state to become+    -- > "half-closed (remote)".+    --+    -- Crucially (for the specific case we're dealing with here), it continues:+    --+    -- > /Either endpoint/ can send a RST_STREAM frame from this state, causing+    -- > it to transition immediately to "closed".+    --+    -- (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+    -- Resource Loop - CVE-2019-9513+    PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs+    checkPriority newpri streamNumber+    return s++-- this ordering is important+stream FrameContinuation FrameHeader{streamId} _ _ _ _ =+    E.throwIO $+        ConnectionErrorIsSent ProtocolError streamId "continue frame cannot come here"+stream _ FrameHeader{streamId} _ _ (Open _ Continued{}) _ =+    E.throwIO $+        ConnectionErrorIsSent+            ProtocolError+            streamId+            "an illegal frame follows header/continuation frames"+-- Ignore frames to streams we have just reset, per section 5.1.+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st+stream FrameData FrameHeader{streamId} _ _ _ _ =+    E.throwIO $+        StreamErrorIsSent StreamClosed streamId $+            fromString ("illegal data frame for " ++ show streamId)+stream x FrameHeader{streamId} _ _ _ _ =+    E.throwIO $+        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 RxQ (Int -> IO ()) (IORef Bool)++mkSource :: RxQ -> (Int -> IO ()) -> IO Source+mkSource q inform = Source q inform <$> newIORef False++readSource :: Source -> IO (ByteString, Bool)+readSource (Source q inform refEOF) = do+    eof <- readIORef refEOF+    if eof+        then return (mempty, True)+        else do+            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+    frame = pingFrame ack bs
+ Network/HTTP2/H2/Sender.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.HTTP2.H2.Sender (+    frameSender,+) where++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 Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.IO++import Imports+import Network.HPACK (setLimitForEncoding, toTokenHeaderTable)+import Network.HTTP2.Frame+import Network.HTTP2.H2.Context+import Network.HTTP2.H2.EncodeFrame+import Network.HTTP2.H2.HPACK+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.Settings+import Network.HTTP2.H2.Stream+import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Types+import Network.HTTP2.H2.Window++----------------------------------------------------------------++data Switch+    = C Control+    | O Output+    | Flush++-- Peer SETTINGS_INITIAL_WINDOW_SIZE+-- Adjusting initial window size for streams+updatePeerSettings :: Context -> SettingsList -> IO ()+updatePeerSettings Context{peerSettings, oddStreamTable, evenStreamTable} peerAlist = do+    oldws <- initialWindowSize <$> readIORef peerSettings+    modifyIORef' peerSettings $ \old -> fromSettingsList old peerAlist+    newws <- initialWindowSize <$> readIORef peerSettings+    -- FIXME: race condition+    -- 1) newOddStream reads old peerSettings and+    --    insert it to its stream table after adjusting.+    -- 2) newOddStream reads new peerSettings and+    --    insert it to its stream table before adjusting.+    let dif = newws - oldws+    when (dif /= 0) $ do+        getOddStreams oddStreamTable >>= updateAllStreamTxFlow dif+        getEvenStreams evenStreamTable >>= updateAllStreamTxFlow dif+  where+    updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO ()+    updateAllStreamTxFlow siz strms =+        forM_ strms $ \strm -> increaseStreamWindowSize strm siz++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{..} = do+        labelMe "H2 sender"+        loop 0 `E.catch` return+      where+        ----------------------------------------------------------------+        loop :: Offset -> IO E.SomeException+        loop off = do+            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.+        flushN :: Offset -> IO ()+        flushN 0 = return ()+        flushN n = bufferIO confWriteBuffer n confSendAll++        flushIfNecessary :: Offset -> IO Offset+        flushIfNecessary off = do+            buflim <- readIORef outputBufferLimit+            if off <= buflim - 512+                then return off+                else do+                    flushN off+                    return 0++        dequeue :: Offset -> STM Switch+        dequeue off = do+            isEmptyC <- isEmptyTQueue controlQ+            if isEmptyC+                then do+                    -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit+                    waitConnectionWindowSize ctx+                    isEmptyO <- isEmptyTQueue outputQ+                    if isEmptyO+                        then if off /= 0 then return Flush else retry+                        else O <$> readTQueue outputQ+                else C <$> readTQueue controlQ++        ----------------------------------------------------------------+        copyAll [] buf = return buf+        copyAll (x : xs) buf = copy buf x >>= copyAll xs++        -- called with off == 0+        control :: Control -> IO ()+        control (CFrames ms xs) = do+            buf <- copyAll xs confWriteBuffer+            let off = buf `minusPtr` confWriteBuffer+            flushN off+            case ms of+                Nothing -> return ()+                Just peerAlist -> do+                    -- Peer SETTINGS_INITIAL_WINDOW_SIZE+                    updatePeerSettings ctx peerAlist+                    -- Peer SETTINGS_MAX_FRAME_SIZE+                    case lookup SettingsMaxFrameSize peerAlist of+                        Nothing -> return ()+                        Just payloadLen -> do+                            let dlim = payloadLen + frameHeaderLength+                                buflim+                                    | confBufferSize >= dlim = dlim+                                    | otherwise = confBufferSize+                            writeIORef outputBufferLimit buflim+                    -- Peer SETTINGS_HEADER_TABLE_SIZE+                    case lookup SettingsTokenHeaderTableSize peerAlist of+                        Nothing -> return ()+                        Just siz -> setLimitForEncoding siz encodeDynamicTable++        ----------------------------------------------------------------+        -- 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 = isNothing mnext+            (ths, _) <- toTokenHeaderTable $ fixHeaders hdr+            off' <- headerContinue sid ths endOfStream off0+            -- halfClosedLocal calls closed which removes+            -- the stream from stream table.+            off <- flushIfNecessary off'+            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+            return (off, Nothing)+        output _ _ _ = undefined -- never reached++        ----------------------------------------------------------------+        headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset+        headerContinue sid ths0 endOfStream off0 = do+            buflim <- readIORef outputBufferLimit+            let offkv = off0 + frameHeaderLength+                bufkv = confWriteBuffer `plusPtr` offkv+                limkv = buflim - offkv+            (ths, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0+            if kvlen == 0+                then continue off0 ths FrameHeaders+                else do+                    let flag = getFlag ths+                        buf = confWriteBuffer `plusPtr` off0+                        off = offkv + kvlen+                    fillFrameHeader FrameHeaders kvlen sid flag buf+                    continue off ths FrameContinuation+          where+            eos = if endOfStream then setEndStream else id+            getFlag [] = eos $ setEndHeader defaultFlags+            getFlag _ = eos defaultFlags++            continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset+            continue off [] _ = return off+            continue off ths ft = do+                flushN off+                -- Now off is 0+                buflim <- readIORef outputBufferLimit+                let bufHeaderPayload = confWriteBuffer `plusPtr` frameHeaderLength++                    headerPayloadLim = buflim - frameHeaderLength+                (ths', kvlen') <-+                    hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths+                when (ths == ths') $+                    E.throwIO $+                        ConnectionErrorIsSent CompressionError sid "cannot compress the header"+                let flag = getFlag ths'+                    off' = frameHeaderLength + kvlen'+                fillFrameHeader ft kvlen' sid flag confWriteBuffer+                continue off' ths' FrameContinuation++        ----------------------------------------------------------------+        fillDataHeader+            :: Stream+            -> Offset+            -> Int+            -> Maybe DynaNext+            -> (Maybe ByteString -> IO NextTrailersMaker)+            -> Output+            -> Bool+            -> IO (Offset, Maybe Output)+        fillDataHeader+            strm@Stream{streamNumber}+            off+            datPayloadLen+            Nothing+            tlrmkr+            _+            reqflush = do+                let buf = confWriteBuffer `plusPtr` off+                (mtrailers, flag) <- do+                    tm <- tlrmkr Nothing+                    let trailers = case tm of+                            Trailers t -> t+                            _ -> []+                    if null trailers+                        then return (Nothing, setEndStream defaultFlags)+                        else return (Just trailers, defaultFlags)+                -- 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'+                halfClosedLocal ctx strm Finished+                if reqflush+                    then do+                        flushN off''+                        return (0, Nothing)+                    else return (off'', Nothing)+              where+                handleTrailers Nothing off0 = return off0+                handleTrailers (Just trailers) off0 = do+                    (ths, _) <- toTokenHeaderTable trailers+                    headerContinue streamNumber ths True {- endOfStream -} off0+        fillDataHeader+            _+            off+            0+            (Just next)+            tlrmkr+            out+            reqflush = do+                let out' = out{outputType = ONext next tlrmkr}+                if reqflush+                    then do+                        flushN off+                        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+                    off' = off + frameHeaderLength + datPayloadLen+                    flag = defaultFlags+                fillFrameHeader FrameData datPayloadLen streamNumber flag buf+                decreaseWindowSize ctx strm datPayloadLen+                let out' = out{outputType = ONext next tlrmkr}+                if reqflush+                    then do+                        flushN off'+                        return (0, Just out')+                    else return (off', Just out')++        ----------------------------------------------------------------+        pushPromise :: StreamId -> StreamId -> TokenHeaderList -> Offset -> IO Int+        pushPromise pid sid ths off = do+            let offsid = off + frameHeaderLength -- checkme+                bufsid = confWriteBuffer `plusPtr` offsid+            poke32 (fromIntegral sid) bufsid 0+            let offkv = offsid + 4+                bufkv = confWriteBuffer `plusPtr` offkv+                limkv = confBufferSize - offkv+            (_, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths+            let flag = setEndHeader defaultFlags -- No EndStream flag+                buf = confWriteBuffer `plusPtr` off+                len = kvlen + 4+            fillFrameHeader FramePushPromise len pid flag buf+            return len++        ----------------------------------------------------------------+        {-# INLINE fillFrameHeader #-}+        fillFrameHeader :: FrameType -> Int -> StreamId -> FrameFlags -> Buffer -> IO ()+        fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf+          where+            hinfo =+                FrameHeader+                    { payloadLength = len+                    , flags = flag+                    , streamId = sid+                    }
+ Network/HTTP2/H2/Settings.hs view
@@ -0,0 +1,156 @@+module Network.HTTP2.H2.Settings where++import Network.Control++import Imports+import Network.HTTP2.Frame+import Network.HTTP2.H2.EncodeFrame++----------------------------------------------------------------++-- | HTTP\/2 settings. See <https://datatracker.ietf.org/doc/html/rfc9113#name-defined-settings>.+data Settings = Settings+    { headerTableSize :: Int+    -- ^ SETTINGS_HEADER_TABLE_SIZE+    , enablePush :: Bool+    -- ^ SETTINGS_ENABLE_PUSH+    , maxConcurrentStreams :: Maybe Int+    -- ^ SETTINGS_MAX_CONCURRENT_STREAMS+    , initialWindowSize :: WindowSize+    -- ^ SETTINGS_INITIAL_WINDOW_SIZE+    , maxFrameSize :: Int+    -- ^ SETTINGS_MAX_FRAME_SIZE+    , maxHeaderListSize :: Maybe Int+    -- ^ 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, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}+baseSettings :: Settings+baseSettings =+    Settings+        { headerTableSize = 4096 -- defaultDynamicTableSize+        , enablePush = True+        , maxConcurrentStreams = Nothing+        , initialWindowSize = defaultWindowSize -- 64K (65,535)+        , 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, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}+defaultSettings :: Settings+defaultSettings =+    baseSettings+        { maxConcurrentStreams = Just defaultMaxStreams+        , initialWindowSize = defaultMaxStreamData+        }++----------------------------------------------------------------++-- | 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, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}+{- FOURMOLU_DISABLE -}+fromSettingsList :: Settings -> SettingsList -> Settings+fromSettingsList settings kvs = foldl' update settings kvs+  where+    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 }+    update def (SettingsInitialWindowSize,x)    = def { initialWindowSize = x }+    update def (SettingsMaxFrameSize,x)         = def { maxFrameSize = x }+    update def (SettingsMaxHeaderListSize,x)    = def { maxHeaderListSize = Just x }+    update def _                                = def+{- FOURMOLU_ENABLE -}++----------------------------------------------------------------++diff+    :: Eq a+    => Settings+    -> Settings+    -> (Settings -> a)+    -> SettingsKey+    -> (a -> SettingsValue)+    -> Maybe (SettingsKey, SettingsValue)+diff settings settings0 label key enc+    | val == val0 = Nothing+    | otherwise = Just (key, enc val)+  where+    val = label settings+    val0 = label settings0++toSettingsList :: Settings -> Settings -> SettingsList+toSettingsList s s0 =+    catMaybes+        [ diff+            s+            s0+            headerTableSize+            SettingsTokenHeaderTableSize+            id+        , diff+            s+            s0+            enablePush+            SettingsEnablePush+            (const 0) -- fixme+        , diff+            s+            s0+            maxConcurrentStreams+            SettingsMaxConcurrentStreams+            fromJust+        , diff+            s+            s0+            initialWindowSize+            SettingsInitialWindowSize+            id+        , diff+            s+            s0+            maxFrameSize+            SettingsMaxFrameSize+            id+        , diff+            s+            s0+            maxHeaderListSize+            SettingsMaxHeaderListSize+            fromJust+        ]++----------------------------------------------------------------++makeNegotiationFrames :: Settings -> WindowSize -> [ByteString]+makeNegotiationFrames settings connWindowSize = frame1 : frames+  where+    alist = toSettingsList settings baseSettings+    frame1 = settingsFrame id alist+    frames =+        if connWindowSize /= defaultWindowSize+            then [windowUpdateFrame 0 (connWindowSize - defaultWindowSize)]+            else []++----------------------------------------------------------------
+ Network/HTTP2/H2/Stream.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# 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 Network.HTTP.Semantics+import Network.HTTP.Semantics.IO++import Network.HTTP2.Frame+import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Types++----------------------------------------------------------------++isIdle :: StreamState -> Bool+isIdle Idle = True+isIdle _ = False++isOpen :: StreamState -> Bool+isOpen Open{} = True+isOpen _ = False++isHalfClosedRemote :: StreamState -> Bool+isHalfClosedRemote HalfClosedRemote = True+isHalfClosedRemote (Closed _) = True+isHalfClosedRemote _ = False++isHalfClosedLocal :: StreamState -> Bool+isHalfClosedLocal (Open (Just _) _) = True+isHalfClosedLocal (Closed _) = True+isHalfClosedLocal _ = False++isClosed :: StreamState -> Bool+isClosed Closed{} = True+isClosed _ = False++isReserved :: StreamState -> Bool+isReserved Reserved = True+isReserved _ = False++----------------------------------------------------------------++newOddStream :: StreamId -> WindowSize -> WindowSize -> IO Stream+newOddStream sid txwin rxwin =+    Stream sid+        <$> newIORef Idle+        <*> newEmptyMVar+        <*> newTVarIO (newTxFlow txwin)+        <*> newIORef (newRxFlow rxwin)+        <*> newIORef Nothing++newEvenStream :: StreamId -> WindowSize -> WindowSize -> IO Stream+newEvenStream sid txwin rxwin =+    Stream sid+        <$> newIORef Reserved+        <*> newEmptyMVar+        <*> newTVarIO (newTxFlow txwin)+        <*> newIORef (newRxFlow rxwin)+        <*> newIORef Nothing++----------------------------------------------------------------++{-# INLINE readStreamState #-}+readStreamState :: Stream -> IO StreamState+readStreamState Stream{streamState} = readIORef streamState++----------------------------------------------------------------++closeAllStreams+    :: TVar OddStreamTable -> TVar EvenStreamTable -> Maybe SomeException -> IO ()+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) err+        case st of+            Open _ (Body q _ _ _) ->+                atomically $ writeTQueue q $ maybe (Right (mempty, True)) Left mErr+            _otherwise ->+                return ()++    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
@@ -0,0 +1,183 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.H2.StreamTable (+    -- * Types+    OddStreamTable (..),+    emptyOddStreamTable,+    EvenStreamTable (..),+    emptyEvenStreamTable,++    -- * Odd+    insertOdd,+    insertOdd',+    deleteOdd,+    lookupOdd,+    getOddConcurrency,+    getOddStreams,+    clearOddStreamTable,+    waitIncOdd,++    -- * Even+    insertEven,+    insertEven',+    deleteEven,+    lookupEven,+    getEvenConcurrency,+    clearEvenStreamTable,+    waitIncEven,+    insertEvenCache,+    deleteEvenCache,+    lookupEvenCache,+    getEvenStreams,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Network.Control (LRUCache)+import qualified Network.Control as LRUCache++import Imports+import Network.HTTP2.H2.Types (Stream (..))++----------------------------------------------------------------++data OddStreamTable = OddStreamTable+    { oddConc :: Int+    , oddTable :: IntMap Stream+    }++emptyOddStreamTable :: OddStreamTable+emptyOddStreamTable = OddStreamTable 0 IntMap.empty++data EvenStreamTable = EvenStreamTable+    { evenConc :: Int+    , evenTable :: IntMap Stream+    , -- 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+    }++emptyEvenStreamTable :: Int -> EvenStreamTable+emptyEvenStreamTable lim = EvenStreamTable 0 IntMap.empty $ LRUCache.empty lim++----------------------------------------------------------------++insertOdd :: TVar OddStreamTable -> IntMap.Key -> Stream -> IO ()+insertOdd var k v = atomically $ modifyTVar var $ \OddStreamTable{..} ->+    let oddConc' = oddConc + 1+        oddTable' = IntMap.insert k v oddTable+     in OddStreamTable oddConc' oddTable'++insertOdd' :: TVar OddStreamTable -> IntMap.Key -> Stream -> IO ()+insertOdd' var k v = atomically $ modifyTVar var $ \OddStreamTable{..} ->+    let oddTable' = IntMap.insert k v oddTable+     in OddStreamTable oddConc oddTable'++deleteOdd :: TVar OddStreamTable -> IntMap.Key -> SomeException -> IO ()+deleteOdd var k err = do+    mv <- atomically deleteStream+    case mv of+        Nothing -> return () -- Stream was already removed+        Just v -> void . tryPutMVar (streamInput v) $ Left err+  where+    deleteStream :: STM (Maybe Stream)+    deleteStream = do+        OddStreamTable{..} <- readTVar var+        let oddConc' = oddConc - 1+            oddTable' = IntMap.delete k oddTable+        writeTVar var $ OddStreamTable oddConc' oddTable'+        return $ IntMap.lookup k oddTable++lookupOdd :: TVar OddStreamTable -> IntMap.Key -> IO (Maybe Stream)+lookupOdd var k = IntMap.lookup k . oddTable <$> readTVarIO var++getOddConcurrency :: TVar OddStreamTable -> IO Int+getOddConcurrency var = oddConc <$> readTVarIO var++getOddStreams :: TVar OddStreamTable -> IO (IntMap Stream)+getOddStreams var = oddTable <$> readTVarIO var++clearOddStreamTable :: TVar OddStreamTable -> IO (IntMap Stream)+clearOddStreamTable var = atomically $ do+    OddStreamTable{..} <- readTVar var+    writeTVar var emptyOddStreamTable+    return oddTable++waitIncOdd :: TVar OddStreamTable -> Int -> STM ()+waitIncOdd var maxConc = do+    OddStreamTable{..} <- readTVar var+    check (oddConc < maxConc)+    let oddConc' = oddConc + 1+    writeTVar var $ OddStreamTable oddConc' oddTable++----------------------------------------------------------------++insertEven :: TVar EvenStreamTable -> IntMap.Key -> Stream -> IO ()+insertEven var k v = atomically $ modifyTVar var $ \EvenStreamTable{..} ->+    let evenConc' = evenConc + 1+        evenTable' = IntMap.insert k v evenTable+     in EvenStreamTable evenConc' evenTable' evenCache++insertEven' :: TVar EvenStreamTable -> IntMap.Key -> Stream -> IO ()+insertEven' var k v = atomically $ modifyTVar var $ \EvenStreamTable{..} ->+    let evenTable' = IntMap.insert k v evenTable+     in EvenStreamTable evenConc evenTable' evenCache++deleteEven :: TVar EvenStreamTable -> IntMap.Key -> SomeException -> IO ()+deleteEven var k err = do+    mv <- atomically deleteStream+    case mv of+        Nothing -> return () -- Stream was already removed+        Just v -> void . tryPutMVar (streamInput v) $ Left err+  where+    deleteStream :: STM (Maybe Stream)+    deleteStream = do+        EvenStreamTable{..} <- readTVar var+        let evenConc' = evenConc - 1+            evenTable' = IntMap.delete k evenTable+        writeTVar var $ EvenStreamTable evenConc' evenTable' evenCache+        return $ IntMap.lookup k evenTable++lookupEven :: TVar EvenStreamTable -> IntMap.Key -> IO (Maybe Stream)+lookupEven var k = IntMap.lookup k . evenTable <$> readTVarIO var++getEvenConcurrency :: TVar EvenStreamTable -> IO Int+getEvenConcurrency var = evenConc <$> readTVarIO var++clearEvenStreamTable :: TVar EvenStreamTable -> IO (IntMap Stream)+clearEvenStreamTable var = atomically $ do+    EvenStreamTable{..} <- readTVar var+    writeTVar var $ emptyEvenStreamTable 0+    return evenTable++waitIncEven :: TVar EvenStreamTable -> Int -> STM ()+waitIncEven var maxConc = do+    EvenStreamTable{..} <- readTVar var+    check (evenConc < maxConc)+    let evenConc' = evenConc + 1+    writeTVar var $ EvenStreamTable evenConc' evenTable evenCache++insertEvenCache+    :: TVar EvenStreamTable -> Method -> ByteString -> Stream -> IO ()+insertEvenCache var method path strm@Stream{..} = atomically $ modifyTVar var $ \EvenStreamTable{..} ->+    let evenConc' = evenConc + 1+        evenTable' = IntMap.insert streamNumber strm evenTable+        evenCache' = LRUCache.insert (method, path) strm evenCache+     in EvenStreamTable evenConc' evenTable' evenCache'++deleteEvenCache :: TVar EvenStreamTable -> Method -> ByteString -> IO ()+deleteEvenCache var m path = atomically $ modifyTVar var $ \EvenStreamTable{..} ->+    let evenCache' = LRUCache.delete (m, path) evenCache+     in EvenStreamTable evenConc evenTable evenCache'++lookupEvenCache+    :: TVar EvenStreamTable -> Method -> ByteString -> IO (Maybe Stream)+lookupEvenCache var m path = LRUCache.lookup (m, path) . evenCache <$> readTVarIO var++getEvenStreams :: TVar EvenStreamTable -> IO (IntMap Stream)+getEvenStreams var = evenTable <$> readTVarIO var
+ 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
@@ -0,0 +1,296 @@+{-# 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.IORef+import Foreign.Ptr (nullPtr)+import Network.Control+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 Imports+import Network.HPACK+import Network.HTTP2.Frame++----------------------------------------------------------------++{-++== Stream state++The stream state is stored in the 'streamState' field (an @IORef@) of a+'Stream'. The main place where the stream state is updated is in+'controlOrStream', which does something like this:++> state0 <- readStreamState strm+> state1 <- stream .. state0 ..+> processState .. state1 ..++where 'processState' updates the @IORef@, based on 'state1' (the state computed+by 'stream') and the /current/ state of the stream; for simplicity, we will+assume here that this must equal 'state0' (it might not, if a concurrent thread+changed the stream state).++The diagram below summarizes the stream state transitions on the client side,+omitting error cases (which result in exceptions being thrown). Each transition+is labelled with the relevant case in either the function 'stream' or the+function 'processState'.++>                        [Open JustOpened]+>                               |+>                               |+>                            HEADERS+>                               |+>                               | (stream1)+>                               |+>                          END_HEADERS?+>                               |+>                        ______/ \______+>                       /   yes   no    \+>                      |                |+>                      |         [Open Continued] <--\+>                      |                |            |+>                      |           CONTINUATION      |+>                      |                |            |+>                      |                | (stream5)  |+>                      |                |            |+>                      |           END_HEADERS?      |+>                      |                |            |+>                      v           yes / \ no        |+>                 END_STREAM? <-------/   \-----------/+>                      |                   (process3)+>                      |+>            _________/ \_________+>           /      yes   no       \+>           |                     |+>      [Open NoBody]        [Open HasBody]+>           |                     |+>           | (process1)          | (process2)+>           |                     |+>  [HalfClosedRemote] <--\   [Open Body] <----------------------\+>           |             |        |                             |+>           |             |        +---------------\             |+>       RST_STREAM        |        |               |             |+>           |             |     HEADERS           DATA           |+>           | (stream6)   |        |               |             |+>           |             |        | (stream2)     | (stream4)   |+>           | (process5)  |        |               |             |+>           |             |   END_STREAM?      END_STREAM?       |+>        [Closed]         |        |               |             |+>                         |        | yes      yes / \ no         |+>                         \--------+-------------/   \-----------/+>                          (process4)                 (process6)++Notes:++- The 'HalfClosedLocal' state is not used on the client side.+- Indeed, unless an exception is thrown, even the 'Closed' stream state is not+  used in the client; when the @IORef@ is collected, it is typically in+  'HalfClosedRemote' state.++-}++data OpenState+    = JustOpened+    | Continued+        [HeaderBlockFragment]+        Int -- Total size+        Int -- The number of continuation frames+        Bool -- End of stream+    | NoBody TokenHeaderTable+    | HasBody TokenHeaderTable+    | Body+        (TQueue (Either SomeException (ByteString, Bool)))+        (Maybe Int) -- received Content-Length+        -- compared the body length for error checking+        (IORef Int) -- actual body length+        (IORef (Maybe TokenHeaderTable)) -- trailers++data ClosedCode+    = Finished+    | Killed+    | Reset ErrorCode+    | 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+        Finished -> ConnectionIsClosed+        Killed -> ConnectionIsTimeout+        Reset err -> ConnectionErrorIsReceived err sid "Connection was reset"+        ResetByMe err -> BadThingHappen err++----------------------------------------------------------------++data StreamState+    = Idle+    | Open (Maybe ClosedCode) OpenState -- HalfClosedLocal if Just+    | HalfClosedRemote+    | Closed ClosedCode+    | Reserved++instance Show StreamState where+    show Idle = "Idle"+    show (Open Nothing _) = "Open"+    show (Open (Just e) _) = "HalfClosedLocal: " ++ show e+    show HalfClosedRemote = "HalfClosedRemote"+    show (Closed e) = "Closed: " ++ show e+    show Reserved = "Reserved"++----------------------------------------------------------------++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+    show Stream{..} =+        "Stream{id="+            ++ show streamNumber+            ++ ",state="+            ++ show (unsafePerformIO (readIORef streamState))+            ++ "}"++----------------------------------------------------------------++data Output = Output+    { outputStream :: Stream+    , outputType :: OutputType+    , outputSync :: Maybe Output -> IO ()+    }++data OutputType+    = OHeader [Header] (Maybe DynaNext) TrailersMaker+    | OPush TokenHeaderList StreamId -- associated stream id from client+    | ONext DynaNext TrailersMaker++data Sync = Done | Cont Output++----------------------------------------------------------------++data Control = CFrames (Maybe SettingsList) [ByteString]++----------------------------------------------------------------++type ReasonPhrase = ShortByteString++-- | The connection error or the stream error.+--   Stream errors are treated as connection errors since+--   there are no good recovery ways.+--   `ErrorCode` in connection errors should be the highest stream identifier+--   but in this implementation it identifies the stream that+--   caused this error.+data HTTP2Error+    = ConnectionIsClosed -- NoError+    | ConnectionIsTimeout+    | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase+    | ConnectionErrorIsSent ErrorCode StreamId ReasonPhrase+    | StreamErrorIsReceived ErrorCode StreamId+    | StreamErrorIsSent ErrorCode StreamId ReasonPhrase+    | BadThingHappen E.SomeException+    deriving (Show)++instance E.Exception HTTP2Error++----------------------------------------------------------------++-- | Checking 'SettingsList' and reporting an error if any.+--+-- >>> checkSettingsList [(SettingsEnablePush,2)]+-- Just (ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1")+checkSettingsList :: SettingsList -> Maybe HTTP2Error+checkSettingsList settings = case mapMaybe checkSettingsValue settings of+    [] -> Nothing+    (x : _) -> Just x++checkSettingsValue :: (SettingsKey, SettingsValue) -> Maybe HTTP2Error+checkSettingsValue (SettingsEnablePush, v)+    | v /= 0 && v /= 1 =+        Just $ ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1"+checkSettingsValue (SettingsInitialWindowSize, v)+    | v > maxWindowSize =+        Just $+            ConnectionErrorIsSent+                FlowControlError+                0+                "Window size must be less than or equal to 65535"+checkSettingsValue (SettingsMaxFrameSize, v)+    | v < defaultPayloadLength || v > maxPayloadLength =+        Just $+            ConnectionErrorIsSent+                ProtocolError+                0+                "Max frame size must be in between 16384 and 16777215"+checkSettingsValue _ = Nothing++----------------------------------------------------------------++-- | HTTP/2 configuration.+data Config = Config+    { confWriteBuffer :: Buffer+    -- ^ This is used only by frameSender.+    -- This MUST be freed after frameSender is terminated.+    , confBufferSize :: BufferSize+    -- ^ The size of the write buffer.+    --   We assume that the read buffer is the same size.+    --   So, this value is announced via SETTINGS_MAX_FRAME_SIZE+    --   to the peer.+    , confSendAll :: ByteString -> IO ()+    , confReadN :: Int -> IO ByteString+    , confPositionReadMaker :: PositionReadMaker+    , confTimeoutManager :: T.Manager+    , confMySockAddr :: SockAddr+    -- ^ 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
@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++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 Imports+import Network.HTTP2.Frame+import Network.HTTP2.H2.Context+import Network.HTTP2.H2.EncodeFrame+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.Types++getStreamWindowSize :: Stream -> IO WindowSize+getStreamWindowSize Stream{streamTxFlow} =+    txWindowSize <$> readTVarIO streamTxFlow++getConnectionWindowSize :: Context -> IO WindowSize+getConnectionWindowSize Context{txFlow} =+    txWindowSize <$> readTVarIO txFlow++waitStreamWindowSize :: Stream -> IO ()+waitStreamWindowSize Stream{streamTxFlow} = atomically $ do+    w <- txWindowSize <$> readTVar streamTxFlow+    check (w > 0)++waitConnectionWindowSize :: Context -> STM ()+waitConnectionWindowSize Context{txFlow} = do+    w <- txWindowSize <$> readTVar txFlow+    check (w > 0)++----------------------------------------------------------------+-- Receiving window update++increaseWindowSize :: StreamId -> TVar TxFlow -> WindowSize -> IO ()+increaseWindowSize sid tvar n = do+    atomically $ modifyTVar' tvar $ \flow -> flow{txfLimit = txfLimit flow + n}+    w <- txWindowSize <$> readTVarIO tvar+    when (isWindowOverflow w) $ do+        let msg = fromString ("window update for stream " ++ show sid ++ " is overflow")+            err =+                if isControl sid+                    then ConnectionErrorIsSent+                    else StreamErrorIsSent+        E.throwIO $ err FlowControlError sid msg++increaseStreamWindowSize :: Stream -> WindowSize -> IO ()+increaseStreamWindowSize Stream{streamNumber, streamTxFlow} n =+    increaseWindowSize streamNumber streamTxFlow n++increaseConnectionWindowSize :: Context -> Int -> IO ()+increaseConnectionWindowSize Context{txFlow} n =+    increaseWindowSize 0 txFlow n++decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()+decreaseWindowSize Context{txFlow} Stream{streamTxFlow} siz = do+    dec txFlow+    dec streamTxFlow+  where+    dec tvar = atomically $ modifyTVar' tvar $ \flow -> flow{txfSent = txfSent flow + siz}++----------------------------------------------------------------+-- Sending window update++informWindowUpdate :: Context -> Stream -> Int -> IO ()+informWindowUpdate _ _ 0 = return ()+informWindowUpdate Context{controlQ, rxFlow} Stream{streamNumber, streamRxFlow} len = do+    mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate+    forM_ mxc $ \ws -> do+        let frame = windowUpdateFrame 0 ws+            cframe = CFrames Nothing [frame]+        enqueueControl controlQ cframe+    mxs <- atomicModifyIORef streamRxFlow $ maybeOpenRxWindow len FCTWindowUpdate+    forM_ mxs $ \ws -> do+        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,31 +0,0 @@-module Network.HTTP2.Internal (-  -- * File-    module Network.HTTP2.Arch.File-  -- * Types-  , Scheme-  , Authority-  , Path-  -- * Request and response-  , InpObj(..)-  , InpBody-  , OutObj(..)-  , OutBody(..)-  , FileSpec(..)-  -- * Sender-  , Next(..)-  , BytesFilled-  , DynaNext-  , StreamingChunk(..)-  , fillBuilderBodyGetNext-  , fillFileBodyGetNext-  , fillStreamBodyGetNext-  -- * Trailer-  , TrailersMaker-  , defaultTrailersMaker-  , NextTrailersMaker(..)-  , runTrailersMaker-  )  where--import Network.HTTP2.Arch.File-import Network.HTTP2.Arch.Types-import Network.HTTP2.Arch.Sender
− Network/HTTP2/Priority.hs 
@@ -1,154 +0,0 @@--- | This is partial implementation of the priority of HTTP/2.------ This implementation does support structured priority queue--- but not support re-structuring. This means that it is assumed that--- an entry created by a Priority frame is never closed. The entry--- behaves an intermediate node, not a leaf.------ This queue is fair for weight. Consider two weights: 201 and 101.--- Repeating enqueue/dequeue probably produces--- 201, 201, 101, 201, 201, 101, ...------ Only one entry per stream should be enqueued.--module Network.HTTP2.Priority {-# DEPRECATED "Should be replaced with extensible priority" #-} (-  -- * Precedence-    Precedence-  , defaultPrecedence-  , toPrecedence-  -- * PriorityTree-  , PriorityTree-  , newPriorityTree-  -- * PriorityTree functions-  , prepare-  , enqueue-  , dequeue-  , dequeueSTM-  , isEmpty-  , isEmptySTM-  , delete-  ) where--import Control.Concurrent.STM-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as Map--import Imports hiding (delete, empty)-import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence)-import qualified Network.HTTP2.Priority.Queue as Q-import Network.HTTP2.Frame.Types---------------------------------------------------------------------- | Abstract data type for priority trees.-data PriorityTree a = PriorityTree (TVar (Glue a))-                                   (TNestedPriorityQueue a)--type Glue a = IntMap (TNestedPriorityQueue a, Precedence)---- INVARIANT: Empty TNestedPriorityQueue is never enqueued in--- another TNestedPriorityQueue.-type TNestedPriorityQueue a = TPriorityQueue (Element a)--data Element a = Child a-               | Parent (TNestedPriorityQueue a)----------------------------------------------------------------------- | Default precedence.-defaultPrecedence :: Precedence-defaultPrecedence = toPrecedence defaultPriority---- | Converting 'Priority' to 'Precedence'.---   When an entry is enqueued at the first time,---   this function should be used.-toPrecedence :: Priority -> Precedence-toPrecedence (Priority _ dep w) = Q.Precedence 0 w dep---------------------------------------------------------------------- | Creating a new priority tree.-newPriorityTree :: IO (PriorityTree a)-newPriorityTree = PriorityTree <$> newTVarIO Map.empty-                               <*> atomically Q.new---------------------------------------------------------------------- | Bringing up the structure of the priority tree.---   This must be used for Priority frame.-prepare :: PriorityTree a -> StreamId -> Priority -> IO ()-prepare (PriorityTree var _) sid p = atomically $ do-    q <- Q.new-    let pre = toPrecedence p-    modifyTVar' var $ Map.insert sid (q, pre)---- | Enqueuing an entry to the priority tree.---   This must be used for Header frame.-enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO ()-enqueue (PriorityTree var q0) sid p0 x = atomically $ do-    m <- readTVar var-    let el = Child x-    loop m el p0-  where-    loop m el p-      | pid == 0  = Q.enqueue q0 sid p el-      | otherwise = case Map.lookup pid m of-          -- If not found, enqueuing it to the stream 0 queue.-          Nothing -> Q.enqueue q0 sid p el-          Just (q', p') -> do-              notQueued <- Q.isEmpty q'-              Q.enqueue q' sid p el-              when notQueued $ do-                  let el' = Parent q'-                  loop m el' p'-      where-        pid = Q.dependency p----- | Checking if the priority tree is empty.-isEmpty :: PriorityTree a -> IO Bool-isEmpty = atomically . isEmptySTM---- | Checking if the priority tree is empty.-isEmptySTM :: PriorityTree a -> STM Bool-isEmptySTM (PriorityTree _ q0) = Q.isEmpty q0---- | Dequeuing an entry from the priority tree.-dequeue :: PriorityTree a -> IO (StreamId, Precedence, a)-dequeue = atomically . dequeueSTM---- | Dequeuing an entry from the priority tree.-dequeueSTM :: PriorityTree a -> STM (StreamId, Precedence, a)-dequeueSTM (PriorityTree _ q0) = loop q0-  where-    loop q = do-        (sid,p,el) <- Q.dequeue q-        case el of-            Child x   -> return (sid, p, x)-            Parent q' -> do-                entr <- loop q'-                empty <- Q.isEmpty q'-                unless empty $ Q.enqueue q sid p el-                return entr---- | Deleting the entry corresponding to 'StreamId'.---   'delete' and 'enqueue' are used to change the priority of---   a live stream.-delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)-delete (PriorityTree var q0) sid p-  | pid == 0  = atomically $ del q0-  | otherwise = atomically $ do-        m <- readTVar var-        case Map.lookup pid m of-            Nothing    -> return Nothing-            Just (q,_) -> del q-  where-    pid = Q.dependency p-    del q = do-        mel <- Q.delete sid q-        case mel of-            Nothing -> return Nothing-            Just el -> case el of-                Child  x -> return $ Just x-                Parent _ -> return Nothing -- fixme: this is error
− Network/HTTP2/Priority/Internal.hs 
@@ -1,5 +0,0 @@-module Network.HTTP2.Priority.Internal (-    module Network.HTTP2.Priority.PSQ-  ) where--import Network.HTTP2.Priority.PSQ
− Network/HTTP2/Priority/PSQ.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Priority.PSQ (-    Key-  , Weight-  , Deficit-  , Precedence(..)-  , newPrecedence-  , PriorityQueue(..)-  , Heap-  , empty-  , isEmpty-  , enqueue-  , dequeue-  , delete-  ) where--import Data.Array (Array, listArray, (!))-import Data.IntPSQ (IntPSQ)-import qualified Data.IntPSQ as P--------------------------------------------------------------------type Key = Int-type Weight = Int-type Deficit = Word -- Deficit can be overflowed---- | Internal representation of priority in priority queues.---   The precedence of a dequeued entry should be specified---   to enqueue when the entry is enqueued again.-data Precedence = Precedence {-    deficit    :: Deficit-  , weight     :: Weight-  -- stream dependency, used by the upper layer-  , dependency :: Key-  } deriving Show---- | For test only-newPrecedence :: Weight -> Precedence-newPrecedence w = Precedence 0 w 0--instance Eq Precedence where-  Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2--instance Ord Precedence where-  -- This is correct even if one of them is overflowed-  Precedence d1 _ _ <  Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW-  Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW--type Heap a = IntPSQ Precedence a--data PriorityQueue a = PriorityQueue {-    baseDeficit :: Deficit-  , queue :: Heap a-  }--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs-  where-    idxs = [1..256] :: [Double]-    calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Int Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------empty :: PriorityQueue a-empty = PriorityQueue 0 P.empty--isEmpty :: PriorityQueue a -> Bool-isEmpty PriorityQueue{..} = P.null queue--enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a-enqueue k p@Precedence{..} v PriorityQueue{..} =-    PriorityQueue baseDeficit queue'-  where-    d = weightToDeficit weight-    b = if deficit == 0 then baseDeficit else deficit-    deficit' = max (b + d) baseDeficit-    p' = p { deficit = deficit' }-    queue' = P.insert k p' v queue--dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a)-dequeue PriorityQueue{..} = case P.minView queue of-    Nothing                -> Nothing-    Just (k, p, v, queue') -> let base = deficit p-                              in Just (k, p, v, PriorityQueue base queue')--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k q@PriorityQueue{..} = case P.alter f k queue of-    (mv@(Just _), queue') -> case P.minView queue of-        Nothing          -> error "delete"-        Just (k',p',_,_)-          | k' == k      -> (mv, PriorityQueue (deficit p') queue')-          | otherwise    -> (mv, PriorityQueue baseDeficit queue')-    (Nothing, _)         -> (Nothing, q)-  where-    f Nothing      = (Nothing, Nothing)-    f (Just (_,v)) = (Just v,  Nothing)
− Network/HTTP2/Priority/Queue.hs 
@@ -1,42 +0,0 @@-module Network.HTTP2.Priority.Queue (-    Precedence(..)-  , TPriorityQueue-  , new-  , isEmpty-  , enqueue-  , dequeue-  , delete-  ) where--import Control.Concurrent.STM-import Network.HTTP2.Priority.PSQ (PriorityQueue, Key, Precedence(..))-import qualified Network.HTTP2.Priority.PSQ as Q--------------------------------------------------------------------newtype TPriorityQueue a = TPriorityQueue (TVar (PriorityQueue a))--new :: STM (TPriorityQueue a)-new = TPriorityQueue <$> newTVar Q.empty--isEmpty :: TPriorityQueue a -> STM Bool-isEmpty (TPriorityQueue th) = Q.isEmpty <$> readTVar th--enqueue :: TPriorityQueue a -> Key -> Precedence -> a -> STM ()-enqueue (TPriorityQueue th) k p v = modifyTVar' th $ Q.enqueue k p v--dequeue :: TPriorityQueue a -> STM (Key, Precedence, a)-dequeue (TPriorityQueue th) = do-  h <- readTVar th-  case Q.dequeue h of-    Nothing -> retry-    Just (k, p, v, h') -> do-      writeTVar th h'-      return (k, p, v)--delete :: Key -> TPriorityQueue a -> STM (Maybe a)-delete k (TPriorityQueue th) = do-    q <- readTVar th-    let (mv, q') = Q.delete k q-    writeTVar th q'-    return mv
Network/HTTP2/Server.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | HTTP\/2 server library. -- --  Example:@@ -15,176 +13,66 @@ -- > import Network.HTTP2.Server -- > -- > main :: IO ()--- > main = runTCPServer Nothing "80" $ \s _peer -> runHTTP2Server s+-- > main = runTCPServer Nothing "80" runHTTP2Server -- >   where -- >     runHTTP2Server s = E.bracket (allocSimpleConfig s 4096) -- >                                  freeSimpleConfig--- >                                  (\config -> run config server)+-- >                                  (\config -> run defaultServerConfig config server) -- >     server _req _aux sendResponse = sendResponse response [] -- >       where -- >         response = responseBuilder ok200 header body -- >         header = [("Content-Type", "text/plain")] -- >         body = byteString "Hello, world!\n"- module Network.HTTP2.Server (-  -- * Runner-    run-  -- * Runner arguments-  , Config(..)-  , allocSimpleConfig-  , freeSimpleConfig-  -- * HTTP\/2 server-  , Server-  -- * Request-  , Request-  -- ** Accessing request-  , requestMethod-  , requestPath-  , requestAuthority-  , requestScheme-  , requestHeaders-  , requestBodySize-  , getRequestBodyChunk-  , getRequestTrailers-  -- * Aux-  , Aux-  , auxTimeHandle-  -- * Response-  , Response-  -- ** Creating response-  , responseNoBody-  , responseFile-  , responseStreaming-  , responseBuilder-  -- ** Accessing response-  , responseBodySize-  -- ** Trailers maker-  , TrailersMaker-  , NextTrailersMaker(..)-  , defaultTrailersMaker-  , setResponseTrailersMaker-  -- * Push promise-  , PushPromise-  , pushPromise-  , promiseRequestPath-  , promiseResponse-  , promiseWeight-  , defaultWeight-  -- * Types-  , Path-  , Authority-  , Scheme-  , FileSpec(..)-  , FileOffset-  , ByteCount-  -- * RecvN-  , defaultReadN-  -- * Position read for files-  , PositionReadMaker-  , PositionRead-  , Sentinel(..)-  , defaultPositionReadMaker-  ) where--import Data.ByteString.Builder (Builder)-import Data.IORef (readIORef)-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Arch-import Network.HTTP2.Frame.Types-import Network.HTTP2.Server.Run (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) = 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+    -- * Runner+    run, --- | 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+    -- * Server configuration+    ServerConfig,+    defaultServerConfig,+    numberOfWorkers,+    connectionWindowSize,+    settings, -----------------------------------------------------------------+    -- * HTTP\/2 setting+    Settings,+    defaultSettings,+    headerTableSize,+    enablePush,+    maxConcurrentStreams,+    initialWindowSize,+    maxFrameSize,+    maxHeaderListSize, --- | 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+    -- ** Rate limits+    pingRateLimit,+    settingsRateLimit,+    emptyFrameRateLimit,+    rstRateLimit, --- | Setting 'TrailersMaker' to 'Response'.-setResponseTrailersMaker :: Response -> TrailersMaker -> Response-setResponseTrailersMaker (Response rsp) tm = Response rsp { outObjTrailers = tm }+    -- * Common configuration+    Config,+    defaultConfig,+    confWriteBuffer,+    confBufferSize,+    confSendAll,+    confReadN,+    confPositionReadMaker,+    confTimeoutManager,+    confMySockAddr,+    confPeerSockAddr,+    confReadNTimeout,+    allocSimpleConfig,+    allocSimpleConfig',+    freeSimpleConfig,+    module Network.HTTP.Semantics.Server,+) where -----------------------------------------------------------------+import Network.HTTP.Semantics.Server --- | Creating push promise.---   The third argument is traditional, not used.-pushPromise :: ByteString -> Response -> Weight -> PushPromise-pushPromise path rsp w = PushPromise path rsp w+import Network.HTTP2.H2+import Network.HTTP2.Server.Run (+    ServerConfig (..),+    defaultServerConfig,+    run,+ )
Network/HTTP2/Server/Internal.hs view
@@ -1,7 +1,18 @@ module Network.HTTP2.Server.Internal (-    Request(..)-  , Response(..)-  , Aux(..)-  ) where+    Request (..),+    Response (..),+    Config (..),+    ServerConfig (..),+    Aux (..), -import Network.HTTP2.Server.Types+    -- * Low level+    Stream,+    ServerIO (..),+    runIO,+) where++import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal++import Network.HTTP2.H2+import Network.HTTP2.Server.Run
Network/HTTP2/Server/Run.hs view
@@ -3,53 +3,137 @@  module Network.HTTP2.Server.Run where -import Control.Concurrent (forkIO, killThread)-import qualified Control.Exception as E-+import Control.Concurrent.Async+import Control.Concurrent.STM import Imports-import Network.HTTP2.Arch+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 qualified System.ThreadManager as T+ import Network.HTTP2.Frame-import Network.HTTP2.Server.Types+import Network.HTTP2.H2 import Network.HTTP2.Server.Worker +-- | Server configuration+data ServerConfig = ServerConfig+    { numberOfWorkers :: Int+    -- ^ Deprecated field.+    , connectionWindowSize :: WindowSize+    -- ^ The window size of incoming streams+    , settings :: Settings+    -- ^ Settings+    }+    deriving (Eq, Show)++{-# DEPRECATED numberOfWorkers "No effect anymore" #-}++-- | The default server config.+--+-- >>> defaultServerConfig+-- 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+        { numberOfWorkers = 8+        , connectionWindowSize = defaultMaxData+        , settings = defaultSettings+        }+ ----------------------------------------------------------------  -- | Running HTTP/2 server.-run :: Config -> Server -> IO ()-run conf@Config{..} server = do-    ok <- checkPreface+run :: ServerConfig -> Config -> Server -> IO ()+run sconf conf server = do+    ok <- checkPreface conf     when ok $ do-        serverInfo <- newServerInfo-        ctx <- newContext serverInfo-        -- Workers, worker manager and timer manager-        mgr <- start confTimeoutManager-        let wc = fromContext ctx-        setAction mgr $ worker wc mgr server-        -- The number of workers is 3.-        -- This was carefully chosen based on a lot of benchmarks.-        -- If it is 1, we cannot avoid head-of-line blocking.-        -- If it is large, huge memory is consumed and many-        -- context switches happen.-        replicateM_ 3 $ spawnAction mgr-        -- Receiver-        tid <- forkIO $ frameReceiver ctx confReadN-        -- Sender-        -- frameSender is the main thread because it ensures to send-        -- a goway frame.-        frameSender ctx conf mgr `E.finally` do-            stop mgr-            killThread tid-  where-    checkPreface = do-        preface <- confReadN connectionPrefaceLength-        if connectionPreface /= preface then do+        let lnch = runServer conf server+        ctx <- setup sconf conf lnch Nothing+        runH2 conf ctx++----------------------------------------------------------------++data ServerIO a = ServerIO+    { sioMySockAddr :: SockAddr+    , sioPeerSockAddr :: SockAddr+    , 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.+-- Any frames can be sent with `sioWriteBytes`.+runIO+    :: ServerConfig+    -> Config+    -> (ServerIO Stream -> IO (IO ()))+    -> IO ()+runIO sconf conf@Config{..} action = do+    ok <- checkPreface conf+    when ok $ do+        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+    preface <- confReadN connectionPrefaceLength+    if connectionPreface /= preface+        then do             goaway conf ProtocolError "Preface mismatch"             return False-          else-            return True+        else return True +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 -> 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 -> ErrorCodeId -> ByteString -> IO ()+goaway :: Config -> ErrorCode -> ByteString -> IO () goaway Config{..} etype debugmsg = confSendAll bytestream   where     bytestream = goawayFrame 0 etype debugmsg
− Network/HTTP2/Server/Types.hs 
@@ -1,43 +0,0 @@-module Network.HTTP2.Server.Types where--import qualified System.TimeManager as T--import Imports-import Network.HTTP2.Arch-import Network.HTTP2.Frame---------------------------------------------------------------------- | 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 {-    -- | Accessor for a URL path in a push promise (a virtual request from a server).-    --   E.g. \"\/style\/default.css\".-      promiseRequestPath :: ByteString-    -- | Accessor for response actually pushed from a server.-    , promiseResponse    :: Response-    -- | Accessor for response weight.-    , promiseWeight      :: Weight-    }--{-# DEPRECATED promiseWeight "Don't use this" #-}---- | Additional information.-newtype Aux = Aux {-    -- | Time handle for the worker processing this request and response.-    auxTimeHandle :: T.Handle-  }
Network/HTTP2/Server/Worker.hs view
@@ -1,229 +1,191 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-}  module Network.HTTP2.Server.Worker (-    worker-  , WorkerConf(..)-  , fromContext-  ) where+    runServer,+) where  import Control.Concurrent.STM-import Control.Exception (SomeException(..), AsyncException(..))-import qualified Control.Exception as E import Data.IORef-import qualified Network.HTTP.Types as H-import qualified System.TimeManager as T+import 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.Arch import Network.HTTP2.Frame-import Network.HTTP2.Server.Types--------------------------------------------------------------------data WorkerConf a = WorkerConf {-    readInputQ     :: IO (Input a)-  , writeOutputQ   :: Output a -> IO ()-  , workerCleanup  :: a -> IO ()-  , isPushable     :: IO Bool-  , insertStream   :: StreamId -> a -> IO ()-  , makePushStream :: a -> PushPromise -> IO (StreamId, StreamId, a)-  }--fromContext :: Context -> WorkerConf Stream-fromContext ctx@Context{..} = WorkerConf {-    readInputQ = atomically $ readTQueue $ inputQ roleInfo-  , writeOutputQ = enqueueOutput outputQ-  , workerCleanup = \strm -> do-        closed ctx strm Killed-        let frame = resetFrame InternalError (streamNumber strm)-        enqueueControl controlQ $ CFrame frame-  , isPushable = enablePush <$> readIORef http2settings-  , insertStream = insert streamTable-  , makePushStream = \pstrm _ -> do-        ws <- initialWindowSize <$> readIORef http2settings-        sid <- getMyNewStreamId ctx-        newstrm <- newPushStream sid ws-        let pid = streamNumber pstrm-        return (pid, sid, newstrm)-  }+import Network.HTTP2.H2  ---------------------------------------------------------------- -pushStream :: WorkerConf a-           -> a -- parent stream-           -> ValueTable -- request-           -> [PushPromise]-           -> IO OutputType-pushStream _ _ _ [] = return OObj-pushStream WorkerConf{..} pstrm reqvt pps0-  | len == 0 = return OObj-  | otherwise = do-        pushable <- isPushable-        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-  where-    len = length pps0-    increment tvar = atomically $ modifyTVar' tvar (+1)-    waiter lim tvar = atomically $ do-        n <- readTVar tvar-        check (n >= lim)-    push _ [] n = return (n :: Int)-    push tvar (pp:pps) n = do-        (pid, sid, newstrm) <- makePushStream pstrm pp-        insertStream sid newstrm-        let scheme = fromJust $ getHeaderValue tokenScheme reqvt-            -- fixme: this value can be Nothing-            auth   = fromJust (getHeaderValue tokenHost reqvt-                            <|> getHeaderValue tokenAuthority 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-        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-      strmbdy push flush-      atomically $ writeTBQueue tbq StreamingFinished-      deleteMyId mgr-  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+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-    go sinfo tcont th = do-        setThreadContinue tcont True-        ex <- E.try $ 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-            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 ThreadKilled    <- E.fromException e -> return False-              -- killed by the local timeout manager-              | Just T.TimeoutThread <- E.fromException e -> do-                  cleanup sinfo-                  return True-              | otherwise -> do-                  cleanup sinfo-                  return True-        cont2 <- getThreadContinue tcont-        clearStreamInfo sinfo-        when (cont1 && cont2) $ go sinfo tcont th-    pauseRequestBody req th = req { inpObjBody = readBody' }+    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+            T.resume th -- this is the same as 'tickle'             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+-- | 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 -{-# INLINE setThreadContinue #-}-setThreadContinue :: ThreadContinue -> Bool -> IO ()-setThreadContinue (ThreadContinue ref) x = writeIORef ref x+---------------------------------------------------------------- -{-# INLINE getThreadContinue #-}-getThreadContinue :: ThreadContinue -> IO Bool-getThreadContinue (ThreadContinue ref) = readIORef ref+pushStream+    :: Config+    -> Context+    -> Stream -- parent stream+    -> ValueTable -- request+    -> [PushPromise]+    -> IO (Maybe (IO ()))+pushStream _ _ _ _ [] = return Nothing+pushStream conf ctx@Context{..} pstrm reqvt pps0+    | len == 0 = return Nothing+    | otherwise = do+        pushable <- enablePush <$> readIORef peerSettings+        if pushable+            then do+                tvar <- newTVarIO 0+                lim <- push tvar pps0 0+                if lim == 0+                    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+        check (n >= lim)+    push _ [] n = return (n :: Int)+    push tvar (pp : pps) n = do+        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)  ---------------------------------------------------------------- --- | The type for cleaning up.-newtype StreamInfo a = StreamInfo (IORef (Maybe a))+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) -{-# 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)
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench-hpack/Main.hs view
@@ -3,47 +3,49 @@ module Main where  import Control.Exception-import Gauge.Main-import Network.HPACK+import Criterion.Main import Data.ByteString (ByteString)+import Network.HPACK  ----------------------------------------------------------------  naive, naiveh, static, statich, linear, linearh :: EncodeStrategy-naive   = EncodeStrategy {compressionAlgo = Naive,  useHuffman = False}-naiveh  = EncodeStrategy {compressionAlgo = Naive,  useHuffman = True}-static  = EncodeStrategy {compressionAlgo = Static, useHuffman = False}-statich = EncodeStrategy {compressionAlgo = Static, useHuffman = True}-linear  = EncodeStrategy {compressionAlgo = Linear, useHuffman = False}-linearh = EncodeStrategy {compressionAlgo = Linear, useHuffman = True}+naive = EncodeStrategy{compressionAlgo = Naive, useHuffman = False}+naiveh = EncodeStrategy{compressionAlgo = Naive, useHuffman = True}+static = EncodeStrategy{compressionAlgo = Static, useHuffman = False}+statich = EncodeStrategy{compressionAlgo = Static, useHuffman = True}+linear = EncodeStrategy{compressionAlgo = Linear, useHuffman = False}+linearh = EncodeStrategy{compressionAlgo = Linear, useHuffman = True}  main :: IO () main = do     hdrs <- read <$> readFile "bench-hpack/headers.hs"     hpacks <- prepare hdrs     _ <- evaluate hpacks-    defaultMain [-        bgroup "HPACK decoding" [-              bench "LinearH" $ nfIO (dec hpacks)+    defaultMain+        [ bgroup+            "HPACK decoding"+            [ bench "LinearH" $ nfIO (dec hpacks)             ]-      , bgroup "HPACK encoding" [-              bench "Naive"   $ nfIO (enc naive   hdrs)-            , bench "HaiveH"  $ nfIO (enc naiveh  hdrs)-            , bench "Static"  $ nfIO (enc static  hdrs)+        , bgroup+            "HPACK encoding"+            [ bench "Naive" $ nfIO (enc naive hdrs)+            , bench "HaiveH" $ nfIO (enc naiveh hdrs)+            , bench "Static" $ nfIO (enc static hdrs)             , bench "StaticH" $ nfIO (enc statich hdrs)-            , bench "Linear"  $ nfIO (enc linear  hdrs)+            , bench "Linear" $ nfIO (enc linear hdrs)             , bench "LinearH" $ nfIO (enc linearh hdrs)             ]-      ]+        ]  -----------------------------------------------------------------prepare :: [HeaderList] -> IO [ByteString]+prepare :: [[Header]] -> IO [ByteString] prepare hdrs = do     tbl <- newDynamicTableForEncoding defaultDynamicTableSize     go tbl hdrs id   where-    go _    []     b = return (b [])-    go !tbl (h:hs) b = do+    go _ [] b = return (b [])+    go !tbl (h : hs) b = do         !frag <- encodeHeader linearh 4096 tbl h         go tbl hs (b . (frag :)) @@ -52,17 +54,17 @@     tbl <- newDynamicTableForDecoding defaultDynamicTableSize 4096     go tbl hpacks   where-    go _    []     = return ()-    go !tbl (f:fs) = do+    go _ [] = return ()+    go !tbl (f : fs) = do         !_ <- decodeHeader tbl f         go tbl fs -enc :: EncodeStrategy -> [HeaderList] -> IO ()+enc :: EncodeStrategy -> [[Header]] -> IO () enc stgy hdrs = do     tbl <- newDynamicTableForEncoding defaultDynamicTableSize     go tbl hdrs   where-    go _    []     = return ()-    go !tbl (h:hs) = do+    go _ [] = return ()+    go !tbl (h : hs) = do         !_ <- encodeHeader stgy 4096 tbl h         go tbl hs
− bench-priority/BinaryHeap.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts, CPP #-}--module BinaryHeap (-    Entry-  , newEntry-  , renewEntry-  , item-  , PriorityQueue(..)-  , new-  , enqueue-  , dequeue-  , delete-  ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Word (Word)-#endif-import Control.Monad (when, void)-import Data.Array (Array, listArray, (!))-import Data.Array.IO (IOArray)-import Data.Array.MArray (newArray_, readArray, writeArray)-import Data.IORef--------------------------------------------------------------------type Weight = Int-type Deficit = Word---- | Abstract data type of entries for priority queues.---   This does not contain Key because Entry is assumed to be stored---   in HTTP/2 stream information, too.-data Entry a = Entry {-    weight  :: {-# UNPACK #-} !Weight-  , item    :: {-# UNPACK #-} !(IORef a) -- ^ Extracting an item from an entry.-  , deficit :: {-# UNPACK #-} !(IORef Deficit)-  , index   :: {-# UNPACK #-} !(IORef Index)-  }--newEntry :: a -> Weight -> IO (Entry a)-newEntry x w = Entry w <$> newIORef x <*> newIORef magicDeficit <*> newIORef (-1)---- | Changing the item of an entry.-renewEntry :: Entry a -> a -> IO ()-renewEntry Entry{..} x = writeIORef item x--------------------------------------------------------------------type Index = Int-type MA a = IOArray Index (Entry a)--data PriorityQueue a = PriorityQueue (IORef Deficit)-                                     (IORef Index)-                                     (MA a)--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs-  where-    idxs = [1..256] :: [Double]-    calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Index Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------new :: Int -> IO (PriorityQueue a)-new n = PriorityQueue <$> newIORef 0-                      <*> newIORef 1-                      <*> newArray_ (1,n)---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> IO ()-enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do-    i <- readIORef idx-    base <- readIORef bref-    d <- readIORef deficit-    let !b = if d == magicDeficit then base else d-        !d' = b + weightToDeficit weight-    writeIORef deficit d'-    write arr i ent-    shiftUp arr i-    let !i' = i + 1-    writeIORef idx i'-    return ()---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> IO (Entry a)-dequeue (PriorityQueue bref idx arr) = do-    ent <- shrink arr 1 idx-    i <- readIORef idx-    shiftDown arr 1 i-    d <- readIORef $ deficit ent-    writeIORef bref $ if i == 1 then 0 else d-    return ent--shrink :: MA a -> Index -> IORef Index -> IO (Entry a)-shrink arr r idx = do-    entr <- readArray arr r-    -- fixme: checking if i == 0-    i <- subtract 1 <$> readIORef idx-    xi <- readArray arr i-    write arr r xi-    writeIORef idx i-    return entr--shiftUp :: MA a -> Int -> IO ()-shiftUp _   1 = return ()-shiftUp arr c = do-    swapped <- swap arr p c-    when swapped $ shiftUp arr p-  where-    p = c `div` 2--shiftDown :: MA a -> Int -> Int -> IO ()-shiftDown arr p n-  | c1 > n    = return ()-  | c1 == n   = void $ swap arr p c1-  | otherwise = do-      let !c2 = c1 + 1-      xc1 <- readArray arr c1-      xc2 <- readArray arr c2-      d1 <- readIORef $ deficit xc1-      d2 <- readIORef $ deficit xc2-      let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2-      swapped <- swap arr p c-      when swapped $ shiftDown arr c n-  where-    c1 = 2 * p--{-# INLINE swap #-}-swap :: MA a -> Index -> Index -> IO Bool-swap arr p c = do-    xp <- readArray arr p-    xc <- readArray arr c-    dp <- readIORef $ deficit xp-    dc <- readIORef $ deficit xc-    if dc < dp then do-        write arr c xp-        write arr p xc-        return True-      else-        return False--{-# INLINE write #-}-write :: MA a -> Index -> Entry a -> IO ()-write arr i ent = do-    writeArray arr i ent-    writeIORef (index ent) i--delete :: Entry a -> PriorityQueue a -> IO ()-delete ent pq@(PriorityQueue _ idx arr) = do-    i <- readIORef $ index ent-    if i == 1 then-        void $ dequeue pq-      else do-        entr <- shrink arr i idx-        r <- readIORef $ index entr-        shiftDown arr r (i - 1)-        shiftUp arr r
− bench-priority/BinaryHeapSTM.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts, CPP #-}--module BinaryHeapSTM (-    Entry-  , newEntry-  , renewEntry-  , item-  , PriorityQueue(..)-  , new-  , enqueue-  , dequeue-  , delete-  ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Word (Word)-#endif-import Control.Concurrent.STM-import Control.Monad (when, void)-import Data.Array (Array, listArray, (!))-import Data.Array.MArray (newArray_, readArray, writeArray)--------------------------------------------------------------------type Weight = Int-type Deficit = Word---- | Abstract data type of entries for priority queues.-data Entry a = Entry {-    weight  :: {-# UNPACK #-} !Weight-  , item    :: {-# UNPACK #-} !(TVar a) -- ^ Extracting an item from an entry.-  , deficit :: {-# UNPACK #-} !(TVar Deficit)-  , index   :: {-# UNPACK #-} !(TVar Index)-  }--newEntry :: a -> Weight -> STM (Entry a)-newEntry x w = Entry w <$> newTVar x <*> newTVar magicDeficit <*> newTVar (-1)---- | Changing the item of an entry.-renewEntry :: Entry a -> a -> STM ()-renewEntry Entry{..} x = writeTVar item x--------------------------------------------------------------------type Index = Int-type MA a = TArray Index (Entry a)---- FIXME: The base (Word64) would be overflowed.---        In that case, the heap must be re-constructed.-data PriorityQueue a = PriorityQueue (TVar Deficit)-                                     (TVar Index)-                                     (MA a)--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs-  where-    idxs = [1..256] :: [Double]-    calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Index Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------new :: Int -> STM (PriorityQueue a)-new n = PriorityQueue <$> newTVar 0-                      <*> newTVar 1-                      <*> newArray_ (1,n)---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> STM ()-enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do-    i <- readTVar idx-    base <- readTVar bref-    d <- readTVar deficit-    let !b = if d == magicDeficit then base else d-        !d' = b + weightToDeficit weight-    writeTVar deficit d'-    write arr i ent-    shiftUp arr i-    let !i' = i + 1-    writeTVar idx i'-    return ()---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> STM (Entry a)-dequeue (PriorityQueue bref idx arr) = do-    ent <- shrink arr 1 idx-    i <- readTVar idx-    shiftDown arr 1 i-    d <- readTVar $ deficit ent-    writeTVar bref $ if i == 1 then 0 else d-    return ent--shrink :: MA a -> Index -> TVar Index -> STM (Entry a)-shrink arr r idx = do-    entr <- readArray arr r-    -- fixme: checking if i == 0-    i <- subtract 1 <$> readTVar idx-    xi <- readArray arr i-    write arr r xi-    writeTVar idx i-    return entr--shiftUp :: MA a -> Int -> STM ()-shiftUp _   1 = return ()-shiftUp arr c = do-    swapped <- swap arr p c-    when swapped $ shiftUp arr p-  where-    p = c `div` 2--shiftDown :: MA a -> Int -> Int -> STM ()-shiftDown arr p n-  | c1 > n    = return ()-  | c1 == n   = void $ swap arr p c1-  | otherwise = do-      let !c2 = c1 + 1-      xc1 <- readArray arr c1-      xc2 <- readArray arr c2-      d1 <- readTVar $ deficit xc1-      d2 <- readTVar $ deficit xc2-      let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2-      swapped <- swap arr p c-      when swapped $ shiftDown arr c n-  where-    c1 = 2 * p--{-# INLINE swap #-}-swap :: MA a -> Index -> Index -> STM Bool-swap arr p c = do-    xp <- readArray arr p-    xc <- readArray arr c-    dp <- readTVar $ deficit xp-    dc <- readTVar $ deficit xc-    if dc < dp then do-        write arr c xp-        write arr p xc-        return True-      else-        return False--{-# INLINE write #-}-write :: MA a -> Index -> Entry a -> STM ()-write arr i ent = do-    writeArray arr i ent-    writeTVar (index ent) i--delete :: Entry a -> PriorityQueue a -> STM ()-delete ent pq@(PriorityQueue _ idx arr) = do-    i <- readTVar $ index ent-    if i == 1 then-        void $ dequeue pq-      else do-        entr <- shrink arr i idx-        r <- readTVar $ index entr-        shiftDown arr r (i - 1)-        shiftUp arr r
− bench-priority/DoublyLinkedQueueIO.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module DoublyLinkedQueueIO (-    Queue-  , Node-  , item-  , new-  , isEmpty-  , enqueue-  , dequeue-  , delete-  ) where--import Data.IORef--data Queue a = Queue {-    entr :: Node a-  , exit :: Node a-  }--data Node a = Node {-    item :: a-  , prev :: {-# UNPACK #-} !(IORef (Node a))-  , next :: {-# UNPACK #-} !(IORef (Node a))-  } deriving Eq--newNode :: a -> IO (Node a)-newNode x = Node x <$> newIORef undefined <*> newIORef undefined--{-# INLINE getNext #-}-getNext :: Node a -> IO (Node a)-getNext Node{..} = readIORef next--{-# INLINE setNext #-}-setNext :: Node a -> Node a -> IO ()-setNext Node{..} x = writeIORef next x--{-# INLINE getPrev #-}-getPrev :: Node a -> IO (Node a)-getPrev Node{..} = readIORef prev--{-# INLINE setPrev #-}-setPrev :: Node a -> Node a -> IO ()-setPrev Node{..} x = writeIORef prev x--new :: IO (Queue a)-new = do-    a1 <- newNode undefined-    a2 <- newNode undefined-    setPrev a1 a2-    setNext a1 a2-    setPrev a2 a1-    setNext a2 a1-    return $! Queue a1 a2--isEmpty :: Queue a -> IO Bool-isEmpty Queue{..} = do-    n <- getNext entr-    nn <- getNext n-    return $! next entr == next nn--enqueue :: a -> Queue a -> IO (Node a)-enqueue a Queue{..} = do-    x <- newNode a-    n <- getNext entr-    setPrev x entr-    setNext x n-    setPrev n x-    setNext entr x-    return x--dequeue :: Queue a -> IO a-dequeue Queue{..} = do-    p <- getPrev exit-    pp <- getPrev p-    setPrev exit pp-    setNext pp exit-    return $! item p--delete :: Node a -> IO ()-delete x = do-    p <- getPrev x-    n <- getNext x-    setNext p n-    setPrev n p
− bench-priority/Heap.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}--module Heap (-    PriorityQueue(..)-  , Precedence(..)-  , newPrecedence-  , empty-  , isEmpty-  , enqueue-  , dequeue-  , delete-  ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-import Data.Word (Word)-#endif-import Data.Array (Array, listArray, (!))-import Data.Heap (Heap)-import qualified Data.Heap as H--------------------------------------------------------------------type Key = Int-type Weight = Int-type Deficit = Word -- Deficit can be overflowed--data Precedence = Precedence {-    deficit    :: {-# UNPACK #-} !Deficit-  , weight     :: {-# UNPACK #-} !Weight-  -- stream dependency, used by the upper layer-  , dependency :: {-# UNPACK #-} !Key-  } deriving Show---- | For test only-newPrecedence :: Weight -> Precedence-newPrecedence w = Precedence 0 w 0--instance Eq Precedence where-  Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2--instance Ord Precedence where-  -- This is correct even if one of them is overflowed-  Precedence d1 _ _ <  Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW-  Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW--data Entry a = Entry Key Precedence a--instance Eq (Entry a) where-    Entry _ p1 _ == Entry _ p2 _ = p1 == p2--instance Ord (Entry a) where-    Entry _ p1 _ <  Entry _ p2 _ = p1 <  p2-    Entry _ p1 _ <= Entry _ p2 _ = p1 <= p2---- FIXME: The base (Word64) would be overflowed.---        In that case, the heap must be re-constructed.-data PriorityQueue a = PriorityQueue {-    baseDeficit :: {-# UNPACK #-} !Deficit-  , queue :: Heap (Entry a)-  }--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs-  where-    idxs = [1..256] :: [Double]-    calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Int Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------empty :: PriorityQueue a-empty = PriorityQueue 0 H.empty--isEmpty :: PriorityQueue a -> Bool-isEmpty (PriorityQueue _ h) = H.null h--enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a-enqueue k p v PriorityQueue{..} = PriorityQueue b queue'-  where-    !d = weightToDeficit (weight p)-    !b = if deficit p == magicDeficit then baseDeficit else deficit p-    !deficit' = max (b + d) baseDeficit-    !p' = p { deficit = deficit' }-    !queue' = H.insert (Entry k p' v) queue--dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a)-dequeue (PriorityQueue _ heap) = case H.uncons heap of-    Nothing                   -> Nothing-    Just (Entry k p v, heap') -> Just (k, p, v, PriorityQueue (deficit p) heap')--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k (PriorityQueue base heap) = (mv, PriorityQueue base' heap')-  where-    !(h,heap') = H.partition  (\(Entry k' _ _) -> k' == k) heap-    mv = case H.viewMin h of-        Nothing               -> Nothing-        Just (Entry _ _ v, _) -> Just v-    base' = case H.viewMin heap of-        Nothing       -> base-        Just (Entry k' p _, _)-          | k == k'   -> deficit p-          | otherwise -> base
− bench-priority/Main.hs 
@@ -1,240 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main where--import Control.Concurrent.STM-import Gauge.Main-import Data.List (foldl')-import System.Random.MWC--import qualified RingOfQueuesSTM as A-import qualified RingOfQueues as AIO-import qualified BinaryHeapSTM as B-import qualified BinaryHeap as BIO-import qualified Heap as O-import qualified Network.HTTP2.Priority.PSQ as P-import qualified RandomSkewHeap as R--type Key = Int-type Weight = Int--numOfStreams :: Int-numOfStreams = 100--numOfTrials :: Int-numOfTrials = 10000--main :: IO ()-main = do-    gen <- create-    ws <- uniformRs (1,256) gen numOfStreams-    let ks = [1,3..]-        xs = zip ks ws-    defaultMain [-        bgroup "enqueue & dequeue" [-              bench "Random Skew Heap"      $ whnf enqdeqR xs-            , bench "Skew Binomial Heap"    $ whnf enqdeqO xs-            , bench "Priority Search Queue" $ whnf enqdeqP xs-            , bench "Binary Heap"           $ nfIO (enqdeqBIO xs)-            , bench "Binary Heap STM"       $ nfIO (enqdeqB xs)-            , bench "Ring of Queues"        $ nfIO (enqdeqAIO xs)-            , bench "Ring of Queues STM"    $ nfIO (enqdeqA xs)-            ]-      , bgroup "delete" [-              bench "Random Skew Heap"      $ whnf deleteR xs-            , bench "Skew Binomial Heap"    $ whnf deleteO xs-            , bench "Priority Search Queue" $ whnf deleteP xs-            , bench "Binary Heap"           $ nfIO (deleteBIO xs)-            , bench "Binary Heap STM"       $ nfIO (deleteB xs)-            , bench "Ring of Queues IO"     $ nfIO (deleteAIO xs)-            ]-      ]-  where-    uniformRs range gen n = loop n []-      where-        loop 0 rs = return rs-        loop i rs = do-            r <- uniformR range gen-            loop (i-1) (r:rs)--------------------------------------------------------------------enqdeqR :: [(Key,Weight)] -> ()-enqdeqR xs = loop pq numOfTrials-  where-    !pq = createR xs R.empty-    loop _ 0  = ()-    loop q !n = case R.dequeue q of-        Nothing -> error "enqdeqR"-        Just (k,w,v,q') -> let !q'' = R.enqueue k w v q'-                           in loop q'' (n - 1)--deleteR :: [(Key,Weight)] -> R.PriorityQueue Int-deleteR xs = foldl' (\q k -> let (_,!q') = R.delete k q in q') pq ks-  where-    !pq = createR xs R.empty-    (ks,_) = unzip xs--createR :: [(Key,Weight)] -> R.PriorityQueue Int -> R.PriorityQueue Int-createR [] !q = q-createR ((k,w):xs) !q = createR xs q'-  where-    !v = k-    !q' = R.enqueue k w v q--------------------------------------------------------------------enqdeqO :: [(Key,Weight)] -> O.PriorityQueue Int-enqdeqO xs = loop pq numOfTrials-  where-    !pq = createO xs O.empty-    loop !q  0 = q-    loop !q !n = case O.dequeue q of-        Nothing -> error "enqdeqO"-        Just (k,p,v,q') -> loop (O.enqueue k p v q') (n - 1)--deleteO :: [(Key,Weight)] -> O.PriorityQueue Int-deleteO xs = foldl' (\q k -> let (_,!q') = O.delete k q in q') pq ks-  where-    !pq = createO xs O.empty-    (ks,_) = unzip xs--createO :: [(Key,Weight)] -> O.PriorityQueue Int -> O.PriorityQueue Int-createO [] !q = q-createO ((k,w):xs) !q = createO xs q'-  where-    !pre = O.newPrecedence w-    !v = k-    !q' = O.enqueue k pre v q--------------------------------------------------------------------enqdeqP :: [(Key,Weight)] -> P.PriorityQueue Int-enqdeqP xs = loop pq numOfTrials-  where-    !pq = createP xs P.empty-    loop !q 0  = q-    loop !q !n = case P.dequeue q of-        Nothing -> error "enqdeqP"-        Just (k,pre,x,q') -> loop (P.enqueue k pre x q') (n - 1)--deleteP :: [(Key,Weight)] -> P.PriorityQueue Int-deleteP xs = foldl' (\q k -> let (_,!q') = P.delete k q in q') pq ks-  where-    !pq = createP xs P.empty-    (ks,_) = unzip xs--createP :: [(Key,Weight)] -> P.PriorityQueue Int -> P.PriorityQueue Int-createP [] !q = q-createP ((k,w):xs) !q = createP xs q'-  where-    !pre = P.newPrecedence w-    !v = k-    !q' = P.enqueue k pre v q--------------------------------------------------------------------enqdeqB :: [(Key,Weight)] -> IO ()-enqdeqB xs = do-    q <- atomically (B.new numOfStreams)-    _ <- createB xs q-    loop q numOfTrials-  where-    loop _ 0  = return ()-    loop q !n = do-        ent <- atomically $ B.dequeue q-        atomically $ B.enqueue ent q-        loop q (n - 1)--deleteB :: [(Key,Weight)] -> IO ()-deleteB xs = do-    q <- atomically $ B.new numOfStreams-    ents <- createB xs q-    mapM_ (\ent -> atomically $ B.delete ent q) ents--createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO [B.Entry Key]-createB []          _ = return []-createB ((k,w):xs) !q = do-    ent <- atomically $ B.newEntry k w-    atomically $ B.enqueue ent q-    ents <- createB xs q-    return $ ent:ents--------------------------------------------------------------------enqdeqBIO :: [(Key,Weight)] -> IO ()-enqdeqBIO xs = do-    q <- BIO.new numOfStreams-    _ <- createBIO xs q-    loop q numOfTrials-  where-    loop _ 0  = return ()-    loop q !n = do-        ent <- BIO.dequeue q-        BIO.enqueue ent q-        loop q (n - 1)--deleteBIO :: [(Key,Weight)] -> IO ()-deleteBIO xs = do-    q <- BIO.new numOfStreams-    ents <- createBIO xs q-    mapM_ (\ent -> BIO.delete ent q) ents--createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO [BIO.Entry Key]-createBIO []          _ = return []-createBIO ((k,w):xs) !q = do-    ent <- BIO.newEntry k w-    BIO.enqueue ent q-    ents <- createBIO xs q-    return $ ent:ents--------------------------------------------------------------------enqdeqA :: [(Key,Weight)] -> IO ()-enqdeqA ws = do-    q <- atomically A.new-    createA ws q-    loop q numOfTrials-  where-    loop _ 0  = return ()-    loop q !n = do-        ent <- atomically $ A.dequeue q-        atomically $ A.enqueue ent q-        loop q (n - 1)--createA :: [(Key,Weight)] -> A.PriorityQueue Int -> IO ()-createA [] _          = return ()-createA ((k,w):xs) !q = do-    let !ent = A.newEntry k w-    atomically $ A.enqueue ent q-    createA xs q--------------------------------------------------------------------enqdeqAIO :: [(Key,Weight)] -> IO ()-enqdeqAIO xs = do-    q <- AIO.new-    _ <- createAIO xs q-    loop q numOfTrials-  where-    loop _ 0  = return ()-    loop q !n = do-        Just ent <- AIO.dequeue q-        _ <- AIO.enqueue ent q-        loop q (n - 1)--deleteAIO :: [(Key,Weight)] -> IO ()-deleteAIO xs = do-    q <- AIO.new-    ns <- createAIO xs q-    mapM_ AIO.delete ns--createAIO :: [(Key,Weight)] -> AIO.PriorityQueue Int -> IO [AIO.Node (AIO.Entry Weight)]-createAIO []          _ = return []-createAIO ((k,w):xs) !q = do-    let !ent = AIO.newEntry k w-    n <- AIO.enqueue ent q-    ns <- createAIO xs q-    return $ n : ns------------------------------------------------------------------
− bench-priority/RandomSkewHeap.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- This data structure is based on skew heap.------ If we take weight as priority, a typical heap (priority queue)--- is not fair enough. Consider two weight 201 for A and 101 for B.--- A typical heap would generate A(201), A(200), A(199), A(198), ....,--- and finally A(101), B(101), A(100), B(100).--- What we want is A, A, B, A, A, B...------ So, we introduce randomness to Skew Heap.------ In the random binary tree,--- an element is selected as the root with probability of--- 1 / (n + 1) where n is the size of the original tree.--- In the random skew heap, an element is selected as the root--- with the probability of weight / total_weight.------ Since this data structure uses random numbers, APIs should be--- essentially impure. But since this is used with STM,--- APIs are made to be pure with unsafePerformIO.--module RandomSkewHeap (-    PriorityQueue-  , empty-  , isEmpty-  , enqueue-  , dequeue-  , delete-  ) where--import Data.List (partition)-import System.IO.Unsafe (unsafePerformIO)-import System.Random.MWC (createSystemRandom, uniformR, GenIO)--------------------------------------------------------------------type Key = Int-type Weight = Int--------------------------------------------------------------------data PriorityQueue a = Leaf | Node {-# UNPACK #-} !Weight -- total-                                   {-# UNPACK #-} !Key-                                   {-# UNPACK #-} !Weight-                                   !a-                                   !(PriorityQueue a)-                                   !(PriorityQueue a) deriving Show--------------------------------------------------------------------empty :: PriorityQueue a-empty = Leaf--isEmpty :: PriorityQueue a -> Bool-isEmpty Leaf = True-isEmpty _    = False--singleton :: Key -> Weight -> a -> PriorityQueue a-singleton k w v = Node w k w v Leaf Leaf--------------------------------------------------------------------enqueue :: Key -> Weight -> a -> PriorityQueue a -> PriorityQueue a-enqueue k w v q = merge (singleton k w v) q---- if l is a singleton, w1 == tw1.-merge :: PriorityQueue t -> PriorityQueue t -> PriorityQueue t-merge t Leaf = t-merge Leaf t = t-merge l@(Node tw1 k1 w1 v1 ll lr) r@(Node tw2 k2 w2 v2 rl rr)-  | g <= w1   = Node tw k1 w1 v1 lr $ merge ll r-  | otherwise = Node tw k2 w2 v2 rr $ merge rl l-  where-    tw = tw1 + tw2-    g = unsafePerformIO $ uniformR (1,tw) gen-{-# NOINLINE merge #-}--dequeue :: PriorityQueue a -> Maybe (Key, Weight, a, PriorityQueue a)-dequeue Leaf               = Nothing-dequeue (Node _ k w v l r) = Just (k, w, v, t)-  where-    !t = merge l r--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k q = (mv, fromList xs')-  where-    !xs = toList q-    (!ds,!xs') = partition (\(k',_,_) -> k' == k) xs-    mv = case ds of-       []          -> Nothing-       ((_,_,v):_) -> Just v--toList :: PriorityQueue a -> [(Key, Weight, a)]-toList q = go q id []-  where-    go Leaf b = b-    go (Node _ k w v l r) b = go r (go l (((k,w,v) :) . b))--fromList :: [(Key, Weight, a)] -> PriorityQueue a-fromList xs = go empty xs-  where-    go !q [] = q-    go !q ((k,w,v):xks) = go (enqueue k w v q) xks--{-# NOINLINE gen #-}-gen :: GenIO-gen = unsafePerformIO createSystemRandom
− bench-priority/RingOfQueues.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}---- Haskell implementation of H2O's priority queue.--- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c--module RingOfQueues (-    Entry-  , newEntry-  , renewEntry-  , item-  , Node-  , PriorityQueue(..)-  , new-  , enqueue-  , dequeue-  , delete-  ) where--import Control.Monad (replicateM)-import Data.Array (Array, listArray, (!))-import Data.Bits (setBit, clearBit, shiftR)-import Data.IORef-import Data.Word (Word64)-import Foreign.C.Types (CLLong(..))--import DoublyLinkedQueueIO (Queue, Node)-import qualified DoublyLinkedQueueIO as Q--------------------------------------------------------------------type Weight = Int---- | Abstract data type of entries for priority queues.-data Entry a = Entry {-    item :: a -- ^ Extracting an item from an entry.-  , weight  :: {-# UNPACK #-} !Weight-  , deficit :: {-# UNPACK #-} !Int-  } deriving Show--newEntry :: a -> Weight -> Entry a-newEntry x w = Entry x w 0---- | Changing the item of an entry.-renewEntry :: Entry a -> b -> Entry b-renewEntry ent x = ent { item = x }--------------------------------------------------------------------data PriorityQueue a = PriorityQueue {-    bitsRef   :: IORef Word64-  , offsetRef :: IORef Int-  , queues    :: Array Int (Queue (Entry a))-  }--------------------------------------------------------------------bitWidth :: Int-bitWidth = 64--relativeIndex :: Int -> Int -> Int-relativeIndex idx offset = (offset + idx) `mod` bitWidth--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitList :: [Int]-deficitList = map calc idxs-  where-    idxs :: [Double]-    idxs = [1..256]-    calc w = round (65536 * 63 / w)--deficitTable :: Array Int Int-deficitTable = listArray (1,256) deficitList---------------------------------------------------------------------- https://en.wikipedia.org/wiki/Find_first_set-foreign import ccall unsafe "strings.h ffsll"-    c_ffs :: CLLong -> CLLong---- | Finding first bit set. O(1)------ >>> firstBitSet $ setBit 0 63--- 63--- >>> firstBitSet $ setBit 0 62--- 62--- >>> firstBitSet $ setBit 0 1--- 1--- >>> firstBitSet $ setBit 0 0--- 0--- >>> firstBitSet 0--- -1-firstBitSet :: Word64 -> Int-firstBitSet x = ffs x - 1-  where-    ffs = fromIntegral . c_ffs . fromIntegral--------------------------------------------------------------------new :: IO (PriorityQueue a)-new = PriorityQueue <$> newIORef 0 <*> newIORef 0 <*> newQueues-  where-    newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth Q.new---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> IO (Node (Entry a))-enqueue ent PriorityQueue{..} = do-    let (!idx,!deficit') = calcIdxAndDeficit-    !offidx <- getOffIdx idx-    node <- push offidx ent { deficit = deficit' }-    updateBits idx-    return node-  where-    calcIdxAndDeficit = total `divMod` deficitSteps-      where-        total = deficitTable ! weight ent + deficit ent-    getOffIdx idx = relativeIndex idx <$> readIORef offsetRef-    push offidx ent' = Q.enqueue ent' (queues ! offidx)-    updateBits idx = modifyIORef' bitsRef $ flip setBit idx---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> IO (Maybe (Entry a))-dequeue pq@PriorityQueue{..} = do-    !idx <- getIdx-    if idx == -1 then-        return Nothing-      else do-        !offidx <- getOffIdx idx-        updateOffset offidx-        queueIsEmpty <- checkEmpty offidx-        updateBits idx queueIsEmpty-        if queueIsEmpty then-            dequeue pq-          else-            Just <$> pop offidx-  where-    getIdx = firstBitSet <$> readIORef bitsRef-    getOffIdx idx = relativeIndex idx <$> readIORef offsetRef-    pop offidx = Q.dequeue (queues ! offidx)-    checkEmpty offidx = Q.isEmpty (queues ! offidx)-    updateOffset offset' = writeIORef offsetRef offset'-    updateBits idx isEmpty = modifyIORef' bitsRef shiftClear-      where-        shiftClear bits-          | isEmpty   = clearBit (shiftR bits idx) 0-          | otherwise = shiftR bits idx---- bits is not updated because it's difficult.-delete :: Node (Entry a) -> IO ()-delete node = Q.delete node
− bench-priority/RingOfQueuesSTM.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}---- Haskell implementation of H2O's priority queue.--- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c---- delete is not supported because TQueue does not support deletion.--- So, key is not passed to enqueue.--module RingOfQueuesSTM (-    Entry-  , newEntry-  , renewEntry-  , item-  , PriorityQueue(..)-  , new-  , enqueue-  , dequeue-  ) where--import Control.Concurrent.STM-import Control.Monad (replicateM)-import Data.Array (Array, listArray, (!))-import Data.Bits (setBit, clearBit, shiftR)-import Data.Word (Word64)-import Foreign.C.Types (CLLong(..))--------------------------------------------------------------------type Weight = Int---- | Abstract data type of entries for priority queues.-data Entry a = Entry {-    item :: a -- ^ Extracting an item from an entry.-  , weight  :: {-# UNPACK #-} !Weight-  , deficit :: {-# UNPACK #-} !Int-  } deriving Show--newEntry :: a -> Weight -> Entry a-newEntry x w = Entry x w 0---- | Changing the item of an entry.-renewEntry :: Entry a -> b -> Entry b-renewEntry ent x = ent { item = x }--------------------------------------------------------------------data PriorityQueue a = PriorityQueue {-    bitsRef   :: TVar Word64-  , offsetRef :: TVar Int-  , queues    :: Array Int (TQueue (Entry a))-  }--------------------------------------------------------------------bitWidth :: Int-bitWidth = 64--relativeIndex :: Int -> Int -> Int-relativeIndex idx offset = (offset + idx) `mod` bitWidth--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitList :: [Int]-deficitList = map calc idxs-  where-    idxs :: [Double]-    idxs = [1..256]-    calc w = round (65536 * 63 / w)--deficitTable :: Array Int Int-deficitTable = listArray (1,256) deficitList---------------------------------------------------------------------- https://en.wikipedia.org/wiki/Find_first_set-foreign import ccall unsafe "strings.h ffsll"-    c_ffs :: CLLong -> CLLong---- | Finding first bit set. O(1)------ >>> firstBitSet $ setBit 0 63--- 63--- >>> firstBitSet $ setBit 0 62--- 62--- >>> firstBitSet $ setBit 0 1--- 1--- >>> firstBitSet $ setBit 0 0--- 0--- >>> firstBitSet 0--- -1-firstBitSet :: Word64 -> Int-firstBitSet x = ffs x - 1-  where-    ffs = fromIntegral . c_ffs . fromIntegral--------------------------------------------------------------------new :: STM (PriorityQueue a)-new = PriorityQueue <$> newTVar 0 <*> newTVar 0 <*> newQueues-  where-    newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth newTQueue---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> STM ()-enqueue ent PriorityQueue{..} = do-    let (!idx,!deficit') = calcIdxAndDeficit-    !offidx <- getOffIdx idx-    push offidx ent { deficit = deficit' }-    updateBits idx-  where-    calcIdxAndDeficit = total `divMod` deficitSteps-      where-        total = deficitTable ! weight ent + deficit ent-    getOffIdx idx = relativeIndex idx <$> readTVar offsetRef-    push offidx ent' = writeTQueue (queues ! offidx) ent'-    updateBits idx = modifyTVar' bitsRef $ flip setBit idx---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> STM (Entry a)-dequeue pq@PriorityQueue{..} = do-    !idx <- getIdx-    if idx == -1 then-        retry-      else do-        !offidx <- getOffIdx idx-        updateOffset offidx-        queueIsEmpty <- checkEmpty offidx-        updateBits idx queueIsEmpty-        if queueIsEmpty then-            dequeue pq-          else-            pop offidx-  where-    getIdx = firstBitSet <$> readTVar bitsRef-    getOffIdx idx = relativeIndex idx <$> readTVar offsetRef-    pop offidx = readTQueue (queues ! offidx)-    checkEmpty offidx = isEmptyTQueue (queues ! offidx)-    updateOffset offset' = writeTVar offsetRef offset'-    updateBits idx isEmpty = modifyTVar' bitsRef shiftClear-      where-        shiftClear bits-          | isEmpty   = clearBit (shiftR bits idx) 0-          | otherwise = shiftR bits idx
http2.cabal view
@@ -1,430 +1,408 @@-Name:                   http2-Version:                3.0.3-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>-License:                BSD3-License-File:           LICENSE-Synopsis:               HTTP/2 library-Description:            HTTP/2 library including frames, priority queues, HPACK, client and server.-Homepage:               https://github.com/kazu-yamamoto/http2-Category:               Network-Cabal-Version:          >= 1.10-Build-Type:             Simple-Extra-Source-Files:     ChangeLog.md-                        test/inputFile-                        test-hpack/hpack-test-case/go-hpack/*.json-                        test-hpack/hpack-test-case/haskell-http2-linear/*.json-                        test-hpack/hpack-test-case/haskell-http2-linear-huffman/*.json-                        test-hpack/hpack-test-case/haskell-http2-naive/*.json-                        test-hpack/hpack-test-case/haskell-http2-naive-huffman/*.json-                        test-hpack/hpack-test-case/haskell-http2-static/*.json-                        test-hpack/hpack-test-case/haskell-http2-static-huffman/*.json-                        test-hpack/hpack-test-case/nghttp2/*.json-                        test-hpack/hpack-test-case/nghttp2-16384-4096/*.json-                        test-hpack/hpack-test-case/nghttp2-change-table-size/*.json-                        test-hpack/hpack-test-case/node-http2-hpack/*.json-                        test-frame/http2-frame-test-case/continuation/*.json-                        test-frame/http2-frame-test-case/data/*.json-                        test-frame/http2-frame-test-case/error/*.json-                        test-frame/http2-frame-test-case/goaway/*.json-                        test-frame/http2-frame-test-case/headers/*.json-                        test-frame/http2-frame-test-case/ping/*.json-                        test-frame/http2-frame-test-case/priority/*.json-                        test-frame/http2-frame-test-case/push_promise/*.json-                        test-frame/http2-frame-test-case/rst_stream/*.json-                        test-frame/http2-frame-test-case/settings/*.json-                        test-frame/http2-frame-test-case/window_update/*.json-                        bench-hpack/headers.hs+cabal-version:      >=1.10+name:               http2+version:            5.4.1+license:            BSD3+license-file:       LICENSE+maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>+author:             Kazu Yamamoto <kazu@iij.ad.jp>+homepage:           https://github.com/kazu-yamamoto/http2+synopsis:           HTTP/2 library+description:+    HTTP/2 library including frames, HPACK, client and server. -----------------------------------------------------------------+category:           Network+build-type:         Simple+extra-source-files:+    ChangeLog.md+    test/inputFile+    test-hpack/hpack-test-case/go-hpack/*.json+    test-hpack/hpack-test-case/haskell-http2-linear/*.json+    test-hpack/hpack-test-case/haskell-http2-linear-huffman/*.json+    test-hpack/hpack-test-case/haskell-http2-naive/*.json+    test-hpack/hpack-test-case/haskell-http2-naive-huffman/*.json+    test-hpack/hpack-test-case/haskell-http2-static/*.json+    test-hpack/hpack-test-case/haskell-http2-static-huffman/*.json+    test-hpack/hpack-test-case/nghttp2/*.json+    test-hpack/hpack-test-case/nghttp2-16384-4096/*.json+    test-hpack/hpack-test-case/nghttp2-change-table-size/*.json+    test-hpack/hpack-test-case/node-http2-hpack/*.json+    test-frame/http2-frame-test-case/continuation/*.json+    test-frame/http2-frame-test-case/data/*.json+    test-frame/http2-frame-test-case/error/*.json+    test-frame/http2-frame-test-case/goaway/*.json+    test-frame/http2-frame-test-case/headers/*.json+    test-frame/http2-frame-test-case/ping/*.json+    test-frame/http2-frame-test-case/priority/*.json+    test-frame/http2-frame-test-case/push_promise/*.json+    test-frame/http2-frame-test-case/rst_stream/*.json+    test-frame/http2-frame-test-case/settings/*.json+    test-frame/http2-frame-test-case/window_update/*.json+    bench-hpack/headers.hs -Source-Repository head-  Type:                 git-  Location:             git://github.com/kazu-yamamoto/http2+source-repository head+    type:     git+    location: https://github.com/kazu-yamamoto/http2 -Flag devel-  Description:          Development commands-  Default:              False+flag devel+    description: Development commands+    default:     False -Flag h2spec-  Description:          Development commands-  Default:              False+flag h2spec+    description: Development commands+    default:     False -Flag doc-  Description:          Doctest-  Default:              False+library+    exposed-modules:+        Network.HPACK+        Network.HPACK.Internal+        Network.HPACK.Table+        Network.HPACK.Token+        Network.HTTP2.Client+        Network.HTTP2.Client.Internal+        Network.HTTP2.Frame+        Network.HTTP2.Server+        Network.HTTP2.Server.Internal -----------------------------------------------------------------+    other-modules:+        Imports+        Network.HPACK.Builder+        Network.HTTP2.Client.Run+        Network.HPACK.HeaderBlock+        Network.HPACK.HeaderBlock.Decode+        Network.HPACK.HeaderBlock.Encode+        Network.HPACK.HeaderBlock.Integer+        Network.HPACK.Huffman+        Network.HPACK.Huffman.Bit+        Network.HPACK.Huffman.ByteString+        Network.HPACK.Huffman.Decode+        Network.HPACK.Huffman.Encode+        Network.HPACK.Huffman.Params+        Network.HPACK.Huffman.Table+        Network.HPACK.Huffman.Tree+        Network.HPACK.Table.Dynamic+        Network.HPACK.Table.Entry+        Network.HPACK.Table.RevIndex+        Network.HPACK.Table.Static+        Network.HPACK.Types+        Network.HTTP2.H2+        Network.HTTP2.H2.Config+        Network.HTTP2.H2.Context+        Network.HTTP2.H2.EncodeFrame+        Network.HTTP2.H2.HPACK+        Network.HTTP2.H2.Queue+        Network.HTTP2.H2.Receiver+        Network.HTTP2.H2.Sender+        Network.HTTP2.H2.Settings+        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.Worker -Library-  Default-Language:     Haskell2010-  GHC-Options:          -Wall-  Exposed-Modules:      Network.HPACK-                        Network.HPACK.Internal-                        Network.HPACK.Table-                        Network.HPACK.Token-                        Network.HTTP2-                        Network.HTTP2.Client-                        Network.HTTP2.Client.Internal-                        Network.HTTP2.Frame-                        Network.HTTP2.Internal-                        Network.HTTP2.Priority-                        Network.HTTP2.Priority.Internal-                        Network.HTTP2.Server-                        Network.HTTP2.Server.Internal-  Other-Modules:        Imports-                        Network.HPACK.Builder-                        Network.HTTP2.Client.Types-                        Network.HTTP2.Client.Run-                        Network.HPACK.HeaderBlock-                        Network.HPACK.HeaderBlock.Decode-                        Network.HPACK.HeaderBlock.Encode-                        Network.HPACK.HeaderBlock.Integer-                        Network.HPACK.Huffman-                        Network.HPACK.Huffman.Bit-                        Network.HPACK.Huffman.ByteString-                        Network.HPACK.Huffman.Decode-                        Network.HPACK.Huffman.Encode-                        Network.HPACK.Huffman.Params-                        Network.HPACK.Huffman.Table-                        Network.HPACK.Huffman.Tree-                        Network.HPACK.Table.Dynamic-                        Network.HPACK.Table.Entry-                        Network.HPACK.Table.RevIndex-                        Network.HPACK.Table.Static-                        Network.HPACK.Types-                        Network.HTTP2.Arch-                        Network.HTTP2.Arch.Cache-                        Network.HTTP2.Arch.Config-                        Network.HTTP2.Arch.Context-                        Network.HTTP2.Arch.EncodeFrame-                        Network.HTTP2.Arch.File-                        Network.HTTP2.Arch.HPACK-                        Network.HTTP2.Arch.Manager-                        Network.HTTP2.Arch.Queue-                        Network.HTTP2.Arch.Rate-                        Network.HTTP2.Arch.ReadN-                        Network.HTTP2.Arch.Receiver-                        Network.HTTP2.Arch.Sender-                        Network.HTTP2.Arch.Status-                        Network.HTTP2.Arch.Stream-                        Network.HTTP2.Arch.Types-                        Network.HTTP2.Frame.Decode-                        Network.HTTP2.Frame.Encode-                        Network.HTTP2.Frame.Types-                        Network.HTTP2.Priority.PSQ-                        Network.HTTP2.Priority.Queue-                        Network.HTTP2.Server.Run-                        Network.HTTP2.Server.Types-                        Network.HTTP2.Server.Worker-  Build-Depends:        base >= 4.9 && < 5-                      , array-                      , async-                      , bytestring >= 0.10-                      , case-insensitive-                      , containers >= 0.5-                      , http-types-                      , network-                      , network-byte-order >= 0.1.5-                      , psqueues-                      , stm-                      , time-manager-                      , unix-time-  Default-Extensions:   Strict StrictData+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        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 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:+        base >=4.9 && <5,+        async,+        bytestring,+        http-types,+        http2,+        network,+        network-run >= 0.5 && <0.6,+        unix-time -Test-Suite doctest-  if flag(doc)-    Buildable:          True-  else-    Buildable:          False-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-  Ghc-Options:          -Wall-  Main-Is:              doctests.hs-  Build-Depends:        base >= 4.9 && < 5-                      , doctest >= 0.9.3-  Default-Extensions:   Strict StrictData+    if flag(devel) -Test-Suite spec-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        HPACK.DecodeSpec-                        HPACK.EncodeSpec-                        HPACK.HeaderBlock-                        HPACK.HuffmanSpec-                        HPACK.IntegerSpec-                        HTTP2.FrameSpec-                        HTTP2.PrioritySpec-                        HTTP2.ServerSpec-  Build-Depends:        base >= 4.9 && < 5-                      , async-                      , base16-bytestring >= 1.0-                      , bytestring-                      , cryptonite-                      , hspec >= 1.3-                      , http-types-                      , http2-                      , network-                      , network-run >= 0.1.0-                      , typed-process-  Default-Extensions:   Strict StrictData-  Build-Tool-Depends:   hspec-discover:hspec-discover+    else+        buildable: False +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+    build-depends:+        base >=4.9 && <5,+        bytestring,+        crypton,+        http2,+        http-types,+        network-run -Test-Suite spec2-  if flag(h2spec)-    Buildable:          True-  else-    Buildable:          False-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test2-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        ServerSpec-  Build-Depends:        base >= 4.9 && < 5-                      , bytestring-                      , hspec >= 1.3-                      , http-types-                      , http2-                      , network-run >= 0.1.0-                      , typed-process-  Default-Extensions:   Strict StrictData-  Build-Tool-Depends:   hspec-discover:hspec-discover+    if flag(devel) -Test-Suite hpack-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-hpack-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        HPACKDecode-                        HPACKSpec-                        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , aeson >= 2-                      , base16-bytestring >= 1.0-                      , bytestring-                      , directory-                      , filepath-                      , hspec >= 1.3-                      , http2-                      , text-                      , unordered-containers-                      , vector-  Default-Extensions:   Strict StrictData-  Build-Tool-Depends:   hspec-discover:hspec-discover+    else+        buildable: False -Test-Suite frame-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-frame-  GHC-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        Case-                        FrameSpec-                        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , Glob >= 0.9-                      , aeson >= 2-                      , aeson-pretty-                      , base16-bytestring >= 1.0-                      , bytestring-                      , directory-                      , filepath-                      , hspec >= 1.3-                      , http2-                      , network-byte-order-                      , text-                      , unordered-containers-  Default-Extensions:   Strict StrictData-  Build-Tool-Depends:   hspec-discover:hspec-discover+executable hpack-encode+    main-is:            hpack-encode.hs+    hs-source-dirs:     test-hpack+    other-modules:+        HPACKEncode+        JSON -----------------------------------------------------------------+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        aeson >=2,+        aeson-pretty,+        array,+        base16-bytestring >=1.0,+        bytestring,+        containers,+        http2,+        network-byte-order,+        text,+        unordered-containers,+        vector,+        word8 -Executable client-  Default-Language:     Haskell2010-  HS-Source-Dirs:       util-  GHC-Options:          -Wall -threaded-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              client.hs-  Build-Depends:        base >= 4.9 && < 5-                      , bytestring-                      , http-types-                      , http2-                      , network-run-  Default-Extensions:   Strict StrictData+    if flag(devel) -Executable server-  Default-Language:     Haskell2010-  HS-Source-Dirs:       util-  GHC-Options:          -Wall -threaded-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              server.hs-  Build-Depends:        base >= 4.9 && < 5-                      , bytestring-                      , cryptonite-                      , http2-                      , http-types-                      , network-run-  Default-Extensions:   Strict StrictData+    else+        buildable: False -----------------------------------------------------------------+executable hpack-debug+    main-is:            hpack-debug.hs+    hs-source-dirs:     test-hpack+    other-modules:+        HPACKDecode+        JSON -Executable hpack-encode-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-hpack-  GHC-Options:          -Wall-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              hpack-encode.hs-  Other-Modules:        HPACKEncode-                        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , aeson >= 2-                      , aeson-pretty-                      , array-                      , base16-bytestring >= 1.0-                      , bytestring-                      , case-insensitive-                      , containers-                      , http2-                      , network-byte-order-                      , text-                      , unordered-containers-                      , vector-                      , word8-  Default-Extensions:   Strict StrictData+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        aeson >=2,+        array,+        base16-bytestring >=1.0,+        bytestring,+        containers,+        http2,+        network-byte-order,+        text,+        unordered-containers,+        vector,+        word8 -Executable hpack-debug-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-hpack-  GHC-Options:          -Wall-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              hpack-debug.hs-  Other-Modules:        HPACKDecode-                        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , aeson >= 2-                      , array-                      , base16-bytestring >= 1.0-                      , bytestring-                      , case-insensitive-                      , containers-                      , http2-                      , network-byte-order-                      , text-                      , unordered-containers-                      , vector-                      , word8-  Default-Extensions:   Strict StrictData+    if flag(devel) -Executable hpack-stat-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-hpack-  GHC-Options:          -Wall-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              hpack-stat.hs-  Other-Modules:        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , aeson >= 2-                      , aeson-pretty-                      , array-                      , bytestring-                      , case-insensitive-                      , containers-                      , directory-                      , filepath-                      , http2-                      , network-byte-order-                      , text-                      , unordered-containers-                      , vector-                      , word8-  Default-Extensions:   Strict StrictData+    else+        buildable: False -Executable frame-encode-  Default-Language:     Haskell2010-  HS-Source-Dirs:       test-frame-  GHC-Options:          -Wall-  if flag(devel)-    Buildable:          True-  else-    Buildable:          False-  Main-Is:              frame-encode.hs-  Other-Modules:        Case-                        JSON-  Build-Depends:        base >= 4.9 && < 5-                      , aeson >= 2-                      , aeson-pretty-                      , base16-bytestring >= 1.0-                      , bytestring-                      , http2-                      , text-                      , unordered-containers-  Default-Extensions:   Strict StrictData+executable hpack-stat+    main-is:            hpack-stat.hs+    hs-source-dirs:     test-hpack+    other-modules:      JSON+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        aeson >=2,+        aeson-pretty,+        array,+        bytestring,+        containers,+        directory,+        filepath,+        http2,+        network-byte-order,+        text,+        unordered-containers,+        vector,+        word8 -----------------------------------------------------------------+    if flag(devel) -Benchmark priority-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  Hs-Source-Dirs:       bench-priority, .-  Ghc-Options:          -Wall-  Main-Is:              Main.hs-  Other-Modules:        BinaryHeap-                        BinaryHeapSTM-                        DoublyLinkedQueueIO-                        Heap-                        RandomSkewHeap-                        RingOfQueues-                        RingOfQueuesSTM-                        Network.HTTP2.Priority.PSQ-  Build-Depends:        base >= 4.9 && < 5-                      , array-                      , case-insensitive-                      , containers-                      , gauge-                      , heaps-                      , mwc-random-                      , network-byte-order-                      , psqueues-                      , stm-  Default-Extensions:   Strict StrictData+    else+        buildable: False -Benchmark header-compression-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  Hs-Source-Dirs:       bench-hpack-  Ghc-Options:          -Wall-  Main-Is:              Main.hs-  Build-Depends:        base-                      , array-                      , bytestring-                      , case-insensitive-                      , containers-                      , gauge-                      , network-byte-order-                      , stm-                      , http2-  Default-Extensions:   Strict StrictData+executable frame-encode+    main-is:            frame-encode.hs+    hs-source-dirs:     test-frame+    other-modules:+        Case+        JSON++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        aeson >=2,+        aeson-pretty,+        base16-bytestring >=1.0,+        bytestring,+        http2,+        text,+        unordered-containers++    if flag(devel)++    else+        buildable: False++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test+    other-modules:+        HPACK.DecodeSpec+        HPACK.EncodeSpec+        HPACK.HeaderBlock+        HPACK.HuffmanSpec+        HPACK.IntegerSpec+        HTTP2.ClientSpec+        HTTP2.FrameSpec+        HTTP2.ServerSpec++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall -threaded+    build-depends:+        base >=4.9 && <5,+        async,+        base16-bytestring >=1.0,+        bytestring,+        crypton,+        hspec >=1.3,+        http-semantics,+        http-types,+        http2,+        network,+        network-run >= 0.5 && <0.6,+        random,+        typed-process++test-suite spec2+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test2+    other-modules:      ServerSpec+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall -threaded+    build-depends:+        base >=4.9 && <5,+        bytestring,+        hspec >=1.3,+        http-types,+        http2,+        network-run >= 0.5 && <0.6,+        typed-process++    if flag(h2spec)++    else+        buildable: False++test-suite hpack+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test-hpack+    other-modules:+        HPACKDecode+        HPACKSpec+        JSON++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        aeson >=2,+        base16-bytestring >=1.0,+        bytestring,+        directory,+        filepath,+        hspec >=1.3,+        http2,+        text,+        unordered-containers,+        vector++test-suite frame+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test-frame+    other-modules:+        Case+        FrameSpec+        JSON++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        Glob >=0.9,+        aeson >=2,+        aeson-pretty,+        base16-bytestring >=1.0,+        bytestring,+        directory,+        filepath,+        hspec >=1.3,+        http2,+        network-byte-order,+        text,+        unordered-containers++benchmark header-compression+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     bench-hpack+    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base,+        array,+        bytestring,+        case-insensitive,+        containers,+        criterion,+        http2,+        network-byte-order,+        stm
test-frame/Case.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE RecordWildCards, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}  module Case where @@ -11,45 +12,50 @@ import JSON import Network.HTTP2.Frame -data CaseSource = CaseSource {-    cs_description :: String-  , cs_encodeinfo :: EncodeInfo-  , cs_payload :: FramePayload-  } deriving (Show,Read)+data CaseSource = CaseSource+    { cs_description :: String+    , cs_encodeinfo :: EncodeInfo+    , cs_payload :: FramePayload+    }+    deriving (Show, Read) -data CaseWire = CaseWire {-    wire_description :: String-  , wire_hex :: ByteString-  , wire_padding :: Maybe Pad-  , wire_error :: Maybe [ErrorCodeId]-  } deriving (Show,Read)+data CaseWire = CaseWire+    { wire_description :: String+    , wire_hex :: ByteString+    , wire_padding :: Maybe Pad+    , wire_error :: Maybe [ErrorCode]+    }+    deriving (Show, Read)  sourceToWire :: CaseSource -> CaseWire-sourceToWire CaseSource{..} = CaseWire {-    wire_description = cs_description-  , wire_hex = wire-  , wire_padding = Pad <$> encodePadding cs_encodeinfo-  , wire_error = Nothing-  }+sourceToWire CaseSource{..} =+    CaseWire+        { wire_description = cs_description+        , wire_hex = wire+        , wire_padding = Pad <$> encodePadding cs_encodeinfo+        , wire_error = Nothing+        }   where     frame = encodeFrame cs_encodeinfo cs_payload     wire = B16.encode frame  wireToCase :: CaseWire -> Case-wireToCase CaseWire { wire_error = Nothing, ..} = Case {-    description = wire_description-  , wire = wire_hex-  , frame = Just $ FramePad frm wire_padding-  , err = Nothing-  }+wireToCase CaseWire{wire_error = Nothing, ..} =+    Case+        { description = wire_description+        , wire = wire_hex+        , frame = Just $ FramePad frm wire_padding+        , err = Nothing+        }   where     -- fromJust is unsafe-    frm = case decodeFrame defaultSettings $ B16.decodeLenient wire_hex of-        Left  e -> error $ show e+    frm = case decodeFrame $ B16.decodeLenient wire_hex of+        Left e -> error $ show e         Right r -> r-wireToCase CaseWire { wire_error = Just e, ..} = Case {-    description = wire_description-  , wire = wire_hex-  , frame = Nothing-  , err = Just $ fromErrorCodeId <$> e-  }+wireToCase CaseWire{wire_error = Just e, ..} =+    Case+        { description = wire_description+        , wire = wire_hex+        , frame = Nothing+        , err = Just e+        }
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@@ -29,24 +29,26 @@         Left _ -> putStrLn $ "JSON error: " ++ file         Right tc -> do             let bin = B16.decodeLenient $ wire tc-                erc = decodeFrame defaultSettings bin+                erc = decodeFrame bin             case erc of-                Left h2err -> case err tc of+                Left fderr -> case err tc of                     Nothing -> do                         putStrLn file -- fixme-                        print h2err+                        print fderr                     Just errs -> do-                        let e = fromErrorCodeId $ errorCodeId h2err+                        let e = case fderr of+                                FrameDecodeError x _ _ -> x                         errs `shouldContain` [e]                 Right frm -> do                     case frame tc of                         Just fp -> do                             fpFrame fp `shouldBe` frm-                            let einfo = EncodeInfo {-                                    encodeFlags = flags $ frameHeader $ fpFrame fp-                                  , encodeStreamId = streamId (frameHeader frm)-                                  , encodePadding = unPad <$> fpPad fp-                                  }+                            let einfo =+                                    EncodeInfo+                                        { encodeFlags = flags $ frameHeader $ fpFrame fp+                                        , encodeStreamId = streamId (frameHeader frm)+                                        , encodePadding = unPad <$> fpPad fp+                                        }                                 payload = framePayload frm                             encodeFrame einfo payload `shouldBe` bin                         Nothing -> putStrLn file -- fixme
test-frame/JSON.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings, RecordWildCards, CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module JSON where@@ -10,11 +12,11 @@ import Control.Arrow (first) import Control.Monad (mzero) import Data.Aeson+import Data.Aeson.KeyMap (union) import Data.Aeson.Types import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8-import Data.Aeson.KeyMap (union) import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T@@ -31,16 +33,17 @@  (+++) :: Value -> Value -> Value Object x +++ Object y = Object $ x `union` y-Null     +++ x        = x-x        +++ Null     = x-_        +++ _        = error "+++"+Null +++ x = x+x +++ Null = x+_ +++ _ = error "+++"  ---------------------------------------------------------------- -data FramePad = FramePad {-    fpFrame :: Frame-  , fpPad :: Maybe Pad-  } deriving (Show, Read)+data FramePad = FramePad+    { fpFrame :: Frame+    , fpPad :: Maybe Pad+    }+    deriving (Show, Read)  newtype Pad = Pad Padding deriving (Show, Read) @@ -49,12 +52,13 @@  ---------------------------------------------------------------- -data Case = Case {-    description :: String-  , wire :: ByteString-  , frame :: Maybe FramePad-  , err :: Maybe [ErrorCode]-  } deriving (Show, Read)+data Case = Case+    { description :: String+    , wire :: ByteString+    , frame :: Maybe FramePad+    , err :: Maybe [ErrorCode]+    }+    deriving (Show, Read)  ---------------------------------------------------------------- @@ -66,17 +70,23 @@     parseJSON x = StreamIdentifier <$> parseJSON x -} -instance ToJSON ErrorCodeId where-    toJSON e = toJSON $ fromErrorCodeId e+instance ToJSON ErrorCode where+    toJSON e = toJSON $ fromErrorCode e -instance FromJSON ErrorCodeId where-    parseJSON e = toErrorCodeId <$> parseJSON e+instance FromJSON ErrorCode where+    parseJSON e = toErrorCode <$> parseJSON e +instance ToJSON FrameType where+    toJSON e = toJSON $ fromFrameType e++instance FromJSON FrameType where+    parseJSON e = toFrameType <$> parseJSON e+ instance {-# OVERLAPPING #-} ToJSON SettingsList where-    toJSON settings = toJSON $ map (first fromSettingsKeyId) settings+    toJSON settings = toJSON $ map (first fromSettingsKey) settings  instance {-# OVERLAPPING #-} FromJSON SettingsList where-    parseJSON x = map (first (fromJust . toSettingsKeyId)) <$> parseJSON x+    parseJSON x = map (first toSettingsKey) <$> parseJSON x  instance ToJSON ByteString where     toJSON bs = toJSON $ byteStringToText bs@@ -87,64 +97,76 @@ ----------------------------------------------------------------  instance ToJSON FramePayload where-    toJSON (DataFrame body) = object [-        "data" .= body-      ]-    toJSON (HeadersFrame mpri hdr) = object [-        "exclusive"             .= maybe Null (toJSON . exclusive) mpri-      , "stream_dependency"     .= maybe Null (toJSON . streamDependency) mpri-      , "weight"                .= maybe Null (toJSON . weight) mpri-      , "header_block_fragment" .= hdr-      ]-    toJSON (PriorityFrame pri) = object [-        "exclusive" .= exclusive pri-      , "stream_dependency" .= streamDependency pri-      , "weight" .= weight pri-      ]-    toJSON (RSTStreamFrame e) = object [-        "error_code" .= e-      ]-    toJSON (SettingsFrame settings) = object [-        "settings" .= settings-      ]-    toJSON (PushPromiseFrame sid hdr) = object [-        "promised_stream_id" .= sid-      , "header_block_fragment" .= hdr-      ]-    toJSON (PingFrame odata) = object [-        "opaque_data" .= odata-      ]-    toJSON (GoAwayFrame sid e debug) = object [-        "last_stream_id" .= sid-      , "error_code" .= e-      , "additional_debug_data" .= debug-      ]-    toJSON (WindowUpdateFrame size) = object [-        "window_size_increment" .= size-      ]-    toJSON (ContinuationFrame hdr) = object [-        "header_block_fragment" .= hdr-      ]-    toJSON (UnknownFrame _ opaque) = object [-        "payload" .= opaque-      ]+    toJSON (DataFrame body) =+        object+            [ "data" .= body+            ]+    toJSON (HeadersFrame mpri hdr) =+        object+            [ "exclusive" .= maybe Null (toJSON . exclusive) mpri+            , "stream_dependency" .= maybe Null (toJSON . streamDependency) mpri+            , "weight" .= maybe Null (toJSON . weight) mpri+            , "header_block_fragment" .= hdr+            ]+    toJSON (PriorityFrame pri) =+        object+            [ "exclusive" .= exclusive pri+            , "stream_dependency" .= streamDependency pri+            , "weight" .= weight pri+            ]+    toJSON (RSTStreamFrame e) =+        object+            [ "error_code" .= e+            ]+    toJSON (SettingsFrame settings) =+        object+            [ "settings" .= settings+            ]+    toJSON (PushPromiseFrame sid hdr) =+        object+            [ "promised_stream_id" .= sid+            , "header_block_fragment" .= hdr+            ]+    toJSON (PingFrame odata) =+        object+            [ "opaque_data" .= odata+            ]+    toJSON (GoAwayFrame sid e debug) =+        object+            [ "last_stream_id" .= sid+            , "error_code" .= e+            , "additional_debug_data" .= debug+            ]+    toJSON (WindowUpdateFrame size) =+        object+            [ "window_size_increment" .= size+            ]+    toJSON (ContinuationFrame hdr) =+        object+            [ "header_block_fragment" .= hdr+            ]+    toJSON (UnknownFrame _ opaque) =+        object+            [ "payload" .= opaque+            ]  ----------------------------------------------------------------  instance ToJSON FramePad where-    toJSON FramePad{fpFrame = Frame{..},..} = object [-        "length" .= payloadLength frameHeader-      , "type" .= fromFrameTypeId (framePayloadToFrameTypeId framePayload)-      , "flags" .= flags frameHeader-      , "stream_identifier" .= streamId frameHeader-      , "frame_payload" .= (toJSON framePayload +++ padObj)-      ]+    toJSON FramePad{fpFrame = Frame{..}, ..} =+        object+            [ "length" .= payloadLength frameHeader+            , "type" .= framePayloadToFrameType framePayload+            , "flags" .= flags frameHeader+            , "stream_identifier" .= streamId frameHeader+            , "frame_payload" .= (toJSON framePayload +++ padObj)+            ]       where         padObj = case toJSON fpPad of             Null-              | isPaddingDefined framePayload -> emptyPad-              | otherwise                     -> noPad-            x    -> x+                | isPaddingDefined framePayload -> emptyPad+                | otherwise -> noPad+            x -> x  instance FromJSON FramePad where     parseJSON (Object o) = do@@ -153,28 +175,30 @@         flg <- o .: "flags"         sid <- o .: "stream_identifier"         pld <- o .: "frame_payload"-        (payload,mpad) <- parsePayloadPad typ pld-        return FramePad {-            fpFrame = Frame {-                 frameHeader = FrameHeader len flg sid-               , framePayload = payload-               }-          , fpPad = mpad-          }+        (payload, mpad) <- parsePayloadPad typ pld+        return+            FramePad+                { fpFrame =+                    Frame+                        { frameHeader = FrameHeader len flg sid+                        , framePayload = payload+                        }+                , fpPad = mpad+                }     parseJSON _ = mzero  parsePayloadPad :: FrameType -> Object -> Parser (FramePayload, Maybe Pad) parsePayloadPad ftyp o = do     mpad <- (Pad <$>) <$> o .:? "padding"-    payload <- parsePayload ftid o+    payload <- parsePayload ftyp o     return (payload, mpad)-  where-    ftid = toFrameTypeId ftyp  priority :: Object -> Parser Priority-priority o = Priority <$> o .: "exclusive"-                       <*> o .: "stream_dependency"-                       <*> o .: "weight"+priority o =+    Priority+        <$> o .: "exclusive"+        <*> o .: "stream_dependency"+        <*> o .: "weight"  mpriority :: Object -> Parser (Maybe Priority) mpriority o = do@@ -185,7 +209,7 @@         Nothing -> Nothing         Just ex -> Just $ Priority ex (fromJust ms) (fromJust mw) -parsePayload :: FrameTypeId -> Object -> Parser FramePayload+parsePayload :: FrameType -> Object -> Parser FramePayload parsePayload FrameData o = DataFrame <$> o .: "data" parsePayload FrameHeaders o = do     mpri <- mpriority o@@ -194,27 +218,33 @@ parsePayload FramePriority o = PriorityFrame <$> priority o parsePayload FrameRSTStream o = RSTStreamFrame <$> o .: "error_code" parsePayload FrameSettings o = SettingsFrame <$> o .: "settings"-parsePayload FramePushPromise o = PushPromiseFrame <$> o .: "promised_stream_id"-                                                   <*> o .: "header_block_fragment"+parsePayload FramePushPromise o =+    PushPromiseFrame+        <$> o .: "promised_stream_id"+        <*> o .: "header_block_fragment" parsePayload FramePing o = PingFrame <$> o .: "opaque_data"-parsePayload FrameGoAway o = GoAwayFrame <$> o .: "last_stream_id"-                                         <*> o .: "error_code"-                                         <*> o .: "additional_debug_data"+parsePayload FrameGoAway o =+    GoAwayFrame+        <$> o .: "last_stream_id"+        <*> o .: "error_code"+        <*> o .: "additional_debug_data" parsePayload FrameWindowUpdate o = WindowUpdateFrame <$> o .: "window_size_increment" parsePayload FrameContinuation o = ContinuationFrame <$> o .: "header_block_fragment"-parsePayload (FrameUnknown typ) o = UnknownFrame typ <$> o .: "dummy"+parsePayload ftyp o = UnknownFrame ftyp <$> o .: "dummy"  instance ToJSON Pad where-    toJSON (Pad padding) = object [-        "padding_length" .= BS.length padding-      , "padding" .= padding-      ]+    toJSON (Pad padding) =+        object+            [ "padding_length" .= BS.length padding+            , "padding" .= padding+            ]  emptyPad :: Value-emptyPad = object [-    "padding_length" .= Null-  , "padding" .= Null-  ]+emptyPad =+    object+        [ "padding_length" .= Null+        , "padding" .= Null+        ]  noPad :: Value noPad = object []@@ -222,16 +252,19 @@ ----------------------------------------------------------------  instance ToJSON Case where-    toJSON Case{..} = object [-        "description" .= description-      , "wire" .= wire-      , "frame" .= frame-      , "error" .= err-      ]+    toJSON Case{..} =+        object+            [ "description" .= description+            , "wire" .= wire+            , "frame" .= frame+            , "error" .= err+            ]  instance FromJSON Case where-    parseJSON (Object o) = Case <$> o .: "description"-                                <*> o .: "wire"-                                <*> o .:? "frame"-                                <*> o .:? "error"-    parseJSON _          = mzero+    parseJSON (Object o) =+        Case+            <$> o .: "description"+            <*> o .: "wire"+            <*> o .:? "frame"+            <*> o .:? "error"+    parseJSON _ = mzero
test-frame/frame-encode.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Main where  import Data.Aeson@@ -13,10 +11,9 @@ main = do     args <- getArgs     xs <- getContents-    if not (null args) then -- "-w"-        printWire xs-      else-        printJSON xs+    if not (null args) -- "-w"+        then printWire xs+        else printJSON xs  printWire :: String -> IO () printWire = print . sourceToWire . read
test-hpack/HPACKDecode.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module HPACKDecode (-    run-  , Result(..)-  , EncodeStrategy(..)-  , defaultEncodeStrategy-  , CompressionAlgo(..)-  ) where+    run,+    Result (..),+    EncodeStrategy (..),+    defaultEncodeStrategy,+    CompressionAlgo (..),+) where  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))@@ -21,35 +22,37 @@  import JSON -newtype Conf = Conf {-    debug :: Bool-  }+newtype Conf = Conf+    { debug :: Bool+    } -data Result = Pass | Fail String deriving (Eq,Show)+data Result = Pass | Fail String deriving (Eq, Show)  run :: Bool -> Test -> IO Result-run _ (Test _ [])        = return Pass+run _ (Test _ []) = return Pass run d (Test _ ccs) = do     -- 'size c' must not be used. Initial value is defaultDynamicTableSize!     withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dyntbl -> do-        let conf = Conf { debug = d }+        let conf = Conf{debug = d}         testLoop conf ccs dyntbl -testLoop :: Conf-         -> [Case]-         -> DynamicTable-         -> IO Result-testLoop _    []     _      = return Pass-testLoop conf (c:cs) dyntbl = do+testLoop+    :: Conf+    -> [Case]+    -> DynamicTable+    -> IO Result+testLoop _ [] _ = return Pass+testLoop conf (c : cs) dyntbl = do     res <- test conf c dyntbl     case res of         Nothing -> testLoop conf cs dyntbl-        Just  e -> return $ Fail e+        Just e -> return $ Fail e -test :: Conf-     -> Case-     -> DynamicTable-     -> IO (Maybe String)+test+    :: Conf+    -> Case+    -> DynamicTable+    -> IO (Maybe String) test conf c dyntbl = do     -- context is destructive!!!     when (debug conf) $ do@@ -61,28 +64,35 @@         putStrLn "---- Input Hex"         B8.putStrLn wirehex     case size c of-        Nothing  -> return ()+        Nothing -> return ()         Just siz -> renewDynamicTable siz dyntbl     x <- try $ decodeHeader dyntbl inp     case x of         Left e -> return $ Just $ show (e :: DecodeError)         Right hs' -> do             let pass = sort hs == sort hs'-            if pass then-                return Nothing-              else-                return $ Just $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hs ++ "\n" ++ show hs'+            if pass+                then return Nothing+                else+                    return $+                        Just $+                            "Headers are different in "+                                ++ B8.unpack wirehex+                                ++ ":\n"+                                ++ show hs+                                ++ "\n"+                                ++ show hs'   where     wirehex = wire c     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+    printHeader (k, v) = do+        B8.putStr $ original k         putStr ": "         B8.putStr v         putStr "\n"
test-hpack/HPACKEncode.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-}  module HPACKEncode (-    run-  , EncodeStrategy(..)-  , defaultEncodeStrategy-  , CompressionAlgo(..)-  ) where+    run,+    EncodeStrategy (..),+    defaultEncodeStrategy,+    CompressionAlgo (..),+) where  import Control.Monad (when) import Data.ByteString (ByteString)@@ -18,33 +18,35 @@  import JSON -data Conf = Conf {-    debug :: Bool-  , enc :: DynamicTable -> HeaderList -> IO ByteString-  }+data Conf = Conf+    { debug :: Bool+    , enc :: DynamicTable -> [Header] -> IO ByteString+    }  run :: Bool -> EncodeStrategy -> Test -> IO [ByteString]-run _ _    (Test        _ []) = return []-run d stgy (Test _ ccs@(c:_)) = do+run _ _ (Test _ []) = return []+run d stgy (Test _ ccs@(c : _)) = do     let siz = fromMaybe 4096 $ size c     withDynamicTableForEncoding siz $ \dyntbl -> do-        let conf = Conf { debug = d, enc = encodeHeader stgy 4096 }+        let conf = Conf{debug = d, enc = encodeHeader stgy 4096}         testLoop conf ccs dyntbl [] -testLoop :: Conf-         -> [Case]-         -> DynamicTable-         -> [ByteString]-         -> IO [ByteString]-testLoop _    []     _    hexs = return $ reverse hexs-testLoop conf (c:cs) dyntbl hxs = do+testLoop+    :: Conf+    -> [Case]+    -> DynamicTable+    -> [ByteString]+    -> IO [ByteString]+testLoop _ [] _ hexs = return $ reverse hexs+testLoop conf (c : cs) dyntbl hxs = do     hx <- test conf c dyntbl     testLoop conf cs dyntbl (C8.map toLower hx : hxs) -test :: Conf-     -> Case-     -> DynamicTable-     -> IO ByteString+test+    :: Conf+    -> Case+    -> DynamicTable+    -> IO ByteString test conf c dyntbl = do     out <- enc conf dyntbl hs     let hex' = B16.encode out
test-hpack/HPACKSpec.hs view
@@ -5,16 +5,20 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Control.Monad (forM_, filterM)+import Control.Monad (filterM, forM_) import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL import Data.List (isPrefixOf, isSuffixOf)-import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)+import System.Directory (+    doesDirectoryExist,+    doesFileExist,+    getDirectoryContents,+ ) import System.FilePath ((</>)) import Test.Hspec -import JSON import HPACKDecode+import JSON  testDir :: FilePath testDir = "test-hpack/hpack-test-case"@@ -39,11 +43,11 @@     bs <- BL.readFile file     let etc = eitherDecode bs :: Either String Test     case etc of-        Left e   -> return $ Just $ file ++ ": " ++ e+        Left e -> return $ Just $ file ++ ": " ++ e         Right tc -> do             res <- run False tc             case res of-                Pass   -> return Nothing+                Pass -> return Nothing                 Fail e -> return $ Just $ file ++ ": " ++ e  spec :: Spec
test-hpack/JSON.hs view
@@ -1,21 +1,23 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module JSON (-    Test(..)-  , Case(..)-  , HeaderList-  ) where+    Test (..),+    Case (..),+    Header,+) where  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad (mzero) import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as H import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8-import qualified Data.Aeson.KeyMap as H-import qualified Data.Aeson.Key as Key import Data.Text (Text) import qualified Data.Text as T import Data.Vector ((!))@@ -33,64 +35,79 @@     BL.putStr $ encodePretty x -} -data Test = Test {-    description :: String-  , cases :: [Case]-  } deriving Show+data Test = Test+    { description :: String+    , cases :: [Case]+    }+    deriving (Show) -data Case = Case {-    size :: Maybe Int-  , wire :: ByteString-  , headers :: HeaderList-  , seqno :: Maybe Int-  } deriving Show+data Case = Case+    { size :: Maybe Int+    , wire :: ByteString+    , headers :: [Header]+    , seqno :: Maybe Int+    }+    deriving (Show)  instance FromJSON Test where-    parseJSON (Object o) = Test <$> o .: "description"-                                <*> o .: "cases"-    parseJSON _          = mzero+    parseJSON (Object o) =+        Test+            <$> o .: "description"+            <*> o .: "cases"+    parseJSON _ = mzero  instance ToJSON Test where-    toJSON (Test desc cs) = object ["description" .= desc-                                   ,"cases" .= cs-                                   ]+    toJSON (Test desc cs) =+        object+            [ "description" .= desc+            , "cases" .= cs+            ]  instance FromJSON Case where-    parseJSON (Object o) = Case <$> o .:? "header_table_size"-                                <*> (textToByteString <$> (o .: "wire"))-                                <*> o .: "headers"-                                <*> o .:? "seqno"-    parseJSON _          = mzero+    parseJSON (Object o) =+        Case+            <$> o .:? "header_table_size"+            <*> (textToByteString <$> (o .: "wire"))+            <*> o .: "headers"+            <*> o .:? "seqno"+    parseJSON _ = mzero  instance ToJSON Case where-    toJSON (Case (Just siz) w hs no) = object ["header_table_size" .= siz-                                              ,"wire" .= byteStringToText w-                                              ,"headers" .= hs-                                              ,"seqno" .= no-                                              ]-    toJSON (Case Nothing    w hs no) = object ["wire" .= byteStringToText w-                                              ,"headers" .= hs-                                              ,"seqno" .= no-                                              ]+    toJSON (Case (Just siz) w hs no) =+        object+            [ "header_table_size" .= siz+            , "wire" .= byteStringToText w+            , "headers" .= hs+            , "seqno" .= no+            ]+    toJSON (Case Nothing w hs no) =+        object+            [ "wire" .= byteStringToText w+            , "headers" .= hs+            , "seqno" .= no+            ] -instance {-# OVERLAPPING #-} FromJSON HeaderList where+instance {-# OVERLAPPING #-} FromJSON [Header] where     parseJSON (Array a) = mapM parseJSON $ V.toList a-    parseJSON _         = mzero+    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-    parseJSON _          = mzero+        (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@@ -100,4 +117,4 @@  toValue :: Value -> ByteString toValue (String s) = textToByteString s-toValue _          = error "toValue"+toValue _ = error "toValue"
test-hpack/hpack-debug.hs view
@@ -3,18 +3,18 @@ import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL -import JSON import HPACKDecode+import JSON  main :: IO () main = do     bs <- BL.getContents     let etc = eitherDecode bs :: Either String Test     res <- case etc of-        Left e   -> return $ Just e+        Left e -> return $ Just e         Right tc -> do             res <- run True tc             case res of-                Pass   -> return Nothing+                Pass -> return Nothing                 Fail e -> return $ Just e     print res
test-hpack/hpack-encode.hs view
@@ -1,9 +1,9 @@ module Main where -import Control.Monad (when) import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Maybe (fromJust) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr)@@ -14,31 +14,33 @@ main :: IO () main = do     args <- getArgs-    when (length args /= 3) $ do-        hPutStrLn stderr "hpack-encode on/off naive|linear <desc>"-        exitFailure-    let [arg1,arg2,desc] = args-        huffman-          | arg1 == "on" = True-          | otherwise = False+    (arg1, arg2, desc) <- case args of+        [a, b, c] -> return (a, b, c)+        _ -> do+            hPutStrLn stderr "hpack-encode on/off naive|linear <desc>"+            exitFailure+    let huffman+            | arg1 == "on" = True+            | otherwise = False         algo-          | arg2 == "naive"  = Naive-          | arg2 == "static" = Static-          | otherwise        = Linear+            | arg2 == "naive" = Naive+            | arg2 == "static" = Static+            | otherwise = Linear         stgy = EncodeStrategy algo huffman     hpackEncode stgy desc  hpackEncode :: EncodeStrategy -> String -> IO () hpackEncode stgy desc = do     bs <- BL.getContents-    let Just tc = decode bs :: Maybe Test+    let tc = fromJust (decode bs :: Maybe Test)     hexs <- run False stgy tc     let cs = cases tc         cs' = zipWith update cs hexs-        tc' = tc {-            description = desc-          , cases = cs'-          }+        tc' =+            tc+                { description = desc+                , cases = cs'+                }     BL.putStrLn $ encodePretty tc'   where-    update c hex = c { wire = hex }+    update c hex = c{wire = hex}
test-hpack/hpack-stat.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE ScopedTypeVariables, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Main where  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif+import Control.Monad import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BL import Data.List+import Data.Maybe (fromJust)+import Network.HPACK import System.Directory import System.FilePath-import Control.Monad  import JSON @@ -36,11 +39,9 @@ wdir6 :: FilePath wdir6 = "test-hpack/hpack-test-case/haskell-http2-linear-huffman" -- main :: IO () main = do-    hs  <- get getHeaderSize hdir+    hs <- get getHeaderSize hdir     hlen <- get getHeaderLen hdir     ws1 <- get getWireSize wdir1     ws2 <- get getWireSize wdir2@@ -48,7 +49,7 @@     ws4 <- get getWireSize wdir4     ws5 <- get getWireSize wdir5     ws6 <- get getWireSize wdir6-    let h  :: Float = fromIntegral $ sum hs+    let h :: Float = fromIntegral $ sum hs         w1 :: Float = fromIntegral $ sum ws1         w2 :: Float = fromIntegral $ sum ws2         w3 :: Float = fromIntegral $ sum ws3@@ -56,12 +57,14 @@         w5 :: Float = fromIntegral $ sum ws5         w6 :: Float = fromIntegral $ sum ws6         hl :: Float = fromIntegral $ sum hlen-    print (w1 / h-          ,w2 / h-          ,w3 / h-          ,w4 / h-          ,w5 / h-          ,w6 / h)+    print+        ( w1 / h+        , w2 / h+        , w3 / h+        , w4 / h+        , w5 / h+        , w6 / h+        )     print ((w4 - w6) / hl)  get :: (FilePath -> IO Int) -> String -> IO [Int]@@ -75,23 +78,23 @@ getHeaderSize :: FilePath -> IO Int getHeaderSize file = do     bs <- BL.readFile file-    let Just tc = decode bs :: Maybe Test+    let tc = fromJust (decode bs :: Maybe Test)     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     bs <- BL.readFile file-    let Just tc = decode bs :: Maybe Test+    let tc = fromJust (decode bs :: Maybe Test)     let len = length $ cases tc     return len  getWireSize :: FilePath -> IO Int getWireSize file = do     bs <- BL.readFile file-    let Just tc = decode bs :: Maybe Test+    let tc = fromJust (decode bs :: Maybe Test)     let len = sum $ map toT $ cases tc     return len   where
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,8 +40,11 @@                     isDynamicTableEmpty etbl `shouldReturn` True                     isDynamicTableEmpty dtbl `shouldReturn` True -hl1 :: HeaderList-hl1 = [("custom-key","custom-value")-      ,("loooooooooooooooooooooooooooooooooooooooooog-key"-       ,"loooooooooooooooooooooooooooooooooooooooooog-value")-      ]+hl1 :: [Header]+hl1 =+    [ ("custom-key", "custom-value")+    ,+        ( "loooooooooooooooooooooooooooooooooooooooooog-key"+        , "loooooooooooooooooooooooooooooooooooooooooog-value"+        )+    ]
test/HPACK/EncodeSpec.hs view
@@ -6,8 +6,8 @@ import Control.Applicative ((<$>)) #endif import qualified Control.Exception as E-import qualified Data.ByteString as BS import Data.Bits+import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) import Network.HPACK import Test.Hspec@@ -16,22 +16,22 @@ spec = do     describe "encodeHeader and decodeHeader" $ do         it "works for Naive" $-            run Nothing EncodeStrategy {compressionAlgo = Naive, useHuffman = False} []+            run Nothing EncodeStrategy{compressionAlgo = Naive, useHuffman = False} []         it "works for NaiveH" $-            run Nothing EncodeStrategy {compressionAlgo = Naive, useHuffman = True} []+            run Nothing EncodeStrategy{compressionAlgo = Naive, useHuffman = True} []         it "works for Static" $-            run Nothing EncodeStrategy {compressionAlgo = Static, useHuffman = False} []+            run Nothing EncodeStrategy{compressionAlgo = Static, useHuffman = False} []         it "works for StaticH" $-            run Nothing EncodeStrategy {compressionAlgo = Static, useHuffman = True} []+            run Nothing EncodeStrategy{compressionAlgo = Static, useHuffman = True} []         it "works for Linear" $-            run Nothing EncodeStrategy {compressionAlgo = Linear, useHuffman = False} [] -- linearLens+            run Nothing EncodeStrategy{compressionAlgo = Linear, useHuffman = False} [] -- linearLens         it "works for LinearH" $-            run Nothing EncodeStrategy {compressionAlgo = Linear, useHuffman = True} []+            run Nothing EncodeStrategy{compressionAlgo = Linear, useHuffman = True} []     describe "encodeHeader with a 0-size table" $ do-      it "works for Linear" $-          run (Just 0) EncodeStrategy {compressionAlgo = Linear, useHuffman = False} []-      it "does not use indexed fields" $ do-          runNotIndexed EncodeStrategy {compressionAlgo = Linear, useHuffman = False}+        it "works for Linear" $+            run (Just 0) EncodeStrategy{compressionAlgo = Linear, useHuffman = False} []+        it "does not use indexed fields" $ do+            runNotIndexed EncodeStrategy{compressionAlgo = Linear, useHuffman = False}  run :: Maybe Int -> EncodeStrategy -> [Int] -> Expectation run msz stgy lens0 = do@@ -39,27 +39,34 @@     hdrs <- read <$> readFile "bench-hpack/headers.hs"     withDynamicTableForEncoding sz $ \etbl ->         withDynamicTableForDecoding sz 4096 $ \dtbl ->-        go etbl dtbl hdrs lens0 `shouldReturn` True-    where-        go :: DynamicTable -> DynamicTable -> [HeaderList] -> [Int] -> IO Bool-        go _    _    []     _    = return True-        go etbl dtbl (h:hs) lens = do-            bs <- encodeHeader stgy 4096 etbl h `E.catch` \(E.SomeException e) -> do+            go etbl dtbl hdrs lens0 `shouldReturn` True+  where+    go :: DynamicTable -> DynamicTable -> [[Header]] -> [Int] -> IO Bool+    go _ _ [] _ = return True+    go etbl dtbl (h : hs) lens = do+        bs <-+            encodeHeader stgy 4096 etbl h `E.catch` \(E.SomeException e) -> do                 putStrLn $ "encodeHeader: " ++ show e                 print h                 E.throwIO e-            lens' <- case lens of-                    l:ls-                      | BS.length bs == l -> return ls-                      | otherwise         -> error $ "The length of encoded headers should be " ++ show l ++ " but " ++ show (BS.length bs)-                    []                    -> return []-            h' <- decodeHeader dtbl bs  `E.catch` \(E.SomeException e) -> do+        lens' <- case lens of+            l : ls+                | BS.length bs == l -> return ls+                | otherwise ->+                    error $+                        "The length of encoded headers should be "+                            ++ show l+                            ++ " but "+                            ++ show (BS.length bs)+            [] -> return []+        h' <-+            decodeHeader dtbl bs `E.catch` \(E.SomeException e) -> do                 putStrLn $ "decodeHeader: " ++ show e                 print h                 E.throwIO e-            if h == h' then-                go etbl dtbl hs lens'-              else do+        if h == h'+            then go etbl dtbl hs lens'+            else do                 return False  runNotIndexed :: EncodeStrategy -> Expectation@@ -67,27 +74,28 @@     hdrs <- read <$> readFile "bench-hpack/headers.hs"     withDynamicTableForEncoding 0 $ \etbl ->         withDynamicTableForDecoding 0 4096 $ \dtbl ->-            mapM_ (go etbl dtbl) (hdrs :: [HeaderList])-    where-        go etbl _dtbl h = do-          print h-          bs <- encodeHeader stgy 4096 etbl h `E.catch` \(E.SomeException e) -> do-              putStrLn $ "encodeHeader: " ++ show e-              print h-              E.throwIO e-          findIndexed bs `shouldBe` False+            mapM_ (go etbl dtbl) (hdrs :: [[Header]])+  where+    go etbl _dtbl h = do+        print h+        bs <-+            encodeHeader stgy 4096 etbl h `E.catch` \(E.SomeException e) -> do+                putStrLn $ "encodeHeader: " ++ show e+                print h+                E.throwIO e+        findIndexed bs `shouldBe` False  -- check whether indexed fields are used (HPACK spec 6.1) findIndexed :: BS.ByteString -> Bool findIndexed = go . BS.unpack-    where-        go [] = False-        go (b : bs)-          | testBit b 7 = if clearBit b 7 <= 61 then go bs else True-          | b == 0x40 || b == 0 = go (skip (skip bs))-          | otherwise = go (skip bs)-        skip (b : bs) = drop (fromIntegral (clearBit b 7)) bs-        skip [] = []+  where+    go [] = False+    go (b : bs)+        | testBit b 7 = if clearBit b 7 <= 61 then go bs else True+        | b == 0x40 || b == 0 = go (skip (skip bs))+        | otherwise = go (skip bs)+    skip (b : bs) = drop (fromIntegral (clearBit b 7)) bs+    skip [] = []  {- fixme: form where these values come? linearLens :: [Int]
test/HPACK/HeaderBlock.hs view
@@ -4,87 +4,101 @@  import Data.ByteString (ByteString) import Data.ByteString.Base16-import Network.HPACK+import Network.HTTP.Types  fromHexString :: ByteString -> ByteString fromHexString = decodeLenient  ---------------------------------------------------------------- -d41h :: HeaderList-d41h = [(":method","GET")-       ,(":scheme","http")-       ,(":path","/")-       ,(":authority","www.example.com")-       ]+d41h :: [Header]+d41h =+    [ (":method", "GET")+    , (":scheme", "http")+    , (":path", "/")+    , (":authority", "www.example.com")+    ]  d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" -d42h :: HeaderList-d42h = [(":method","GET")-       ,(":scheme","http")-       ,(":path","/")-       ,(":authority","www.example.com")-       ,("cache-control","no-cache")]+d42h :: [Header]+d42h =+    [ (":method", "GET")+    , (":scheme", "http")+    , (":path", "/")+    , (":authority", "www.example.com")+    , ("cache-control", "no-cache")+    ]  d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" -d43h :: HeaderList-d43h = [(":method","GET")-       ,(":scheme","https")-       ,(":path","/index.html")-       ,(":authority","www.example.com")-       ,("custom-key","custom-value")-       ]+d43h :: [Header]+d43h =+    [ (":method", "GET")+    , (":scheme", "https")+    , (":path", "/index.html")+    , (":authority", "www.example.com")+    , ("custom-key", "custom-value")+    ]  d43b :: ByteString d43b = fromHexString "828785bf408825a849e95ba97d7f8925a849e95bb8e8b4bf"  ---------------------------------------------------------------- -d61h :: HeaderList-d61h = [(":status","302")-       ,("cache-control","private")-       ,("date","Mon, 21 Oct 2013 20:13:21 GMT")-       ,("location","https://www.example.com")-       ]+d61h :: [Header]+d61h =+    [ (":status", "302")+    , ("cache-control", "private")+    , ("date", "Mon, 21 Oct 2013 20:13:21 GMT")+    , ("location", "https://www.example.com")+    ]  d61b :: ByteString-d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3"+d61b =+    fromHexString+        "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" -d62h :: HeaderList-d62h = [(":status","307")-       ,("cache-control","private")-       ,("date","Mon, 21 Oct 2013 20:13:21 GMT")-       ,("location","https://www.example.com")-       ]+d62h :: [Header]+d62h =+    [ (":status", "307")+    , ("cache-control", "private")+    , ("date", "Mon, 21 Oct 2013 20:13:21 GMT")+    , ("location", "https://www.example.com")+    ]  d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" -d63h :: HeaderList-d63h = [(":status","200")-       ,("cache-control","private")-       ,("date","Mon, 21 Oct 2013 20:13:22 GMT")-       ,("location","https://www.example.com")-       ,("content-encoding","gzip")-       ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")]+d63h :: [Header]+d63h =+    [ (":status", "200")+    , ("cache-control", "private")+    , ("date", "Mon, 21 Oct 2013 20:13:22 GMT")+    , ("location", "https://www.example.com")+    , ("content-encoding", "gzip")+    , ("set-cookie", "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")+    ]  d63b :: ByteString-d63b = fromHexString "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"+d63b =+    fromHexString+        "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"  ---------------------------------------------------------------- -d81h :: HeaderList-d81h = [(":status","403")-       ,("server","nginx/1.14.0")-       ,("date","Wed, 13 Feb 2019 14:57:11 GMT")-       ,("content-type","text/html")-       ,("content-length","169")-       ]+d81h :: [Header]+d81h =+    [ (":status", "403")+    , ("server", "nginx/1.14.0")+    , ("date", "Wed, 13 Feb 2019 14:57:11 GMT")+    , ("content-type", "text/html")+    , ("content-length", "169")+    ]  d81b :: ByteString-d81b = fromHexString "2048033430337689aa6355e580ae1697076196e4593e940b2a612c6a08017d40b571b76e042a62d1bf5f87497ca589d34d1f5c03313639"-+d81b =+    fromHexString+        "2048033430337689aa6355e580ae1697076196e4593e940b2a612c6a08017d40b571b76e042a62d1bf5f87497ca589d34d1f5c03313639"
test/HPACK/HuffmanSpec.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module HPACK.HuffmanSpec where @@ -15,19 +16,28 @@ import Test.Hspec.QuickCheck  testData :: [(ByteString, ByteString)]-testData = [-    ("", "")-  , ("www.example.com", "f1e3c2e5f23a6ba0ab90f4ff")-  , ("no-cache", "a8eb10649cbf")-  , ("custom-key", "25a849e95ba97d7f")-  , ("custom-value", "25a849e95bb8e8b4bf")-  , ("private", "aec3771a4b")-  , ("Mon, 21 Oct 2013 20:13:21 GMT", "d07abe941054d444a8200595040b8166e082a62d1bff")-  , ("https://www.example.com", "9d29ad171863c78f0b97c8e9ae82ae43d3")-  , ("Mon, 21 Oct 2013 20:13:22 GMT", "d07abe941054d444a8200595040b8166e084a62d1bff")-  , ("gzip", "9bd9ab")-  , ("foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1", "94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007")-  ]+testData =+    [ ("", "")+    , ("www.example.com", "f1e3c2e5f23a6ba0ab90f4ff")+    , ("no-cache", "a8eb10649cbf")+    , ("custom-key", "25a849e95ba97d7f")+    , ("custom-value", "25a849e95bb8e8b4bf")+    , ("private", "aec3771a4b")+    ,+        ( "Mon, 21 Oct 2013 20:13:21 GMT"+        , "d07abe941054d444a8200595040b8166e082a62d1bff"+        )+    , ("https://www.example.com", "9d29ad171863c78f0b97c8e9ae82ae43d3")+    ,+        ( "Mon, 21 Oct 2013 20:13:22 GMT"+        , "d07abe941054d444a8200595040b8166e084a62d1bff"+        )+    , ("gzip", "9bd9ab")+    ,+        ( "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1"+        , "94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"+        )+    ]  shouldBeEncoded :: ByteString -> ByteString -> Expectation shouldBeEncoded inp out = do@@ -52,10 +62,10 @@             ds `shouldBe` bs     describe "encode" $ do         it "encodes" $ do-            mapM_ (\(x,y) -> x `shouldBeEncoded` y) testData+            mapM_ (\(x, y) -> x `shouldBeEncoded` y) testData     describe "decode" $ do         it "decodes" $ do-            tryDecode       "ff" `shouldThrow` (== TooLongEos)+            tryDecode "ff" `shouldThrow` (== TooLongEos)             tryDecode "ffffeaff" `shouldThrow` (== TooLongEos)             "ffffea" `shouldBeDecoded` "\9"-            mapM_ (\(x,y) -> y `shouldBeDecoded` x) testData+            mapM_ (\(x, y) -> y `shouldBeDecoded` x) testData
test/HPACK/IntegerSpec.hs view
@@ -1,6 +1,7 @@ module HPACK.IntegerSpec where  import qualified Data.ByteString as BS+import Data.Maybe (fromMaybe) import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -9,7 +10,7 @@ dual n i = do     let x = abs i     bs <- encodeInteger n x-    let Just (w, ws) = BS.uncons bs+    let (w, ws) = fromMaybe (error "dual") $ BS.uncons bs     x' <- decodeInteger n w ws     x `shouldBe` x'
+ test/HTTP2/ClientSpec.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module HTTP2.ClientSpec (spec) where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import Data.ByteString.Builder (byteString)+import Data.Foldable (for_)+import Data.Maybe+import Data.Traversable (for)+import Network.HTTP.Semantics+import Network.HTTP.Types+import Network.Run.TCP hiding (defaultSettings)+import System.IO.Unsafe (unsafePerformIO)+import System.Random+import System.Timeout (timeout)+import Test.Hspec++import Network.HTTP2.Client+import qualified Network.HTTP2.Server as S++port :: String+port = show $ unsafePerformIO (randomPort <$> getStdGen)+  where+    randomPort = fst . randomR (43124 :: Int, 44320)++host :: String+host = "127.0.0.1"++spec :: Spec+spec = do+    describe "client" $ do+        it "receives an error if scheme is missing" $+            E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do+                threadDelay 10000+                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` 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` streamError++        it "does not deadlock (in concurrent setting)" $+            E.bracket (forkIO $ runServer irresponsiveServer) killThread $ \_ -> do+                threadDelay 10000+                resultVar <- newEmptyMVar+                runClient "http" "localhost" $ concurrentClient resultVar+                result <- timeout 1000000 $ takeMVar resultVar+                case result of+                    Nothing -> expectationFailure "Exception was not raised"+                    Just (Left ConnectionIsClosed) -> return ()+                    Just (Left err) -> expectationFailure $ "Raise unexpected exception " ++ show err+                    Just (Right ()) -> expectationFailure "Unexpected client termination"++        it "respects max concurrent streams setting" $+            E.bracket (forkIO $ runServer irresponsiveServer) killThread $ \_ -> do+                threadDelay 10000+                let maxConc = fromJust $ maxConcurrentStreams defaultSettings++                resultVars <- runClient "http" "localhost" $ \sendReq aux -> do+                    replicateM ((maxConc + 1) :: Int) $ do+                        resultVar <- newEmptyMVar+                        concurrentClient resultVar sendReq aux+                        pure resultVar++                let acceptedRequestVars = take maxConc resultVars+                acceptedResults <- for acceptedRequestVars (timeout 1000000 . takeMVar)+                for_ acceptedResults $ \case+                    Nothing -> expectationFailure "Exception was not raised"+                    Just (Left ConnectionIsClosed) -> return ()+                    Just (Left err) -> expectationFailure $ "Raise unexpected exception " ++ show err+                    Just (Right ()) -> expectationFailure "Unexpected client termination"++                let waitingRequestVars = drop maxConc resultVars+                waitingResults <- for waitingRequestVars (timeout 1000000 . takeMVar)+                for_ waitingResults $ \case+                    Nothing -> pure ()+                    Just (Left err) -> expectationFailure $ "Raise unexpected exception " ++ show err+                    Just (Right ()) -> expectationFailure "Unexpected client termination"++runServer :: S.Server -> IO ()+runServer server = runTCPServer (Just host) port runHTTP2Server+  where+    runHTTP2Server s =+        E.bracket+            (allocSimpleConfig s 4096)+            freeSimpleConfig+            (\conf -> S.run S.defaultServerConfig conf server)++defaultServer :: S.Server+defaultServer _req _aux sendResponse = sendResponse responseHello []++irresponsiveServer :: S.Server+irresponsiveServer _req _aux _sendResponse = do+    forever $ threadDelay 10000000++responseHello :: S.Response+responseHello = S.responseBuilder ok200 header body+  where+    header = [("Content-Type", "text/plain")]+    body = byteString "Hello, world!\n"++runClient :: Scheme -> Authority -> Client a -> IO a+runClient sc au client = runTCPClient host port runHTTP2Client+  where+    cliconf = defaultClientConfig{scheme = sc, authority = au}+    runHTTP2Client s =+        E.bracket+            (allocSimpleConfig s 4096)+            freeSimpleConfig+            ( \conf -> run cliconf conf $ \sendRequest ->+                client sendRequest+            )++defaultClient :: RequestHeaders -> Client ()+defaultClient hd sendRequest _aux = do+    let req = requestNoBody methodGet "/" hd+    sendRequest req $ \rsp -> do+        responseStatus rsp `shouldBe` Just ok200+        fmap statusMessage (responseStatus rsp) `shouldBe` Just "OK"++concurrentClient :: MVar (Either HTTP2Error ()) -> Client ()+concurrentClient resultVar sendRequest _aux = do+    let req = requestNoBody methodGet "/" []+    void $ forkIO $ do+        result <- E.try $ sendRequest req $ \_rsp -> return ()+        putMVar resultVar result+    threadDelay 10000++streamError :: Selector HTTP2Error+streamError StreamErrorIsReceived{} = True+streamError ConnectionErrorIsReceived{} = True+streamError _ = False
test/HTTP2/FrameSpec.hs view
@@ -5,41 +5,49 @@ import Test.Hspec  import Data.ByteString.Char8 ()+import Data.Either import Network.HTTP2.Frame  spec :: Spec spec = do     describe "encodeFrameHeader & decodeFrameHeader" $ do         it "encode/decodes frames properly" $ do-            let header = FrameHeader {-                    payloadLength = 500-                  , flags = defaultFlags-                  , streamId = 10-                  }+            let header =+                    FrameHeader+                        { payloadLength = 500+                        , flags = defaultFlags+                        , streamId = 10+                        }                 wire = encodeFrameHeader FramePriority header                 fibHeader = decodeFrameHeader wire             fibHeader `shouldBe` (FramePriority, header)      describe "encodeFrame & decodeFrame" $ do         it "encode/decodes frames properly" $ do-            let einfo = EncodeInfo {-                    encodeFlags = defaultFlags-                  , encodeStreamId = 2-                  , encodePadding = Nothing-                  }+            let einfo =+                    EncodeInfo+                        { encodeFlags = defaultFlags+                        , encodeStreamId = 2+                        , encodePadding = Nothing+                        }                 payload = DataFrame "Hello, world!"                 wire = encodeFrame einfo payload-                Right frame = decodeFrame defaultSettings wire+                frame =+                    fromRight (error "encode/decodes frames properly") $+                        decodeFrame wire                 payload' = framePayload frame             payload' `shouldBe` payload         it "encode/decodes padded frames properly" $ do-            let einfo = EncodeInfo {-                    encodeFlags = defaultFlags-                  , encodeStreamId = 2-                  , encodePadding = Just "padding!"-                  }+            let einfo =+                    EncodeInfo+                        { encodeFlags = defaultFlags+                        , encodeStreamId = 2+                        , encodePadding = Just "padding!"+                        }                 payload = DataFrame "Hello, world!"                 wire = encodeFrame einfo payload-                Right frame = decodeFrame defaultSettings wire+                frame =+                    fromRight (error "encode/decodes padded frames properly") $+                        decodeFrame wire                 payload' = framePayload frame             payload' `shouldBe` payload
− test/HTTP2/PrioritySpec.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-{-# OPTIONS_GHC -Wno-deprecations #-}--module HTTP2.PrioritySpec where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Data.List (group, sort)-import Test.Hspec--import Network.HTTP2.Frame-import Network.HTTP2.Priority-import qualified Network.HTTP2.Priority.Internal as P--spec :: Spec-spec = do-    describe "priority tree" $ do-        it "enqueue and dequeue frames from Firefox properly" $ firefox-    describe "base priority queue" $ do-        it "queues entries based on weight" $ do-            let q = P.enqueue 5 (P.newPrecedence   1) 5 $-                    P.enqueue 3 (P.newPrecedence 101) 3 $-                    P.enqueue 1 (P.newPrecedence 201) 1 P.empty-                xs = enqdeq q 1000-            map length (group (sort xs)) `shouldBe` [664,333,3]-        it "deletes properly" $ do-            let q = P.enqueue 7 (P.newPrecedence   1) 7 $-                    P.enqueue 5 (P.newPrecedence   5) 5 $-                    P.enqueue 3 (P.newPrecedence  50) 3 $-                    P.enqueue 1 (P.newPrecedence 201) (1 :: Int) P.empty-            let Just (k1,_,_,q1) = P.dequeue q-            k1 `shouldBe` 1-            let (mk, q2) = P.delete 5 q1-            mk `shouldBe` Just 5-            let Just (k3,_,_,q3) = P.dequeue q2-            k3 `shouldBe` 3-            let Just (k4,_,_,_) = P.dequeue q3-            k4 `shouldBe` 7-        it "deletes entries properly" $ do-            let q = P.enqueue 5 (P.newPrecedence   1) 5 $-                    P.enqueue 3 (P.newPrecedence 101) 3 $-                    P.enqueue 1 (P.newPrecedence 201) 1 P.empty-                (mv1,q1) = P.delete 1 q-                (mv2,q2) = P.delete 3 q-            P.baseDeficit q `shouldBe` 0-            mv1 `shouldBe` Just (1 :: Int)-            P.baseDeficit q1 `shouldBe` 326-            mv2 `shouldBe` Just 3-            P.baseDeficit q2 `shouldBe` 0--firefox :: IO ()-firefox = do-    pt <- newPriorityTree :: IO (PriorityTree Int)-    prepare pt  3 (pri 0 201)-    prepare pt  5 (pri 0 101)-    prepare pt  7 (pri 0   1)-    prepare pt  9 (pri 7   1)-    prepare pt 11 (pri 3   1)-    enQ pt 13 (pre 11 32)-    deQ pt `shouldReturn` 13-    enQ pt 15 (pre  3 32)-    enQ pt 17 (pre  3 32)-    enQ pt 19 (pre  3 32)-    enQ pt 21 (pre  3 32)-    enQ pt 23 (pre  3 32)-    enQ pt 25 (pre  3 32)-    enQ pt 27 (pre 11 22)-    enQ pt 29 (pre 11 22)-    enQ pt 31 (pre 11 22)-    enQ pt 33 (pre  5 32)-    enQ pt 35 (pre  5 32)-    enQ pt 37 (pre  5 32)-    deQ pt `shouldReturn` 15-    deQ pt `shouldReturn` 33-    deQ pt `shouldReturn` 17-    delete pt 17 (pre  3 32) `shouldReturn` Nothing-    delete pt 31 (pre 11 22) `shouldReturn` Just 31-    deQ pt `shouldReturn` 19-    deQ pt `shouldReturn` 35-    deQ pt `shouldReturn` 21-    deQ pt `shouldReturn` 23-    deQ pt `shouldReturn` 37-    deQ pt `shouldReturn` 25-    deQ pt `shouldReturn` 27-    deQ pt `shouldReturn` 29-    enQ pt 39 (pre  3 32)-    deQ pt `shouldReturn` 39--enQ :: PriorityTree Int -> StreamId -> Precedence -> IO ()-enQ pt sid p = enqueue pt sid p sid--deQ :: PriorityTree Int-    -> IO StreamId-deQ pt = (\(x,_,_) -> x) <$> dequeue pt--pri :: StreamId -> Weight -> Priority-pri dep w = Priority False dep w--pre :: StreamId -> Weight -> Precedence-pre dep w = toPrecedence $ pri dep w--enqdeq :: P.PriorityQueue Int -> Int -> [Int]-enqdeq pq num = loop pq num []-  where-    loop _   0 ks = ks-    loop !q !n ks = case P.dequeue q of-        Nothing         -> error "enqdeq"-        Just (k,p,v,q') -> loop (P.enqueue k p v q') (n - 1) (k:ks)
test/HTTP2/ServerSpec.hs view
@@ -1,32 +1,42 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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 (byteString, Builder)-import Data.ByteString.Char8+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 import Network.Socket.ByteString+import System.IO+import System.IO.Unsafe+import System.Random import Test.Hspec  import Network.HPACK+import Network.HPACK.Internal import qualified Network.HTTP2.Client as C-import Network.HTTP2.Server+import qualified Network.HTTP2.Client.Internal as C import Network.HTTP2.Frame+import Network.HTTP2.Server  port :: String-port = "8080"+port = show $ unsafePerformIO (randomPort <$> getStdGen)+  where+    randomPort = fst . randomR (43124 :: Int, 44320)  host :: String host = "127.0.0.1"@@ -37,7 +47,8 @@         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             E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do@@ -47,50 +58,63 @@             preface <- takeMVar prefaceVar             preface `shouldBe` connectionPreface -ignoreHTTP2Error :: HTTP2Error -> IO ()+        it "prevents attacks" $+            E.bracket (forkIO runServer) killThread $ \_ -> do+                threadDelay 10000+                runAttack rapidSettings `shouldThrow` connectionError "too many settings"+                runAttack rapidPing `shouldThrow` connectionError "too many ping"+                runAttack rapidEmptyHeader+                    `shouldThrow` connectionError "too many empty headers"+                runAttack rapidEmptyData `shouldThrow` connectionError "too many empty data"+                runAttack rapidRst `shouldThrow` connectionError "too many rst_stream"++ignoreHTTP2Error :: C.HTTP2Error -> IO () ignoreHTTP2Error _ = pure ()  runServer :: IO () runServer = runTCPServer (Just host) port runHTTP2Server   where-    runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)-                                 freeSimpleConfig-                                 (`run` server)+    runHTTP2Server s =+        E.bracket+            (allocSimpleConfig s 32768)+            freeSimpleConfig+            (\conf -> run defaultServerConfig conf server)  runFakeServer :: MVar ByteString -> IO () runFakeServer prefaceVar = do-  runTCPServer (Just host) port $ \s -> do-    ref <- newIORef Nothing+    runTCPServer (Just host) port $ \s -> do+        ref <- newIORef Nothing -    -- send settings-    sendAll s $ "\x00\x00\x12\x04\x00\x00\x00\x00\x00"-      `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00"-      `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff"+        -- send settings+        sendAll s $+            "\x00\x00\x12\x04\x00\x00\x00\x00\x00"+                `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00"+                `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff" -    -- receive preface-    value <- defaultReadN s ref (B.length connectionPreface)-    putMVar prefaceVar value+        -- receive preface+        value <- defaultReadN s ref (B.length connectionPreface)+        putMVar prefaceVar value -    -- send goaway frame-    sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01"+        -- send goaway frame+        sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01" -    -- wait for a few ms to make sure the client has a chance to close the-    -- socket on its end-    threadDelay 10000+        -- wait for a few ms to make sure the client has a chance to close the+        -- socket on its end+        threadDelay 10000  server :: Server server req _aux sendResponse = case requestMethod req of-  Just "GET"  -> case requestPath req of-                   Just "/"     -> sendResponse responseHello []-                   Just "/stream" -> sendResponse responseInfinite []-                   Just "/push" -> do-                       let pp = pushPromise "/push-pp" responsePP 0-                       sendResponse responseHello [pp]-                   _            -> sendResponse response404 []-  Just "POST" -> case requestPath req of-                   Just "/echo" -> sendResponse (responseEcho req) []-                   _        -> sendResponse responseHello []-  _           -> sendResponse response405 []+    Just "GET" -> case requestPath req of+        Just "/" -> sendResponse responseHello []+        Just "/stream" -> sendResponse responseInfinite []+        Just "/push" -> do+            let pp = pushPromise "/push-pp" responsePP 0+            sendResponse responseHello [pp]+        _ -> sendResponse response404 []+    Just "POST" -> case requestPath req of+        Just "/echo" -> sendResponse (responseEcho req) []+        _ -> sendResponse responseHello []+    _ -> sendResponse response405 []  responseHello :: Response responseHello = responseBuilder ok200 header body@@ -101,8 +125,10 @@ responsePP :: Response responsePP = responseBuilder ok200 header body   where-    header = [("Content-Type", "text/plain")-             ,("x-push", "True")]+    header =+        [ ("Content-Type", "text/plain")+        , ("x-push", "True")+        ]     body = byteString "Push\n"  responseInfinite :: Response@@ -111,8 +137,8 @@     header = [("Content-Type", "text/plain")]     body :: (Builder -> IO ()) -> IO () -> IO ()     body write flush = do-      let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n)-      go (0 :: Int)+        let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n)+        go (0 :: Int)  response404 :: Response response404 = responseNoBody notFound404 []@@ -125,14 +151,15 @@   where     h2rsp = responseStreaming ok200 header streamingBody     header = [("Content-Type", "text/plain")]+    mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req))     streamingBody write _flush = do         loop         mt <- getRequestTrailers req-        firstTrailerValue <$> mt `shouldBe` Just "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+        firstTrailerValue <$> mt `shouldBe` mhx       where         loop = do             bs <- getRequestBodyChunk req-            unless (B.null bs) $ do+            when (bs /= "") $ do                 void $ write $ byteString bs                 loop     maker = trailersMaker (CH.hashInit :: Context SHA1)@@ -148,63 +175,121 @@  runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig =-  runTCPClient host port $ runHTTP2Client+    runTCPClient host port runHTTP2Client   where-    authority = C8.pack host-    cliconf = C.ClientConfig "http" authority 20-    runHTTP2Client s = E.bracket (allocConfig s 4096)-                                 freeSimpleConfig-                                 (\conf -> C.run cliconf conf client)-    client sendRequest = mapConcurrently_ ($ sendRequest) clients-    clients = [client0,client1,client2,client3,client4,client5]+    auth = host+    cliconf = C.defaultClientConfig{C.authority = auth}+    runHTTP2Client s =+        E.bracket+            (allocConfig s 4096)+            freeSimpleConfig+            (\conf -> C.run cliconf conf client) +    client :: C.Client ()+    client sendRequest aux =+        foldr1+            concurrently_+            [ client0 sendRequest aux+            , client1 sendRequest aux+            , client2 sendRequest aux+            , client3 sendRequest aux+            , client3' sendRequest aux+            , client3'' sendRequest aux+            , client4 sendRequest aux+            , client5 sendRequest aux+            ]+ -- delay sending preface to be able to test if it is always sent first allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config allocSlowPrefaceConfig s size = do-  config <- allocSimpleConfig s size-  pure config { confSendAll = slowPrefaceSend (confSendAll config) }+    config <- allocSimpleConfig s size+    pure config{confSendAll = slowPrefaceSend (confSendAll config)}   where     slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO ()     slowPrefaceSend orig chunk = do-      when (C8.pack "PRI" `isPrefixOf` chunk) $ do-        threadDelay 10000-      orig chunk+        when (C8.pack "PRI" `C8.isPrefixOf` chunk) $ do+            threadDelay 10000+        orig chunk  client0 :: C.Client ()-client0 sendRequest = do+client0 sendRequest _aux = do     let req = C.requestNoBody methodGet "/" []     sendRequest req $ \rsp -> do         C.responseStatus rsp `shouldBe` Just ok200         fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK"  client1 :: C.Client ()-client1 sendRequest = do+client1 sendRequest _aux = do     let req = C.requestNoBody methodGet "/push-pp" []     sendRequest req $ \rsp -> do         C.responseStatus rsp `shouldBe` Just notFound404  client2 :: C.Client ()-client2 sendRequest = do+client2 sendRequest _aux = do     let req = C.requestNoBody methodPut "/" []     sendRequest req $ \rsp -> do         C.responseStatus rsp `shouldBe` Just methodNotAllowed405  client3 :: C.Client ()-client3 sendRequest = do-    let req0 = C.requestFile methodPost "/echo" [] $ FileSpec "test/inputFile" 0 1012731+client3 sendRequest _aux = do+    let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+        req0 =+            C.requestFile methodPost "/echo" [("X-Tag", hx)] $+                FileSpec "test/inputFile" 0 1012731         req = C.setRequestTrailersMaker req0 maker     sendRequest req $ \rsp -> do-        let comsumeBody = do+        let consumeBody = do                 bs <- C.getResponseBodyChunk rsp-                unless (B.null bs) comsumeBody-        comsumeBody+                when (bs /= "") consumeBody+        consumeBody         mt <- C.getResponseTrailers rsp-        firstTrailerValue <$> mt `shouldBe` Just "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+        firstTrailerValue <$> mt `shouldBe` Just hx   where     !maker = trailersMaker (CH.hashInit :: Context SHA1) +client3' :: C.Client ()+client3' sendRequest _aux = do+    let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+        req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do+            let sendFile h = do+                    bs <- B.hGet h 1024+                    when (bs /= "") $ do+                        write $ byteString bs+                        sendFile h+            withFile "test/inputFile" ReadMode sendFile+        req = C.setRequestTrailersMaker req0 maker+    sendRequest req $ \rsp -> do+        let consumeBody = do+                bs <- C.getResponseBodyChunk rsp+                when (bs /= "") consumeBody+        consumeBody+        mt <- C.getResponseTrailers rsp+        firstTrailerValue <$> mt `shouldBe` Just hx+  where+    !maker = trailersMaker (CH.hashInit :: Context SHA1)++client3'' :: C.Client ()+client3'' sendRequest _axu = do+    let hx = "59f82dfddc0adf5bdf7494b8704f203a67e25d4a"+        req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do+            let chunk = C8.replicate (16384 * 2) 'c'+                tag = C8.replicate 16 't'+            -- I don't think 9 is important here, this is just what I have, the client hangs on receiving the last one+            replicateM_ 9 $ write $ byteString chunk+            write $ byteString tag+        req = C.setRequestTrailersMaker req0 maker+    sendRequest req $ \rsp -> do+        let consumeBody = do+                bs <- C.getResponseBodyChunk rsp+                when (bs /= "") consumeBody+        consumeBody+        mt <- C.getResponseTrailers rsp+        firstTrailerValue <$> mt `shouldBe` Just hx+  where+    !maker = trailersMaker (CH.hashInit :: Context SHA1)+ client4 :: C.Client ()-client4 sendRequest = do+client4 sendRequest _aux = do     let req0 = C.requestNoBody methodGet "/push" []     sendRequest req0 $ \rsp -> do         C.responseStatus rsp `shouldBe` Just ok200@@ -213,14 +298,139 @@         C.responseStatus rsp `shouldBe` Just ok200  client5 :: C.Client ()-client5 sendRequest = do+client5 sendRequest _aux = do     let req0 = C.requestNoBody methodGet "/stream" []     sendRequest req0 $ \rsp -> do         C.responseStatus rsp `shouldBe` Just ok200-        let go n | n > 0 = do _ <- C.getResponseBodyChunk rsp-                              go (pred n)-                 | otherwise = pure ()+        let go n+                | n > 0 = do+                    _ <- C.getResponseBodyChunk rsp+                    go (pred n)+                | 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+  where+    auth = host+    cliconf = C.defaultClientConfig{C.authority = auth}+    runHTTP2Client s =+        E.bracket+            (allocSimpleConfig s 4096)+            freeSimpleConfig+            (\conf -> C.runIO cliconf conf client)+    client cconf = return $ do+        attack cconf+        threadDelay 1000000++rapidSettings :: C.ClientIO -> IO ()+rapidSettings C.ClientIO{..} = do+    let einfo = EncodeInfo defaultFlags 0 Nothing+        bs = encodeFrame einfo $ SettingsFrame [(SettingsEnablePush, 0)]+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs++rapidPing :: C.ClientIO -> IO ()+rapidPing C.ClientIO{..} = do+    let einfo = EncodeInfo defaultFlags 0 Nothing+        opaque64 = "01234567"+        bs = encodeFrame einfo $ PingFrame opaque64+    replicateM_ 20 $ cioWriteBytes bs++rapidEmptyHeader :: C.ClientIO -> IO ()+rapidEmptyHeader C.ClientIO{..} = do+    (sid, _) <- cioCreateStream+    let einfo = EncodeInfo defaultFlags sid Nothing+        bs = encodeFrame einfo $ HeadersFrame Nothing ""+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs+    cioWriteBytes bs++rapidEmptyData :: C.ClientIO -> IO ()+rapidEmptyData C.ClientIO{..} = do+    (sid, _) <- cioCreateStream+    let einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+        hdr =+            hpackEncode+                [ (":scheme", "http")+                , (":authority", "127.0.0.1")+                , (":path", "/")+                , (":method", "GET")+                ]+        bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr+    cioWriteBytes bsH+    let einfoD = EncodeInfo defaultFlags sid Nothing+        bsD = encodeFrame einfoD $ DataFrame ""+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD+    cioWriteBytes bsD++rapidRst :: C.ClientIO -> IO ()+rapidRst C.ClientIO{..} = do+    reset+    reset+    reset+    reset+    reset+    reset+    reset+    reset+  where+    reset = do+        (sid, _) <- cioCreateStream+        -- setEndStream for HalfClosedRemote+        let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+            hdr =+                hpackEncode+                    [ (":scheme", "http")+                    , (":authority", "127.0.0.1")+                    , (":path", "/")+                    , (":method", "GET")+                    ]+            bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr+        cioWriteBytes bsH+        let einfoR = EncodeInfo defaultFlags sid Nothing+            -- Only (HalfClosedRemote, NoError) is accepted.+            -- Otherwise, a stream error terminates the connection.+            bsR = encodeFrame einfoR $ RSTStreamFrame NoError+        cioWriteBytes bsR++connectionError :: C.ReasonPhrase -> C.HTTP2Error -> Bool+connectionError phrase (C.ConnectionErrorIsReceived _ _ p)+    | phrase == p = True+connectionError _ _ = False++hpackEncode :: [(ByteString, ByteString)] -> ByteString+hpackEncode kvs = foldr cat "" kvs+  where+    (k, v) `cat` b =+        B.singleton 0x10+            <> unsafePerformIO (encodeInteger 7 (B.length k))+            <> k+            <> unsafePerformIO (encodeInteger 7 (B.length v))+            <> v+            <> b
− test/doctests.hs 
@@ -1,14 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = do-    doctest [-        "-XOverloadedStrings"-      , "Network/HPACK.hs"-      ]-    doctest [-        "-XOverloadedStrings"-      , "Network/HTTP2.hs"-      ]
test2/ServerSpec.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}  module ServerSpec (spec) where @@ -25,21 +24,23 @@     describe "server" $ do         it "handles error cases" $             E.bracket (forkIO runServer) killThread $ \_ -> do-                runProcess (proc "h2spec" ["-h",host,"-p",port]) `shouldReturn` ExitSuccess+                runProcess (proc "h2spec" ["-h", host, "-p", port]) `shouldReturn` ExitSuccess  runServer :: IO () runServer = runTCPServer (Just host) port runHTTP2Server   where-    runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)-                                 freeSimpleConfig-                                 (`run` server)+    runHTTP2Server s =+        E.bracket+            (allocSimpleConfig s 4096)+            freeSimpleConfig+            (\conf -> run defaultServerConfig conf server)  server :: Server server req _aux sendResponse = case requestMethod req of-  Just "GET"  -> case requestPath req of-                   Just "/"     -> sendResponse responseHello []-                   _            -> sendResponse response404 []-  _           -> sendResponse response405 []+    Just "GET" -> case requestPath req of+        Just "/" -> sendResponse responseHello []+        _ -> sendResponse response404 []+    _ -> sendResponse response405 []  responseHello :: Response responseHello = responseBuilder ok200 header body
+ 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,35 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Control.Concurrent (forkIO, threadDelay)-import qualified Control.Exception as E-import Control.Monad-import qualified Data.ByteString.Char8 as C8-import Network.HTTP.Types-import Network.HTTP2.Client-import Network.Run.TCP (runTCPClient) -- network-run-import System.Environment-import System.Exit--main :: IO ()-main = do-    args <- getArgs-    when (length args /= 2) $ do-        putStrLn "client <addr> <port>"-        exitFailure-    let [host,port] = args-    runTCPClient host port $ runHTTP2Client host-  where-    cliconf host = ClientConfig "http" (C8.pack host) 20-    runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096)-                                      freeSimpleConfig-                                      (\conf -> run (cliconf host) conf client)-    client sendRequest = do-        let req = requestNoBody methodGet "/" []-        _ <- forkIO $ sendRequest req $ \rsp -> do-            print rsp-            getResponseBodyChunk rsp >>= C8.putStrLn-        sendRequest req $ \rsp -> do-            threadDelay 100000-            print rsp-            getResponseBodyChunk rsp >>= C8.putStrLn
+ util/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,71 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}--module Main (main) where--import qualified Control.Exception as E-import Control.Monad-import Crypto.Hash (Context, SHA1) -- cryptonite-import qualified Crypto.Hash as CH-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Builder (byteString)-import qualified Data.ByteString.Char8 as C8-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP.Types-import Network.HTTP2.Server-import Network.Run.TCP -- network-run-import System.Environment-import System.Exit--main :: IO ()-main = do-    args <- getArgs-    when (length args /= 2) $ do-        putStrLn "server <addr> <port>"-        exitFailure-    let [host,port] = args-    runTCPServer (Just host) port runHTTP2Server-  where-    runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)-                                 freeSimpleConfig-                                 (`run` server)-    server req _aux sendResponse = case getHeaderValue tokenMethod vt of-      Just "GET"  -> sendResponse responseHello []-      Just "POST" -> sendResponse (responseEcho req) []-      _           -> sendResponse response404 []-      where-        (_, vt) = requestHeaders req--responseHello :: Response-responseHello = responseBuilder ok200 header body-  where-    header = [("Content-Type", "text/plain")]-    body = byteString "Hello, world!\n"--response404 :: Response-response404 = responseNoBody notFound404 []--responseEcho :: Request -> Response-responseEcho req = setResponseTrailersMaker h2rsp maker-  where-    h2rsp = responseStreaming ok200 header streamingBody-    header = [("Content-Type", "text/plain")]-    streamingBody write _flush = loop-      where-        loop = do-            bs <- getRequestBodyChunk req-            unless (B.null bs) $ do-                void $ write $ byteString bs-                loop-    maker = trailersMaker (CH.hashInit :: Context SHA1)---- Strictness is important for Context.-trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker-trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]-  where-    !sha1 = C8.pack $ show $ CH.hashFinalize ctx-trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'-  where-    !ctx' = CH.hashUpdate ctx bs