http2 4.2.2 → 5.0.0

raw patch · 94 files changed

+6196/−4694 lines, 94 filesdep +network-controldep −psqueuesdep ~arraydep ~asyncdep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: network-control

Dependencies removed: psqueues

Dependency ranges changed: array, async, bytestring, case-insensitive, containers, http-types, network, network-byte-order, stm, time-manager, unix-time, unliftio

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• Imports.hs +22/−22
• Network/HPACK.hs +51/−43
• Network/HPACK/HeaderBlock.hs +9/−9
• Network/HPACK/HeaderBlock/Decode.hs +147/−129
• Network/HPACK/HeaderBlock/Encode.hs +109/−87
• Network/HPACK/HeaderBlock/Integer.hs +50/−34
• Network/HPACK/Huffman.hs +9/−9
• Network/HPACK/Huffman/Bit.hs +11/−8
• Network/HPACK/Huffman/ByteString.hs +17/−18
• Network/HPACK/Huffman/Decode.hs +41/−32
• Network/HPACK/Huffman/Encode.hs +30/−26
• Network/HPACK/Huffman/Table.hs +2/−0
• Network/HPACK/Huffman/Tree.hs +43/−34
• Network/HPACK/Internal.hs +16/−10
• Network/HPACK/Table.hs +30/−26
• Network/HPACK/Table/Dynamic.hs +115/−99
• Network/HPACK/Table/Entry.hs +33/−28
• Network/HPACK/Table/RevIndex.hs +75/−60
• Network/HPACK/Table/Static.hs +69/−68
• Network/HPACK/Token.hs +163/−145
• Network/HPACK/Types.hs +63/−46
• Network/HTTP2/Arch.hs +0/−31
• Network/HTTP2/Arch/Cache.hs +0/−28
• Network/HTTP2/Arch/Config.hs +0/−59
• Network/HTTP2/Arch/Context.hs +0/−202
• Network/HTTP2/Arch/EncodeFrame.hs +0/−34
• Network/HTTP2/Arch/File.hs +0/−36
• Network/HTTP2/Arch/HPACK.hs +0/−115
• Network/HTTP2/Arch/Manager.hs +0/−180
• Network/HTTP2/Arch/Queue.hs +0/−25
• Network/HTTP2/Arch/Rate.hs +0/−30
• Network/HTTP2/Arch/ReadN.hs +0/−41
• Network/HTTP2/Arch/Receiver.hs +0/−529
• Network/HTTP2/Arch/Sender.hs +0/−510
• Network/HTTP2/Arch/Status.hs +0/−44
• Network/HTTP2/Arch/Stream.hs +0/−96
• Network/HTTP2/Arch/Types.hs +0/−331
• Network/HTTP2/Arch/Window.hs +0/−120
• Network/HTTP2/Client.hs +117/−60
• Network/HTTP2/Client/Internal.hs +13/−3
• Network/HTTP2/Client/Run.hs +181/−76
• Network/HTTP2/Client/Types.hs +8/−2
• Network/HTTP2/Frame.hs +125/−80
• Network/HTTP2/Frame/Decode.hs +176/−121
• Network/HTTP2/Frame/Encode.hs +58/−44
• Network/HTTP2/Frame/Types.hs +88/−110
• Network/HTTP2/H2.hs +35/−0
• Network/HTTP2/H2/Config.hs +40/−0
• Network/HTTP2/H2/Context.hs +299/−0
• Network/HTTP2/H2/EncodeFrame.hs +34/−0
• Network/HTTP2/H2/File.hs +38/−0
• Network/HTTP2/H2/HPACK.hs +123/−0
• Network/HTTP2/H2/Manager.hs +182/−0
• Network/HTTP2/H2/Queue.hs +26/−0
• Network/HTTP2/H2/ReadN.hs +40/−0
• Network/HTTP2/H2/Receiver.hs +641/−0
• Network/HTTP2/H2/Sender.hs +586/−0
• Network/HTTP2/H2/Settings.hs +147/−0
• Network/HTTP2/H2/Status.hs +44/−0
• Network/HTTP2/H2/Stream.hs +97/−0
• Network/HTTP2/H2/StreamTable.hs +183/−0
• Network/HTTP2/H2/Types.hs +396/−0
• Network/HTTP2/H2/Window.hs +81/−0
• Network/HTTP2/Internal.hs +37/−32
• Network/HTTP2/Server.hs +106/−71
• Network/HTTP2/Server/Internal.hs +11/−4
• Network/HTTP2/Server/Run.hs +103/−31
• Network/HTTP2/Server/Types.hs +14/−14
• Network/HTTP2/Server/Worker.hs +122/−111
• Setup.hs +1/−0
• bench-hpack/Main.hs +24/−22
• http2.cabal +32/−32
• test-frame/Case.hs +38/−32
• test-frame/FrameSpec.hs +9/−8
• test-frame/JSON.hs +131/−102
• test-frame/frame-encode.hs +3/−4
• test-hpack/HPACKDecode.hs +40/−30
• test-hpack/HPACKEncode.hs +25/−23
• test-hpack/HPACKSpec.hs +9/−5
• test-hpack/JSON.hs +57/−43
• test-hpack/hpack-debug.hs +3/−3
• test-hpack/hpack-encode.hs +16/−15
• test-hpack/hpack-stat.hs +14/−13
• test/HPACK/DecodeSpec.hs +7/−4
• test/HPACK/EncodeSpec.hs +50/−42
• test/HPACK/HeaderBlock.hs +56/−42
• test/HPACK/HuffmanSpec.hs +27/−17
• test/HTTP2/ClientSpec.hs +95/−29
• test/HTTP2/FrameSpec.hs +24/−17
• test/HTTP2/ServerSpec.hs +230/−75
• test2/ServerSpec.hs +11/−9
• util/client.hs +14/−12
• util/server.hs +14/−12

@@ -1,3 +1,13 @@+## 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.

@@ -1,28 +1,28 @@ module Imports (-    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-  , 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,+    GCBuffer,+    withForeignPtr,+    mallocPlainForeignPtrBytes,+) 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.Either import Data.Foldable@@ -30,11 +30,11 @@ import Data.List import Data.Maybe import Data.Monoid-import Data.String import Data.Ord+import Data.String import Data.Word import Foreign.ForeignPtr-import Numeric import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import Numeric  type GCBuffer = ForeignPtr Word8

@@ -2,49 +2,57 @@  -- | 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,++    -- * 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  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))

@@ -1,13 +1,13 @@ module Network.HPACK.HeaderBlock (-    decodeHeader-  , decodeTokenHeader-  , ValueTable-  , HeaderTable-  , toHeaderTable-  , getHeaderValue-  , encodeHeader-  , encodeTokenHeader-  ) where+    decodeHeader,+    decodeTokenHeader,+    ValueTable,+    HeaderTable,+    toHeaderTable,+    getHeaderValue,+    encodeHeader,+    encodeTokenHeader,+) where  import Network.HPACK.HeaderBlock.Decode import Network.HPACK.HeaderBlock.Encode

@@ -1,26 +1,27 @@-{-# 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,+    HeaderTable,+    toHeaderTable,+    getHeaderValue,+    decodeString,+    decodeS,+    decodeSophisticated,+    decodeSimple, -- testing+) where -import Control.Exception (throwIO, catch)+import Control.Exception (catch, throwIO) import Data.Array (Array) import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite) import qualified Data.Array.IO as IOA import qualified Data.Array.Unsafe as Unsafe import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8-import Data.CaseInsensitive (CI(..))+import Data.CaseInsensitive (CI (..)) import Data.Char (isUpper) import Network.ByteOrder @@ -49,9 +50,11 @@ --   * 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 HeaderList decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl))  -- | Converting the HPACK format to 'TokenHeaderList'@@ -68,48 +71,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 HeaderTable 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'. -- --   * 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 HeaderList 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 = tokenFoldedKey t in (k, v)) tvs+                return kvs  headerLimit :: Int headerLimit = 200@@ -129,12 +138,13 @@ --     '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 HeaderTable 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)@@ -144,64 +154,64 @@       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 +231,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 +271,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 +293,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  ---------------------------------------------------------------- @@ -322,9 +339,9 @@  -- | Converting a header list of the http-types style to --   'TokenHeaderList' and 'ValueTable'.-toHeaderTable :: [(CI HeaderName,HeaderValue)]  -> IO HeaderTable+toHeaderTable :: [(CI HeaderName, HeaderValue)] -> IO HeaderTable toHeaderTable kvs = do-    arr <- IOA.newArray (minTokenIx,maxTokenIx) Nothing+    arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing     tvs <- conv arr     tbl <- Unsafe.unsafeFreeze arr     return (tvs, tbl)@@ -332,11 +349,12 @@     conv :: IOA.IOArray Int (Maybe HeaderValue) -> 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+            :: [(CI HeaderName, HeaderValue)] -> 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'

@@ -1,19 +1,20 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  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 @@ -43,30 +44,35 @@ -- | Converting 'HeaderList' 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+    -> HeaderList+    -> IO ByteString+    -- ^ An HPACK format encodeHeader stgy siz dyntbl hs = encodeHeader' stgy siz dyntbl hs'   where-    hs' = map (\(k,v) -> let t = toToken k in (t,v)) hs-+    hs' = map (\(k, v) -> let t = toToken k in (t, v)) hs  -- | Converting 'HeaderList' to the HPACK format. --   '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 +91,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 +112,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 +126,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,7 +134,8 @@  ---------------------------------------------------------------- -naiveStep :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO ()+naiveStep+    :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO () naiveStep fe t v = fe (tokenFoldedKey t) v  ----------------------------------------------------------------@@ -201,7 +210,8 @@  -- Using Huffman encoding {-# INLINE indexedName #-}-indexedName :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()+indexedName+    :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO () indexedName wbuf huff n set v idx = do     encodeI wbuf set n idx     encStr wbuf huff v@@ -220,9 +230,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 +241,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 +311,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

@@ -1,11 +1,11 @@ {-# 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 +17,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 +41,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 +102,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

@@ -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

@@ -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]

@@ -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)

@@ -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 -}

@@ -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

@@ -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 -}

@@ -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,30 @@  -- | 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', ts') = partition ((==) F . head . snd) xs     fs = map (second tail) fs'     ts = map (second tail) ts'  -- | 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)

@@ -1,15 +1,21 @@ 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,+) where++import Network.HPACK.HeaderBlock.Decode (+    decodeS,+    decodeSimple,+    decodeSophisticated,+    decodeString,+ )+import Network.HPACK.HeaderBlock.Encode (encodeS, encodeString) import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table.Entry

@@ -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

@@ -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 #-}@@ -80,46 +80,51 @@ -}  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+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"+toEncodeInfo _ = error "toEncodeInfo"  toDecodeInfo :: CodeInfo -> DecodeInfo toDecodeInfo (CID x) = x-toDecodeInfo _       = error "toDecodeInfo"+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@@ -138,14 +143,14 @@         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 = "@@ -176,10 +181,10 @@     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.@@ -196,8 +201,10 @@ ----------------------------------------------------------------  -- | 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@@ -205,9 +212,12 @@     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@@ -217,13 +227,14 @@  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@@ -236,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@@ -245,7 +256,7 @@         writeIORef maxDynamicTableSize maxsiz         case codeInfo of             CIE (EncodeInfo rev _) -> renewRevIndex rev-            _                      -> return ()+            _ -> return ()         copyEntries dyntbl entries  getEntries :: DynamicTable -> IO [Entry]@@ -258,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@@ -277,19 +288,24 @@ -- | 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 @@ -305,7 +321,7 @@     es <- adjustTableSize dyntbl     case codeInfo of         CIE (EncodeInfo rev _) -> deleteRevIndexList es rev-        _                      -> return ()+        _ -> return ()  insertFront :: Entry -> DynamicTable -> IO () insertFront e DynamicTable{..} = do@@ -317,16 +333,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-          CIE (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 []@@ -335,11 +351,11 @@     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)  ---------------------------------------------------------------- @@ -357,7 +373,7 @@     writeIORef dynamicTableSize dsize'     case codeInfo of         CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev-        _                      -> return ()+        _ -> return ()  ---------------------------------------------------------------- @@ -392,7 +408,7 @@ ----------------------------------------------------------------  {-# INLINE getRevIndex #-}-getRevIndex :: DynamicTable-> RevIndex+getRevIndex :: DynamicTable -> RevIndex getRevIndex DynamicTable{..} = rev   where     EncodeInfo rev _ = toEncodeInfo codeInfo

@@ -1,27 +1,30 @@ {-# 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 (..),+    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+ import qualified Data.ByteString as BS import Network.HPACK.Token import Network.HPACK.Types@@ -32,7 +35,7 @@ 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 HeaderValue deriving (Show)  ---------------------------------------------------------------- @@ -40,20 +43,22 @@ headerSizeMagicNumber = 32  headerSize :: Header -> Size-headerSize (k,v) = BS.length k-                 + BS.length v-                 + headerSizeMagicNumber+headerSize (k, v) =+    BS.length k+        + BS.length v+        + headerSizeMagicNumber  headerSize' :: Token -> HeaderValue -> Size-headerSize' t v = BS.length (tokenFoldedKey t)-                + BS.length v-                + headerSizeMagicNumber+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     siz = headerSize kv

@@ -3,14 +3,14 @@ {-# 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@@ -39,71 +39,82 @@ -- 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  ----------------------------------------------------------------  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)       where         m = case xs of-            []  -> error "staticRevIndex"-            [("",i)] -> StaticEntry i Nothing-            (_,i):_  -> let vs = M.fromList xs-                        in StaticEntry i (Just vs)+            [] -> error "staticRevIndex"+            [("", i)] -> StaticEntry i Nothing+            (_, i) : _ ->+                let vs = M.fromList xs+                 in StaticEntry i (Just vs)     zs = map extract $ groupBy ((==) `on` fst) lst       where-        lst = zipWith (\(k,v) i -> (k,(v,i))) staticTableList $ map SIndex [1..]+        lst = zipWith (\(k, v) i -> (k, (v, i))) staticTableList $ map SIndex [1 ..]         extract xs = (fst (head xs), map snd xs)  {-# INLINE lookupStaticRevIndex #-}-lookupStaticRevIndex :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()+lookupStaticRevIndex+    :: Int -> HeaderValue -> (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]+    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+    -> HeaderValue+    -> 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 -> HeaderValue -> HIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i   where     ref = drev `unsafeAt` tokenIx t@@ -123,10 +134,11 @@ 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+    :: 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  {-# INLINE insertOtherRevIndex #-} insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()@@ -151,19 +163,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+    -> HeaderValue+    -> (HIndex -> IO ())+    -> (HeaderValue -> Entry -> HIndex -> IO ())+    -> (HeaderName -> HeaderValue -> Entry -> IO ())+    -> (HeaderValue -> 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 +187,16 @@     fd' = fd v  {-# INLINE lookupRevIndex' #-}-lookupRevIndex' :: Token-                -> HeaderValue-                -> (HIndex -> IO ())-                -> (HeaderValue -> HIndex -> IO ())-                -> (HeaderName -> HeaderValue -> IO ())-                -> IO ()+lookupRevIndex'+    :: Token+    -> HeaderValue+    -> (HIndex -> IO ())+    -> (HeaderValue -> HIndex -> IO ())+    -> (HeaderName -> HeaderValue -> 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 +208,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 ()

@@ -1,10 +1,10 @@ {-# 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)@@ -17,6 +17,7 @@ staticTableSize = length staticTableList  {-# INLINE toStaticEntry #-}+ -- | Get 'Entry' from the static table. -- -- >>> toStaticEntry 1@@ -30,71 +31,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", "")+    ]

@@ -1,115 +1,123 @@ {-# 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+    -- * 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 Data.ByteString.Internal (ByteString (..), memcmp)+import Data.CaseInsensitive (CI (..), mk, original) 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)+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 #-}@@ -121,6 +129,7 @@ tokenFoldedKey :: Token -> ByteString tokenFoldedKey (Token _ _ _ ci) = foldedCase ci +{- FOURMOLU_DISABLE -} tokenAuthority                :: Token tokenMethod                   :: Token tokenPath                     :: Token@@ -276,6 +285,7 @@ tokenXXssProtection                = Token 72  True False "X-Xss-Protection"  tokenMax                           = Token 73  True False "for other tokens"+{- FOURMOLU_ENABLE -}  -- | Minimum token index. minTokenIx :: Int@@ -326,9 +336,9 @@ toToken bs = case len of     2 -> if bs === "te" then tokenTE else mkTokenMax bs     3 -> case lst of-        97  | bs === "via" -> tokenVia+        97 | bs === "via" -> tokenVia         101 | bs === "age" -> tokenAge-        _                  -> mkTokenMax bs+        _ -> mkTokenMax bs     4 -> case lst of         101 | bs === "date" -> tokenDate         103 | bs === "etag" -> tokenEtag@@ -336,54 +346,55 @@         109 | bs === "from" -> tokenFrom         116 | bs === "host" -> tokenHost         121 | bs === "vary" -> tokenVary-        _                   -> mkTokenMax bs+        _ -> mkTokenMax bs     5 -> case lst of         101 | bs === "range" -> tokenRange         104 | bs === ":path" -> tokenPath         119 | bs === "allow" -> tokenAllow-        _                    -> mkTokenMax bs+        _ -> mkTokenMax bs     6 -> case lst of         101 | bs === "cookie" -> tokenCookie         110 | bs === "origin" -> tokenOrigin         114 | bs === "server" -> tokenServer-        116 | bs === "expect" -> tokenExpect+        116+            | bs === "expect" -> tokenExpect             | bs === "accept" -> tokenAccept-        _                     -> mkTokenMax bs+        _ -> mkTokenMax bs     7 -> case lst of-        99  | bs === "alt-svc" -> tokenAltSvc+        99 | bs === "alt-svc" -> tokenAltSvc         100 | bs === ":method" -> tokenMethod-        101 | bs === ":scheme" -> tokenScheme+        101+            | bs === ":scheme" -> tokenScheme             | bs === "purpose" -> tokenPurpose         104 | bs === "refresh" -> tokenRefresh         114 | bs === "referer" -> tokenReferer-        115 | bs === "expires" -> tokenExpires+        115+            | bs === "expires" -> tokenExpires             | bs === ":status" -> tokenStatus-        _                      -> mkTokenMax bs+        _ -> mkTokenMax bs     8 -> case lst of         101 | bs === "if-range" -> tokenIfRange         104 | bs === "if-match" -> tokenIfMatch         110 | bs === "location" -> tokenLocation-        _                       -> mkTokenMax bs-+        _ -> mkTokenMax bs     9 -> case lst of         100 | bs === "forwarded" -> tokenForwarded         116 | bs === "expect-ct" -> tokenExpectCt-        _                        -> mkTokenMax bs-+        _ -> mkTokenMax bs     10 -> case lst of-        97  | bs === "early-data" -> tokenEarlyData+        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+        _ -> mkTokenMax bs     11 -> case lst of         114 | bs === "retry-after" -> tokenRetryAfter-        _                          -> mkTokenMax bs+        _ -> mkTokenMax bs     12 -> case lst of         101 | bs === "content-type" -> tokenContentType         115 | bs === "max-forwards" -> tokenMaxForwards-        _                           -> mkTokenMax bs+        _ -> mkTokenMax bs     13 -> case lst of         100 | bs === "last-modified" -> tokenLastModified         101 | bs === "content-range" -> tokenContentRange@@ -391,77 +402,84 @@         108 | bs === "cache-control" -> tokenCacheControl         110 | bs === "authorization" -> tokenAuthorization         115 | bs === "accept-ranges" -> tokenAcceptRanges-        _                            -> mkTokenMax bs+        _ -> mkTokenMax bs     14 -> case lst of         104 | bs === "content-length" -> tokenContentLength         116 | bs === "accept-charset" -> tokenAcceptCharset-        _                             -> mkTokenMax bs+        _ -> 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+        _ -> mkTokenMax bs     16 -> case lst of-        101 | bs === "content-language" -> tokenContentLanguage+        101+            | bs === "content-language" -> tokenContentLanguage             | bs === "www-authenticate" -> tokenWwwAuthenticate         103 | bs === "content-encoding" -> tokenContentEncoding-        110 | bs === "content-location" -> tokenContentLocation+        110+            | bs === "content-location" -> tokenContentLocation             | bs === "x-xss-protection" -> tokenXXssProtection-        _                               -> mkTokenMax bs+        _ -> mkTokenMax bs     17 -> case lst of         101 | bs === "if-modified-since" -> tokenIfModifiedSince         103 | bs === "transfer-encoding" -> tokenTransferEncoding-        _                                -> mkTokenMax bs+        _ -> mkTokenMax bs     18 -> case lst of         101 | bs === "proxy-authenticate" -> tokenProxyAuthenticate-        _                                 -> mkTokenMax bs+        _ -> mkTokenMax bs     19 -> case lst of         101 | bs === "if-unmodified-since" -> tokenIfUnmodifiedSince-        110 | bs === "proxy-authorization" -> tokenProxyAuthorization+        110+            | bs === "proxy-authorization" -> tokenProxyAuthorization             | bs === "content-disposition" -> tokenContentDisposition             | bs === "timing-allow-origin" -> tokenTimingAllowOrigin-        _                                  -> mkTokenMax bs+        _ -> mkTokenMax bs     22 -> case lst of         115 | bs === "x-content-type-options" -> tokenXContentTypeOptions-        _                                     -> mkTokenMax bs+        _ -> mkTokenMax bs     23 -> case lst of         121 | bs === "content-security-policy" -> tokenContentSecurityPolicy-        _                                      -> mkTokenMax bs+        _ -> mkTokenMax bs     25 -> case lst of         115 | bs === "upgrade-insecure-requests" -> tokenUpgradeInsecureRequests         121 | bs === "strict-transport-security" -> tokenStrictTransportSecurity-        _                                        -> mkTokenMax bs+        _ -> mkTokenMax bs     27 -> case lst of         110 | bs === "access-control-allow-origin" -> tokenAccessControlAllowOrigin-        _                                          -> mkTokenMax bs+        _ -> mkTokenMax bs     28 -> case lst of-        115 | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders+        115+            | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders             | bs === "access-control-allow-methods" -> tokenAccessControlAllowMethods-        _                                           -> mkTokenMax bs+        _ -> mkTokenMax bs     29 -> case lst of         100 | bs === "access-control-request-method" -> tokenAccessControlRequestMethod         115 | bs === "access-control-expose-headers" -> tokenAccessControlExposeHeaders-        _                                            -> mkTokenMax bs+        _ -> mkTokenMax bs     30 -> case lst of         115 | bs === "access-control-request-headers" -> tokenAccessControlRequestHeaders-        _                                             -> mkTokenMax bs+        _ -> mkTokenMax bs     32 -> case lst of-        115 | bs === "access-control-allow-credentials" -> tokenAccessControlAllowCredentials-        _                                               -> mkTokenMax bs-    _  -> mkTokenMax bs+        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+        withForeignPtr fp1 $ \p1 ->+            withForeignPtr fp2 $ \p2 -> do+                i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz+                return $ i == 0  mkTokenMax :: ByteString -> Token mkTokenMax bs = Token maxTokenIx True p (mk bs)   where-    p | B.length bs == 0 = False-      | B.head bs == 58  = True-      | otherwise        = False+    p+        | B.length bs == 0 = False+        | B.head bs == 58 = True+        | otherwise = False

@@ -1,30 +1,33 @@ {-# 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+    -- * 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 Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize)  import Imports import Network.HPACK.Token (Token)@@ -59,42 +62,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, Typeable)  instance Exception DecodeError

@@ -1,31 +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-  , module Network.HTTP2.Arch.Window-  ) 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-import Network.HTTP2.Arch.Window

@@ -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

@@ -1,59 +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 {-    -- | This is used only by frameSender.-    -- This MUST be freed after frameSender is terminated.-      confWriteBuffer :: Buffer-    -- | 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.-    , confBufferSize  :: BufferSize-    , confSendAll     :: ByteString -> IO ()-    , confReadN       :: Int -> IO ByteString-    , confPositionReadMaker :: PositionReadMaker-    , confTimeoutManager :: T.Manager-    -- | This is copied into 'Aux', if exist, on server.-    , confMySockAddr     :: SockAddr-    -- | This is copied into 'Aux', if exist, on server.-    , confPeerSockAddr   :: SockAddr-    }---- | 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-    mysa <- getSocketName s-    peersa <- getPeerName s-    let config = Config {-            confWriteBuffer = buf-          , confBufferSize = bufsiz-          , confSendAll = sendAll s-          , confReadN = defaultReadN s ref-          , confPositionReadMaker = defaultPositionReadMaker-          , confTimeoutManager = timmgr-          , confMySockAddr   = mysa-          , confPeerSockAddr = peersa-          }-    return config---- | Deallocating the resource of the simple configuration.-freeSimpleConfig :: Config -> IO ()-freeSimpleConfig conf = do-    free $ confWriteBuffer conf-    T.killManager $ confTimeoutManager conf

@@ -1,202 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Network.HTTP2.Arch.Context where--import Data.IORef-import Network.HTTP.Types (Method)-import Network.Socket (SockAddr)-import UnliftIO.STM--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 = RIS ServerInfo | RIC ClientInfo--data ServerInfo = ServerInfo {-    inputQ :: TQueue (Input Stream)-  }--data ClientInfo = ClientInfo {-    scheme    :: ByteString-  , authority :: ByteString-  , cache     :: IORef (Cache (Method,ByteString) Stream)-  }--toServerInfo :: RoleInfo -> ServerInfo-toServerInfo (RIS x) = x-toServerInfo _       = error "toServerInfo"--toClientInfo :: RoleInfo -> ClientInfo-toClientInfo (RIC x) = x-toClientInfo _       = error "toClientInfo"--newServerInfo :: IO RoleInfo-newServerInfo = RIS . ServerInfo <$> newTQueueIO--newClientInfo :: ByteString -> ByteString -> Int -> IO RoleInfo-newClientInfo scm auth lim =  RIC . ClientInfo scm auth <$> newIORef (emptyCache lim)--insertCache :: Method -> ByteString -> Stream -> RoleInfo -> IO ()-insertCache m path v (RIC (ClientInfo _ _ ref)) = atomicModifyIORef' ref $ \c ->-  (Cache.insert (m,path) v c, ())-insertCache _ _ _ _ = error "insertCache"--lookupCache :: Method -> ByteString -> RoleInfo -> IO (Maybe Stream)-lookupCache m path (RIC (ClientInfo _ _ ref)) = Cache.lookup (m,path) <$> readIORef ref-lookupCache _ _ _ = error "lookupCache"---------------------------------------------------------------------- | The context for HTTP/2 connection.-data Context = Context {-    role               :: Role-  , roleInfo           :: RoleInfo-  -- Settings-  , myFirstSettings    :: IORef Bool-  , myPendingAlist     :: IORef (Maybe SettingsList)-  , mySettings         :: IORef Settings-  , peerSettings       :: IORef Settings-  , streamTable        :: StreamTable-  , concurrency        :: IORef Int-  -- | 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.-  , continued          :: IORef (Maybe StreamId)-  , myStreamId         :: IORef StreamId-  , peerStreamId       :: IORef StreamId-  , outputBufferLimit  :: IORef Int-  , outputQ            :: TQueue (Output Stream)-  , outputQStreamID    :: TVar StreamId-  , controlQ           :: TQueue Control-  , encodeDynamicTable :: DynamicTable-  , decodeDynamicTable :: DynamicTable-  -- the connection window for sending data-  , txConnectionWindow :: TVar WindowSize-  -- window update for receiving data-  , rxConnectionInc    :: IORef WindowSize -- this is diff-  , pingRate           :: Rate-  , settingsRate       :: Rate-  , emptyFrameRate     :: Rate-  , rstRate            :: Rate-  , mySockAddr         :: SockAddr-  , peerSockAddr       :: SockAddr-  }--------------------------------------------------------------------newContext :: RoleInfo -> BufferSize -> SockAddr -> SockAddr -> IO Context-newContext rinfo siz mysa peersa =-    Context rl rinfo-               <$> newIORef False-               <*> newIORef Nothing-               <*> newIORef defaultSettings-               <*> newIORef defaultSettings-               <*> newStreamTable-               <*> newIORef 0-               <*> newIORef Nothing-               <*> newIORef sid0-               <*> newIORef 0-               <*> newIORef buflim-               <*> newTQueueIO-               <*> newTVarIO sid0-               <*> newTQueueIO-               -- My SETTINGS_HEADER_TABLE_SIZE-               <*> newDynamicTableForEncoding defaultDynamicTableSize-               <*> newDynamicTableForDecoding defaultDynamicTableSize 4096-               <*> newTVarIO defaultWindowSize-               <*> newIORef 0-               <*> newRate-               <*> newRate-               <*> newRate-               <*> newRate-               <*> return mysa-               <*> return peersa-   where-     rl = case rinfo of-       RIC{} -> Client-       _     -> Server-     sid0 | rl == Client = 1-          | otherwise    = 2-     dlim = defaultPayloadLength + frameHeaderLength-     buflim | siz >= dlim = dlim-            | otherwise   = siz--------------------------------------------------------------------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 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{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 -> FrameType -> IO Stream-openStream ctx@Context{streamTable, peerSettings} sid ftyp = do-    ws <- initialWindowSize <$> readIORef peerSettings-    newstrm <- newStream sid ws-    when (ftyp == FrameHeaders || ftyp == FramePushPromise) $ opened ctx newstrm-    insert streamTable sid newstrm-    return newstrm

@@ -1,34 +0,0 @@-module Network.HTTP2.Arch.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 :: 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

@@ -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)

@@ -1,115 +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.Arch.Types-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 -> StreamId -> Context -> IO HeaderTable-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 HeaderTable-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     = getHeaderValue tokenStatus reqvt-    mScheme     = getHeaderValue tokenScheme reqvt-    mPath       = getHeaderValue tokenPath reqvt-    mMethod     = getHeaderValue tokenMethod reqvt-    mConnection = getHeaderValue tokenConnection reqvt-    mTE         = getHeaderValue tokenTE reqvt-    mAuthority  = getHeaderValue tokenAuthority reqvt-    mHost       = getHeaderValue tokenHost reqvt--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

@@ -1,180 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | A thread manager.---   The manager has responsibility to spawn and kill---   worker threads.-module Network.HTTP2.Arch.Manager (-    Manager-  , Action-  , start-  , setAction-  , stopAfter-  , spawnAction-  , forkManaged-  , forkManagedUnmask-  , timeoutKillThread-  , timeoutClose-  , KilledByHttp2ThreadManager(..)-  , incCounter-  , decCounter-  , waitCounter0-  ) where--import Control.Exception-import Data.Foldable-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import qualified System.TimeManager as T-import UnliftIO.Concurrent-import qualified UnliftIO.Exception as E-import UnliftIO.STM--import Imports---------------------------------------------------------------------- | Action to be spawned by the manager.-type Action = IO ()--noAction :: Action-noAction = return ()--data Command = Stop (Maybe SomeException) | Spawn | Add ThreadId | Delete ThreadId---- | Manager to manage the thread and the timer.-data Manager = Manager (TQueue Command) (IORef Action) (TVar Int) T.Manager---- | Starting a thread manager.---   Its action is initially set to 'return ()' and should be set---   by 'setAction'. This allows that the action can include---   the manager itself.-start :: T.Manager -> IO Manager-start timmgr = do-    q <- newTQueueIO-    ref <- newIORef noAction-    cnt <- newTVarIO 0-    void $ forkIO $ go q Set.empty ref-    return $ Manager q ref cnt timmgr-  where-    go q tset0 ref = do-        x <- atomically $ readTQueue q-        case x of-            Stop err      -> kill tset0 err-            Spawn         -> next tset0-            Add    newtid -> let tset = add newtid tset0-                             in go q tset ref-            Delete oldtid -> let tset = del oldtid tset0-                             in go q tset ref-      where-        next tset = do-            action <- readIORef ref-            newtid <- forkFinally action $ \_ -> do-                mytid <- myThreadId-                atomically $ writeTQueue q $ Delete mytid-            let tset' = add newtid tset-            go q tset' ref---- | Setting the action to be spawned.-setAction :: Manager -> Action -> IO ()-setAction (Manager _ ref _ _) action = writeIORef ref action---- | Stopping the manager.-stopAfter :: Manager -> IO a -> (Either SomeException a -> IO b) -> IO b-stopAfter (Manager q _ _ _) action cleanup = do-   mask $ \unmask -> do-     ma <- try $ unmask action-     atomically $ writeTQueue q $ Stop (either Just (const Nothing) ma)-     cleanup ma---- | Spawning the action.-spawnAction :: Manager -> IO ()-spawnAction (Manager q _ _ _) = atomically $ writeTQueue q Spawn---------------------------------------------------------------------- | Fork managed thread------ This guarantees that the thread ID is added to the manager's queue before--- the thread starts, and is removed again when the thread terminates--- (normally or abnormally).-forkManaged :: Manager -> IO () -> IO ()-forkManaged mgr io =-    forkManagedUnmask mgr $ \unmask -> unmask io---- | Like 'forkManaged', but run action with exceptions masked-forkManagedUnmask :: Manager -> ((forall x. IO x -> IO x) -> IO ()) -> IO ()-forkManagedUnmask mgr io =-    void $ mask_ $ forkIOWithUnmask $ \unmask -> do-      addMyId mgr-      -- We catch the exception and do not rethrow it: we don't want the-      -- exception printed to stderr.-      io unmask `catch` \(_e :: SomeException) -> return ()-      deleteMyId mgr---- | Adding my thread id to the kill-thread list on stopping.------ This is not part of the public API; see 'forkManaged' instead.-addMyId :: Manager -> IO ()-addMyId (Manager q _ _ _) = do-    tid <- myThreadId-    atomically $ writeTQueue q $ Add tid---- | Deleting my thread id from the kill-thread list on stopping.------ This is /only/ necessary when you want to remove the thread's ID from--- the manager /before/ the thread terminates (thereby assuming responsibility--- for thread cleanup yourself).-deleteMyId :: Manager -> IO ()-deleteMyId (Manager q _ _ _) = do-    tid <- myThreadId-    atomically $ writeTQueue q $ Delete tid--------------------------------------------------------------------add :: ThreadId -> Set ThreadId -> Set ThreadId-add tid set = set'-  where-    set' = Set.insert tid set--del :: ThreadId -> Set ThreadId -> Set ThreadId-del tid set = set'-  where-    set' = Set.delete tid set--kill :: Set ThreadId -> Maybe SomeException -> IO ()-kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadManager err) set---- | Killing the IO action of the second argument on timeout.-timeoutKillThread :: Manager -> (T.Handle -> IO a) -> IO a-timeoutKillThread (Manager _ _ _ tmgr) action = E.bracket register T.cancel action-  where-    register = T.registerKillThread tmgr noAction---- | Registering closer for a resource and---   returning a timer refresher.-timeoutClose :: Manager -> IO () -> IO (IO ())-timeoutClose (Manager _ _ _ tmgr) closer = do-    th <- T.register tmgr closer-    return $ T.tickle th--data KilledByHttp2ThreadManager = KilledByHttp2ThreadManager (Maybe SomeException)-  deriving Show--instance Exception KilledByHttp2ThreadManager where-  toException   = asyncExceptionToException-  fromException = asyncExceptionFromException--------------------------------------------------------------------incCounter :: Manager -> IO ()-incCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (+1)--decCounter :: Manager -> IO ()-decCounter (Manager _ _ cnt _) = atomically $ modifyTVar' cnt (subtract 1)--waitCounter0 :: Manager -> IO ()-waitCounter0 (Manager _ _ cnt _) = atomically $ do-    n <- readTVar cnt-    checkSTM (n < 1)

@@ -1,25 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Queue where--import UnliftIO.STM--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 =-    forkManaged mgr $ do-        wait-        enqueueOutput outQ out--{-# 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------------------------------------------------------------------

@@ -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'

@@ -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

@@ -1,529 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Receiver (-    frameReceiver-  ) where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Short as Short-import Data.IORef-import UnliftIO.Concurrent-import qualified UnliftIO.Exception as E-import UnliftIO.STM--import Imports hiding (delete, insert)-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Arch.Config-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.Arch.Window-import Network.HTTP2.Frame--------------------------------------------------------------------continuationLimit :: Int-continuationLimit = 10--headerFragmentLimit :: Int-headerFragmentLimit = 51200 -- 50K--pingRateLimit :: Int-pingRateLimit = 4--settingsRateLimit :: Int-settingsRateLimit = 4--emptyFrameRateLimit :: Int-emptyFrameRateLimit = 4--rstRateLimit :: Int-rstRateLimit = 4--------------------------------------------------------------------frameReceiver :: Context -> Config -> IO ()-frameReceiver ctx@Context{..} conf@Config{..} = loop 0 `E.catch` sendGoaway-  where-    loop :: Int -> IO ()-    loop n-      | n == 6 = do-          yield-          loop 0-      | otherwise = do-        hd <- confReadN frameHeaderLength-        if BS.null hd then-            enqueueControl controlQ $ CFinish ConnectionIsClosed-          else do-            processFrame ctx conf $ decodeFrameHeader hd-            loop (n + 1)--    sendGoaway se-      | Just e@ConnectionIsClosed  <- E.fromException se =-          enqueueControl controlQ $ CFinish e-      | Just e@(ConnectionErrorIsReceived _ _ _) <- E.fromException se =-          enqueueControl controlQ $ CFinish e-      | Just e@(ConnectionErrorIsSent err sid msg) <- E.fromException se = do-          let frame = goawayFrame sid err $ Short.fromShort msg-          enqueueControl controlQ $ CFrames Nothing [frame]-          enqueueControl controlQ $ CFinish e-      | Just e@(StreamErrorIsSent err sid msg) <- E.fromException se = do-          let frame = resetFrame err sid-          enqueueControl controlQ $ CFrames Nothing [frame]-          let frame' = goawayFrame sid err $ Short.fromShort msg-          enqueueControl controlQ $ CFrames Nothing [frame']-          enqueueControl controlQ $ CFinish e-      | Just e@(StreamErrorIsReceived err sid) <- E.fromException se = do-          let frame = goawayFrame sid err "treat a stream error as a connection error"-          enqueueControl controlQ $ CFrames Nothing [frame]-          enqueueControl controlQ $ CFinish e-      -- this never happens-      | Just e@(BadThingHappen _) <- E.fromException se =-          enqueueControl controlQ $ CFinish e-      | otherwise =-          enqueueControl controlQ $ CFinish $ BadThingHappen se--------------------------------------------------------------------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 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 Config{..} (FramePushPromise, header@FrameHeader{payloadLength,streamId})-  | isServer ctx = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "push promise is not allowed"-  | otherwise = do-      pl <- confReadN payloadLength-      PushPromiseFrame sid frag <- guardIt $ decodePushPromiseFrame header pl-      unless (isServerInitiated sid) $-          E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "wrong sid for push promise"-      when (frag == "") $-          E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "wrong header fragment for push promise"-      (_,vt) <- hpackDecodeHeader frag streamId ctx-      let ClientInfo{..} = toClientInfo $ 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 ()-processFrame ctx@Context{..} conf typhdr@(ftyp, header) = do-    -- My SETTINGS_MAX_FRAME_SIZE-    -- My SETTINGS_ENABLE_PUSH-    settings <- readIORef mySettings-    case checkFrameHeader settings typhdr of-      Left (FrameDecodeError ec sid msg) -> E.throwIO $ ConnectionErrorIsSent ec sid msg-      Right _    -> controlOrStream ctx conf ftyp header--------------------------------------------------------------------controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()-controlOrStream ctx@Context{..} conf@Config{..} ftyp header@FrameHeader{streamId, payloadLength}-  | isControl streamId = do-      pl <- confReadN payloadLength-      control ftyp header pl ctx conf-  | otherwise = do-      checkContinued-      mstrm <- getStream ctx ftyp streamId-      pl <- confReadN 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 ()-  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 <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)-    when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent ProtocolError streamId "no body but content-length is not zero"-    halfClosedRemote ctx strm-    tlr <- newIORef Nothing-    let inpObj = InpObj tbl (Just 0) (return "") tlr-    if isServer ctx then do-        let si = toServerInfo roleInfo-        atomically $ writeTQueue (inputQ si) $ Input strm inpObj-      else-        putMVar streamInput inpObj-    return False---- Transition (process2)-processState (Open hcl (HasBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} _streamId = do-    let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)-    bodyLength <- newIORef 0-    tlr <- newIORef Nothing-    q <- newTQueueIO-    setStreamState ctx strm $ Open hcl (Body q mcl bodyLength tlr)-    incref <- newIORef 0-    bodySource <- mkSource q $ informWindowUpdate ctx strm incref-    let inpObj = InpObj tbl mcl (readSource bodySource) tlr-    if isServer ctx then do-        let si = toServerInfo roleInfo-        atomically $ writeTQueue (inputQ si) $ Input strm inpObj-      else-        putMVar streamInput 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--------------------------------------------------------------------getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream)-getStream ctx@Context{..} ftyp streamId =-    search streamTable streamId >>= getStream' ctx ftyp streamId--getStream' :: Context -> FrameType -> 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 $ 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-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 $ 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) $ do-                setPeerStreamID ctx streamId-                cnt <- readIORef concurrency-                -- Checking the limitation of concurrency-                -- My SETTINGS_MAX_CONCURRENT_STREAMS-                mMaxConc <- maxConcurrentStreams <$> readIORef mySettings-                case mMaxConc of-                  Nothing      -> return ()-                  Just maxConc -> when (cnt >= maxConc) $-                    E.throwIO $ StreamErrorIsSent RefusedStream streamId "exceeds max concurrent"-            Just <$> openStream ctx streamId ftyp-  | otherwise = undefined -- never reach--------------------------------------------------------------------type Payload = ByteString--control :: FrameType -> FrameHeader -> Payload -> Context -> Config -> IO ()-control FrameSettings header@FrameHeader{flags,streamId} bs ctx@Context{myFirstSettings,myPendingAlist,mySettings,controlQ,settingsRate} conf = 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"-        mAlist <- readIORef myPendingAlist-        case mAlist of-          Nothing      -> return () -- fixme-          Just myAlist -> do-              modifyIORef' mySettings $ \old -> updateSettings old myAlist-              writeIORef myPendingAlist Nothing-      else do-        -- Settings Flood - CVE-2019-9515-        rate <- getRate settingsRate-        when (rate > settingsRateLimit) $-            E.throwIO $ ConnectionErrorIsSent ProtocolError 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-            frames <- updateMySettings conf ctx-            let setframe = CFrames (Just peerAlist) (frames ++ [ack])-            enqueueControl controlQ setframe--control FramePing FrameHeader{flags,streamId} bs Context{controlQ,pingRate} _ =-    unless (testAck flags) $ do-        -- Ping Flood - CVE-2019-9512-        rate <- getRate pingRate-        if rate > pingRateLimit then-            E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many ping"-          else do-            let frame = pingFrame bs-            enqueueControl controlQ $ CFrames Nothing [frame]--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 ()--------------------------------------------------------------------{-# 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 then-            E.throwIO $ ConnectionErrorIsSent ProtocolError 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 ""-        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} 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 $ ConnectionErrorIsSent ProtocolError streamId "too many empty data"-      else do-        writeIORef bodyLength len-        atomically $ writeTQueue q $ Right body-    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 ""-        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 then-            E.throwIO $ ConnectionErrorIsSent ProtocolError 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-    rate <- getRate $ rstRate ctx-    when (rate > rstRateLimit) $-        E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many rst_stream"-    RSTStreamFrame err <- guardIt $ decodeRSTStreamFrame header bs-    let cc = Reset err--    -- The spec mandates (section 8.1):-    ---    -- > When this is true, a server MAY request that the client abort-    -- > transmission of a request without error by sending a RST_STREAM with an-    -- > error code of NO_ERROR after sending a complete response (i.e., a frame-    -- > with the END_STREAM flag).-    ---    -- We check the first part ("after sending a complete response") by checking-    -- the current stream state.-    case (s, err) of-      (HalfClosedRemote, NoError) ->-        return (Closed cc)-      _otherwise -> do-        closed ctx strm cc-        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 _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamErrorIsSent ProtocolError streamId $ fromString ("illegal frame for " ++ show streamId)---------------------------------------------------------------------- | Type for input streaming.-data Source = Source (Int -> IO ())-                     (TQueue (Either E.SomeException ByteString))-                     (IORef ByteString)-                     (IORef Bool)--mkSource :: TQueue (Either E.SomeException ByteString) -> (Int -> IO ()) -> IO Source-mkSource q inform = Source inform q <$> newIORef "" <*> newIORef False--readSource :: Source -> IO ByteString-readSource (Source inform q refBS refEOF) = do-    eof <- readIORef refEOF-    if eof then-        return ""-      else do-        bs <- readBS-        let len = BS.length bs-        inform len-        return bs-  where-    readBS :: IO ByteString-    readBS = do-        bs0 <- readIORef refBS-        if bs0 == "" then do-            mBS <- atomically $ readTQueue q-            case mBS of-              Left err -> do-                writeIORef refEOF True-                E.throwIO err-              Right bs -> do-                when (bs == "") $ writeIORef refEOF True-                return bs-          else do-            writeIORef refBS ""-            return bs0

@@ -1,510 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Network.HTTP2.Arch.Sender (-    frameSender-  , fillBuilderBodyGetNext-  , fillFileBodyGetNext-  , fillStreamBodyGetNext-  , runTrailersMaker-  ) where--import Control.Concurrent.MVar (putMVar)-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder.Extra as B-import Data.IORef (readIORef, writeIORef)-import Foreign.Ptr (plusPtr, minusPtr)-import Network.ByteOrder-import qualified UnliftIO.Exception as E-import UnliftIO.STM--import Imports-import Network.HPACK (setLimitForEncoding, toHeaderTable, TokenHeaderList)-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.Arch.Window-import Network.HTTP2.Frame--------------------------------------------------------------------data Leftover = LZero-              | LOne B.BufferWriter-              | LTwo ByteString B.BufferWriter--------------------------------------------------------------------{-# INLINE waitStreaming #-}-waitStreaming :: TBQueue a -> IO ()-waitStreaming tbq = atomically $ do-    isEmpty <- isEmptyTBQueue tbq-    checkSTM (not isEmpty)--data Switch = C Control-            | O (Output Stream)-            | Flush--wrapException :: E.SomeException -> IO ()-wrapException se-  | Just (e :: HTTP2Error) <- E.fromException se = E.throwIO e-  | otherwise = E.throwIO $ BadThingHappen se--frameSender :: Context -> Config -> Manager -> IO ()-frameSender ctx@Context{outputQ,controlQ,encodeDynamicTable,outputBufferLimit}-            Config{..}-            mgr = loop 0 `E.catch` wrapException-  where-    -----------------------------------------------------------------    loop :: Offset -> IO ()-    loop off = do-        x <- atomically $ dequeue off-        case x of-            C ctl -> flushN off >> control ctl >> loop 0-            O out -> outputOrEnqueueAgain out off >>= flushIfNecessary >>= loop-            Flush -> flushN off >> loop 0--    -- 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-        isEmpty <- isEmptyTQueue controlQ-        if isEmpty then do-            waitConnectionWindowSize ctx-            emp <- isEmptyTQueue outputQ-            if emp then-                if off /= 0 then return Flush else retrySTM-              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 (CFinish     e) = E.throwIO e-    control (CGoaway bs mvar) = do-        buf <- copyAll [bs] confWriteBuffer-        let off = buf `minusPtr` confWriteBuffer-        flushN off-        putMVar mvar ()-        E.throwIO GoAwayIsSent-    control (CFrames ms xs) = do-        buf <- copyAll xs confWriteBuffer-        let off = buf `minusPtr` confWriteBuffer-        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 SettingsHeaderTableSize peerAlist of-                Nothing  -> return ()-                Just siz -> setLimitForEncoding siz encodeDynamicTable--    -----------------------------------------------------------------    output :: Output Stream -> Offset -> WindowSize -> IO Offset-    output out@(Output strm OutObj{} (ONext curr tlrmkr) _ sentinel) off0 lim = do-        -- Data frame payload-        buflim <- readIORef outputBufferLimit-        let payloadOff = off0 + frameHeaderLength-            datBuf     = confWriteBuffer `plusPtr` payloadOff-            datBufSiz  = buflim - payloadOff-        Next datPayloadLen reqflush mnext <- curr datBuf datBufSiz lim -- checkme-        NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen-        fillDataHeaderEnqueueNext strm off0 datPayloadLen mnext tlrmkr' sentinel out reqflush--    output out@(Output strm (OutObj hdr body tlrmkr) OObj mtbq _) off0 lim = do-        -- Header frame and Continuation frame-        let sid = streamNumber strm-            endOfStream = case body of-                OutBodyNone -> True-                _           -> False-        (ths,_) <- toHeaderTable $ fixHeaders hdr-        off' <- headerContinue sid ths endOfStream off0-        -- halfClosedLocal calls closed which removes-        -- the stream from stream table.-        when endOfStream $ halfClosedLocal ctx strm Finished-        off <- flushIfNecessary off'-        case body of-            OutBodyNone -> return off-            OutBodyFile (FileSpec path fileoff bytecount) -> do-                (pread, sentinel') <- confPositionReadMaker path-                refresh <- case sentinel' of-                             Closer closer       -> timeoutClose mgr closer-                             Refresher refresher -> return refresher-                let next = fillFileBodyGetNext pread fileoff bytecount refresh-                    out' = out { outputType = ONext next tlrmkr }-                output out' off lim-            OutBodyBuilder builder -> do-                let next = fillBuilderBodyGetNext builder-                    out' = out { outputType = ONext next tlrmkr }-                output out' off lim-            OutBodyStreaming _ ->-                output (setNextForStreaming mtbq tlrmkr out) off lim-            OutBodyStreamingUnmask _ ->-                output (setNextForStreaming mtbq tlrmkr out) off lim--    output out@(Output strm _ (OPush ths pid) _ _) off0 lim = do-        -- Creating a push promise header-        -- Frame id should be associated stream id from the client.-        let sid = streamNumber strm-        len <- pushPromise pid sid ths off0-        off <- flushIfNecessary $ off0 + frameHeaderLength + len-        output out{outputType=OObj} off lim--    output _ _ _ = undefined -- never reach--    -----------------------------------------------------------------    setNextForStreaming :: Maybe (TBQueue StreamingChunk) -> TrailersMaker -> Output Stream -> Output Stream-    setNextForStreaming mtbq tlrmkr out =-        let tbq = fromJust mtbq-            takeQ = atomically $ tryReadTBQueue tbq-            next = fillStreamBodyGetNext takeQ-        in out { outputType = ONext next tlrmkr }--    -----------------------------------------------------------------    outputOrEnqueueAgain :: Output Stream -> Offset -> IO Offset-    outputOrEnqueueAgain out@(Output strm _ otyp _ _) off = E.handle resetStream $ do-        state <- readStreamState strm-        if isHalfClosedLocal state then-            return off-          else case otyp of-                 OWait wait -> do-                     -- Checking if all push are done.-                     forkAndEnqueueWhenReady wait outputQ out{outputType=OObj} mgr-                     return off-                 _ -> case mtbq of-                        Just tbq -> checkStreaming tbq-                        _        -> checkStreamWindowSize-      where-        mtbq = outputStrmQ out-        checkStreaming tbq = do-            isEmpty <- atomically $ isEmptyTBQueue tbq-            if isEmpty then do-                forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr-                return off-              else-                checkStreamWindowSize-        checkStreamWindowSize = do-            sws <- getStreamWindowSize strm-            if sws == 0 then do-                forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr-                return off-              else do-                cws <- getConnectionWindowSize ctx -- not 0-                let lim = min cws sws-                output out off lim-        resetStream e = do-            closed ctx strm (ResetByMe e)-            let rst = resetFrame InternalError $ streamNumber strm-            enqueueControl controlQ $ CFrames Nothing [rst]-            return off--    -----------------------------------------------------------------    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--    -----------------------------------------------------------------    fillDataHeaderEnqueueNext :: Stream-                              -> Offset-                              -> Int-                              -> Maybe DynaNext-                              -> (Maybe ByteString -> IO NextTrailersMaker)-                              -> IO ()-                              -> Output Stream-                              -> Bool-                              -> IO Offset-    fillDataHeaderEnqueueNext strm@Stream{streamNumber}-                   off datPayloadLen Nothing tlrmkr tell _ reqflush = do-        let buf  = confWriteBuffer `plusPtr` off-            off' = off + frameHeaderLength + datPayloadLen-        (mtrailers, flag) <- do-              Trailers trailers <- tlrmkr Nothing-              if null trailers then-                  return (Nothing, setEndStream defaultFlags)-                else-                  return (Just trailers, defaultFlags)-        fillFrameHeader FrameData datPayloadLen streamNumber flag buf-        off'' <- handleTrailers mtrailers off'-        void tell-        halfClosedLocal ctx strm Finished-        decreaseWindowSize ctx strm datPayloadLen-        if reqflush then do-            flushN off''-            return 0-          else-            return off''-      where-        handleTrailers Nothing off0 = return off0-        handleTrailers (Just trailers) off0 = do-            (ths,_) <- toHeaderTable trailers-            headerContinue streamNumber ths True {- endOfStream -} off0--    fillDataHeaderEnqueueNext _-                   off 0 (Just next) tlrmkr _ out reqflush = do-        let out' = out { outputType = ONext next tlrmkr }-        enqueueOutput outputQ out'-        if reqflush then do-            flushN off-            return 0-          else-            return off--    fillDataHeaderEnqueueNext 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 }-        enqueueOutput outputQ out'-        if reqflush then do-            flushN off'-            return 0-          else-            return off'--    -----------------------------------------------------------------    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-          }---- | Running trailers-maker.------ > bufferIO buf siz $ \bs -> tlrmkr (Just bs)-runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker-runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs)--------------------------------------------------------------------fillBuilderBodyGetNext :: Builder -> DynaNext-fillBuilderBodyGetNext bb buf siz lim = do-    let room = min siz lim-    (len, signal) <- B.runBuilder bb buf room-    return $ nextForBuilder len signal--fillFileBodyGetNext :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillFileBodyGetNext pread start bytecount refresh buf siz lim = do-    let room = min siz lim-    len <- pread start (mini room bytecount) buf-    let len' = fromIntegral len-    return $ nextForFile len' pread (start + len) (bytecount - len) refresh--fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext-fillStreamBodyGetNext takeQ buf siz lim = do-    let room = min siz lim-    (cont, len, reqflush, leftover) <- runStreamBuilder buf room takeQ-    return $ nextForStream cont len reqflush leftover takeQ--------------------------------------------------------------------fillBufBuilder :: Leftover -> DynaNext-fillBufBuilder leftover buf0 siz0 lim = do-    let room = min siz0 lim-    case leftover of-        LZero -> error "fillBufBuilder: LZero"-        LOne writer -> do-            (len, signal) <- writer buf0 room-            getNext len signal-        LTwo bs writer-          | BS.length bs <= room -> do-              buf1 <- copy buf0 bs-              let len1 = BS.length bs-              (len2, signal) <- writer buf1 (room - len1)-              getNext (len1 + len2) signal-          | otherwise -> do-              let (bs1,bs2) = BS.splitAt room bs-              void $ copy buf0 bs1-              getNext room (B.Chunk bs2 writer)-  where-    getNext l s = return $ nextForBuilder l s--nextForBuilder :: BytesFilled -> B.Next -> Next-nextForBuilder len B.Done-    = Next len True Nothing -- let's flush-nextForBuilder len (B.More _ writer)-    = Next len False $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer)-    = Next len False $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder :: Buffer -> BufferSize -> IO (Maybe StreamingChunk)-                 -> IO (Bool  -- continue-                       ,BytesFilled-                       ,Bool  -- require flusing-                       ,Leftover)-runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0-  where-    loop buf room total = do-        mbuilder <- takeQ-        case mbuilder of-            Nothing      -> return (True, total, False, LZero)-            Just (StreamingBuilder builder) -> do-                (len, signal) <- B.runBuilder builder buf room-                let total' = total + len-                case signal of-                    B.Done -> loop (buf `plusPtr` len) (room - len) total'-                    B.More  _ writer  -> return (True,  total', False, LOne writer)-                    B.Chunk bs writer -> return (True,  total', False, LTwo bs writer)-            Just StreamingFlush       -> return (True,  total,  True,  LZero)-            Just (StreamingFinished dec) -> do-                dec-                return (False, total,  True,  LZero)--fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext-fillBufStream leftover0 takeQ buf0 siz0 lim0 = do-    let room0 = min siz0 lim0-    case leftover0 of-        LZero -> do-            (cont, len, reqflush, leftover) <- runStreamBuilder buf0 room0 takeQ-            getNext cont len reqflush leftover-        LOne writer -> write writer buf0 room0 0-        LTwo bs writer-          | BS.length bs <= room0 -> do-              buf1 <- copy buf0 bs-              let len = BS.length bs-              write writer buf1 (room0 - len) len-          | otherwise -> do-              let (bs1,bs2) = BS.splitAt room0 bs-              void $ copy buf0 bs1-              getNext True room0 False $ LTwo bs2 writer-  where-    getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next-    getNext cont len reqflush l = return $ nextForStream cont len reqflush l takeQ--    write :: (Buffer -> BufferSize -> IO (Int, B.Next))-          -> Buffer -> BufferSize -> Int-          -> IO Next-    write writer1 buf room sofar = do-        (len, signal) <- writer1 buf room-        case signal of-            B.Done -> do-                (cont, extra, reqflush, leftover) <- runStreamBuilder (buf `plusPtr` len) (room - len) takeQ-                let total = sofar + len + extra-                getNext cont total reqflush leftover-            B.More  _ writer -> do-                let total = sofar + len-                getNext True total False $ LOne writer-            B.Chunk bs writer -> do-                let total = sofar + len-                getNext True total False $ LTwo bs writer--nextForStream :: Bool -> BytesFilled -> Bool-              -> Leftover -> IO (Maybe StreamingChunk)-              -> Next-nextForStream False len reqflush _          _     = Next len reqflush Nothing-nextForStream True  len reqflush leftOrZero takeQ =-    Next len reqflush $ Just (fillBufStream leftOrZero takeQ)--------------------------------------------------------------------fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillBufFile pread start bytes refresh buf siz lim = do-    let room = min siz lim-    len <- pread start (mini room bytes) buf-    refresh-    let len' = fromIntegral len-    return $ nextForFile len' pread (start + len) (bytes - len) refresh--nextForFile :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next-nextForFile 0   _  _     _     _       = Next 0   True  Nothing -- let's flush-nextForFile len _  _     0     _       = Next len False Nothing-nextForFile len pread start bytes refresh =-    Next len False $ Just $ fillBufFile pread start bytes refresh--{-# INLINE mini #-}-mini :: Int -> Int64 -> Int64-mini i n-  | fromIntegral i < n = fromIntegral i-  | otherwise          = n

@@ -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

@@ -1,96 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Network.HTTP2.Arch.Stream where--import Control.Exception-import Data.IORef-import qualified Data.IntMap.Strict as M-import UnliftIO.Concurrent-import UnliftIO.STM--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 (Open (Just _) _) = 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--closeAllStreams :: StreamTable -> Maybe SomeException -> IO ()-closeAllStreams (StreamTable ref) mErr' = do-    strms <- atomicModifyIORef' ref $ \m -> (M.empty, m)-    forM_ strms $ \strm -> do-      st <- readStreamState strm-      case st of-        Open _ (Body q _ _ _) ->-          atomically $ writeTQueue q $ maybe (Right mempty) Left mErr-        _otherwise ->-          return ()-  where-    mErr :: Maybe SomeException-    mErr = case mErr' of-             Just err | Just ConnectionIsClosed <- fromException err ->-               Nothing-             _otherwise ->-               mErr'

@@ -1,331 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Network.HTTP2.Arch.Types where--import qualified Control.Exception as E-import Data.ByteString.Builder (Builder)-import Data.IORef-import Data.IntMap.Strict (IntMap)-import Data.Typeable-import qualified Network.HTTP.Types as H-import UnliftIO.Concurrent-import UnliftIO.Exception (SomeException)-import UnliftIO.STM--import Imports-import Network.HPACK-import Network.HTTP2.Arch.File-import Network.HTTP2.Frame---------------------------------------------------------------------- | "http" or "https".-type Scheme = ByteString---- | Authority.-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 ())-             -- | Like 'OutBodyStreaming', but with a callback to unmask expections-             ---             -- This is used in the client: we spawn the new thread for the request body-             -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask'-             -- with a callback to unmask them again (typically after installing an exception-             -- handler).-             ---             -- We do /NOT/ support this in the server, as here the scope of the thread-             -- that is spawned for the server is the entire handler, not just the response-             -- streaming body.-             ---             -- TODO: The analogous change for the server-side would be to provide a similar-             -- @unmask@ callback as the first argument in the 'Server' type alias.-             | OutBodyStreamingUnmask ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())-             | OutBodyBuilder Builder-             | OutBodyFile FileSpec---- | Input object-data InpObj = InpObj {-    inpObjHeaders  :: HeaderTable   -- ^ Accessor for headers.-  , inpObjBodySize :: Maybe Int     -- ^ Accessor for body length specified in content-length:.-  , inpObjBody     :: InpBody       -- ^ Accessor for body.-  , inpObjTrailers :: IORef (Maybe HeaderTable) -- ^ Accessor for trailers.-  }--instance Show InpObj where-    show (InpObj (thl,_) _ _body _tref) = show thl---- | Output object-data OutObj = OutObj {-    outObjHeaders  :: [H.Header]    -- ^ Accessor for header.-  , outObjBody     :: OutBody       -- ^ Accessor for outObj body.-  , outObjTrailers :: TrailersMaker -- ^ Accessor for trailers maker.-  }--instance Show OutObj where-    show (OutObj hdr _ _) = show hdr---- | Trailers maker. A chunks of the response body is passed---   with 'Just'. The maker should update internal state---   with the 'ByteString' and return the next trailers maker.---   When response body reaches its end,---   'Nothing' is passed and the maker should generate---   trailers. An example:------   > {-# LANGUAGE BangPatterns #-}---   > import Data.ByteString (ByteString)---   > import qualified Data.ByteString.Char8 as C8---   > import Crypto.Hash (Context, SHA1) -- cryptonite---   > import qualified Crypto.Hash as CH---   >---   > -- Strictness is important for Context.---   > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker---   > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]---   >   where---   >     !sha1 = C8.pack $ show $ CH.hashFinalize ctx---   > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'---   >   where---   >     !ctx' = CH.hashUpdate ctx bs------   Usage example:------   > let h2rsp = responseFile ...---   >     maker = trailersMaker (CH.hashInit :: Context SHA1)---   >     h2rsp' = setResponseTrailersMaker h2rsp maker----type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker---- | TrailersMake to create no trailers.-defaultTrailersMaker :: TrailersMaker-defaultTrailersMaker Nothing = return $ Trailers []-defaultTrailersMaker _       = return $ NextTrailersMaker defaultTrailersMaker---- | Either the next trailers maker or final trailers.-data NextTrailersMaker = NextTrailersMaker TrailersMaker-                       | Trailers [H.Header]---------------------------------------------------------------------- | File specification.-data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)--------------------------------------------------------------------{---== Stream state--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 HeaderTable-  | HasBody HeaderTable-  | Body (TQueue (Either SomeException 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 ErrorCode-                | ResetByMe SomeException-                deriving Show--------------------------------------------------------------------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"--------------------------------------------------------------------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      -- payload length-                 Bool             -- require flushing-                 (Maybe DynaNext)--------------------------------------------------------------------data Control = CFinish HTTP2Error-             | CFrames (Maybe SettingsList) [ByteString]-             | CGoaway ByteString (MVar ())--------------------------------------------------------------------data StreamingChunk = StreamingFinished (IO ())-                    | StreamingFlush-                    | StreamingBuilder Builder--------------------------------------------------------------------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-  | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase-  | ConnectionErrorIsSent     ErrorCode StreamId ReasonPhrase-  | StreamErrorIsReceived     ErrorCode StreamId-  | StreamErrorIsSent         ErrorCode StreamId ReasonPhrase-  | BadThingHappen E.SomeException-  | GoAwayIsSent-  deriving (Show, Typeable)--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

@@ -1,120 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Arch.Window where--import Data.IORef-import qualified UnliftIO.Exception as E-import UnliftIO.STM--import Imports-import Network.HTTP2.Arch.Config-import Network.HTTP2.Arch.Context-import Network.HTTP2.Arch.EncodeFrame-import Network.HTTP2.Arch.Queue-import Network.HTTP2.Arch.Stream-import Network.HTTP2.Arch.Types-import Network.HTTP2.Frame--getStreamWindowSize :: Stream -> IO WindowSize-getStreamWindowSize Stream{streamWindow} = readTVarIO streamWindow--getConnectionWindowSize :: Context -> IO WindowSize-getConnectionWindowSize Context{txConnectionWindow} = readTVarIO txConnectionWindow--waitStreamWindowSize :: Stream -> IO ()-waitStreamWindowSize Stream{streamWindow} = atomically $ do-    w <- readTVar streamWindow-    checkSTM (w > 0)--waitConnectionWindowSize :: Context -> STM ()-waitConnectionWindowSize Context{txConnectionWindow} = do-    w <- readTVar txConnectionWindow-    checkSTM (w > 0)--------------------------------------------------------------------- Receiving window update--increaseWindowSize :: StreamId -> TVar WindowSize -> WindowSize -> IO ()-increaseWindowSize sid tvar n = do-    w <- atomically $ do-        w0 <- readTVar tvar-        let w1 = w0 + n-        writeTVar tvar w1-        return w1-    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,streamWindow} n =-    increaseWindowSize streamNumber streamWindow n--increaseConnectionWindowSize :: Context -> Int -> IO ()-increaseConnectionWindowSize Context{txConnectionWindow} n =-    increaseWindowSize 0 txConnectionWindow n--decreaseWindowSize :: Context -> Stream -> WindowSize -> IO ()-decreaseWindowSize Context{txConnectionWindow} Stream{streamWindow} siz = do-    atomically $ modifyTVar' txConnectionWindow (subtract siz)-    atomically $ modifyTVar' streamWindow (subtract siz)--------------------------------------------------------------------- Sending window update--informWindowUpdate :: Context -> Stream -> IORef Int -> Int -> IO ()-informWindowUpdate _        _   _       0   = return ()-informWindowUpdate Context{controlQ,rxConnectionInc} Stream{streamNumber} streamInc len = do-    join $ atomicModifyIORef rxConnectionInc $ modify 0-    join $ atomicModifyIORef streamInc       $ modify streamNumber-  where-    modify sid w0-      | w1 < thresh = (w1, return ())-      | otherwise   = let frame = windowUpdateFrame sid w1-                          cframe = CFrames Nothing [frame]-                          action = enqueueControl controlQ cframe-                      in (0, action)-      where-        thresh = defaultWindowSize -- fixme-        w1 = w0 + len---------------------------------------------------------------------- max: 2,147,483,647 (2^31-1) is too large.--- def:        65,535 (2^16-1) it too small.---          1,048,575 (2^20-1)-properWindowSize :: WindowSize-properWindowSize = 1048575--updateMySettings :: Config -> Context -> IO [ByteString]-updateMySettings Config{..} Context{myFirstSettings,myPendingAlist} = do-    writeIORef myFirstSettings True-    writeIORef myPendingAlist $ Just myInitialAlist-    return frames-  where-    len = confBufferSize - frameHeaderLength-    payloadLen = max defaultPayloadLength len-    myInitialAlist =-        -- confBufferSize is the size of the write buffer.-        -- But we assume that the size of the read buffer is the same size.-        -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE.-        [(SettingsMaxFrameSize,payloadLen)-        ,(SettingsMaxConcurrentStreams,recommendedConcurrency)-        -- Initial window size for streams-        ,(SettingsInitialWindowSize,properWindowSize)]-    frame1 = settingsFrame id myInitialAlist-        -- Initial window update for connection-    frame2 = windowUpdateFrame 0 (properWindowSize - defaultWindowSize)-    frames = [frame1,frame2]---- Peer SETTINGS_INITIAL_WINDOW_SIZE--- Adjusting initial window size for streams-updatePeerSettings :: Context -> SettingsList -> IO ()-updatePeerSettings Context{peerSettings,streamTable} peerAlist = do-    oldws <- initialWindowSize <$> readIORef peerSettings-    modifyIORef' peerSettings $ \old -> updateSettings old peerAlist-    newws <- initialWindowSize <$> readIORef peerSettings-    let diff = newws - oldws-    when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable

@@ -6,6 +6,7 @@ --  Example: -- -- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE RankNTypes #-} -- > -- > module Main where -- >@@ -23,11 +24,12 @@ -- > main :: IO () -- > main = runTCPClient serverName "80" $ runHTTP2Client serverName -- >   where--- >     cliconf host = ClientConfig "http" (C8.pack host) 20+-- >     cliconf host = defaultClientConfig { authority = C8.pack host } -- >     runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096) -- >                                       freeSimpleConfig -- >                                       (\conf -> run (cliconf host) conf client)--- >     client sendRequest = do+-- >     client :: Client ()+-- >     client sendRequest _aux = do -- >         let req0 = requestNoBody methodGet "/" [] -- >             client0 = sendRequest req0 $ \rsp -> do -- >                 print rsp@@ -40,68 +42,117 @@ -- >         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-  , requestStreamingUnmask-  , requestBuilder-  -- ** Trailers maker-  , TrailersMaker-  , NextTrailersMaker(..)-  , defaultTrailersMaker-  , setRequestTrailersMaker-  -- * Response-  , Response-  -- ** Accessing response-  , responseStatus-  , responseHeaders-  , responseBodySize-  , getResponseBodyChunk-  , getResponseTrailers-  -- * Types-  , Method-  , Path-  , FileSpec(..)-  , FileOffset-  , ByteCount-  -- * Error-  , HTTP2Error(..)-  , ErrorCode(ErrorCode,NoError,ProtocolError,InternalError,FlowControlError,SettingsTimeout,StreamClosed,FrameSizeError,RefusedStream,Cancel,CompressionError,ConnectError,EnhanceYourCalm,InadequateSecurity,HTTP11Required)-  -- * RecvN-  , defaultReadN-  -- * Position read for files-  , PositionReadMaker-  , PositionRead-  , Sentinel(..)-  , defaultPositionReadMaker-  ) where+    -- * Runner+    run, +    -- * Client configuration+    Scheme,+    Authority,+    ClientConfig,+    defaultClientConfig,+    scheme,+    authority,+    cacheLimit,+    connectionWindowSize,+    settings,++    -- * HTTP\/2 setting+    Settings,+    defaultSettings,+    headerTableSize,+    enablePush,+    maxConcurrentStreams,+    initialWindowSize,+    maxFrameSize,+    maxHeaderListSize,++    -- * Common configuration+    Config (..),+    allocSimpleConfig,+    freeSimpleConfig,++    -- * HTTP\/2 client+    Client,++    -- * Request+    Request,++    -- * Creating request+    requestNoBody,+    requestFile,+    requestStreaming,+    requestStreamingUnmask,+    requestBuilder,++    -- ** Trailers maker+    TrailersMaker,+    NextTrailersMaker (..),+    defaultTrailersMaker,+    setRequestTrailersMaker,++    -- * Response+    Response,++    -- ** Accessing response+    responseStatus,+    responseHeaders,+    responseBodySize,+    getResponseBodyChunk,+    getResponseTrailers,++    -- * Aux+    Aux,+    auxPossibleClientStreams,++    -- * Types+    Method,+    Path,+    FileSpec (..),+    FileOffset,+    ByteCount,++    -- * Error+    HTTP2Error (..),+    ReasonPhrase,+    ErrorCode (+        ErrorCode,+        NoError,+        ProtocolError,+        InternalError,+        FlowControlError,+        SettingsTimeout,+        StreamClosed,+        FrameSizeError,+        RefusedStream,+        Cancel,+        CompressionError,+        ConnectError,+        EnhanceYourCalm,+        InadequateSecurity,+        HTTP11Required+    ),++    -- * RecvN+    defaultReadN,++    -- * Position read for files+    PositionReadMaker,+    PositionRead,+    Sentinel (..),+    defaultPositionReadMaker,+) where+ import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Data.IORef (readIORef) import Network.HTTP.Types  import Network.HPACK-import Network.HTTP2.Arch import Network.HTTP2.Client.Run import Network.HTTP2.Client.Types import Network.HTTP2.Frame+import Network.HTTP2.H2 hiding (authority, scheme)  ---------------------------------------------------------------- @@ -124,17 +175,23 @@     hdr' = addHeaders m p hdr  -- | Creating request with streaming.-requestStreaming :: Method -> Path -> RequestHeaders-                 -> ((Builder -> IO ()) -> IO () -> IO ())-                 -> Request+requestStreaming+    :: Method+    -> Path+    -> RequestHeaders+    -> ((Builder -> IO ()) -> IO () -> IO ())+    -> Request requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker   where     hdr' = addHeaders m p hdr  -- | Like 'requestStreaming', but run the action with exceptions masked-requestStreamingUnmask :: Method -> Path -> RequestHeaders-                       -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())-                       -> Request+requestStreamingUnmask+    :: Method+    -> Path+    -> RequestHeaders+    -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())+    -> Request requestStreamingUnmask m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingUnmask strmbdy) defaultTrailersMaker   where     hdr' = addHeaders m p hdr@@ -144,7 +201,7 @@  -- | Setting 'TrailersMaker' to 'Response'. setRequestTrailersMaker :: Request -> TrailersMaker -> Request-setRequestTrailersMaker (Request req) tm = Request req { outObjTrailers = tm }+setRequestTrailersMaker (Request req) tm = Request req{outObjTrailers = tm}  ---------------------------------------------------------------- 

@@ -1,6 +1,16 @@ module Network.HTTP2.Client.Internal (-    Request(..)-  , Response(..)-  ) where+    Request (..),+    Response (..),+    ClientConfig (..),+    Settings (..),+    Aux (..), +    -- * Low level+    Stream,+    ClientIO (..),+    runIO,+) where++import Network.HTTP2.Client.Run import Network.HTTP2.Client.Types+import Network.HTTP2.H2

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -6,96 +7,189 @@  import Control.Concurrent.STM (check) import Control.Exception+import Data.ByteString.Builder (Builder)+import Data.IORef+import Network.Control (RxFlow (..), defaultMaxData)+import Network.Socket (SockAddr) import UnliftIO.Async import UnliftIO.Concurrent import UnliftIO.STM  import Imports-import Network.HTTP2.Arch import Network.HTTP2.Client.Types import Network.HTTP2.Frame-import Data.ByteString.Builder (Builder)+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.+--+-- >>> defaultClientConfig+-- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing}}+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 confBufferSize confMySockAddr confPeerSockAddr+run cconf@ClientConfig{..} conf client = do+    (ctx, mgr) <- setup cconf conf+    runH2 conf ctx mgr $ runClient ctx mgr+  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 =+        Aux+            { auxPossibleClientStreams = possibleClientStream ctx+            }+    clientCore ctx mgr req processResponse = do+        strm <- sendRequest ctx mgr scheme authority req+        rsp <- getResponse strm+        processResponse rsp+    runClient ctx mgr = do+        x <- client (clientCore ctx mgr) $ aux ctx+        waitCounter0 mgr+        let frame = goawayFrame 0 NoError "graceful closing"+        mvar <- newMVar ()+        enqueueControl (controlQ ctx) $ CGoaway frame mvar+        takeMVar mvar+        return x++-- | Launching a receiver and a sender.+runIO :: ClientConfig -> Config -> (ClientIO -> IO (IO a)) -> IO a+runIO cconf@ClientConfig{..} conf@Config{..} action = do+    (ctx@Context{..}, mgr) <- setup cconf conf+    let putB bs = enqueueControl controlQ $ CFrames Nothing [bs]+        putR req = do+            strm <- sendRequest ctx mgr scheme authority req+            return (streamNumber strm, strm)+        get = getResponse+        create = openOddStreamWait ctx+    runClient <-+        action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create+    runH2 conf ctx mgr runClient++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, Manager)+setup ClientConfig{..} conf@Config{..} = do+    let clientInfo = newClientInfo scheme authority+    ctx <-+        newContext+            clientInfo+            conf+            cacheLimit+            connectionWindowSize+            settings     mgr <- start confTimeoutManager-    let runBackgroundThreads = do-            let runReceiver = frameReceiver ctx conf-                runSender   = frameSender   ctx conf mgr-            concurrently_ runReceiver runSender-    exchangeSettings conf ctx-    mvar <- newMVar ()-    let runClient = do-            x <- client $ sendRequest ctx mgr scheme authority-            waitCounter0 mgr-            let frame = goawayFrame 0 NoError "graceful closing"-            enqueueControl (controlQ ctx) $ CGoaway frame mvar-            takeMVar mvar-            return x+    exchangeSettings ctx+    return (ctx, mgr)++runH2 :: Config -> Context -> Manager -> IO a -> IO a+runH2 conf ctx mgr runClient =     stopAfter mgr (race runBackgroundThreads runClient) $ \res -> do-      closeAllStreams (streamTable ctx) $ either Just (const Nothing) res-      case res of-        Left err ->-          throwIO err-        Right (Left ()) ->-          undefined -- never reach-        Right (Right x) ->-          return x+        closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $+            either Just (const Nothing) res+        case res of+            Left err ->+                throwIO err+            Right (Left ()) ->+                undefined -- never reach+            Right (Right x) ->+                return x+  where+    runReceiver = frameReceiver ctx conf+    runSender = frameSender ctx conf mgr+    runBackgroundThreads = concurrently_ runReceiver runSender -sendRequest :: Context -> Manager -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a-sendRequest ctx@Context{..} mgr scheme auth (Request req) processResponse = do+sendRequest+    :: Context+    -> Manager+    -> Scheme+    -> Authority+    -> Request+    -> IO Stream+sendRequest ctx@Context{..} mgr scheme auth (Request req) = do     -- Checking push promises     let hdr0 = outObjHeaders req         method = fromMaybe (error "sendRequest:method") $ lookup ":method" hdr0-        path   = fromMaybe (error "sendRequest:path") $ lookup ":path" hdr0-    mstrm0 <- lookupCache method path roleInfo-    strm <- case mstrm0 of-      Nothing -> do-          -- Arch/Sender is originally implemented for servers where-          -- the ordering of responses can be out-of-order.-          -- But for clients, the ordering must be maintained.-          -- To implement this, 'outputQStreamID' is used.-          -- Also, for 'OutBodyStreaming', TBQ must not be empty-          -- when its 'Output' is enqueued into 'outputQ'.-          -- Otherwise, it would be re-enqueue because of empty-          -- resulting in out-of-order.-          -- To implement this, 'tbqNonEmpty' is used.-          let hdr1 | scheme /= "" = (":scheme", scheme) : hdr0-                   | otherwise    = hdr0-              hdr2 | auth /= "" = (":authority", auth) : hdr1-                   | otherwise  = hdr1-              req' = req { outObjHeaders = hdr2 }-          sid <- getMyNewStreamId ctx-          newstrm <- openStream ctx sid FrameHeaders-          case outObjBody req of-            OutBodyStreaming strmbdy ->-                sendStreaming ctx mgr req' sid newstrm $ \unmask push flush ->-                    unmask $ strmbdy push flush-            OutBodyStreamingUnmask strmbdy ->-                sendStreaming ctx mgr req' sid newstrm strmbdy-            _ -> atomically $ do-                sidOK <- readTVar outputQStreamID-                check (sidOK == sid)-                writeTVar outputQStreamID (sid + 2)-                writeTQueue outputQ $ Output newstrm req' OObj Nothing (return ())-          return newstrm-      Just strm0 -> return strm0-    rsp <- takeMVar $ streamInput strm-    processResponse $ Response rsp+        path = fromMaybe (error "sendRequest:path") $ lookup ":path" hdr0+    mstrm0 <- lookupEvenCache evenStreamTable method path+    case mstrm0 of+        Just strm0 -> do+            deleteEvenCache evenStreamTable method path+            return strm0+        Nothing -> do+            -- Arch/Sender is originally implemented for servers where+            -- the ordering of responses can be out-of-order.+            -- But for clients, the ordering must be maintained.+            -- To implement this, 'outputQStreamID' is used.+            -- Also, for 'OutBodyStreaming', TBQ must not be empty+            -- when its 'Output' is enqueued into 'outputQ'.+            -- Otherwise, it would be re-enqueue because of empty+            -- resulting in out-of-order.+            -- To implement this, 'tbqNonEmpty' is used.+            let 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+            case outObjBody req of+                OutBodyStreaming strmbdy ->+                    sendStreaming ctx mgr req' sid newstrm $ \unmask push flush ->+                        unmask $ strmbdy push flush+                OutBodyStreamingUnmask strmbdy ->+                    sendStreaming ctx mgr req' sid newstrm strmbdy+                _ -> atomically $ do+                    sidOK <- readTVar outputQStreamID+                    check (sidOK == sid)+                    writeTVar outputQStreamID (sid + 2)+                    writeTQueue outputQ $ Output newstrm req' OObj Nothing (return ())+            return newstrm -sendStreaming :: Context -> Manager -> OutObj -> StreamId -> Stream-              -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())-              -> IO ()+sendStreaming+    :: Context+    -> Manager+    -> OutObj+    -> StreamId+    -> Stream+    -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())+    -> IO () sendStreaming Context{..} mgr req sid newstrm strmbdy = do     tbq <- newTBQueueIO 10 -- fixme: hard coding: 10     tbqNonEmpty <- newTVarIO False@@ -103,7 +197,7 @@         let push b = atomically $ do                 writeTBQueue tbq (StreamingBuilder b)                 writeTVar tbqNonEmpty True-            flush  = atomically $ writeTBQueue tbq StreamingFlush+            flush = atomically $ writeTBQueue tbq StreamingFlush             finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr)         incCounter mgr         strmbdy unmask push flush `finally` finished@@ -114,8 +208,19 @@         writeTVar outputQStreamID (sid + 2)         writeTQueue outputQ $ Output newstrm req OObj (Just tbq) (return ()) -exchangeSettings :: Config -> Context -> IO ()-exchangeSettings conf ctx@Context{..} = do-    frames <- updateMySettings conf ctx-    let setframe = CFrames Nothing (connectionPreface:frames)+exchangeSettings :: Context -> IO ()+exchangeSettings Context{..} = do+    connRxWS <- rxfWindow <$> 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)+    }

@@ -2,15 +2,21 @@  module Network.HTTP2.Client.Types where -import Network.HTTP2.Arch+import Network.HTTP2.H2  ----------------------------------------------------------------  -- | Client type.-type Client a = (forall b. Request -> (Response -> IO b) -> IO b) -> IO a+type Client a = (forall b. Request -> (Response -> IO b) -> IO b) -> Aux -> IO a  -- | Request from client. newtype Request = Request OutObj deriving (Show)  -- | Response from server. newtype Response = Response InpObj deriving (Show)++-- | Additional information.+data Aux = Aux+    { auxPossibleClientStreams :: IO Int+    -- ^ How many streams can be created without blocking.+    }

@@ -2,88 +2,133 @@  -- | 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-  , 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,SettingsHeaderTableSize,SettingsEnablePush,SettingsMaxConcurrentStreams,SettingsInitialWindowSize,SettingsMaxFrameSize,SettingsMaxHeaderBlockSize)-  , SettingsValue-  , fromSettingsKey-  , toSettingsKey-  -- * Settings-  , Settings(..)-  , defaultSettings-  , updateSettings-  -- * 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+    -- * 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,+        SettingsHeaderTableSize,+        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

@@ -1,27 +1,30 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Network.HTTP2.Frame.Decode (-  -- * Decoding-    decodeFrame-  , decodeFrameHeader-  , checkFrameHeader-  , FrameDecodeError(..)-  -- * 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)@@ -34,22 +37,28 @@ ----------------------------------------------------------------  data FrameDecodeError = FrameDecodeError ErrorCode StreamId ShortByteString-                        deriving (Eq, Show)+    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 FrameDecodeError 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  ---------------------------------------------------------------- @@ -59,9 +68,9 @@ decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do     let p = ptr +. off     len <- fromIntegral <$> N.peek24 p 0-    typ <- toFrameType  <$> N.peek8  p 3-    flg <-                  N.peek8  p 4-    w32 <-                  N.peek32 p 5+    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) @@ -72,85 +81,125 @@  -- | Checking a frame header and reporting an error if any. ----- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0))+-- >>> checkFrameHeader (FrameData,(FrameHeader 100 0 0)) -- Left (FrameDecodeError ProtocolError 0 "cannot used in control stream")-checkFrameHeader :: Settings-                 -> (FrameType, FrameHeader)-                 -> Either FrameDecodeError (FrameType, FrameHeader)-checkFrameHeader Settings{..} typfrm@(typ,FrameHeader{..})-  | payloadLength > maxFrameSize =-      Left $ FrameDecodeError FrameSizeError streamId "exceeds maximum frame size"-  | 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+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 $ 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"+        | 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 $ 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"+        | 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 $ FrameDecodeError ProtocolError streamId "push not enabled" -- checkme-      | isClientInitiated streamId =-        Left $ FrameDecodeError ProtocolError streamId "push promise must be used with even 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"+        | 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 :: [FrameType]-zeroFrameTypes = [-    FrameSettings-  , FramePing-  , FrameGoAway-  ]+zeroFrameTypes =+    [ FrameSettings+    , FramePing+    , FrameGoAway+    ]  nonZeroFrameTypes :: [FrameType]-nonZeroFrameTypes = [-    FrameData-  , FrameHeaders-  , FramePriority-  , FrameRSTStream-  , FramePushPromise-  , FrameContinuation-  ]+nonZeroFrameTypes =+    [ FrameData+    , FrameHeaders+    , FramePriority+    , FrameRSTStream+    , FramePushPromise+    , FrameContinuation+    ]  ----------------------------------------------------------------  -- | The type for frame payload decoder.-type FramePayloadDecoder = FrameHeader -> ByteString-                        -> Either FrameDecodeError FramePayload+type FramePayloadDecoder =+    FrameHeader+    -> ByteString+    -> Either FrameDecodeError FramePayload  payloadDecoders :: Array FrameType FramePayloadDecoder-payloadDecoders = listArray (minFrameType, maxFrameType)-    [ decodeDataFrame-    , decodeHeadersFrame-    , decodePriorityFrame-    , decodeRSTStreamFrame-    , decodeSettingsFrame-    , decodePushPromiseFrame-    , decodePingFrame-    , decodeGoAwayFrame-    , decodeWindowUpdateFrame-    , decodeContinuationFrame-    ]+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@@ -158,7 +207,7 @@ decodeFramePayload :: FrameType -> FramePayloadDecoder decodeFramePayload ftyp     | ftyp > maxFrameType = checkFrameSize $ decodeUnknownFrame ftyp-decodeFramePayload ftyp   = checkFrameSize decoder+decodeFramePayload ftyp = checkFrameSize decoder   where     decoder = payloadDecoders ! ftyp @@ -171,12 +220,12 @@ -- | 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'+    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 @@ -191,8 +240,9 @@ -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder decodeSettingsFrame FrameHeader{..} (PS fptr off _)-  | num > 10  = Left $ FrameDecodeError EnhanceYourCalm streamId "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@@ -205,14 +255,14 @@             n' = n - 1         w32 <- N.peek32 p 2         let v = fromIntegral w32-        settings n' (p +. 6) (builder. ((k,v):))+        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'+    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@@ -222,16 +272,17 @@ decodeGoAwayFrame :: FramePayloadDecoder decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2   where-    (bs0,bs1') = BS.splitAt 4 bs-    (bs1,bs2)  = BS.splitAt 4 bs1'+    (bs0, bs1') = BS.splitAt 4 bs+    (bs1, bs2) = BS.splitAt 4 bs1'     sid = streamIdentifier (N.word32 bs0)     ecid = toErrorCode (N.word32 bs1)  -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder decodeWindowUpdateFrame FrameHeader{..} bs-  | wsi == 0  = Left $ FrameDecodeError ProtocolError streamId "window update must not be 0"-  | otherwise = Right $ WindowUpdateFrame wsi+    | wsi == 0 =+        Left $ FrameDecodeError ProtocolError streamId "window update must not be 0"+    | otherwise = Right $ WindowUpdateFrame wsi   where     wsi = fromIntegral (N.word32 bs `clearBit` 31) @@ -246,24 +297,28 @@  checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder checkFrameSize func header@FrameHeader{..} body-  | payloadLength > BS.length body =-      Left $ FrameDecodeError FrameSizeError streamId "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 FrameDecodeError FramePayload+decodeWithPadding+    :: FrameHeader+    -> ByteString+    -> (ByteString -> FramePayload)+    -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body-  | 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+    | 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     padded = testPadded flags 

@@ -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  ----------------------------------------------------------------@@ -72,10 +76,10 @@ --   The length of the buffer must be larger than or equal to 9 bytes. 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 = fromFrameType ftid@@ -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)@@ -182,20 +191,22 @@     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+    go _ [] = return ()+    go p ((k, v) : kvs) = do         N.poke16 (fromSettingsKey k) p 0-        N.poke32 (fromIntegral v)    p 2+        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 -> ErrorCode -> 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 (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 :)

@@ -5,6 +5,7 @@ module Network.HTTP2.Frame.Types where  import Data.Ix+import Network.Control (WindowSize) import Text.Read import qualified Text.Read.Lex as L @@ -32,6 +33,7 @@  -- | The type for error code. See <https://www.rfc-editor.org/rfc/rfc9113#ErrorCodes>. +{- FOURMOLU_DISABLE -} pattern NoError            :: ErrorCode pattern NoError             = ErrorCode 0x0 @@ -73,23 +75,26 @@  pattern HTTP11Required     :: ErrorCode pattern HTTP11Required      = ErrorCode 0xd+{- FOURMOLU_ENABLE -} +{- FOURMOLU_DISABLE -} instance Show ErrorCode where-    show (ErrorCode 0x0) = "NoError"-    show (ErrorCode 0x1) = "ProtocolError"-    show (ErrorCode 0x2) = "InternalError"-    show (ErrorCode 0x3) = "FlowControlError"-    show (ErrorCode 0x4) = "SettingsTimeout"-    show (ErrorCode 0x5) = "StreamClosed"-    show (ErrorCode 0x6) = "FrameSizeError"-    show (ErrorCode 0x7) = "RefusedStream"-    show (ErrorCode 0x8) = "Cancel"-    show (ErrorCode 0x9) = "CompressionError"-    show (ErrorCode 0xa) = "ConnectError"-    show (ErrorCode 0xb) = "EnhanceYourCalm"-    show (ErrorCode 0xc) = "InadequateSecurity"-    show (ErrorCode 0xd) = "HTTP11Required"-    show (ErrorCode   x) = "ErrorCode " ++ show x+    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 -}  ---------------------------------------------------------------- @@ -108,6 +113,7 @@ maxSettingsKey :: SettingsKey maxSettingsKey = SettingsKey 6 +{- FOURMOLU_DISABLE -} pattern SettingsHeaderTableSize      :: SettingsKey pattern SettingsHeaderTableSize       = SettingsKey 1 @@ -123,17 +129,20 @@ pattern SettingsMaxFrameSize         :: SettingsKey pattern SettingsMaxFrameSize          = SettingsKey 5 -- this means payload size -pattern SettingsMaxHeaderBlockSize   :: SettingsKey-pattern SettingsMaxHeaderBlockSize    = SettingsKey 6+pattern SettingsMaxHeaderListSize    :: SettingsKey+pattern SettingsMaxHeaderListSize     = SettingsKey 6+{- FOURMOLU_ENABLE -} +{- FOURMOLU_DISABLE -} instance Show SettingsKey where     show SettingsHeaderTableSize      = "SettingsHeaderTableSize"     show SettingsEnablePush           = "SettingsEnablePush"     show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams"     show SettingsInitialWindowSize    = "SettingsInitialWindowSize"     show SettingsMaxFrameSize         = "SettingsMaxFrameSize"-    show SettingsMaxHeaderBlockSize   = "SettingsMaxHeaderBlockSize"+    show SettingsMaxHeaderListSize    = "SettingsMaxHeaderListSize"     show (SettingsKey x)              = "SettingsKey " ++ show x+{- FOURMOLU_ENABLE -}  instance Read SettingsKey where     readListPrec = readListPrecDefault@@ -141,67 +150,22 @@         Ident idnt <- lexP         readSK idnt       where-        readSK "SettingsHeaderTableSize"      = return SettingsHeaderTableSize-        readSK "SettingsEnablePush"           = return SettingsEnablePush+        readSK "SettingsHeaderTableSize" = return SettingsHeaderTableSize+        readSK "SettingsEnablePush" = return SettingsEnablePush         readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams-        readSK "SettingsInitialWindowSize"    = return SettingsInitialWindowSize-        readSK "SettingsMaxFrameSize"         = return SettingsMaxFrameSize-        readSK "SettingsMaxHeaderBlockSize"   = return SettingsMaxHeaderBlockSize-        readSK "SettingsKey"         = do-              Number ftyp <- lexP-              return $ SettingsKey $ fromIntegral $ fromJust $ L.numberToInteger ftyp-        readSK _                   = error "Read for SettingsKey"+        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"  -- | The type for raw SETTINGS value. type SettingsValue = Int -- Word32  -- | Association list of SETTINGS.-type SettingsList = [(SettingsKey,SettingsValue)]---------------------------------------------------------------------- | 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-  , maxHeaderListSize :: Maybe Int-  } deriving (Show)---- | The default settings.------ >>> defaultSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = Nothing}-defaultSettings :: Settings-defaultSettings = Settings {-    headerTableSize = 4096 -- defaultDynamicTableSize-  , enablePush = True-  , maxConcurrentStreams = Nothing-  , initialWindowSize = defaultWindowSize-  , maxFrameSize = defaultPayloadLength-  , maxHeaderListSize = Nothing-  }---- | Updating settings.------ >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)]--- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderListSize = 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 { maxHeaderListSize = Just x }-    update def _                                = def---- | The type for window size.-type WindowSize = Int+type SettingsList = [(SettingsKey, SettingsValue)]  -- | The default initial window size. --@@ -228,7 +192,6 @@ isWindowOverflow :: WindowSize -> Bool isWindowOverflow w = testBit w 31 - -- | Default concurrency. -- -- >>> recommendedConcurrency@@ -243,11 +206,12 @@ type Weight = Int  -- | 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)+data Priority = Priority+    { exclusive :: Bool+    , streamDependency :: StreamId+    , weight :: Weight+    }+    deriving (Show, Read, Eq)  ---------------------------------------------------------------- @@ -272,6 +236,7 @@ maxFrameType :: FrameType maxFrameType = FrameType 9 +{- FOURMOLU_DISABLE -} pattern FrameData         :: FrameType pattern FrameData          = FrameType 0 @@ -301,20 +266,24 @@  pattern FrameContinuation :: FrameType pattern FrameContinuation  = FrameType 9+{- FOURMOLU_ENABLE -} +{- FOURMOLU_DISABLE -} instance Show FrameType where-    show (FrameType 0) = "FrameData"-    show (FrameType 1) = "FrameHeaders"-    show (FrameType 2) = "FramePriority"-    show (FrameType 3) = "FrameRSTStream"-    show (FrameType 4) = "FrameSettings"-    show (FrameType 5) = "FramePushPromise"-    show (FrameType 6) = "FramePing"-    show (FrameType 7) = "FrameGoAway"-    show (FrameType 8) = "FrameWindowUpdate"-    show (FrameType 9) = "FrameContinuation"-    show (FrameType x) = "FrameType " ++ show x+    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@@ -335,6 +304,7 @@               Number ftyp <- lexP               return $ FrameType $ fromIntegral $ fromJust $ L.numberToInteger ftyp         readFT _                   = error "Read for FrameType"+{- FOURMOLU_ENABLE -}  ---------------------------------------------------------------- @@ -343,14 +313,14 @@ -- >>> maxPayloadLength -- 16777215 maxPayloadLength :: Int-maxPayloadLength = 2^(24::Int) - 1+maxPayloadLength = 2 ^ (24 :: Int) - 1  -- | The default payload length of HTTP/2 payload. -- -- >>> defaultPayloadLength -- 16384 defaultPayloadLength :: Int-defaultPayloadLength = 2^(14::Int)+defaultPayloadLength = 2 ^ (14 :: Int)  ---------------------------------------------------------------- -- Flags@@ -491,31 +461,33 @@  -- | 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 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)+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)  ---------------------------------------------------------------- @@ -523,6 +495,7 @@ -- -- >>> framePayloadToFrameType (DataFrame "body") -- FrameData+{- FOURMOLU_DISABLE -} framePayloadToFrameType :: FramePayload -> FrameType framePayloadToFrameType DataFrame{}          = FrameData framePayloadToFrameType HeadersFrame{}       = FrameHeaders@@ -535,6 +508,7 @@ framePayloadToFrameType WindowUpdateFrame{}  = FrameWindowUpdate framePayloadToFrameType ContinuationFrame{}  = FrameContinuation framePayloadToFrameType (UnknownFrame ft _)  = ft+{- FOURMOLU_ENABLE -}  ---------------------------------------------------------------- @@ -544,6 +518,7 @@ -- True -- >>> isPaddingDefined $ PingFrame "" -- False+{- FOURMOLU_DISABLE -} isPaddingDefined :: FramePayload -> Bool isPaddingDefined DataFrame{}         = True isPaddingDefined HeadersFrame{}      = True@@ -556,13 +531,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" -}

@@ -0,0 +1,35 @@+module Network.HTTP2.H2 (+    module Network.HTTP2.H2.Config,+    module Network.HTTP2.H2.Context,+    module Network.HTTP2.H2.EncodeFrame,+    module Network.HTTP2.H2.File,+    module Network.HTTP2.H2.HPACK,+    module Network.HTTP2.H2.Manager,+    module Network.HTTP2.H2.Queue,+    module Network.HTTP2.H2.ReadN,+    module Network.HTTP2.H2.Receiver,+    module Network.HTTP2.H2.Sender,+    module Network.HTTP2.H2.Settings,+    module Network.HTTP2.H2.Status,+    module Network.HTTP2.H2.Stream,+    module Network.HTTP2.H2.StreamTable,+    module Network.HTTP2.H2.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.File+import Network.HTTP2.H2.HPACK+import Network.HTTP2.H2.Manager+import Network.HTTP2.H2.Queue+import Network.HTTP2.H2.ReadN+import Network.HTTP2.H2.Receiver+import Network.HTTP2.H2.Sender+import Network.HTTP2.H2.Settings+import Network.HTTP2.H2.Status+import Network.HTTP2.H2.Stream+import Network.HTTP2.H2.StreamTable+import Network.HTTP2.H2.Types+import Network.HTTP2.H2.Window

@@ -0,0 +1,40 @@+module Network.HTTP2.H2.Config where++import Data.IORef+import Foreign.Marshal.Alloc (free, mallocBytes)+import Network.Socket+import Network.Socket.ByteString (sendAll)+import qualified System.TimeManager as T++import Network.HPACK+import Network.HTTP2.H2.File+import Network.HTTP2.H2.ReadN+import Network.HTTP2.H2.Types++-- | Making simple configuration whose IO is not efficient.+--   A write buffer is allocated internally.+allocSimpleConfig :: Socket -> BufferSize -> IO Config+allocSimpleConfig s bufsiz = do+    buf <- mallocBytes bufsiz+    ref <- newIORef Nothing+    timmgr <- T.initialize $ 30 * 1000000+    mysa <- getSocketName s+    peersa <- getPeerName s+    let config =+            Config+                { confWriteBuffer = buf+                , confBufferSize = bufsiz+                , confSendAll = sendAll s+                , confReadN = defaultReadN s ref+                , confPositionReadMaker = defaultPositionReadMaker+                , confTimeoutManager = timmgr+                , confMySockAddr = mysa+                , confPeerSockAddr = peersa+                }+    return config++-- | Deallocating the resource of the simple configuration.+freeSimpleConfig :: Config -> IO ()+freeSimpleConfig conf = do+    free $ confWriteBuffer conf+    T.killManager $ confTimeoutManager conf

@@ -0,0 +1,299 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.H2.Context where++import Control.Exception+import Data.IORef+import Network.Control+import Network.HTTP.Types (Method)+import Network.Socket (SockAddr)+import qualified UnliftIO.Exception as E+import UnliftIO.STM++import 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++data ServerInfo = ServerInfo+    { inputQ :: TQueue (Input Stream)+    }++data ClientInfo = ClientInfo+    { scheme :: ByteString+    , authority :: ByteString+    }++toServerInfo :: RoleInfo -> ServerInfo+toServerInfo (RIS x) = x+toServerInfo _ = error "toServerInfo"++toClientInfo :: RoleInfo -> ClientInfo+toClientInfo (RIC x) = x+toClientInfo _ = error "toClientInfo"++newServerInfo :: IO RoleInfo+newServerInfo = RIS . ServerInfo <$> newTQueueIO++newClientInfo :: ByteString -> ByteString -> RoleInfo+newClientInfo scm auth = RIC $ ClientInfo scm auth++----------------------------------------------------------------++-- | 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+    , outputBufferLimit :: IORef Int+    , outputQ :: TQueue (Output Stream)+    , 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+    }++----------------------------------------------------------------++newContext+    :: RoleInfo+    -> Config+    -> Int+    -> Int+    -> Settings+    -> IO Context+newContext rinfo Config{..} cacheSiz connRxWS settings =+    -- My: Use this even if ack has not been received yet.+    Context rl rinfo settings+        <$> newIORef False+        -- Peer: The spec defines max concurrency is infinite unless+        -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged.+        -- But it is vulnerable, so we set the limitations.+        <*> newIORef settings+        <*> newTVarIO emptyOddStreamTable+        <*> newTVarIO (emptyEvenStreamTable cacheSiz)+        <*> newIORef Nothing+        <*> newTVarIO sid0+        <*> newIORef 0+        <*> newIORef buflim+        <*> newTQueueIO+        <*> newTVarIO sid0+        <*> newTQueueIO+        -- My SETTINGS_HEADER_TABLE_SIZE+        <*> newDynamicTableForEncoding defaultDynamicTableSize+        <*> newDynamicTableForDecoding (headerTableSize settings) 4096+        <*> newTVarIO (newTxFlow defaultWindowSize) -- 64K+        <*> newIORef (newRxFlow connRxWS)+        <*> newRate+        <*> newRate+        <*> newRate+        <*> newRate+        <*> return confMySockAddr+        <*> return confPeerSockAddr+  where+    rl = case rinfo of+        RIC{} -> Client+        _ -> Server+    sid0+        | rl == Client = 1+        | otherwise = 2+    dlim = defaultPayloadLength + frameHeaderLength+    buflim+        | confBufferSize >= dlim = dlim+        | otherwise = confBufferSize++makeMySettingsList :: Config -> Int -> WindowSize -> [(SettingsKey, Int)]+makeMySettingsList Config{..} maxConc winSiz = myInitialAlist+  where+    -- confBufferSize is the size of the write buffer.+    -- But we assume that the size of the read buffer is the same size.+    -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE.+    len = confBufferSize - frameHeaderLength+    payloadLen = max defaultPayloadLength len+    myInitialAlist =+        [ (SettingsMaxFrameSize, payloadLen)+        , (SettingsMaxConcurrentStreams, maxConc)+        , (SettingsInitialWindowSize, winSiz)+        ]++----------------------------------------------------------------++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++----------------------------------------------------------------++{-# INLINE setStreamState #-}+setStreamState :: Context -> Stream -> StreamState -> IO ()+setStreamState _ Stream{streamState} val = writeIORef streamState val++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)